Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.

(* taken from chapter 5 *)

Inductive plane : Set :=
    point : Z->Z->plane.

Inductive htree (A:Type) : nat->Type :=
  | hleaf : A -> htree A 0%nat
  | hnode : forall n:nat, A -> htree A n -> htree A n -> htree A (S n).

Inductive south_west : plane->plane->Prop :=
  south_west_def :
  forall a1 a2 b1 b2:Z, (a1 <= b1)%Z -> (a2 <= b2)%Z ->
        south_west (point a1 a2)(point b1 b2).

Inductive even : nat->Prop :=
  | O_even : even 0
  | plus_2_even : forall n:nat, even n -> even (S (S n)).

Inductive sorted {A:Type}(R:A->A->Prop) : list A -> Prop :=
  | sorted0 : sorted  R nil
  | sorted1 : forall x:A, sorted  R (x :: nil)
  | sorted2 :
      forall (x y:A)(l:list A),
        R x y ->
        sorted  R (y :: l)-> sorted  R (x  ::  y :: l).

Hint Constructors sorted :  sorted_base.

Require Export Relations.

Inductive clos_trans {A:Type}(R:relation A) : A->A->Prop :=
  | t_step : forall x y:A, R x y -> clos_trans  R x y
  | t_trans :
    forall x y z:A, clos_trans  R x y -> clos_trans  R y z ->
        clos_trans  R x z.

Theorem sorted_nat_123 : sorted le (1::2::3::nil).
Proof.
 auto with sorted_base arith.
Qed.

Theorem xy_ord :
 forall x y:nat, le x y -> sorted  le (x::y::nil).
Proof.
 auto with sorted_base.
Qed.

Theorem zero_cons_ord :
 forall l:list nat, sorted le l -> sorted le (cons 0 l).
Proof.
 induction 1; auto with sorted_base arith.
Qed.

Theorem sorted1_inv {A:Type}{le : relation A} { x l} (H: sorted le (x::l))  :
  sorted le l.
Proof.
 inversion H;  auto with sorted_base.
Qed.

Theorem sorted2_inv {A:Type}{le : relation A} {x y  l}
        (H: sorted le (x::y::l)): le x y.
Proof.
 inversion H; auto with sorted_base.
Qed.

Theorem not_sorted_132 :  ~ sorted le (1::3::2::nil).
Proof.
 intros H; generalize  (sorted1_inv   H); intro H0.
 generalize (sorted2_inv H0).
 omega.
Qed.

(** Tests :
Check True_ind.

Check False_ind.

Check and_ind.

Check or_ind.

Check ex_ind.

Check eq_ind.
*)

Require Import JMeq.

(** Tests :
Check JMeq_eq.

Check JMeq_ind.

*)

Inductive ahtree(A:Type) : Type :=
  any_height : forall n:nat, htree A n -> ahtree A.

Arguments any_height {A} n _.

Theorem any_height_inj2 {A:Type} :
 forall (n1 n2:nat)(t1:htree A n1)(t2:htree A n2),
   any_height n1 t1 = any_height   n2 t2 -> JMeq t1 t2.
Proof.
 intros  n1 n2 t1 t2 H.
 injection H; intros H1 H2.
 dependent rewrite <- H1.
 trivial.
Qed.

Theorem any_height_inj2' {A:Type} :
 forall (n1 n2:nat)(t1:htree A n1)(t2:htree A n2),
   any_height n1 t1 = any_height   n2 t2 -> JMeq t1 t2.
Proof.
 intros  n1 n2 t1 t2 H.
 change (match any_height n2 t2 with
        | any_height  n t => JMeq t1 t
        end);
   now rewrite <- H.
Qed.

Require Import List  Vector.

Section vectors_and_lists.
 Variable A : Type.
 (** Note :
    The type of A-vectors of length n is just (t A n)
    or (Vector.t A n)

    Since the Vector library overloads nil and cons, we use qualified names
    for the operations on lists *)

 Fixpoint vector_to_list (n:nat)(v:t A n){struct v}
  : list A :=
  match v with
  | nil _ => List.nil
  | cons _ a p tl => List.cons a (vector_to_list p tl)
  end.

 Fixpoint list_to_vector (l:list A) : t A (length l) :=
   match l as x return t A (length x) with
   | List.nil => nil A
   | List.cons a tl => cons A a (length tl)(list_to_vector tl)
   end.

 Theorem keep_length :
  forall (n:nat)(v:t A n), length (vector_to_list n v) = n.
 Proof.
   intros n v; induction  v; simpl; auto.
 Qed.

 Lemma Vconseq :
  forall (a:A)(n m:nat),
   n = m ->
   forall (v:t A n)(w:t A m),
     JMeq v w -> JMeq (cons A a n v)(cons A a m w).
 Proof.
  intros a n m Heq; rewrite Heq.
  intros v w HJeq.
  rewrite HJeq; reflexivity.
Qed.

 Theorem vect_to_list_and_back :
  forall n (v:t A n),
    JMeq v (list_to_vector (vector_to_list n v)).
 Proof.
  intros n v; induction  v as [ | h n v IHv].
 -   reflexivity.
 -    simpl;  apply Vconseq.
   +    now rewrite  keep_length.
   +   assumption.
 Qed.

End vectors_and_lists.

Theorem structured_intro_example1 : forall A B C:Prop, A/\B/\C->A.
Proof.
 intros A B C [Ha [Hb Hc]];
 assumption.
Qed.

Theorem structured_intro_example2 : forall A B:Prop, A \/ B/\(B->A)->A.
Proof.
 intros A B [Ha | [Hb Hi]].
 - assumption.
 - now apply Hi.
Qed.

Theorem sum_even : forall n p:nat, even n -> even p -> even (n+p).
Proof.
(** False start
 intros n; elim n.
 auto.
 intros n' Hrec p Heven_Sn' Heven_p.
Restart.
*)

 intros n p Heven_n; induction Heven_n.
 -  trivial.
 -  intro H0; simpl;  constructor; auto.
Qed.

(**
Check le_ind.

*)

Theorem lt_le : forall n p:nat, n < p -> n <= p.
Proof.
 intros n p H; induction H; repeat constructor; assumption.
Qed.

Open Scope Z_scope.

Inductive Pfact : Z->Z->Prop :=
  Pfact0 : Pfact 0 1
| Pfact1 : forall n v:Z, n <> 0 -> Pfact (n-1) v -> Pfact n (n*v).

Theorem pfact3 : Pfact 3 6.
Proof.
 apply Pfact1 with (n := 3)(v := 2).
 discriminate.
 apply (Pfact1 2 1).
 discriminate.
 apply (Pfact1 1 1).
 discriminate.
 apply Pfact0.
Qed.

Theorem fact_def_pos : forall x y:Z, Pfact x y ->  0 <= x.
Proof.
 intros x y H; induction  H.
 -  auto with zarith.
 -  omega.
Qed.

(**
Check Zwf_well_founded.

Check well_founded_ind.
*)

Theorem Zle_Pfact : forall x:Z, 0 <= x -> exists y:Z, Pfact x y.
Proof.
 intros x; induction  x using (well_founded_ind (Zwf_well_founded 0)).
 intros  Hle; destruct  (Zle_lt_or_eq  _ _ Hle).
 - destruct (H (x-1)).
   +  unfold Zwf; omega.
   +  omega.
   + exists (x*x0); apply Pfact1; auto with zarith.
 -  subst x; exists 1; constructor.

Qed.

Section little_semantics.
 Variables Var aExp bExp : Set.
 Inductive inst : Set :=
 | Skip : inst
 | Assign : Var->aExp->inst
 | Sequence : inst->inst->inst
 | WhileDo : bExp->inst->inst.

 Variables
  (state : Set)
  (update : state->Var->Z -> option state)
  (evalA : state->aExp -> option Z)
  (evalB : state->bExp -> option bool).

 Inductive exec : state->inst->state->Prop :=
 | execSkip : forall s:state, exec s Skip s
 | execAssign :
    forall (s s1:state)(v:Var)(n:Z)(a:aExp),
     evalA s a = Some n -> update s v n = Some s1 ->
     exec s (Assign v a) s1
 | execSequence :
    forall (s s1 s2:state)(i1 i2:inst),
     exec s i1 s1 -> exec s1 i2 s2 ->
     exec s (Sequence i1 i2) s2
 | execWhileFalse :
    forall (s:state)(i:inst)(e:bExp),
     evalB s e = Some false -> exec s (WhileDo e i) s
 | execWhileTrue :
    forall (s s1 s2:state)(i:inst)(e:bExp),
     evalB s e = Some true ->
     exec s i s1 ->
     exec s1 (WhileDo e i) s2 ->
     exec s (WhileDo e i) s2.

 Theorem HoareWhileRule :
  forall (P:state->Prop)(b:bExp)(i:inst)(s s':state),
    (forall s1 s2:state,
      P s1 -> evalB s1 b = Some true -> exec s1 i s2 -> P s2)->
    P s -> exec s (WhileDo b i) s' ->
    P s' /\ evalB s' b = Some false.
 Proof.
  intros P b i s s' H Hp Hexec; elim Hexec.
 Restart.
  intros P b i s s' H Hp Hexec; generalize H Hp; elim Hexec.
 Restart.
  intros P b i s s' H.
  cut
   (forall i':inst,
     exec s i' s' ->
     i' = WhileDo b i -> P s -> P s' /\ evalB s' b = Some false);
   eauto.
  intros i' Hexec; elim Hexec; try (intros; discriminate).
  intros s0 i0 e Heval Heq; injection Heq; intros H1 H2.
  match goal  with
  | id:(e = b) |- _ => rewrite <- id; auto
  end.
  intros;
   match goal with
   | id:(_ = _) |- _ => injection id; intros H' H''
   end.
    subst i0 b;eauto.
 Qed.

End little_semantics.

Open Scope nat_scope.

Inductive is_0_1 : nat->Prop :=
  is_0 : is_0_1 0 | is_1 : is_0_1 1.

Hint Resolve is_0 is_1 .

Lemma sqr_01 : forall x:nat, is_0_1 x -> is_0_1 (x * x).
Proof.
  induction 1; simpl; auto.
Qed.

Theorem elim_example : forall n:nat, n <= 1 -> n*n <= 1.
Proof.
 intros n H.
 destruct (sqr_01 n); auto.
 inversion_clear H; auto.
 inversion_clear H0; auto.
Qed.

(** bad attempt
Section bad_proof_for_inversion.

 Theorem not_1_even : ~even 1.
 Proof.
  red; intros H; elim H.
 Abort.

End bad_proof_for_inversion.

*)

Theorem not_even_1 : ~even 1.
Proof.
 unfold not; intros H.
 inversion H.
Qed.

Theorem plus_2_even_inv : forall n:nat, even (S (S n))-> even n.
Proof.
 intros n H; inversion H; assumption.
Qed.

(** Same theorems, but using basic tactics only
*)

Theorem not_even_1' : ~even 1.
Proof.
 intro H.
 generalize (refl_equal 1).
 pattern 1 at -2.
 induction H.
 - discriminate.
 - discriminate.
Qed.

Theorem plus_2_even_inv' : forall n:nat, even (S (S n))-> even n.
Proof.
 intros n H.
 generalize (refl_equal (S (S n))); pattern (S (S n)) at -2.
 induction  H.
 -  discriminate.
 -  intros H0 ; injection H0; intro; now subst n0.
Qed.


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

Definition len (p: list nat * list nat) := length (fst p) + length (snd p).

Function merge (p: list nat * list nat) {measure len p} :=
match p with
| (nil, l2) => l2
| (l1, nil) => l1
| ((hd1 :: tl1) as l1, (hd2 :: tl2) as l2) =>
if hd1 <=? hd2 then hd1 :: merge (tl1, l2)
else hd2 :: merge (l1, tl2)
end.
Proof.
  - intros.
    unfold len.
    simpl.
    lia.
  - intros.
    unfold len.
    simpl.
    lia.
Defined.

Inductive sorted : list nat -> Prop :=
| sorted_nil: sorted nil
| sorted_one: forall x, sorted (x :: nil)
| sorted_all: forall x y l, x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

Theorem merge_sorted: forall l1 l2, sorted l1 -> sorted l2 -> sorted (merge(l1,l2)).
Proof.
  Admitted.


Require Coq.Setoids.Setoid.

Module Type Sig.

  Parameter G : Type.
  Parameter e : G.

  Parameter inv : G -> G.
  Parameter mult : G -> G -> G.
  Infix "*" := mult.

  Axiom left_id : forall x : G, e * x = x.
  Axiom left_inv : forall x : G, inv x * x = e.
  Axiom assoc : forall x y z : G, x * (y * z) = (x * y) * z.

  Definition conjugate : G -> G -> G :=
    fun x y : G => inv y * x * y.

  Infix "^" := conjugate.

End Sig.

Module Group (G : Sig).
Import G.

Theorem left_cancel : forall x y z : G, x * y = x * z -> y = z.
Proof.
  intros x y z.
  intros H.
  assert (inv x * (x * y) = inv x * (x * z)) as Hinv.
    rewrite H.
    reflexivity.
  rewrite assoc in Hinv.
  rewrite assoc in Hinv.
  rewrite left_inv in Hinv.
  rewrite left_id in Hinv.
  rewrite left_id in Hinv.
  exact Hinv.
Qed.

Theorem right_id : forall x : G, x * e = x.
Proof.
  intros x.
  assert (inv x * (x * e) = inv x * x) as H.
    rewrite assoc.
    rewrite left_inv.
    apply left_id.
  apply left_cancel in H.
  exact H.
Qed.

(* Another possible proof *)
(* Proof. *)
(*   intros x. *)
(*   apply left_cancel with (x := inv x). *)
(*   rewrite assoc. *)
(*   rewrite left_inv. *)
(*   apply left_id. *)
(* Qed. *)

Theorem right_inv : forall x : G, x * inv x = e.
Proof.
  intros x.
  assert (inv x * (x * inv x) = inv x * e) as H.
    rewrite assoc.
    rewrite left_inv.
    rewrite right_id.
    apply left_id.
  apply left_cancel in H.
  exact H.
Qed.

Theorem unique_unit : forall f : G,
                        (forall x : G, f * x = x /\ x * f = x) -> e = f.
Proof.
  intros f.
  intros H.
  specialize (H e).
  elim H.
  intros Hf_is_left_unit _.
  assert (f * e = f * e) as Hunit.
    reflexivity.
  rewrite right_id in Hunit at 2.
  rewrite Hf_is_left_unit in Hunit.
  exact Hunit.
Qed.

Theorem right_unique_inv : forall x y : G, x * y = e -> inv x = y.
Proof.
  intros x y H.
  apply left_cancel with (x := x).
  rewrite H.
  apply right_inv.
Qed.

Theorem inv_is_involution : forall x : G, inv (inv x) = x.
Proof.
  intros x.
  apply right_unique_inv.
  apply left_inv.
Qed.

Theorem inv_of_mult: forall x y : G, inv (x * y) = inv y * inv x.
Proof.
  intros x y.
  apply right_unique_inv.
  rewrite <- assoc.
  rewrite assoc with (y := inv y).
  rewrite right_inv, left_id, right_inv.
  reflexivity.
Qed.

Theorem inv_of_conjugate: forall x y z : G,
    x ^ z * y ^ z = (x * y) ^ z.
Proof.
  intros x y z.
  unfold conjugate.
  rewrite assoc.
  rewrite <- assoc with (y := z).
  rewrite assoc with (x := z).
  rewrite right_inv.
  rewrite left_id.
  rewrite assoc.
  reflexivity.
Qed.

Theorem conjugate_of_unit: forall y : G, e ^ y = e.
Proof.
  intros y.
  unfold conjugate.
  rewrite right_id.
  rewrite left_inv.
  reflexivity.
Qed.

End Group.


From NaturalNumbers Require Export Base Tutorial.

(* Given statements in Natural Numbers Game in Lean.
   They just write that Peano gave these.
   If we really wanted we could have just Admitted. them *)
Fact add_zero (n : mynat) : n + 0 = n.
Proof.
  trivial.
Qed.

Fact add_succ (m n : mynat) : n + (S m) = S (n + m).
Proof.
  trivial.
Qed.

(* Level 0 data *)
(* name The `induction` tactic *)
(* tactics induction *)
(* theorems add_succ *)
(* Level 0 prologue *)
(*
Alright, so now that we know the basics, let's get started with addition.
Just as a reminder, these are the things we have and know:

a type `mynat`

a term `0 : mynat`, the number zero

a function `S: mynat -> mynat` taking a number `n` to its successor

addition, with the usual notation `a + b`

a theorem `add_zero (n : mynat) : n + 0 = n.`

a theorem `add_succ (m n : mynat) : n + (S m) = S (n + m).`

the principle of mathematical induction, used with the `induction` tactic, see below.

Okay, so in this first level we will prove
```
#Lemma zero_add (n : mynat) : 0 + n = n.
```
Strange right, it seems so simple knowing our theorem
```
#Fact add_zero (n : mynat) : n + 0 = n.
```
but commutativity is not a given! To prove the lemma for this level,
just `rewrite` and `reflexivity` are not enough, we need something stronger.
There is a tactic called `induction`, which we can use on inductive types
like our type `mynat`. Suppose we have a `n : mynat` in our assumptions, then
we can write
```
induction n s [| ? h].
```
to start our induction proof. When you type this, Coq will start
two "subgoals", one for the base case (`n = 0`), and one for the
induction step. It is common practice to "select" the subgoal explicitly
by typing a dash `-` on the next line. Doing this you will only see one goal again.
Once you are done proving this goal, the interpreter will tell you
```plaintext
This subproof is complete, but there are some unfocused goals.
Focus next goal with bullet -.

1 subgoal

subgoal 1 is:
...
```
Now you might wonder what the `[| ? h]` means. To be very precise, in
our inductive type `mynat` we have two constructors (`0` and `S n`), so `induction`
will produce two paths. In the first path, we don't get any (new) hypotheses, so we
don't have to name any variables. In the second path, we get a number and an induction
hypothesis. The `?` is the name for the number, indicating we don't really care
what it is called, we well see it in the subgoal (it will be `n`, the same name as
the variable we are doing induction over). The second hypothesis is the induction
hypothesis. I always like to call it `h`, I think by default it is `IHn`.
This variable will be the induction hypothesis, saying `h : 0 + n = n`.

In short, the proof will look something like this:
```
induction n as [| ? h].
- rewrite ...
  ...
  reflexivity.
- rewrite ...
  ...
  reflexivity.
```
Try it out below!
*)
Lemma zero_add (n : mynat) : 0 + n = n.
Proof.
    induction n as [| ? H].
    - rewrite add_zero.
      reflexivity.
    - rewrite add_succ.
      rewrite H.
      reflexivity.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 1 data *)
(* name `add_assoc` -- associativity of addition *)
(* tactics induction *)
(* theorems add_succ *)
(* Level 1 prologue *)
(*
The next step is to prove that addition is associative, i.e. that
`(a + b) + c = a + (b + c)`. Note that in the goals, the left
hand side of the equation will show up as `a + b + c` instead
of `(a + b) + c`. This is simply because Coq knows that
addition is left-binding.
*)
Lemma add_assoc (a b c : mynat) : (a + b) + c = a + (b + c).
Proof.
    induction c as [| ? H].
    - repeat rewrite add_zero.
      reflexivity.

      (* This only works if we do induction on C, otherwise we would want succ_add *)
    - repeat rewrite add_succ.
      rewrite H.
      reflexivity.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 2 data *)
(* name `succ_add` *)
(* tactics repeat *)
(* theorems add_succ *)
(* Level 2 prologue *)
(*
It is almost time for the boss level of this world. Before that,
let us first prove the counterpart to `add_succ`: `succ_add`.
Just as a tip, instead of repeatedly writing `rewrite add_zero.`, it
is also possible to use the `repeat` tactic, allowing you to write
```
repeat rewrite add_zero.
```
When using the `rewrite` tactic, Coq guesses which parameters to use
in the theorem. It is also possible to do this explicitly by writing
```
rewrite (add_zero a)
```
to rewrite a subterm `a + 0` into `a`.
*)
Lemma succ_add (a b : mynat) : S a + b = S (a + b).
Proof.
  induction b as [| ? H].
  - repeat rewrite add_zero.
    reflexivity.
  - repeat rewrite add_succ.
    rewrite H.
    reflexivity.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 3 data *)
(* name `add_comm` (boss level) *)
(* tactics repeat *)
(* theorems add_succ *)
(* Level 3 prologue *)
(*
*boss music*

Check the side menu to remember the theorems you have shown so far,
you should be prepared to prove this lemma.
*)
Lemma add_comm (a b : mynat) : a + b = b + a.
Proof.
  induction b as [| ? H].
  - now rewrite add_zero, zero_add.
  - rewrite add_succ, succ_add.
    now rewrite H.
Qed.
(* Level epilogue *)
(* Level end *)

(* Given in natural numbers game *)
Definition I := S 0.
Notation "1" := I.
Fact one_eq_succ_zero : 1 = S 0.
Proof.
  trivial.
Qed.

(* Level 4 data *)
(* name `succ_eq_add_one` *)
(* tactics repeat *)
(* theorems one_eq_succ_zero *)
(* Level 4 prologue *)
(*
I have just defined the number `1`, in the way you would
expect: `1 = S 0`, and added a theorem
```
#Fact one_eq_succ_zero : 1 = S 0.
```
that witnesses this. Use it to prove the following theorem.
*)
Lemma succ_eq_add_one (n : mynat) : S n = n + 1.
Proof.
  rewrite one_eq_succ_zero.
  rewrite add_succ.
  rewrite add_zero.
  reflexivity.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 5 data *)
(* name `add_right_comm` *)
(* tactics repeat *)
(* theorems one_eq_succ_zero *)
(* Level 5 prologue *)
(*
Alright, time for the last level in Addition World.
Here it might be useful to use the strategy I mentioned before:
rewriting a specific term in the equation. Remember you can do this
with the `rewrite` tactic by using it like this:
```
rewrite (add_comm b c).
```
*)
Lemma add_right_comm (a b c : mynat) : a + b + c = a + c + b.
Proof.
  rewrite add_assoc.
  rewrite (add_comm b c).
  (* Can just use the forward direction but whatever *)
  rewrite <- add_assoc.
  reflexivity.
Qed.
(* Level epilogue *)
(*
With all these statements about addition, we have shown that
`mynat` is a commutative monoid. In Lean (the proof checker
from the original Natural Numbers Game) we could tell the
proof checker that `mynat` is indeed a commutative monoid.
Sadly such a structure does not exist, but I have come up with a
(rather hacky) solution for this, so that we can still use some
more advanced tactics to make your life easier.

Basically, I added a "fake" multiplication operation, and
added some `Axiom`s (basically theorems which we just assume to be
true, do this at your own risk!). With these, I was able to convince
Coq that `mynat` is a semiring with this fake multiplication. For now
this will suffice, and it allows us to use the powerful `ring` tactic,
allowing us to prove simple statements about expressions in one line,
such as
```
#Lemma test (a b c d e : mynat) : (((a+b)+c)+d)+e=(c+((b+e)+a))+d.
#Proof.
#    ring.
#Qed.
```

It is now time to move on to Multiplication World! Though if you wish,
you could also go to Function World, as we know enough to get started
there too. You can do this by going back to the main menu and clicking
Function World in the graph!
*)
(* Level end *)


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


Require Import Bool Coq.Strings.Ascii Coq.Lists.List.

Section regexp_def.

    Definition string := list ascii.

    Inductive regexp : Type :=
    | Eps : regexp
    | Concat : regexp -> regexp -> regexp
    | Or : regexp -> regexp -> regexp
    | Star : regexp -> regexp
    | Char : ascii -> regexp.

    Definition Plus (A : regexp) : regexp := Concat A (Star A).

    Inductive re_spec : regexp -> string -> Prop :=
    | rs_eps : re_spec Eps nil
    | rs_concat : forall E E' s s',
        re_spec E s -> re_spec E' s' -> re_spec (Concat E E') (s ++ s')
    | rs_or : forall E E' s, (re_spec E s) + (re_spec E' s) -> re_spec (Or E E') s
    | rs_star_eps : forall E, re_spec (Star E) nil
    | rs_star_one : forall E s, re_spec E s -> re_spec (Star E) s
    | rs_star_many : forall E s s',
        re_spec (Star E) s -> re_spec (Star E) s' -> re_spec (Star E) (s ++ s')
    | rs_char : forall a, re_spec (Char a) (cons a nil).

    (* re_sub E E' : Prop
    Defines a partial ordering on regular expressions
    via language given by E contains language given by E'
    *)

    Inductive re_sub (E E' : regexp) : Prop :=
    | resub : (forall s, re_spec E' s -> re_spec E s) -> re_sub E E'.

    Definition re_eq (E E' : regexp) : Prop := re_sub E E' /\ re_sub E' E.

    Theorem re_sub_reflexivity : forall E, re_sub E E.
    Proof.
        induction E; apply resub; intros; assumption.
    Qed.

    Theorem re_sub_transitivity : forall E E' E'',
        re_sub E E' -> re_sub E' E'' -> re_sub E E''.
    Proof.
        intros. destruct H, H0. apply resub.
        intros. apply H, H0, H1.
    Qed.

    Corollary re_eq_reflexivity : forall E, re_eq E E.
    Proof.
        intro. unfold re_eq. split; apply re_sub_reflexivity.
    Qed.

    Corollary re_eq_transitivity : forall E E' E'',
        re_eq E E' -> re_eq E' E'' -> re_eq E E''.
    Proof.
        unfold re_eq. intros. destruct H, H0. split.
        - apply (re_sub_transitivity E E' E'' H H0).
        - apply (re_sub_transitivity E'' E' E H2 H1).
    Qed.

    Corollary re_eq_symmetry : forall E E', re_eq E' E <-> re_eq E E'.
    Proof.
        unfold re_eq. intros E E'. apply and_comm.
    Qed.

    (* dfa State Alphabet : Type
    Simulates a deterministic finite state automata.
    Record type containing an initial state,
    a function to check if a state is final,
    and a function to transition to the next state
    *)
    Record dfa {S A : Type} := DFA {
        initial_state : S;
        is_final : S -> bool;
        next : S -> A -> S
    }.

    Definition run_dfa S A (M : @dfa S A) (l : list A) : bool :=
        (is_final M) (fold_left (next M) l (initial_state M)).

    Definition redfa_Eps : @dfa bool ascii :=
        {|
        initial_state := true;
        is_final (s : bool) :=
            match s with
            | true => true
            | _ => false
            end;
        next (s : bool) (a : ascii) :=
            match s, a with
            | _, _ => false
            end;
        |}.

    Definition redfa_Concat S S' (M : @dfa S ascii) (M' : @dfa S' ascii) : @dfa (sum S S') ascii :=
        {|
        initial_state := inl (initial_state M);
        is_final (s : sum S S') :=
            match s with
            | inl _ => false
            | inr s' => (is_final M') s'
            end;
        next (s : sum S S') (a : ascii) :=
            match s with
            | inl s' =>
                match (is_final M) s' with
                | true => inr ((next M') (initial_state M') a)
                | false => inl ((next M) s' a)
                end
            | inr s' => inr ((next M') s' a)
            end;
        |}.

    Definition redfa_Or S S'(M : @dfa S ascii) (M' : @dfa S' ascii) : @dfa (prod S S') ascii :=
        {|
        initial_state := pair (initial_state M) (initial_state M');
        is_final (sp : prod S S') :=
            match sp with
            | pair s s' => (is_final M s) || (is_final M' s')
            end;
        next (sp : prod S S') (a : ascii) :=
            match sp with
            | pair s s' => pair (next M s a) (next M' s' a)
            end;
        |}.

    Definition redfa_Star S (M : @dfa S ascii) : @dfa S ascii :=
        {|
        initial_state := (initial_state M);
        is_final := (is_final M);
        next (s : S) (a : ascii) :=
            match (is_final M s) with
            | true => (next M) (initial_state M) a
            | false => (next M) s a
            end;
        |}.

    Definition redfa_Char (c : ascii) : @dfa bool ascii :=
        {|
        initial_state := false;
        is_final (s : bool) := s;
        next (s : bool) (a : ascii) :=
            match s, eqb a c with
            | false, true => true
            | _, _ => false
            end;
        |}.

End Section.


Variables A B C : Prop.
Lemma ex2 : (A -> B) -> (B -> C) -> A -> C.
Proof.
  intro Hab.
  intro Hbc.
  intro Ha.
  apply Hbc.
  apply Hab.
  assumption.
Qed.


Require Import Logic.Axiom.Extensionality.

Require Import Logic.Rel.Initial.
Require Import Logic.Rel.R.

(* The category of relations has a terminal object namely 0.                     *)

(* Arrow needed for terminal object universal property.                          *)
Definition terminal (a:Type) : R a 0 := fun x y => False.

Arguments terminal {a}.

(* Existence part of universal property                                         *)
Lemma terminal_existence : forall (a:Type), exists (r:R a 0), True.
Proof.
    intros a. exists terminal. trivial.
Qed.

(* Uniqueness part of universal property                                        *)
Lemma terminal_uniqueness : forall (a:Type) (r s:R a 0), r = s.
Proof.
    intros a r s. apply Ext. intros x y. split; intros H1; inversion y.
Qed.


Require Export List Relations.

Section Definitions.
  Variables (A: Type)(R: relation A).
  Inductive sorted  : list A -> Prop :=
  | sorted0 : sorted  nil
  | sorted1 : forall x:A, sorted (x::nil)
  | sorted2 :
      forall (x y:A)(l:list A),
        R x y ->
        sorted  (y::l)-> sorted  (x :: y :: l).

  Definition sorted' (l:list A) :=
    forall (l1 l2:list A)(n1 n2:A),
      l = l1 ++ (n1 :: n2 ::l2) ->
      R n1 n2.

  #[local] Hint Constructors sorted : core.

  (** Let us prove that sorted' satisfies the constructors of sorted
   *)

  Lemma sorted'0 : sorted'   nil.
  Proof.
    intro l1;   case l1; simpl; intros; discriminate.
  Qed.

  Lemma sorted'1 : forall x, sorted'  (x::nil).
  Proof.
    intros  x l1 l2 n1 n2; case l1.
    -  simpl; discriminate.
    - intros a l1'; case l1'; simpl; discriminate.
  Qed.

  Lemma sorted'2 :
    forall x y l,
      R x y ->
      sorted' (y :: l)-> sorted' (x :: y :: l).
  Proof.
    intros x y l Hr Hs l1; case l1.
    -  intros l2 n1 n2 Heq; injection Heq; intros; subst; trivial.
    -  simpl; intros a l1' l2 n1 n2 Heq; injection Heq.
       intros Heq' Heqx; apply (Hs l1' l2); trivial.
  Qed.

  #[local] Hint Resolve sorted'0 sorted'1 sorted'2 : core.

  Lemma sorted'_inv : forall a l, sorted' (a::l) -> sorted' l.
  Proof.
    intros a l H l1 l2 n1 n2 e.
    apply (H (a::l1) l2 n1 n2); now rewrite e.
  Qed.

  Lemma sorted_imp_sorted' :
    forall l, sorted l -> sorted'  l.
  Proof.
    intros l H; induction  H; auto.
  Qed.

  Lemma sorted'_imp_sorted: forall l, sorted' l -> sorted  l.
  Proof.
    induction l as [|a l']; auto.
    - destruct l'; auto.
      + intro H; constructor.
        * apply (H nil l'); auto.
        *  apply IHl'; apply (sorted'_inv _ _ H).
  Qed.

End Definitions.


From mathcomp
     Require Import all_ssreflect.

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

(* ***************************** *)
Section Perm_ind.
  Variable (T:eqType).

  Lemma perm_ind (P:seq T -> seq T -> Prop) :
    P [::] [::] ->
    (forall u s t, P s u -> P u t -> P s t) ->
    (forall a s t, P s t -> P (a :: s) (a :: t)) ->
    (forall a b s, P [:: a, b & s] [:: b, a & s]) ->
    forall s t, perm_eq s t -> P s t.
  Proof.
    move => Hnil Htrans Hcons Hcons2 s.
    have [n] := ubnP (size s).
    elim : n s =>[|n IHn][|a s]//=;
                         [by move =>_ t; rewrite perm_sym =>/perm_nilP->|].
    rewrite ltnS => Hs [/permP /(_ predT)|b t]// Hperm.
    move : (perm_mem Hperm b) (Hperm).
    rewrite !in_cons eq_refl =>/=/orP[/eqP->|Hb _].
    - rewrite perm_cons =>/(IHn _ Hs). exact : Hcons.
    - apply : Htrans (Htrans _ _ _ (Hcons a _ _ (IHn _ Hs _ (perm_to_rem Hb)))
                            (Hcons2 _ _ _)) (Hcons _ _ _ (IHn _ _ _ _)).
      + rewrite /= size_rem //. by case : s Hs Hb {Hperm}.
      + rewrite -(perm_cons b). apply : perm_trans Hperm.
          by rewrite -perm_rcons /= perm_cons perm_rcons perm_sym perm_to_rem.
  Qed.

  Lemma perm_eqind (S:Type) (f:seq T -> S) :
    (forall a s t, f s = f t -> f (a :: s) = f (a :: t)) ->
    (forall a b s, f [:: a, b & s] = f [:: b, a & s]) ->
    forall s t, perm_eq s t -> f s = f t.
  Proof.
    move => Hcons Hcons2. by apply : perm_ind =>[|u s t->||].
  Qed.

  Lemma perm_Wr (P:seq T -> seq T -> Prop):
    (forall s t, perm_eq s t -> forall u, P u s -> P u t) ->
    forall s t, perm_eq s t -> P s t -> forall u, perm_eq s u -> P s u.
  Proof.
    move => HPl s t Hpst HPst u Hpsu. apply : HPl HPst.
    apply : perm_trans Hpsu. by rewrite perm_sym.
  Qed.

  Lemma perm_Wl (P:seq T -> seq T -> Prop):
    (forall s t, perm_eq s t -> forall u, P s u -> P t u) ->
    forall s t, perm_eq s t -> P s t -> forall u, perm_eq u t -> P u t.
  Proof.
    move => HPr s t Hpst HPst u Hput. apply : HPr HPst.
    apply : (perm_trans Hpst). by rewrite perm_sym.
  Qed.

  Lemma perm_imply_ind (P Q:seq T -> seq T -> Prop) :
    (forall s t, perm_eq s t -> forall u, P s u -> P t u) ->
    (forall s t, perm_eq s t -> forall u, P u s -> P u t) ->
    (forall a s t, P (a :: s) (a :: t) -> P s t) ->
    (P [::] [::] -> Q [::] [::]) ->
    (forall u s t, Q s u -> Q u t -> Q s t) ->
    (forall a s t, P (a :: s) (a :: t) -> Q s t -> Q (a :: s) (a :: t)) ->
    (forall a b s,
        P [:: a, b & s] [:: b, a & s] -> Q [:: a, b & s] [:: b, a & s]) ->
    forall s t, perm_eq s t -> P s t -> Q s t.
  Proof.
    move => HPl HPr HPcons Hnil Htrans Hcons Hcons2 s.
    have [n] := ubnP (size s).
    elim : n s =>[|n IHn][|a s]//=;
                         [by move =>_ t; rewrite perm_sym =>/perm_nilP->|].
    rewrite ltnS => Hs [/permP/(_ predT)|b t]// Hperm.
    move : (perm_mem Hperm b) (Hperm).
    rewrite !in_cons eq_refl =>/=/orP[/eqP->|Hb _ HPas].
    - rewrite perm_cons => Hpst HPst.
      exact : Hcons HPst (IHn _ Hs _ Hpst (HPcons _ _ _ HPst)).
    - move : (perm_Wl HPl Hperm HPas) (perm_Wr HPr Hperm HPas) (perm_to_rem Hb)
      => HpPl HpPr Hsb.
      have Hbas : perm_eq [:: b, a & rem b s] (b :: t)
        by apply : perm_trans Hperm;
        rewrite -perm_rcons /= perm_cons perm_rcons perm_sym.
      move : (Hsb). rewrite -(perm_cons a) => Hpasr.
      move : (HpPr _ Hpasr) => HPasr.
      apply : (Htrans _ _ _
                (Hcons _ _ _ HPasr (IHn _ Hs _ Hsb (HPcons _ _ _ HPasr)))).
      apply : Htrans (Hcons2 _ _ _ _) _; [|apply : Hcons; [|apply /IHn]].
      + apply : HPl Hpasr _ (HpPr _ _).
          by rewrite perm_sym -perm_rcons /= perm_cons perm_rcons perm_sym.
      + exact : HpPl.
      + rewrite /= (size_rem Hb).
          by case : s Hb Hs {Hperm HPas HpPr Hsb Hbas Hpasr HPasr}.
      + by rewrite -(perm_cons b).
      + exact : HPcons (HpPl _ _).
  Qed.

 Lemma perm_imply1l_ind (P:seq T -> Prop) (Q:seq T -> seq T -> Prop) :
    (forall s t, perm_eq s t -> P s -> P t) ->
    (forall a s, P (a :: s) -> P s) ->
    (P [::] -> Q [::] [::]) ->
    (forall u s t, Q s u -> Q u t -> Q s t) ->
    (forall a s t, P (a :: s) -> Q s t -> Q (a :: s) (a :: t)) ->
    (forall a b s, P [:: a, b & s] -> Q [:: a, b & s] [:: b, a & s]) ->
    forall s t, perm_eq s t -> P s -> Q s t.
  Proof.
    move => HP HPcons Hnil Htrans Hcons Hcons2.
    apply : (@perm_imply_ind (fun s t => P s)) =>[s t Hst _||a s _||||]//.
    - exact : HP.
    - exact : HPcons.
  Qed.

  Lemma perm_imply1r_ind (P:seq T -> Prop) (Q:seq T -> seq T -> Prop) :
    (forall s t, perm_eq s t -> P s -> P t) ->
    (forall a s, P (a :: s) -> P s) ->
    (P [::] -> Q [::] [::]) ->
    (forall u s t, Q s u -> Q u t -> Q s t) ->
    (forall a s t, P (a :: t) -> Q s t -> Q (a :: s) (a :: t)) ->
    (forall a b s, P [:: b, a & s] -> Q [:: a, b & s] [:: b, a & s]) ->
    forall s t, perm_eq s t -> P t -> Q s t.
  Proof.
    move => HP HPcons Hnil Htrans Hcons Hcons2.
    apply : (@perm_imply_ind (fun s t => P t)) =>[|s t Hst _|a _||||]//.
    - exact : HP.
    - exact : HPcons.
  Qed.

(* example *)
  Fixpoint spick (P:pred T) (s:seq T) : option T :=
    if s is x :: s' then if P x then Some x else spick P s' else None.

  Lemma perm_map_spick (S:eqType) (f:T -> S) (s1 s2:seq T):
    perm_eq s1 s2 -> uniq [seq f x | x <- s1] ->
    forall y, spick (eq_op^~ y \o f) s1 = spick (eq_op^~ y \o f) s2.
  Proof.
    move : s1 s2.
    apply : perm_imply1l_ind
    =>[s t /(perm_map f)/perm_uniq->|a s /andP[]|
       |u s t Hsu Hut y|a s t _ H y|a b s]//=.
    - by rewrite Hsu Hut.
    - by rewrite H.
    - rewrite inE negb_or eq_sym =>/and3P[/andP[Hba _] _ _] y.
      case : ifP Hba =>[/eqP->|]//. by case : ifP.
  Qed.
(*
  Variable (P Q:seq T -> seq T -> Prop).

  Goal forall s t, perm_eq s t -> P s t -> Q s t.
  Proof.
    apply : perm_ind.
(*  apply : (@perm_ind (fun s t => P s t -> Q s t)).*)
*)
End Perm_ind.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require real.Real.

Require Import Rbasic_fun.

(* Why3 comment *)
(* max is replaced with (Reals.Rbasic_fun.Rmax x x1) by the coq driver *)

(* Why3 goal *)
Lemma max_def : forall (x:R) (y:R), ((y <= x)%R ->
  ((Reals.Rbasic_fun.Rmax x y) = x)) /\ ((~ (y <= x)%R) ->
  ((Reals.Rbasic_fun.Rmax x y) = y)).
Proof.
intros x y.
split ; intros H.
now apply Rmax_left.
apply Rmax_right.
now apply Rlt_le, Rnot_le_lt.
Qed.

(* Why3 comment *)
(* min is replaced with (Reals.Rbasic_fun.Rmin x x1) by the coq driver *)

(* Why3 goal *)
Lemma min_def : forall (x:R) (y:R), ((y <= x)%R ->
  ((Reals.Rbasic_fun.Rmin x y) = y)) /\ ((~ (y <= x)%R) ->
  ((Reals.Rbasic_fun.Rmin x y) = x)).
Proof.
intros x y.
split ; intros H.
now apply Rmin_right.
apply Rmin_left.
now apply Rlt_le, Rnot_le_lt.
Qed.

(* Why3 goal *)
Lemma Max_r : forall (x:R) (y:R), (x <= y)%R ->
  ((Reals.Rbasic_fun.Rmax x y) = y).
exact Rmax_right.
Qed.

(* Why3 goal *)
Lemma Min_l : forall (x:R) (y:R), (x <= y)%R ->
  ((Reals.Rbasic_fun.Rmin x y) = x).
exact Rmin_left.
Qed.

(* Why3 goal *)
Lemma Max_comm : forall (x:R) (y:R),
  ((Reals.Rbasic_fun.Rmax x y) = (Reals.Rbasic_fun.Rmax y x)).
exact Rmax_comm.
Qed.

(* Why3 goal *)
Lemma Min_comm : forall (x:R) (y:R),
  ((Reals.Rbasic_fun.Rmin x y) = (Reals.Rbasic_fun.Rmin y x)).
exact Rmin_comm.
Qed.

(* Why3 goal *)
Lemma Max_assoc : forall (x:R) (y:R) (z:R),
  ((Reals.Rbasic_fun.Rmax (Reals.Rbasic_fun.Rmax x y) z) = (Reals.Rbasic_fun.Rmax x (Reals.Rbasic_fun.Rmax y z))).
Proof.
intros x y z.
destruct (Rle_or_lt x y) as [Hxy|Hxy].
rewrite Rmax_right with (1 := Hxy).
apply eq_sym, Rmax_right.
apply Rle_trans with (1 := Hxy).
apply Rmax_l.
rewrite (Rmax_left x y) by now apply Rlt_le.
destruct (Rle_or_lt x z) as [Hxz|Hxz].
rewrite Rmax_right with (1 := Hxz).
rewrite Rmax_right.
apply eq_sym, Rmax_right.
apply Rlt_le.
now apply Rlt_le_trans with x.
apply Rle_trans with (1 := Hxz).
apply Rmax_r.
rewrite Rmax_left.
apply eq_sym, Rmax_left.
apply Rmax_case ; now apply Rlt_le.
now apply Rlt_le.
Qed.

Lemma Rmin_max_opp :
  forall x y : R,
  Rmin x y = Ropp (Rmax (-x) (-y)).
Proof.
intros x y.
destruct (Rle_or_lt x y) as [H|H].
rewrite Rmin_left, Rmax_left.
apply eq_sym, Ropp_involutive.
now apply Ropp_le_contravar.
exact H.
rewrite Rmin_right, Rmax_right.
apply eq_sym, Ropp_involutive.
now apply Ropp_le_contravar, Rlt_le.
now apply Rlt_le.
Qed.

(* Why3 goal *)
Lemma Min_assoc : forall (x:R) (y:R) (z:R),
  ((Reals.Rbasic_fun.Rmin (Reals.Rbasic_fun.Rmin x y) z) = (Reals.Rbasic_fun.Rmin x (Reals.Rbasic_fun.Rmin y z))).
Proof.
intros x y z.
rewrite !Rmin_max_opp.
apply f_equal.
rewrite !Ropp_involutive.
apply Max_assoc.
Qed.


(** This first serie of  exercises asks you to prove some derived
    inference rule. For some of them, build a small example of its application.

First, let us look at some example : *)

Lemma P3Q : forall P Q : Prop, (((P->Q)->Q)->Q) -> P -> Q.
Proof.

 intros P Q H p.
 apply H.
 intro H0;apply
 H0;assumption.
Qed.

Lemma triple_neg : forall P:Prop, ~~~P -> ~P.
Proof.
 intros P ;unfold not; apply P3Q.
Qed.

Lemma not_or_1 : forall P Q : Prop, ~(P \/ Q) -> ~P.
Proof.
  intros P Q H H0; apply H;left;assumption.
Qed.

Section not_or_1_example.
 Variable n : nat.
 Hypothesis H : n=0 \/ n =2 -> n <> n.

 Lemma L1 : ~n=0.
 Proof.
 apply not_or_1 with (n=2).
 intro H0.
 apply H;auto.
 Qed.

 End not_or_1_example.

Lemma de_morgan_1 : forall P Q: Prop, ~ (P \/ Q) <-> ~P /\ ~Q.
Proof.
 intros P Q;split.
 intro H ;split; intro H0;destruct H;auto.
 intros [p' q'] [p | q].
 destruct p';assumption.
 destruct q';assumption.
Qed.

Lemma de_morgan_2 : forall P Q: Prop, ~ P \/ ~Q  -> ~(P /\ Q).
Proof.
 intros P Q [p' | q'] [p q];[destruct p'|destruct q'];assumption.
Qed.

Lemma test : forall (A:Type) (P:A->Prop) (x:A), (forall x:A, P x) -> P x.
Proof.
intros A P x.
intro H.
apply H.

Lemma all_perm :
 forall (A:Type) (P:A -> A -> Prop),
   (forall x y:A, P x y) ->
   forall x y:A, P y x.
Proof.
 intros A P H x y;apply H.
Qed.

Lemma resolution :
 forall (A:Type) (P Q R S:A -> Prop),
   (forall a:A, Q a -> R a -> S a) ->
   (forall b:A, P b -> Q b) ->
   forall c:A, P c -> R c -> S c.
Proof.
 intros A P Q R S H H0 c H1 H2;apply H.
 apply H0;assumption.
 assumption.
Qed.

Lemma not_ex_forall_not : forall (A: Type) (P: A -> Prop),
                      ~(exists x, P x) <-> forall x, ~ P x.
Proof.
 intros A P;split.
 intros H x Hx. destruct H. exists x;assumption.
 intros H [x Hx].
 destruct (H x). assumption.
Qed.

Lemma ex_not_forall_not : forall (A: Type) (P: A -> Prop),
                       (exists x, P x) -> ~ (forall x, ~ P x).
Proof.
 intros A P [x Hx] H.
 destruct (H x).
 assumption.
Qed.

Lemma diff_sym : forall (A:Type) (a b : A), a <> b -> b <> a.
Proof.
 intros A a b H e . destruct H.
 symmetry;assumption.
Qed.

Lemma fun_diff :  forall (A B:Type) (f : A -> B) (a b : A),
                       f a <> f b -> a <> b.
Proof.
 intros A B f a b H e.
 destruct H. rewrite e. reflexivity.
Qed.

(**  this exercise deals with five equivalent characterizations of
     classical logic

   Some  solutions may use the following patterns :
    unfold Ident [in H].
    destruct (H t1 ... t2)
    generalize t.
    exact t.

   Please look at Coq's documentation before doing these exercises *)

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

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

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

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

Definition Not_forall_not_exists : Prop :=
           forall (A:Type)(P:A->Prop), ~(forall x:A, ~P x) -> ex P.

Lemma  Exm_Double_neg : Exm -> Double_neg.
Proof.
 unfold Double_neg.
 intros H P.
 destruct (H P) as [p | p'].
 intro;assumption.
 intro H1. destruct H1. assumption.
Qed.

Lemma Double_neg_Exm :  Double_neg -> Exm.
Proof.
 intros H P.
 apply H.
 intro H0.
 assert (H1: ~P).
 intro p;destruct H0;auto.
 destruct H0;auto.
Qed.

Lemma Peirce_Double_neg : Peirce -> Double_neg.
Proof.
 intros H P H0.
  unfold Peirce in H.
 apply H with False.
 intro H1;destruct H0;assumption.
Qed.

Lemma Exm_Peirce : Exm -> Peirce.
Proof.
 intros H P Q.
 intro H0;destruct (H P) as [p | p'];auto.
 apply H0;intro p;destruct p';assumption.
Qed.

Lemma Classical_impl_Exm : Classical_impl -> Exm.
Proof.
 intros H P. red in H.
 destruct (H P P) as [p | p'].
 auto.
 right;assumption.
 left;assumption.
Qed.

Lemma Exm_Classical_impl : Exm -> Classical_impl.
Proof.

 intros H P Q H0.
 unfold Exm in H.
 destruct (H P) as [p | p'].
 right;auto.
 auto.
Qed.

Lemma Not_forall_not_exists_Double_neg :  Not_forall_not_exists -> Double_neg.
Proof.
 intros H P;red in H.

 intro H0;destruct (H nat (fun n => P)) as [x Hx].
 intro H1. destruct H0.
 apply H1. exact 0.
 assumption.
Qed.

Lemma Exm_Not_forall_not_exists: Exm -> Not_forall_not_exists.
Proof.
 intros H A P H0.
 destruct (H (ex  P)).

auto.
 destruct H0;intros x Hx.
 destruct H1. exists x. assumption.
Qed.

(** Consider the following definitions (which could be found in the standard
   library *)

Section On_functions.
Variables (U V W : Type).

Variable g : V -> W.
Variable f : U -> V.

 Definition injective : Prop := forall x y:U, f x = f y -> x = y.
 Definition surjective : Prop := forall v : V, exists u:U, f u = v.

Lemma injective' : injective -> forall x y:U, x <> y -> f x <> f y.
Proof.
 intros Hi x y d e.
 destruct d;apply Hi;assumption.
Qed.

Definition compose := fun u : U => g (f u).

End On_functions.
Implicit Arguments compose [U V W].
Implicit Arguments injective [U V].
Implicit Arguments surjective [U V].

Lemma injective_comp : forall U V W (f:U->V)(g : V -> W),
                       injective (compose g f) -> injective f.
Proof.
 intros U V W f g Hi x y e.
 generalize (Hi x y).
 intro H;apply H.
 unfold compose;rewrite e.
 reflexivity.
Qed.

Lemma surjective_comp : forall U V W (f:U->V)(g : V -> W),
                       surjective (compose g f) -> surjective g.
Proof.
 intros U V W f g Hs y.
 destruct (Hs y) as [x Hx].
 exists (f x);assumption.
Qed.

Lemma comp_injective : forall U V W (f:U->V)(g : V -> W),
                       injective f -> injective g -> injective (compose g f).
Proof.
 intros U V W f g Hf Hg x y e.
 generalize (Hf x y) ;intro H1; apply H1.
 apply Hg;assumption.
Qed.

Fixpoint iterate (A:Type)(f:A->A)(n:nat) {struct n} : A -> A :=
 match n with 0 => (fun a => a)
            | S p => fun a => f (iterate _ f p a)
 end.

 Lemma iterate_inj : forall U (f:U->U) ,
                      injective f ->
                      forall n: nat, injective   (iterate _ f n).
Proof.
 induction n;simpl.
 intros x y e;assumption.
 intros x y e.
 apply IHn.
 apply H;assumption.
Qed.

(** Last serie of exercises : Consider the following definitions
   See "impredicatve definitions" in the book *)

Definition my_False : Prop := forall P:Prop, P.

Definition my_not (P:Prop) := P -> my_False.

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

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

Definition my_exists (A:Type)(P:A->Prop) : Prop :=
  forall R: Prop,
    (forall a: A, P a -> R) -> R.

Lemma my_False_ok : False <-> my_False.
Proof.
 split;intro H.
 destruct H.
 apply H.
Qed.

Lemma my_or_intro_l : forall P Q:Prop, P -> my_or P Q.
Proof.
 intros P Q p R H H0;apply H;assumption.
Qed.

Lemma my_or_ok : forall P Q:Prop, P \/ Q <-> my_or P Q.
Proof.
 split.
 intros [p | q] R H H0;auto.
 intro H;apply H.
 left;assumption.
 right;assumption.
Qed.

Lemma my_and_ok :  forall P Q:Prop, P /\ Q <-> my_and P Q.
Proof.
 split.
 intros [p q] R H;apply H;assumption.
 intro H;apply H.
 split;assumption.
Qed.

Lemma my_ex_ok :  forall (A:Type)(P:A->Prop),
                   (exists x, P x) <-> (my_exists A P).
Proof.
 intros A P ; split.
 intros [x Hx] R H.
 apply H with x;assumption.
 intro H;apply H.
 intros a Ha;exists a;assumption.
Qed.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Fixpoint revflat (revflat_arg0 : tree) : lst
           := match revflat_arg0 with
              | Leaf => Nil
              | Node d l r => append (revflat l) (Cons d (revflat r))
              end.

Fixpoint qrevaflat (qrevaflat_arg0 : tree) (qrevaflat_arg1 : lst) : lst
           := match qrevaflat_arg0, qrevaflat_arg1 with
              | Leaf, x => x
              | Node d l r, x => qrevaflat l (Cons d (qrevaflat r x))
              end.

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

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

Theorem qrevflat_append: forall (x : tree) (y: lst), append (revflat x) y = qrevaflat x y.
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite <- IHx1.
   rewrite <- append_assoc.
   f_equal.
   simpl.
   rewrite IHx2.
   reflexivity.
   }
   {
   rewrite append_nil.
   rewrite <- IHx1.
   f_equal.
   f_equal.
   rewrite <- IHx2.
   rewrite append_nil.
   reflexivity.
   }
Qed.

Theorem theorem0 : forall (x : tree), eq (revflat x) (qrevaflat x Nil).
Proof.
   intro.
   rewrite <- qrevflat_append.
   rewrite append_nil.
   reflexivity.
Qed.


(** 1.2 Function Types *)
Module HoTT_1_2.

Definition f : nat -> nat := fun x => x + x.

Compute (f 2). (** 2 + 2 = 4 *)

Type (fun (x : nat) => x + x). (** nat -> nat *)

(* uniqueness principle for function types *)
Theorem fun_uniq :
  forall (A B : Type) (f : A -> B), f = (fun x => f x).
Proof.
  intros A B f.
  exact eq_refl.
Qed.

End HoTT_1_2.

(** 1.3 Universes and Families *)
Module HoTT_1_3.

Set Printing Universes.

Inductive Unit : Type := point.

Definition type_family_example : nat -> Type :=
  fix TFEfix (x : nat) := match x with
                     | O => Prop
                     | S x' => sum Unit (TFEfix x') end.

Type type_family_example. (* nat -> Type@{Top.10} *)

Definition constant_type_family (B : Type) : forall {A : Type}, A -> Type :=
  fun {A : Type} (x : A) => B.

End HoTT_1_3.

(** 1.4 Dependent Function Types *)
Module HoTT_1_4.

(* the dependent product type into a constant type family is equivalent to the function type *)
Lemma prod_const__fun : forall A B : Type, (forall x : A, B) = (A -> B).
Proof.
  reflexivity.
Show Proof.
Qed.

(* Polymorphic functions *)
Definition id : forall (A : Type), A -> A := fun (A : Type) (x : A) => x.

Definition swap : forall (A B C: Type), (A -> B -> C) -> (B -> A -> C) :=
  fun (A B C : Type) (g : A -> B -> C) (b : B) (a: A) => g a b.

Inductive Unit := point.

Definition true_unit : True <-> Unit := conj (fun _ => point) (fun _ => I).

Definition lf : forall {A B : Prop}, A /\ B -> A :=
  fun {A B : Prop} (p : A /\ B) => match p with
                        | conj a b => a end.

Definition rt : forall {A B : Prop}, A /\ B -> B :=
  fun {A B : Prop} (p : A /\ B) => match p with
                                     | conj a b => b end.

Definition unit_contractible : forall a b : Unit, a = b :=
  fun (a b : Unit) =>
    match a, b with
    | point, point => eq_refl end.

Definition true_contractible : forall a b : True, a = b :=
  fun (a b : True) =>
    match a, b with
      | I, I => eq_refl end.

End HoTT_1_4.

Module HoTT_1_5.

Inductive prod' (A B : Type) := pair' : A -> B -> prod' A B.

Definition prod_elim :
  forall {A B C : Type} (g : A -> B -> C), A * B -> C.
Proof.
  intros A B C g [a b]. exact (g a b).
Show Proof.
Defined.

Type @prod_elim. (* forall A B C : Type, (A -> B -> C) -> A * B -> C) *)

(* comparison with other coq-defined defs *)
Type prod_rect.
(* forall (A B : Type) (P : A * B -> Type),
    (forall (a : A) (b : B), P (a, b)) -> forall p : A * B, P p *)

Type prod_ind. (* = ind type *)
(* forall (A B : Type) (P : A * B -> Prop),
    (forall (a : A) (b : B), P (a, b)) -> forall p : A * B, P p *)

Type prod_rec.
(* forall (A B : Type) (P : A * B -> Set),
    (forall (a : A) (b : B), P (a, b)) -> forall p : A * B, P p *)

Definition Unit_rec' : forall (C : Type), C -> HoTT_1_4.Unit -> C.
Proof.
  intros C c []. exact c.
Show Proof.
Defined.

Type Unit_rec'.
(* forall C : Type, C -> Unit -> C *)

Type True_rect.
(* forall P : Type, P -> True -> P *)

Definition pr1 :
  forall {A B : Type}, A * B -> A := fun A B => prod_elim (fun a b => a).

Definition pr2 :
  forall {A B : Type}, A * B -> B := fun A B => prod_elim (fun a b => b).

Definition prod_uniq : forall {A B : Type} (x : A * B), (pr1(x), pr2(x)) = x.
Proof.
  intros A B [a b]. reflexivity.
Show Proof.
Defined.

Definition Unit := HoTT_1_4.Unit.
Definition point := HoTT_1_4.point.

Definition unit_ind :
  forall C : Unit -> Type, C(point) -> (forall x : Unit, C(x)) :=
  fun C C_pt x => match x with point => C_pt end.

Type True_ind.
(* forall P : Prop, P -> True -> P *)
(** Notice that HoTT _ind is not the same as Coq's _ind. *)

Definition unit_uniq :
  forall x : Unit, x = point := fun x => match x with point => eq_refl end.
Compute unit_uniq.

Definition unit_uniq' :
  forall x : Unit, x = point := unit_ind (fun x => x = point) eq_refl.
Compute unit_uniq'.

End HoTT_1_5.

(* 1.6 Dependent Pair Types *)
Module HoTT_1_6.

Definition constant_type_family := HoTT_1_3.constant_type_family.

Inductive sig1 {A : Type} (P : A -> Type) : Type :=
  existP : forall x:A, P x -> sig1 P.

Definition dpt_test1 : forall A : Type, nat := fun x => 3.
Definition dpt_test2 : forall A : Type, A -> Type := fun x y => nat.
Definition dpt_test3 : forall A B: Type, nat -> Prop := fun x y z => (z = z).
Definition dpt_test4 : forall A B : Type, nat -> Type := fun x y z => nat.
Definition dpt_test5 : forall A: Type, A -> (A -> Type) := fun x y z => nat.
Definition dpt_test6 : forall A : Type, 3 = 3 := fun x => eq_refl.
Definition dpt_test7 : forall A : Type, 3 = 3 -> nat := fun x y => 3.

Type (existP (fun x => x)).

Definition iffT : Type -> Type -> Type := fun A B => prod (A -> B) (B -> A).

(* the dependent pair type over a constant type is equivalent to the cartesian product *)
Definition sum_const__prod : forall A B : Type, iffT (sigT (fun a:A => B)) (prod A B).
Proof.
  intros A B. split.
  - intros [a b]. exact (pair a b).
  - intros [a b]. exact (existT (fun _ => B) a b).
Show Proof.
Defined.

Definition pr1 : forall {A : Type} {B : A -> Type}, (sigT (fun x:A => B x)) -> A.
Proof.
  intros A B [a _].
  exact a.
Show Proof.
Defined.

 Definition pr2 : forall {A : Type} {B : A -> Type} (p : sigT (fun x:A => B x)), B (pr1 p).
Proof.
  intros A B [a b].
  simpl. exact b.
Show Proof.
Defined.

Definition sum_elim :
  forall {A : Type} {B : A -> Type} {C : (sigT (fun (x : A) => B x)) -> Type}
                                           (a : A) (b : B a), C (existT _ a b).
Proof. Admitted.

Definition sum_elim_f :
  forall {A : Type} {B : A -> Type} {C : (sigT (fun (x : A) => B x)) -> Type}
         (p : sigT (fun (x : A) => B x)), C p.
Proof.
  intros A B C [a b].
  exact (sum_elim a b).
Defined.

(* recursor for dependent pair types *)
Definition sig_rec : forall {A : Type} {B : A -> Type} {C : Type},
    (forall x : A, B x -> C) -> (sigT (fun x:A => B x)) -> C.
Proof.
  intros A B C g [a b].
  exact (g a b).
Show Proof.
Defined.

(* inductor for dependent pair types *)
Definition sig_ind : forall {A : Type} {B : A -> Type} (C : (sigT (fun x : A => B x)) -> Type),
                            (forall (a : A) (b : B a), C (existT _ a b)) ->
                            (forall (p : (sigT (fun x : A => B x))), C p).
Proof.
  intros A B C g [a b].
  exact (g a b).
Show Proof.
Defined.

(* The type-theoretic axiom of choice *)
Definition sig_ac : forall {A B : Type} {R : A -> B -> Type},
    (forall (x : A), sigT (fun y : B => R x y)) ->
    (sigT (fun f : A -> B => forall x : A, R x (f x))).
Proof.
  intros A B R g.
  pose (fun f : A -> B => forall x : A, R x (f x)).
  exact (existT T (fun x => pr1 (g x)) (fun x => pr2 (g x))).
Show Proof.
Defined.

(* We may define magmas and pointed magmas in terms of dependent pair types. *)
Definition Magma : Type := sigT (fun A : Type => A -> A -> A).
Definition PointedMagma : Type := sigT (fun A : Type => prod (A -> A -> A) A).

End HoTT_1_6.

(** Coproduct types *)
Module HoTT_1_7.

Inductive empty : Type :=.

(* recursor for the coproduct type *)
Definition sum_rec : forall {A B : Type} (C : Type), (A -> C) -> (B -> C) -> (A + B -> C).
Proof.
  intros A B C g0 g1 [a | b].
  - exact (g0 a).
  - exact (g1 b).
Show Proof.
Defined.

(* recursor for the empty type *)
Definition empty_rec' : forall C : Type, empty -> C.
Proof.
  intros C [].
Show Proof.
Defined.

(* inductor for the coproduct type *)
Definition sum_ind : forall {A B : Type} (C : A + B -> Type),
    (forall a : A, C (inl a)) -> (forall b : B, C (inr b)) ->
    (forall x : A + B, C x).
Proof.
  intros A B C g0 g1 [a | b].
  - exact (g0 a).
  - exact (g1 b).
Show Proof.
Defined.

(* inductor for the empty type *)
Definition empty_ind' : forall (C : empty -> Type) (z : empty), C z.
Proof.
  intros C [].
Show Proof.
Defined.

End HoTT_1_7.

Module HoTT_1_8.

Definition Unit := HoTT_1_4.Unit.
Definition point := HoTT_1_4.point.

Definition bool : Type := sum Unit Unit.

(* recursor on bool type *)
Definition bool_rec' : forall (C : Type), C -> C -> bool -> C.
Proof.
  intros C c0 c1 [[] | []].
  - exact c0.
  - exact c1.
Show Proof.
Defined.

(* Observe that the rec proofs constructed here are not proof-independent: indeed,
  a natural proof of bool_rec would be as follows: *)

Definition bool_rec_faulty : forall (C : Type), C -> C -> bool -> C :=
  fun C c _ _ => c.

(* While this definition type-checks, it clearly does not capture the expected
semantics of the type bool; using this as a recursor, in fact, would lend it the
behavior of the unit type. That this is possible shows bool -> unit. *)

Definition false' : bool := inl point.
Definition true' : bool := inr point.

(* inductor on bool type *)
Definition bool_ind' : forall (C : bool -> Type),
    C false' -> C true' -> forall x : bool, C x.
Proof.
  intros C c0 c1 [[] | []].
  - exact c0.
  - exact c1.
Show Proof.
Defined.

(* Note that the proof for induction, however, is in fact the most natural construction
of the function, and we shall later show uniqueness. In this manner, the semantics
of the bool type may be predicated purely on the type of the inductor. *)

Definition thm_1_8_1 : forall x : bool, (x = false') + (x = true').
Proof.
  apply bool_ind'.
  - apply (inl eq_refl).
  - apply (inr eq_refl).
Show Proof.
Defined.

Definition sum' (A B : Type) := sigT (fun x : bool => bool_rec' Type A B x).
Definition inl' {A B: Type} (a : A) : (sum' A B) :=
  existT (fun x : bool => bool_rec' Type A B x) false' a.
Definition inr' {A B : Type} (b : B) : (sum' A B) :=
  existT (fun x : bool => bool_rec' Type A B x) true' b.

(* Exercise : Derive induction principle for coproducts from this. *)

Definition prod' (A B : Type) := forall x : bool, bool_rec' Type A B x.
Definition pair' {A B : Type} (a : A) (b : B) : prod' A B :=
  bool_ind' (bool_rec' Type A B) a b.
Definition pr1' {A B : Type} (p : prod' A B) := p false'.
Definition pr2' {A B : Type} (p : prod' A B) := p true'.

Compute pr1' (pair' 3 4). (* 3 : bool_rec' Type nat nat false' *)
Compute (bool_rec' Type nat nat false'). (* nat : Type *)

(* However this product has an extensional flavor to it. *)
(** TODO : Exercises and proofs of equivalence *)

End HoTT_1_8.


(** 116297 - Tópicos Avançados em Computadores - 2017/2           **)
(** Provas Formais: Uma Introdução à Teoria de Tipos - Turma B    **)
(** Prof. Flávio L. C. de Moura                                   **)
(** Email: contato@flaviomoura.mat.br                             **)
(** Homepage: http://flaviomoura.mat.br                           **)

(** Aluno:  Gabriel F P Araujo                                    **)
(** Matrícula: 12/0050943                                         **)

(** Formalização do algoritmo Bubble Sort. *)
(**
A ideia geral da formalização do algoritmo Bubble Sort foi feita em sala. Utilizando as informações dadas, faça a prova do teorema bubbleSort_correcao abaixo. Você pode adicionar os lemas (com provas completas!) que achar necessário.
 *)

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

Open Scope list_scope.

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

Fixpoint bubbleSort (l: list nat) : list nat :=
  match l with
  | nil => l
  | h::tl => bubble (h :: (bubbleSort tl))
  end.

Inductive ordenada : list nat -> Prop :=
  | lista_vazia : ordenada nil
  | lista_1: forall n : nat, ordenada (cons n nil)
  | lista_nv : forall (x y : nat) (l : list nat), ordenada (cons y l) -> x <= y -> ordenada (cons x (cons y l)).

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

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

Lemma ordenada_n_l: forall h tl, ordenada (h :: tl) -> ((h :: tl) = bubble (h :: tl)).
Proof.
  intros h tl.
  induction (h :: tl).
  - intro H.
    reflexivity.
  - intro H.
    rewrite bubble_equation.
    destruct l.
    + reflexivity.
    + destruct (le_lt_dec a n).
      * rewrite <- IHl.
        ** reflexivity.
        ** inversion H.
           assumption.
      * inversion H; subst.
        apply le_not_lt in H4.
        contradiction.
Qed.

Lemma bubble_preserva_ordem : forall l n, ordenada l -> ordenada (bubble (n::l)).
Proof.
  (* intros l n H. *)
  induction l.
  - intros.
    rewrite bubble_equation.
    apply lista_1.
  - intros.
    rewrite bubble_equation.
    destruct (le_lt_dec n a).
    + rewrite <- ordenada_n_l.
      * apply lista_nv.
        assumption.
        assumption.
      * assumption.
    + rewrite bubble_equation.
      destruct l.
      * apply lista_nv.
        ** apply lista_1.
        ** apply Nat.lt_le_incl.
           assumption.
      * destruct (le_lt_dec n n0).
        ** apply lista_nv.
          *** assert (ordenada (bubble (n :: n0 :: l))).
            { apply IHl. inversion H. assumption. }
              rewrite bubble_equation in H0.
              destruct (le_lt_dec n n0).
              assumption.
              apply le_not_lt in l1.
              contradiction.
          *** apply Nat.lt_le_incl.
              assumption.
        ** apply lista_nv.
          *** assert (ordenada (bubble (n :: n0 :: l))).
            { apply IHl. inversion H. assumption. }
              rewrite bubble_equation in H0.
              destruct (le_lt_dec n n0).
              **** apply le_not_lt in l2.
                   contradiction.
              **** assumption.
          *** inversion H.
              assumption.
Qed.

Lemma num_oc_bubble: forall l n, num_oc n (bubble l) =  (num_oc n l).
Proof.
  intros l n.
  functional induction (bubble l).
  - simpl num_oc.
    destruct (Nat.eq_dec n h0).
    + destruct (Nat.eq_dec n h1).
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h1).
        ** tauto.
        ** contradiction.
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h1).
        ** contradiction.
        ** tauto.
    + destruct (Nat.eq_dec n h1).
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h1).
        ** tauto.
        ** contradiction.
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h1).
        ** contradiction.
        ** tauto.
  - simpl num_oc.
    destruct (Nat.eq_dec n h0).
    + destruct (Nat.eq_dec n h1).
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h0).
        ** reflexivity.
        ** contradiction.
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h0).
        ** reflexivity.
        ** contradiction.
    + destruct (Nat.eq_dec n h1).
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h0).
        ** contradiction.
        ** reflexivity.
      * rewrite IHl0.
        simpl num_oc.
        destruct (Nat.eq_dec n h0).
        ** contradiction.
        ** reflexivity.
  - reflexivity.
Qed.

Theorem bubbleSort_correcao: forall l, equiv (bubbleSort l) l /\ ordenada (bubbleSort l).
Proof.
  induction l.
  - split.
    + simpl.
      unfold equiv.
      intro n.
      reflexivity.
    + simpl.
      apply lista_vazia.
  - destruct IHl as [Hequiv Hord].
    split.
    + simpl.
      unfold equiv in *.
      intro n'.
      assert (H:  num_oc n' (bubble (a :: (bubbleSort l))) = num_oc n' ( a :: (bubbleSort l))).
      { apply num_oc_bubble. }
      apply Nat.eq_trans with (num_oc n' (cons a (bubbleSort l))).
      * assumption.
      * simpl. destruct (Nat.eq_dec n' a).
        ** apply eq_S.
           apply Hequiv.
        ** apply Hequiv.
    + simpl.
      assert (ordenada (bubbleSort l) -> ordenada (bubble (a :: bubbleSort l))).
      { apply bubble_preserva_ordem. }
      apply H.
      assumption.
Qed.


Require Import List Lia.
Import ListNotations.

Require Import Undecidability.PCP.PCP.
Require Import Undecidability.PCP.Util.Facts.
Import PCPListNotation.

Require Import Undecidability.Synthetic.Definitions.

Set Default Goal Selector "!".

(* ** PCP reduces to BPCP *)

(* natural numbers n to bitstrings of the form 1^n *)

Definition to_bitstring (n : nat) : string bool := Nat.iter n (cons true) [].

Lemma bitstring_false a : ~ false el to_bitstring a.
Proof.
  induction a; cbn; firstorder congruence.
Qed.

(* strings of natural numbers to bitstrings, [ n1, ... n2 ] |-> 1^n1 0 ... 1^n2 0 *)
Fixpoint f_s (x : string nat) : string bool :=
  match x with
  | nil => nil
  | a :: x => to_bitstring a ++ [false] ++ f_s x
  end.

Lemma f_s_app x y : f_s (x ++ y) = f_s x ++ f_s y.
Proof.
  induction x; cbn.
  - reflexivity.
  - rewrite IHx. now rewrite <- app_assoc.
Qed.

(* extension to cards and stacks *)
Definition f_c '(x,y) := (f_s x, f_s y).
Definition f (P : stack nat) : stack bool :=
  map f_c P.

Lemma tau1_f A : tau1 (f A) = f_s (tau1 A).
Proof.
  induction A as [ | (x,y) ]; cbn.
  - reflexivity.
  - unfold f in IHA. now rewrite IHA, f_s_app.
Qed.

Lemma tau2_f A : tau2 (f A) = f_s (tau2 A).
Proof.
  induction A as [ | (x,y) ]; cbn.
  - reflexivity.
  - unfold f in IHA. now rewrite IHA, f_s_app.
Qed.

(* interpretation of a bitstring as list of natural numbers *)
Fixpoint g_s' (x : string bool) (n : nat) : string nat :=
  match x with
  | nil => nil
  | true :: x' => g_s' x' (S n)
  | false :: x' => n :: g_s' x' 0
  end.

Lemma g_s'_app n x y :
  g_s' (f_s x ++ y) n = match x with nil => g_s' y n | m :: x => n + m :: x ++ g_s' y 0 end.
Proof.
  revert n y. induction x as [ | m]; intros; cbn in *.
  - reflexivity.
  - revert n; induction m; intros; cbn in *.
    + destruct x.
      * do 2 f_equal. lia.
      * rewrite IHx. f_equal. lia.
    + rewrite IHm. f_equal. lia.
Qed.

Definition g_s x := g_s' x 0.

Lemma f_g_s'_inv x : g_s (f_s x) = x.
Proof.
  unfold g_s. setoid_rewrite <- app_nil_r at 2. rewrite g_s'_app.
  destruct x; eauto. cbn. now rewrite app_nil_r.
Qed.

(* extension to cards and stacks *)
Definition g_c '(x,y) := (g_s x, g_s y).
Definition g (P : stack bool) : stack nat :=
  map g_c P.

(* Invariants *)

Lemma tau1_g A B : A <<= f B -> tau1 (g A) = g_s (tau1 A).
Proof.
  induction A as [ | (x,y)]; cbn.
  - reflexivity.
  - unfold g in IHA. intros. rewrite !IHA.
    { assert ( (x, y) el map f_c B) as ((x',y') & ? & ?) % in_map_iff by firstorder; inv H0.
      rewrite g_s'_app. destruct x'.
      + cbn. reflexivity.
      + rewrite f_g_s'_inv. cbn. reflexivity. }
    firstorder.
Qed.

Lemma tau2_g A B : A <<= f B -> tau2 (g A) = g_s (tau2 A).
Proof.
  induction A as [ | (x,y)]; cbn.
  - reflexivity.
  - unfold g in IHA. intros. rewrite !IHA.
    { assert ( (x, y) el map f_c B) as ((x',y') & ? & ?) % in_map_iff by firstorder; inv H0.
      rewrite g_s'_app. destruct y'.
      + cbn. reflexivity.
      + rewrite f_g_s'_inv. cbn. reflexivity. }
    firstorder.
Qed.

Lemma f_subset B A : A <<= B -> f A <<= f B.
Proof.
  induction A in B |- *; intros H; cbn.
  * firstorder.
  * intros ? [| H0]; subst.
    - unfold f. eapply in_map_iff. exists a.
      constructor; eauto.
      apply H; simpl; auto.
    - eapply IHA in H0; eauto.
      intros ? ?; apply H; simpl; auto.
Qed.

Lemma f_g_subset B A : A <<= f B -> g A <<= B.
Proof.
  revert B; induction A; intros B H; cbn.
  * firstorder.
  * assert (a el f B) by firstorder.
    unfold f in H0. eapply in_map_iff in H0 as ((x,y) & ? & ?). inv H0.
    intros ? [|]; subst. { cbn. now rewrite !f_g_s'_inv. } firstorder.
Qed.

Theorem reduction : PCP ⪯ PCPb.
Proof.
  exists f. intros B. split.
  - intros (A & HP & He & H). exists (f A). repeat split.
    + now eapply f_subset.
    + destruct A; cbn; congruence.
    + unfold f, f_c, f_s. setoid_rewrite tau1_f. setoid_rewrite tau2_f. now rewrite H.
  - intros (A & HP & He & H). exists (g A). repeat split.
    + eapply f_g_subset; eauto.
    + destruct A; cbn; congruence.
    + erewrite tau1_g, tau2_g, H; eauto.
Qed.


Require Import List.
Require Import Bool.
Require Import ZArith.
Require Import Sorting.

(** Aktiviramo notacijo za sezname. *)
Local Open Scope list_scope.
(** Definicija vstavlanja elementov v seznam. **)
Function vstavi (x:Z) (l: list Z) :=
     match l with
      | nil => x::nil
      | y::l' => if (x <=? y)%Z then x::y::l' else y::(vstavi x l')
end.

(** Urejanje seznama po principu insertion sort-a. **)
Fixpoint insert (l:list Z) :=
     match l with
      | nil => nil
      | x::l' => let l'' := (insert l') in vstavi x l''
end.

Eval compute in (insert (2 :: 5 :: 1 :: 4 :: nil)%Z).

(** Dodajanje elementa ohranja urejen seznam. **)
Lemma urejen_t (a: Z) (l: list Z):
  urejen l -> urejen (vstavi a l).
Proof.
  intro.
  induction l.
  - auto.
  - simpl.
    case_eq (a <=? a0)%Z.
    + destruct l.
      * intro.
        apply Zle_bool_imp_le in H0.
        simpl.
        auto.
      * case_eq (a0 <=? z)%Z.
        apply urejen_tail in H. firstorder.
        apply Zle_bool_imp_le in H1; auto.
        apply Zle_bool_imp_le in H0; auto.
        firstorder.
        apply Zle_bool_imp_le in H1; auto.
   + firstorder; simpl.
     destruct l.
     * firstorder.
       apply Z.leb_gt in H0.
       apply Z.lt_le_incl in H0.
       auto.
     * apply Z.leb_gt in H0. simpl.
       case_eq (a <=? z)%Z.
       apply Z.lt_le_incl in H0.
       split; auto.
       apply Zle_bool_imp_le in H1. firstorder.
       intro.
       SearchAbout  [(_ <=? _)%Z].
       apply Z.leb_gt in H1.
       destruct H.
       split. assumption.
       replace (z :: vstavi a l) with (vstavi a (z :: l)).
       now apply IHl.
       simpl.
       case_eq (a<=?z)%Z.
       proof.
          intro.
          absurd ((a<=?z)%Z = true).
          - rewrite -> not_true_iff_false.
               now apply Z.leb_gt.
          - assumption.
       end proof.
       intro.
       reflexivity.
Qed.

Lemma dodaj_glavo:
  forall (x:Z)(l:list Z), pojavi x (x :: l) = S (pojavi x l).

Proof.
  intros x l.
  simpl.
  case_eq (x=?x)%Z.
    - intro. auto.
    - intro. absurd ((x=?x)%Z = false).
      + SearchAbout (?A <> false).
        rewrite -> not_false_iff_true.
        apply Z.eqb_eq.
        reflexivity.
      + assumption.
Qed.

Lemma druga_glava:
   forall (x:Z)(a:Z)(l:list Z),
          ((x =? a)%Z = false) -> pojavi x l = pojavi x (a :: l).

Proof.
  intros x a l H.
  simpl.
  case_eq (x=?a)%Z; intro.
  - absurd ((x =? a)%Z = false).
    + rewrite -> not_false_iff_true; assumption.
    + assumption.
  - reflexivity.
Qed.

Lemma ista_glava:
   forall (x:Z)(l:list Z)(l':list Z),(pojavi x l)=(pojavi x l') -> pojavi x (x :: l) = pojavi x (x :: l').

Proof.
  intros x l l' H.
  simpl.
  case_eq (x =? x)%Z.
  - intro.
    apply eq_S.
    assumption.
  - intro.
    assumption.
Qed.

Lemma vstavi_pojavitev:
  forall (x:Z)(l: list Z), S(pojavi x l)= pojavi x (vstavi x l).

Proof.
  induction l.
  - simpl. case_eq (x=?x)%Z.
    + intro. auto.
    + intro. absurd ((x=?x)%Z = false).
      * SearchAbout (?A <> false).
        rewrite -> not_false_iff_true.
        apply Z.eqb_eq.
        reflexivity.
      * assumption.
  - simpl.
    case_eq (x =? a)%Z.
    + intro.
      apply Z.eqb_eq in H.
      rewrite <- H.
      case_eq (x <=? x)%Z.
      * intro.
        rewrite -> IHl.
        rewrite -> dodaj_glavo.
        apply eq_S.
        rewrite <- IHl.
        rewrite <- dodaj_glavo.
        reflexivity.
      * intro.
        absurd ((x <=? x)%Z = false).
        apply not_false_iff_true.
        apply Z.leb_refl.
        assumption.
   + intro.
     case_eq (x <=? a)%Z.
     * intro.
       rewrite <- dodaj_glavo.
       apply ista_glava.
       apply druga_glava.
       assumption.
     * intro.
       rewrite -> IHl.
       apply druga_glava.
       assumption.
Qed.

Lemma vstavi_nepojavitev:
  forall (x:Z)(a:Z)(l: list Z), (x<>a) -> pojavi x l= pojavi x (vstavi a l).

Proof.
  intros x a l H.
  induction l.
  - simpl.
    case_eq (x =? a)%Z.
    + intro.
      rewrite -> Z.eqb_eq in H0.
      absurd (x=a); auto.
    + auto.
  - simpl.
    case_eq (x =? a)%Z.
    + intros.
      absurd (x=a)%Z.
      * auto.
      * apply Z.eqb_eq in H0; assumption.
    + intros.
      case_eq (x =? a0)%Z.
      * intros.
        case_eq (a <=? a0)%Z.
          intros.
          rewrite <- druga_glava ; [idtac|assumption].
          apply Z.eqb_eq in H1.
          replace  a0 with x.
          rewrite <- dodaj_glavo; auto.

          intros.
          apply Z.eqb_eq in H1.
          replace  a0 with x.
          rewrite -> dodaj_glavo.
          apply eq_S.
          assumption.
      * intros.
        case_eq (a <=? a0)%Z.
        intros.
        rewrite <- druga_glava; [idtac | assumption].
        rewrite <- druga_glava; [auto | assumption].

        intros.
        rewrite <- druga_glava; [idtac | assumption].
        apply IHl.
Qed.

Theorem permutacija:
  forall (l: list Z), (permutiran l (insert l)).
Proof.
  intro.
  induction l.
  - firstorder.
  - intro.
    simpl.
    case_eq (x =? a)%Z.
    + intro.
      apply Z.eqb_eq in H.
      replace a with x.
      replace (pojavi x l) with (pojavi x (insert l)).
      apply vstavi_pojavitev.
      apply permutiran_sym.
      assumption.
    + intro.
      apply Z.eqb_neq in H.
      replace (pojavi x l) with (pojavi x (insert l)).
      apply vstavi_nepojavitev; assumption.
      apply permutiran_sym.
      assumption.
Qed.

Theorem urejenost:
  forall (l : list Z), urejen (insert l).
Proof.
  intro.
  induction l; firstorder.
  simpl.
  apply urejen_t.
  assumption.
Qed.

Theorem vse_dela_pravilno:
  forall (l : list Z), urejen (insert l) /\ permutiran l (insert l).

Proof.
  split; [apply urejenost | apply permutacija].
Qed.

Theorem Mi_smo_najboljsa_skupina:
      true=true.
Admitted.
(**"Malo zabave za profesorja. :D" **).


Require Import Nat Arith Bool.

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

Scheme Equality for Nat.

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

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

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

Fixpoint less (less_arg0 : Nat) (less_arg1 : Nat) : bool
           := match less_arg0, less_arg1 with
              | x, zero => false
              | zero, succ x => true
              | succ x, succ y => less x y
              end.

Fixpoint mem (mem_arg0 : Nat) (mem_arg1 : Lst) : bool
           := match mem_arg0, mem_arg1 with
              | x, nil => false
              | x, cons y z => orb (Nat_beq x y) (mem x z)
              end.

Fixpoint insort (insort_arg0 : Nat) (insort_arg1 : Lst) : Lst
           := match insort_arg0, insort_arg1 with
              | i, nil => cons i nil
              | i, cons x y => if less i x then cons i (cons x y) else cons x (insort i y)
              end.

Fixpoint sort (sort_arg0 : Lst) : Lst
           := match sort_arg0 with
              | nil => nil
              | cons x y => insort x (sort y)
              end.

Lemma Nat_beq_refl : forall (n : Nat), Nat_beq n n = true.
Proof.
  intros.
  induction n.
  - reflexivity.
  - assumption.
Qed.

Theorem theorem0 : forall (x : Nat) (y : Lst), eq (mem x (insort x y)) true.
Proof.
  intros.
  induction y.
  - simpl. rewrite Nat_beq_refl. reflexivity.
  - simpl. destruct (less x n).
    + simpl. rewrite Nat_beq_refl. reflexivity.
    + simpl. rewrite IHy. apply orb_true_r.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_differenceofparts.
Require Import ProofCheckingEuclid.lemma_s_incirc_centre.
Require Import ProofCheckingEuclid.lemma_s_incirc_within_radius.
Require Import ProofCheckingEuclid.proposition_01.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_02 :
	forall A B C,
	neq A B -> neq B C ->
	exists X, Cong A X B C.
Proof.
	intros A B C.
	intros neq_A_B neq_B_C.
	pose proof (proposition_01 _ _ neq_A_B) as (D & equilateral_ABD & Triangle_ABD).
	destruct equilateral_ABD as (Cong_AB_BD & Cong_BD_DA).
	apply lemma_congruencesymmetric in Cong_BD_DA as Cong_DA_BD.
	apply lemma_congruenceflip in Cong_DA_BD as (_ & _ & Cong_DA_DB).
	assert (nCol_A_B_D := Triangle_ABD).
	unfold Triangle in nCol_A_B_D.

	pose proof (postulate_Euclid3 _ _ neq_B_C) as (J & CI_J_B_BC).
	apply lemma_NCdistinct in nCol_A_B_D as (
		_ & neq_B_D & neq_A_D & neq_B_A & neq_D_B & neq_D_A
	).

	pose proof (lemma_s_incirc_centre _ _ _ _ CI_J_B_BC) as InCirc_B_J.
	pose proof (
		postulate_line_circle _ _ _ _ _ _ CI_J_B_BC InCirc_B_J neq_D_B
	) as (_ & G & _ & BetS_D_B_G & _ & OnCirc_G_J & _).

	pose proof(lemma_betweennotequal _ _ _ BetS_D_B_G) as (neq_B_G & _ & neq_D_G).

	pose proof (postulate_Euclid3 _ _ neq_D_G) as (R & CI_R_D_DG).
	pose proof(axiom_circle_center_radius _ _ _ _ _ CI_J_B_BC OnCirc_G_J) as Cong_BG_BC.

	pose proof(cn_congruencereflexive D G) as Cong_DG_DG.
	pose proof (
		lemma_s_incirc_within_radius _ _ _ _ _ _ _ CI_R_D_DG BetS_D_B_G Cong_DG_DG Cong_DA_DB
	) as InCirc_A_R.

	pose proof (
		postulate_line_circle _ _ _ _ _ _ CI_R_D_DG InCirc_A_R neq_D_A
	) as (_ & L & _ & BetS_D_A_L & _ & OnCirc_L_R & _).

	exists L.

	pose proof(axiom_circle_center_radius _ _ _ _ _ CI_R_D_DG OnCirc_L_R) as Cong_DL_DG.

	apply lemma_congruencesymmetric in Cong_DA_DB as Cong_DB_DA.
	apply lemma_congruencesymmetric in Cong_DL_DG as Cong_DG_DL.
	pose proof (
		lemma_differenceofparts _ _ _ _ _ _ Cong_DB_DA Cong_DG_DL BetS_D_B_G BetS_D_A_L
	) as Cong_BG_AL.

	pose proof (cn_congruencetransitive _ _ _ _ _ _ Cong_BG_AL Cong_BG_BC) as Cong_AL_BC.

	exact Cong_AL_BC.
Qed.

End Euclid.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Supplementary Coq material: unification and logic programming
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)

Require Import Frap.

Set Implicit Arguments.

(** * Introducing Logic Programming *)

(* Recall the definition of addition from the standard library. *)

Definition real_plus := Eval compute in plus.
Print real_plus.

(* Recursive definition :: FP style. *)

(* Inductive relations :: Logic style. *)
Inductive plusR : nat -> nat -> nat -> Prop :=
| PlusO : forall m, plusR O m m
| PlusS : forall n m r, plusR n m r -> plusR (S n) m (S r).

(* Recall that Coq will automatically derive the induction principle for
 * inductives. For example: *)

Print list.
Check list_ind.

(* Similarly we have a induction principle for plusR. *)

Check plusR_ind.

(* Intuitively, a fact [plusR n m r] only holds when [plus n m = r].  It is not
 * hard to prove this correspondence formally. *)

Theorem plus_plusR : forall n m,
  plusR n m (n + m).
Proof.
  induct n; simplify.

  (* apply PlusO. *)
  (* exact (PlusO m). *)
  constructor.
  (* [constructor] applies the corresponding constructor definition. *)

  constructor.
  apply IHn.
Qed.

(* We see here another instance of the very mechanical proof pattern that came
 * up before: keep trying constructors and hypotheses.  The tactic [auto] will
 * automate searching through sequences of that kind, when we prime it with good
 * suggestions of single proof steps to try, as with this command: *)

Hint Constructors plusR.

(* That is, every constructor of [plusR] should be considered as an atomic proof
 * step, from which we enumerate step sequences. *)

Theorem plus_plusR_snazzy : forall n m,
  plusR n m (n + m).
Proof.
  induct n; simplify; auto.
Qed.

Theorem plusR_plus : forall n m r,
  plusR n m r
  -> r = n + m.
Proof.
  induct 1.
    (* [induct 1] instructs Coq to perform induction on the first hypothesis
     of the theorem, which is [plusR n m r]. *)
  2: {
    (* Choose the second subgoal to prove first *)
    simplify; linear_arithmetic.
  }
  simplify; linear_arithmetic.
Qed.

(* With the functional definition of [plus], simple equalities about arithmetic
 * follow by computation. *)

Example four_plus_three : 4 + 3 = 7.
Proof.
  reflexivity.
Qed.

Print four_plus_three.

(* With the relational definition, the same equalities take more steps to prove,
 * but the process is completely mechanical.

 * For example, consider this
 * simple-minded manual proof search strategy.  The steps prefaced by [Fail] are
 * intended to fail; they're included for explanatory value, to mimic a
 * simple-minded try-everything strategy. *)

Example four_plus_three' : plusR 4 3 7.
Proof.
  Fail apply PlusO.
  apply PlusS.
  Fail apply PlusO.
  apply PlusS.
  Fail apply PlusO.
  apply PlusS.
  Fail apply PlusO.
  apply PlusS.
  apply PlusO.

  (* At this point the proof is completed.  It is no doubt clear that a simple
   * procedure could find all proofs of this kind for us.  We are just exploring
   * all possible proof trees, built from the two candidate steps [apply PlusO]
   * and [apply PlusS].  Thus, [auto] is another great match! *)
Restart.
  debug auto.
Qed.

Print four_plus_three'.

(* Let us try the same approach on a slightly more complex goal. *)

Example five_plus_three : plusR 5 3 8.
Proof.
  auto.

  (* This time, [auto] is not enough to make any progress.

   * Since even a single candidate step may lead to an infinite
   * space of possible proof trees, [auto] is parameterized on the
   * maximum depth of trees to consider.

   * The default depth is 5, and it turns out that we need depth 6 to prove the
   * goal. *)

  auto 6.
  (* Sometimes it is useful to see a description of the proof tree that [auto]
   * finds, with the [info_auto] variant. *)

Restart.
  info_auto 6.
Restart.
  debug auto 6.
  (* Also shows failed steps *)
Qed.

(* The two key components of logic programming are

    _backtracking_ and _unification_

 * To see these techniques in action, consider this further
 * silly example.  Here our candidate proof steps will be reflexivity and
 * quantifier instantiation. *)

Check ex_intro.

Example seven_minus_three : exists x, x + 3 = 7.
Proof.
  (* For explanatory purposes, let us simulate a user with minimal understanding
   * of arithmetic.  We start by choosing an instantiation for the quantifier.
   * It is relevant that [ex_intro] is the proof rule for existential-quantifier
   * instantiation. *)

  apply ex_intro with 0.
  Fail reflexivity.

  (* This seems to be a dead end.  Let us _backtrack_ to the point where we ran
   * [apply] and make a better alternative choice. *)

Restart.
  apply ex_intro with 4.
  reflexivity.
Qed.

(* The above was a fairly tame example of backtracking. In general, any node in
 * an under-construction proof tree may be the destination of backtracking an
 * arbitrarily large number of times, as different candidate proof steps are
 * found not to lead to full proof trees, within the depth bound passed to [auto].
 *
 * Next we demonstrate unification, which will be easier when we switch to the
 * relational formulation of addition. *)

Example seven_minus_three' : exists x, plusR x 3 7.
Proof.
  (* We could attempt to guess the quantifier instantiation manually as before,
   * but here there is no need.  Instead of [apply], we use [eapply], which
   * proceeds with placeholder _unification variables_ standing in for those
   * parameters we wish to postpone guessing. *)

  eapply ex_intro.
  (* [eapply H]: like [apply], but works when it is not obvious how to
   * instantiate the quantifiers of theorem/hypothesis [H].  Instead,
   * placeholders are inserted for those quantifiers, to be determined
   * later. *)

  (* Now we can finish the proof with the right applications of [plusR]'s
   * constructors.  Note that new unification variables are being generated to
   * stand for new unknowns. *)

  apply PlusS.
  apply PlusS. apply PlusS. apply PlusS.
  apply PlusO.

  (* The [auto] tactic will not perform these sorts of steps that introduce
   * unification variables, but the [eauto] tactic will.  It is helpful to work
   * with two separate tactics, because proof search in the [eauto] style can
   * uncover many more potential proof trees and hence take much longer to
   * run. *)

Restart.
  auto 6.
  info_eauto 6.
Qed.

Print seven_minus_three'.

(* This proof gives us our first example where logic programming simplifies
 * proof search compared to functional programming.

 * In general, functional programs are only meant to be run in a single
 * direction; a function has disjoint sets of inputs and outputs.
 * In the last example, we effectively ran a logic program backwards,
 * deducing an input that gives rise to a certain output.

 * The same works for deducing an unknown value of the other input. *)

Example seven_minus_four' : exists x y, plusR x y 7 /\ x <> 0 /\ y <> 6.
Proof.
  eauto 8.
Qed.

Print seven_minus_four'.

(* _Connecting Functional Programs and Logical Proofs_

 * By proving the right auxiliary facts, we can reason about specific functional
 * programs in the same way as we did above for a logic program.

 * Recall the relational definition of [plusR] *)

Print plusR.

(* Let us prove that the constructors of [plusR] have natural interpretations
 * as lemmas about [plus]. *)

SearchRewrite (O + _).

(* The command [Hint Immediate] asks [auto] and [eauto] to consider this lemma
 * as a candidate step for any leaf of a proof tree, meaning that all premises
 * of the rule need to match hypotheses. *)

Hint Immediate plus_O_n.

(* Proof search will try [simple apply plus_O_n; trivial] whenever it is
 * applicable. *)

(* The counterpart to [PlusS] we will prove ourselves. *)

Print PlusS.

Lemma plusS : forall n m r,
  n + m = r
  -> S n + m = S r.
Proof.
  linear_arithmetic.
Qed.

(* The command [Hint Resolve] adds a new candidate proof step, to be attempted
 * at any level of a proof tree, not just at leaves. *)

Hint Resolve plusS.

(* Proof search will try [simple apply plusS] whenever it is applicable. *)

(* Now that we have registered the proper hints, we can replicate our previous
 * examples with the normal, functional addition [plus]. *)

Example seven_minus_three'' : exists x, x + 3 = 7.
Proof.
  debug eauto 6.
Qed.

Example seven_minus_four : exists x, 4 + x = 7.
Proof.
  info_eauto 6.
Qed.

(* This new _hint database_ is far from a complete decision procedure,
 * as we see in a further example that [eauto] does not finish. *)

Example seven_minus_four_zero : exists x, 4 + x + 0 = 7.
Proof.
  debug eauto 6.
Abort.

(* A further lemma will be helpful. *)

Lemma plusO : forall n m,
  n = m
  -> n + 0 = m.
Proof.
  linear_arithmetic.
Qed.

Hint Resolve plusO.

(* Note that, if we consider the inputs to [plus] as the inputs of a
 * corresponding logic program, the new rule [plusO] introduces an ambiguity. *)

Check plus_O_n.
Check plusO.

(* For instance, a sum [0 + 0] would match both of [plus_O_n] and [plusO],
 * depending on which operand we focus on.  This ambiguity may increase the
 * number of potential search trees, slowing proof search, but semantically it
 * presents no problems, and in fact it leads to an automated proof of the
 * present example. *)

Example seven_minus_four_zero : exists x, 4 + x + 0 = 7.
Proof.
  info_eauto 7.
Qed.

(* Just how much damage can be done by adding hints that grow the space of
 * possible proof trees?  A classic gotcha comes from unrestricted use of
 * transitivity, as embodied in this library theorem about equality: *)

Check eq_trans.

(* Hints are scoped over sections, so let us enter a section to contain the
 * effects of an unfortunate hint choice. *)

Section slow.
  Hint Resolve eq_trans.

  (* The following fact is false, but that does not stop [eauto] from taking a
   * very long time to search for proofs of it.  We use the handy [Time] command
   * to measure how long a proof step takes to run.  None of the following steps
   * make any progress. *)

  Example zero_minus_one : exists x, 1 + x = 0.
    Time eauto 1.
    Time eauto 2.
    Time eauto 3.
    Time eauto 4.
    Time eauto. (* 5 *)

    (* We see worrying exponential growth in running time, and the [debug]
     * tactical helps us see where [eauto] is wasting its time, outputting a
     * trace of every proof step that is attempted.  The rule [eq_trans] applies
     * at every node of a proof tree, and [eauto] tries all such positions. *)

    debug eauto 4.
  Abort.
End slow.

(* Sometimes, though, transitivity is just what is needed to get a proof to go
 * through automatically with [eauto].  For those cases, we can use named
 * _hint databases_ to segregate hints into different groups that may be called
 * on as needed.  Here we put [eq_trans] into the database [slow]. *)

Hint Resolve eq_trans : slow.

Example from_one_to_zero : exists x, 1 + x = 0.
Proof.
  Time eauto.
  (* This [eauto] fails to prove the goal, but at least it takes substantially
   * less than the ~1.2 seconds required above! *)
Abort.

(* When we _do_ need transitivity, we ask for it explicitly. *)

Example needs_trans : forall x y, 1 + x = y
  -> y = 2
  -> exists z, z + x = 3.
Proof.
  info_eauto with slow.
Restart.
  intro.
intro.
intro.
intro.
simple eapply ex_intro.
 simple apply plusS.
  simple eapply eq_trans.
   exact H.
   exact H0.
Qed.

(** * Searching for Underconstrained Values *)

(* Recall the definition of the list length function. *)

Print Datatypes.length.

(* This function is easy to reason about in the forward direction, computing
 * output from input. *)

Example length_1_2 : length (1 :: 2 :: nil) = 2.
Proof.
  info_auto.
Qed.

Print length_1_2.

(* As in the last section, we will prove some lemmas to recast [length] in
 * logic-programming style, to help us compute inputs from outputs. *)

(* Here is the relational definition of length *)
Inductive lengthR {A : Type} : list A -> nat -> Prop :=
| lengthO : lengthR nil 0
| lengthS : forall h t n, lengthR t n -> lengthR (h::t) (S n).

(* As before, connect the logical version to the similar
 * functional version *)
Theorem length_O : forall A, length (@nil A) = O.
Proof.
  simplify; equality.
Qed.

Theorem length_S : forall A (h : A) t n,
  length t = n
  -> length (h :: t) = S n.
Proof.
  simplify; equality.
Qed.

Hint Resolve length_O length_S.

(* Let us apply these hints to prove that a [list nat] of length 2 exists.
 * (Here we register [length_O] with [Hint Resolve] instead of [Hint Immediate]
 * merely as a convenience to use the same command as for [length_S]; [Resolve]
 * and [Immediate] have the same meaning for a premise-free hint.) *)

Example length_is_2 : exists ls : list nat, length ls = 2.
Proof.
  eauto.

  (* Coq leaves for us two subgoals to prove... [nat]?!  We are being asked to
   * show that natural numbers exists.  Why?  Some unification variables of that
   * type were left undetermined, by the end of the proof.  Specifically, these
   * variables stand for the 2 elements of the list we find.  Of course it makes
   * sense that the list length follows without knowing the data values.  In Coq
   * 8.6, the [Unshelve] command brings these goals to the forefront, where we
   * can solve each one with [exact O], but usually it is better to avoid
   * getting to such a point.
   *
   * To debug such situations, it can be helpful to print the current internal
   * representation of the proof, so we can see where the unification variables
   * show up. *)

  Show Proof.
Abort.

(* Paradoxically, we can make the proof-search process easier by constraining
 * the list further, so that proof search naturally locates appropriate data
 * elements by unification.  The library predicate [Forall] will be helpful. *)

Check Forall.

Example length_is_2 : exists ls : list nat, length ls = 2
  /\ Forall (fun n => n >= 0) ls.
Proof.
  eauto 9.
Qed.

(* We can see which list [eauto] found by printing the proof term. *)

Print length_is_2.

(* The elements chosen for the list is [0] *)

(* Let us try one more, fancier example.  First, we use a standard higher-order
 * function to define a function for summing all data elements of a list. *)

Definition sum := fold_right plus O.

(* Another basic lemma will be helpful to guide proof search. *)

Check plusO.

Lemma plusO' : forall n m,
  n = m
  -> 0 + n = m.
Proof.
  linear_arithmetic.
Qed.

Hint Resolve plusO'.

(* Finally, we meet [Hint Extern], the command to register a custom hint.  That
 * is, we provide a pattern to match against goals during proof search.
 * Whenever the pattern matches, a tactic (given to the right of an arrow [=>])
 * is attempted.  Below, the number [1] gives a priority for this step.  Lower
 * priorities are tried before higher priorities, which can have a significant
 * effect on proof search time, i.e. when we manage to give lower priorities to
 * the cheaper rules. *)

Hint Extern 1 (sum _ = _) => simplify.

(* Now we can find a length-2 list whose sum is 0. *)

Example length_and_sum : exists ls : list nat, length ls = 2
  /\ sum ls = O.
Proof.
  info_eauto 7.
Restart.
simple eapply ex_intro.
 simple apply conj.
  simple apply length_S.
   simple apply length_S.
    simple apply length_O.
    (*external*) simplify.
     simple apply plusO'.
      simple apply plus_O_n ; trivial.
Qed.

Print length_and_sum.

(* Printing the proof term shows the unsurprising list that is found.  Here is
 * an example where it is less obvious which list will be used.  Can you guess
 * which list [eauto] will choose? *)

Example length_and_sum' : exists ls : list nat, length ls = 5
  /\ sum ls = 42.
Proof.
  eauto 15.
Qed.

Print length_and_sum'.

(* We will give away part of the answer and say that the above list is less
 * interesting than we would like, because it contains too many zeroes.  A
 * further constraint forces a different solution for a smaller instance of the
 * problem. *)

Example length_and_sum'' : exists ls : list nat, length ls = 2
  /\ sum ls = 3
  /\ Forall (fun n => n <> 0) ls.
Proof.
  eauto 11.
Qed.

Print length_and_sum''.

(* We could continue through exercises of this kind, but even more interesting
 * than finding lists automatically is finding _programs_ automatically. *)

(** * Synthesizing Programs *)

(* Here is a simple syntax type for arithmetic expressions, similar to those we
 * have used several times before.  In this case, we allow expressions to
 * mention exactly one distinguished variable. *)

Inductive exp : Set :=
| Const (n : nat)
| Var
| Plus (e1 e2 : exp).

(* An inductive relation specifies the semantics of an expression, relating a
 * variable value and an expression to the expression value. *)

Inductive eval (var : nat) : exp -> nat -> Prop :=
| EvalConst : forall n, eval var (Const n) n
| EvalVar : eval var Var var
| EvalPlus : forall e1 e2 n1 n2,
       eval var e1 n1
    -> eval var e2 n2
    -> eval var (Plus e1 e2) (n1 + n2).

Hint Constructors eval.

(* We can use [auto] to execute the semantics for specific expressions. *)

Example eval1 : forall var,
  eval var (Plus Var (Plus (Const 8) Var))
           (var + (8 + var)).
Proof.
  info_eauto.
Restart.
intro.
simple apply EvalPlus.
 simple apply EvalVar.
 simple apply EvalPlus.
  simple apply EvalConst.
  simple apply EvalVar.
Qed.

(* Unfortunately, just the constructors of [eval] are not enough to prove
 * theorems like the following, which depends on an arithmetic identity. *)

Example eval1' : forall var,
  eval var (Plus Var (Plus (Const 8) Var))
           (2 * var + 8).
Proof.
  eauto.
Restart.
  intros.
  apply EvalPlus.
   (* cannot proceed further *)
Abort.

(* To help prove [eval1'], we prove an alternative version of [EvalPlus] that
 * inserts an extra equality premise.  This sort of staging is helpful to get
 * around limitations of [eauto]'s unification.

 * With the alternative version below, to prove the first
 * two premises, [eauto] is given free reign in deciding the values of [n1] and
 * [n2], while the third premise can then be proved by [reflexivity], no matter
 * how each of its sides is decomposed as a tree of additions. *)

Check EvalPlus.

Theorem EvalPlus' : forall var e1 e2 n1 n2 n,
     eval var e1 n1
  -> eval var e2 n2
  -> n1 + n2 = n
  -> eval var (Plus e1 e2) n.
  (* One way to think about this is that we're extending the
     evaluator with more rules. *)
Proof.
  simplify.
  subst.
  auto.
Qed.

Hint Resolve EvalPlus'.

(* Further, we instruct [eauto] to apply [ring], via [Hint Extern].  We should
 * try this step for any equality goal. *)

Section use_ring.
  Hint Extern 1 (_ = _) => ring.

  (* Now we can return to [eval1'] and prove it automatically. *)

  Example eval1' : forall var,
    eval var (Plus Var (Plus (Const 8) Var))
             (2 * var + 8).
  Proof.
    info_eauto.
  Restart.
  intro.
  simple eapply EvalPlus'.
   simple apply EvalVar.
   simple apply EvalPlus.
    simple apply EvalConst.
    simple apply EvalVar.
    (*external*) ring.
  Qed.

  (* Now we are ready to take advantage of logic programming's flexibility by
   * searching for a program (arithmetic expression) that always evaluates to a
   * particular symbolic value. *)

  Example synthesize1 : exists e, forall var, eval var e (var + 7).
  Proof.
    eauto.
  Qed.

  Print synthesize1.

  (* Here are two more examples showing off our program-synthesis abilities. *)

  Example synthesize2 : exists e, forall var,
    eval var e (2 * var + 8).
  Proof.
    eauto.
  Qed.

  Print synthesize2.

  Example synthesize3 : exists e, forall var,
    eval var e (3 * var + 42).
  Proof.
    eauto.
  Qed.

  Print synthesize3.
End use_ring.