Require Import Bool Recdef Equality FunctionalExtensionality.
Require Import List.
Import ListNotations.

Inductive PTree (A : Type) : Type :=
| L : A -> PTree A
| N : PTree (A * A) -> PTree A.

Arguments L {A} _.
Arguments N {A} _.

Fixpoint map {A B : Type} (f : A -> B) (t : PTree A) : PTree B :=
match t with
| L x  => L (f x)
| N t' => N (map (fun '(x, y) => (f x, f y)) t')
end.

Definition swap {A B : Type} (p : A * B) : B * A :=
match p with
| (x, y) => (y, x)
end.

Fixpoint mirror {A : Type} (t : PTree A) : PTree A :=
match t with
| L x  => L x
| N t' => N (map swap (mirror t'))
end.

Function leftmost {A : Type} (t : PTree A) : option A :=
match t with
| L x  => Some x
| N t' =>
  match leftmost t' with
  | None        => None
  | Some (x, _) => Some x
  end
end.

Function rightmost {A : Type} (t : PTree A) : option A :=
match t with
| L x  => Some x
| N t' =>
  match rightmost t' with
  | None        => None
  | Some (_, x) => Some x
  end
end.

Fixpoint size {A : Type} (t : PTree A) : nat :=
match t with
| L x  => 0
| N t' => 1 + size t'
end.

Fixpoint height {A : Type} (t : PTree A) : nat :=
match t with
| L x => 0
| N t' => 1 + height t'
end.

Fixpoint flatten {A : Type} (l : list (A * A)) : list A :=
match l with
| [] => []
| (hl, hr) :: t => hl :: hr :: flatten t
end.

Fixpoint bfs {A : Type} (t : PTree A) : list A :=
match t with
| L x => [x]
| N t' => flatten (bfs t')
end.

Fixpoint complete {A : Type} (n : nat) (x : A) : PTree A :=
match n with
| 0 => L x
| S n' => N (complete n' (x, x))
end.

Fixpoint any {A : Type} (p : A -> bool) (t : PTree A) : bool :=
match t with
| L x  => p x
| N t' => any (fun '(x, y) => p x || p y) t'
end.

Fixpoint all {A : Type} (p : A -> bool) (t : PTree A) : bool :=
match t with
| L x  => p x
| N t' => all (fun '(x, y) => p x && p y) t'
end.

Fixpoint find {A : Type} (p : A -> bool) (t : PTree A) : option A :=
match t with
| L x  => if p x then Some x else None
| N t' =>
  match find (fun '(x, y) => p x || p y) t' with
  | None        => None
  | Some (x, y) => if p x then Some x else Some y
  end
end.

(*
Fixpoint zipWith {A B C : Type} (f : A -> B -> C) (ta : PTree A) (tb : PTree B) : PTree C :=
match ta, tb with
| L x, L y => L (f x y)
| _, L x => L x
| Layer a ta', Layer b tb' => Layer (f a b) (zipWith (fun '(al, ar) '(bl, br) => (f al bl, f ar br)) ta' tb')
end.
*)

Fixpoint left {A : Type} (t : PTree (A * A)) : PTree A :=
match t with
| L (x, _) => L x
| N t'     => N (left t')
end.

Fixpoint right {A : Type} (t : PTree (A * A)) : PTree A :=
match t with
| L (x, _) => L x
| N t'     => N (right t')
end.

Fixpoint count {A : Type} (p : A -> nat) (t : PTree A) : nat :=
match t with
| L x  => p x
| N t' => count (fun '(x, y) => p x + p y) t'
end.

(* TODO

Parameter leaf : forall A : Type, A -> BTree A.

Parameter isL x : forall A : Type, BTree A -> bool.

Parameter root : forall A : Type, BTree A -> option A.

Parameter unN : forall A : Type, BTree A -> option (A * BTree A * BTree A).

Parameter inorder : forall A : Type, BTree A -> list A.
Parameter preorder : forall A : Type, BTree A -> list A.
Parameter postorder : forall A : Type, BTree A -> list A.

Parameter iterate : forall A : Type, (A -> A) -> nat -> A -> BTree A.

Parameter index : forall A : Type, list bool -> BTree A -> option A.
Parameter nth : forall A : Type, nat -> BTree A -> option A.

Parameter take : forall A : Type, nat -> BTree A -> BTree A.
Parameter drop : forall A : Type, nat -> BTree A -> list (BTree A).
Parameter takedrop :
  forall A : Type, nat -> BTree A -> BTree A * list (BTree A).

Parameter intersperse : forall A : Type, A -> BTree A -> BTree A.

Parameter insertAtLeaf :
  forall A : Type, list bool -> BTree A -> BTree A.

Parameter findIndex :
  forall A : Type, (A -> bool) -> BTree A -> option (list bool).

Parameter takeWhile : forall A : Type, (A -> bool) -> BTree A -> BTree A.

Parameter findIndices :
  forall A : Type, (A -> bool) -> BTree A -> list (list bool).

Parameter unzipWith :
 forall A B C : Type, (A -> B * C) -> BTree A -> BTree B * BTree C.
*)

Lemma map_id :
  forall {A : Type} (t : PTree A),
    map id t = t.
Proof.
  induction t; cbn; unfold id.
    reflexivity.
    rewrite <- IHt at 2. repeat f_equal.
      extensionality p. destruct p. reflexivity.
Qed.

Lemma map_map :
  forall {A B C : Type} (f : A -> B) (g : B -> C) (t : PTree A),
    map g (map f t) = map (fun x => g (f x)) t.
Proof.
  intros until t. revert B C f g.
  induction t; cbn; intros.
    reflexivity.
    rewrite IHt. repeat f_equal.
      extensionality x. destruct x. reflexivity.
Qed.

Lemma leftmost_map :
  forall {A B : Type} (f : A -> B) (t : PTree A),
    leftmost (map f t) =
      match leftmost t with
      | None   => None
      | Some a => Some (f a)
      end.
Proof.
  intros. revert B f.
  induction t; cbn; intros.
    reflexivity.
    rewrite IHt. destruct (leftmost t).
      destruct p. reflexivity.
      reflexivity.
Qed.

Lemma leftmost_mirror :
  forall {A : Type} (t : PTree A),
    leftmost (mirror t) = rightmost t.
Proof.
  induction t; cbn.
    reflexivity.
    rewrite leftmost_map, IHt.
      destruct (rightmost t) as [[] |]; cbn; reflexivity.
Qed.

Lemma map_mirror :
  forall {A B : Type} (f : A -> B) (t : PTree A),
    map f (mirror t) = mirror (map f t).
Proof.
  intros until t. revert B f.
  induction t; cbn; intros.
    reflexivity.
    rewrite <- IHt, !map_map. repeat f_equal.
      extensionality p. destruct p. cbn. reflexivity.
Qed.

Lemma mirror_mirror :
  forall {A : Type} (t : PTree A),
    mirror (mirror t) = t.
Proof.
  induction t; cbn.
    reflexivity.
    rewrite !map_mirror, map_map. rewrite <- IHt at 2.
      repeat f_equal. rewrite <- map_id. f_equal.
      extensionality p. destruct p. cbn. reflexivity.
Qed.

(*
Inductive PTree' {A : Type} (P : A -> Type) : PTree A -> Type :=
| L x' : PTree' P L x
| Layer' :
    forall (x : A) (t : PTree (prod A A)),
      P x -> PTree' (fun '(x, y) => prod (P x) (P y)) t -> PTree' P (Layer x t).

Fixpoint PTree_ind_deep
  (P : forall (A : Type) (Q : A -> Type), PTree A -> Type)
  (empty : forall (A : Type) (Q : A -> Type),
             P A Q L x)
  (layer : forall (A : Type) (Q : A -> Type) (x : A) (t : PTree (A * A)),
             Q x -> P (prod A A) (fun '(x, y) => prod (Q x) (Q y)) t -> P A Q (Layer x t))
  {A : Type} (Q : A -> Type)
  {t : PTree A} (t' : PTree' Q t) {struct t'} : P A Q t.
Proof.
  destruct t' as [| x t Qx Ct].
    apply empty.
    apply layer.
      exact Qx.
      apply PTree_ind_deep; assumption.
Defined.
*)


(** Let's prove a simple theorem **)

Theorem thm : forall P Q:Prop, ((P->Q)/\P)->Q.
intros p q h.
destruct h.
apply H.
assumption.
Qed.


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

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

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

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

(** One small digression before we get to maps. *)

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

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

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

(*     The [Search] command is a good way to look for theorems involving  *)
(*     objects of specific types.  Take a minute now to experiment with it. *)

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

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

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

Definition beq_id x y :=
  match x,y with
    | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

(** (The function [string_dec] comes from Coq's string library. *)
(*     If you check its result type, you'll see that it does not actually *)
(*     return a [bool], but rather a type that looks like [{x = y} + {x *)
(*     <> y}], called a [sumbool], which can be thought of as an *)
(*     "evidence-carrying boolean."  Formally, an element of [sumbool] is *)
(*     either a proof that two things are equal or a proof that they are *)
(*     unequal, together with a tag indicating which.  But for present *)
(*     purposes you can think of it as just a fancy [bool].) *)

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. destruct (string_dec n n).
  - reflexivity.
  - destruct n0. reflexivity.
Qed.

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

Theorem beq_id_true_iff : forall x y : id,
  beq_id x y = true <-> x = y.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   destruct (string_dec n1 n2).
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. inversion contra.
     + intros H. inversion H. subst. destruct n. reflexivity.
Qed.

(** Similarly: *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Definition examplemap :=
  t_update (t_update (t_empty false) (Id "foo") false)
           (Id "bar") true.

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

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

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

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

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

(** To use maps in later chapters, we'll need several fundamental *)
(*     facts about how they behave. *)

(** Even if you don't work the following exercises, make sure *)
(*     you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom, *)
(*     which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, optional (t_apply_empty)  *)
(** First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty:  forall A x v, @t_empty A v x = v.
Proof.
  auto.
Qed.
(** [] *)

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

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

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

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  intros X v x1 x2 m H.
  unfold t_update.
  rewrite <- beq_id_false_iff in H.
  now rewrite H.
Qed.

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

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

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

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

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  intros x y.
  destruct (beq_id x y) eqn:Heq.
  constructor. now apply beq_id_true_iff.
  constructor. now apply beq_id_false_iff.
Qed.

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

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

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  intros X x m.
  unfold t_update.
  apply functional_extensionality.
  intros x0.
  destruct (beq_id x x0) eqn:Heq; subst.
  apply beq_id_true_iff in Heq; now subst.
  reflexivity.
Qed.
(** [] *)

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

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m H.
  unfold t_update.
  apply functional_extensionality.
  intros x.
  destruct (beq_id x1 x) eqn:Heq1;
    destruct (beq_id x2 x) eqn:Heq2;
    try now auto.
  apply beq_id_true_iff in Heq1;
    apply beq_id_true_iff in Heq2;
    congruence.
Qed.
(** [] *)

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

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

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

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

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

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

Lemma apply_empty : forall A x, @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

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

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

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

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

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

(** $Date: 2017-07-14 19:07:15 -0400 (Fri, 14 Jul 2017) $ *)


Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Families.
Require Export IndexedFamilies.
Require Export FiniteTypes.
Require Import EnsemblesSpec.

Record TopologicalSpace: Type := {
  point_set :> Type;
  open: Ensemble point_set -> Prop;
  open_family_union:  forall F: Family point_set,
                     (forall S: Ensemble point_set, In F S -> open S) -> open (FamilyUnion F);
  open_intersection2: forall U V:Ensemble point_set, open U -> open V -> open (Intersection U V);
  open_full: open Full_set
}.

Arguments open [t].
Arguments open_family_union [t].
Arguments open_intersection2 [t].

Lemma open_empty: forall X:TopologicalSpace,
  open (@Empty_set (point_set X)).
Proof.
intros.
rewrite <- empty_family_union.
apply open_family_union.
intros.
destruct H.
Qed.

Lemma open_union2: forall {X:TopologicalSpace}
  (U V:Ensemble (point_set X)), open U -> open V -> open (Union U V).
Proof.
intros.
assert (Union U V = FamilyUnion (Couple U V)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
exists U; auto with sets.
exists V; auto with sets.
destruct H1.
destruct H1.
left; trivial.
right; trivial.

rewrite H1; apply open_family_union.
intros.
destruct H2; trivial.
Qed.

Lemma open_indexed_union: forall {X:TopologicalSpace} {A:Type}
  (F:IndexedFamily A (point_set X)),
  (forall a:A, open (F a)) -> open (IndexedUnion F).
Proof.
intros.
rewrite indexed_to_family_union.
apply open_family_union.
intros.
destruct H0.
rewrite H1; apply H.
Qed.

Lemma open_finite_indexed_intersection:
  forall {X:TopologicalSpace} {A:Type}
    (F:IndexedFamily A (point_set X)),
    FiniteT A -> (forall a:A, open (F a)) ->
    open (IndexedIntersection F).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
apply open_full.

assert (IndexedIntersection F = Intersection
  (IndexedIntersection (fun x:T => F (Some x)))
  (F None)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
constructor.
constructor.
intros; apply H1.
apply H1.
destruct H1.
destruct H1.
constructor.
destruct a.
apply H1.
apply H2.
rewrite H1.
apply open_intersection2.
apply IHFiniteT.
intros; apply H0.
apply H0.

destruct H1.
assert (IndexedIntersection F =
  IndexedIntersection (fun x:X0 => F (f x))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct H3.
intro; apply H3.
constructor.
destruct H3.
intro; rewrite <- H2 with a.
apply H3.
rewrite H3.
apply IHFiniteT.
intro; apply H0.
Qed.

Definition closed {X:TopologicalSpace} (F:Ensemble (point_set X)) :=
  open (Ensembles.Complement F).

Lemma closed_complement_open: forall {X:TopologicalSpace}
  (U:Ensemble (point_set X)), closed (Ensembles.Complement U) ->
  open U.
Proof.
intros.
red in H.
rewrite Complement_Complement in H.
assumption.
Qed.

Lemma closed_union2: forall {X:TopologicalSpace}
  (F G:Ensemble (point_set X)),
  closed F -> closed G -> closed (Union F G).
Proof.
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Union F G) =
  Intersection (Ensembles.Complement F)
               (Ensembles.Complement G)).
unfold Ensembles.Complement.
apply Extensionality_Ensembles; split; red; intros.
constructor.
auto with sets.
auto with sets.
destruct H1.
red; red; intro.
destruct H3.
apply (H1 H3).
apply (H2 H3).

rewrite H1.
apply open_intersection2; assumption.
Qed.

Lemma closed_intersection2: forall {X:TopologicalSpace}
  (F G:Ensemble (point_set X)),
  closed F -> closed G -> closed (Intersection F G).
Proof.
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Intersection F G) =
  Union (Ensembles.Complement F)
        (Ensembles.Complement G)).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
unfold Ensembles.Complement in H1.
unfold In in H1.
contradict H1.
constructor.
apply NNPP.
red; intro.
auto with sets.
apply NNPP.
red; intro.
auto with sets.

red; red; intro.
destruct H2.
destruct H1; auto with sets.

rewrite H1; apply open_union2; trivial.
Qed.

Lemma closed_family_intersection: forall {X:TopologicalSpace}
  (F:Family (point_set X)),
  (forall S:Ensemble (point_set X), In F S -> closed S) ->
  closed (FamilyIntersection F).
Proof.
intros.
unfold closed in H.
red.
assert (Ensembles.Complement (FamilyIntersection F) =
  FamilyUnion [ S:Ensemble (point_set X) |
                  In F (Ensembles.Complement S) ]).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
red in H0; red in H0.
contradict H0.
constructor.
intros.
apply NNPP.
red; intro.
contradict H1.
exists (Ensembles.Complement S).
constructor.
rewrite Complement_Complement; assumption.
assumption.
destruct H0.
red; red; intro.
destruct H2.
destruct H0.
pose proof (H2 _ H0).
contradiction H3.

rewrite H0; apply open_family_union.
intros.
destruct H1.
pose proof (H _ H1).
rewrite Complement_Complement in H2; assumption.
Qed.

Lemma closed_indexed_intersection: forall {X:TopologicalSpace}
  {A:Type} (F:IndexedFamily A (point_set X)),
  (forall a:A, closed (F a)) -> closed (IndexedIntersection F).
Proof.
intros.
rewrite indexed_to_family_intersection.
apply closed_family_intersection.
intros.
destruct H0.
rewrite H1; trivial.
Qed.

Lemma closed_finite_indexed_union: forall {X:TopologicalSpace}
  {A:Type} (F:IndexedFamily A (point_set X)),
  FiniteT A -> (forall a:A, closed (F a)) ->
  closed (IndexedUnion F).
Proof.
intros.
red.
assert (Ensembles.Complement (IndexedUnion F) =
  IndexedIntersection (fun a:A => Ensembles.Complement (F a))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
intros.
red; red; intro.
contradiction H1.
exists a.
assumption.
destruct H1.
red; red; intro.
destruct H2.
contradiction (H1 a).

rewrite H1; apply open_finite_indexed_intersection; trivial.
Qed.

Hint Unfold closed : topology.
Hint Resolve (@open_family_union) (@open_intersection2) open_full
  open_empty (@open_union2) (@open_indexed_union)
  (@open_finite_indexed_intersection) (@closed_complement_open)
  (@closed_union2) (@closed_intersection2) (@closed_family_intersection)
  (@closed_indexed_intersection) (@closed_finite_indexed_union)
  : topology.

Section Build_from_closed_sets.

Variable X:Type.
Variable closedP : Ensemble X -> Prop.
Hypothesis closedP_empty: closedP Empty_set.
Hypothesis closedP_union2: forall F G:Ensemble X,
  closedP F -> closedP G -> closedP (Union F G).
Hypothesis closedP_family_intersection: forall F:Family X,
  (forall G:Ensemble X, In F G -> closedP G) ->
  closedP (FamilyIntersection F).

Definition Build_TopologicalSpace_from_closed_sets : TopologicalSpace.
refine (Build_TopologicalSpace X
  (fun U:Ensemble X => closedP (Ensembles.Complement U)) _ _ _).
intros.
replace (Ensembles.Complement (FamilyUnion F)) with
  (FamilyIntersection [ G:Ensemble X | In F (Ensembles.Complement G) ]).
apply closedP_family_intersection.
destruct 1.
rewrite <- Complement_Complement.
apply H; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H1.
destruct H0.
absurd (In (Ensembles.Complement S) x).
intro.
contradiction H3.
apply H0.
constructor.
rewrite Complement_Complement; trivial.
constructor.
destruct 1.
apply NNPP; intro.
contradiction H0.
exists (Ensembles.Complement S); trivial.

intros.
replace (Ensembles.Complement (Intersection U V)) with
  (Union (Ensembles.Complement U) (Ensembles.Complement V)).
apply closedP_union2; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H2.
destruct H1; contradiction H1.
apply NNPP; intro.
contradiction H1.
constructor; apply NNPP; intro; contradiction H2;
  [ left | right ]; trivial.

apply eq_ind with (1 := closedP_empty).
apply Extensionality_Ensembles; split; auto with sets;
  red; intros.
contradiction H.
constructor.
Defined.

Lemma Build_TopologicalSpace_from_closed_sets_closed:
  forall (F:Ensemble (point_set Build_TopologicalSpace_from_closed_sets)),
  closed F <-> closedP F.
Proof.
intros.
unfold closed.
simpl.
rewrite Complement_Complement.
split; trivial.
Qed.

End Build_from_closed_sets.

Arguments Build_TopologicalSpace_from_closed_sets [X].


(* This file tests:
    forward_for_simple_bound on 64-bit long integers,
    forward load with 64-bit integer array subscript, and
    forward store with 64-bit integer array subscript.
*)

Require Import VST.floyd.proofauto.
Require Import VST.progs.min64.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Require Import ZArith.
Require Import List.
Import ListNotations.
Open Scope Z.

Theorem fold_min_general:
  forall (al: list Z)(i: Z),
  In i (al) ->
  forall x, List.fold_right Z.min x al <= i.
Proof.
induction al; intros.
inversion H.
destruct H.
subst a.
simpl.
apply Z.le_min_l.
simpl. rewrite Z.le_min_r.
apply IHal.
apply H.
Qed.

Theorem fold_min:
  forall (al: list Z)(i: Z),
  In i (al) ->
  List.fold_right Z.min (hd 0 al) al <= i.
Proof.
intros.
apply fold_min_general.
apply H.
Qed.

Lemma Forall_fold_min:
  forall (f: Z -> Prop) (x: Z) (al: list Z),
    f x -> Forall f al -> f (fold_right Z.min x al).
Proof.
 intros.
 induction H0.
 simpl. auto.
 simpl.
 unfold Z.min at 1.
 destruct (Z.compare x0 (fold_right Z.min x l)) eqn:?; auto.
Qed.

Lemma fold_min_another:
  forall x al y,
    fold_right Z.min x (al ++ [y]) = Z.min (fold_right Z.min x al) y.
Proof.
 intros.
 revert x; induction al; simpl; intros.
 apply Z.min_comm.
 rewrite <- Z.min_assoc. f_equal.
 apply IHal.
Qed.

Lemma is_int_I32_Znth_map_Vint:
 forall i s al,
  0 <= i < Zlength al ->
  is_int I32 s (Znth i (map Vint al)).
Proof.
intros. rewrite Znth_map; auto.
Qed.
#[export] Hint Extern 3 (is_int I32 _ (Znth _ (map Vint _))) =>
  (apply  is_int_I32_Znth_map_Vint; rewrite ?Zlength_map; lia) : core.

Definition minimum_spec :=
 DECLARE _minimum
  WITH a: val, n: Z, al: list Z
  PRE [ tptr tint , tlong ]
    PROP  (1 <= n <= Int64.max_signed; Forall repable_signed al)
    PARAMS (a; Vlong (Int64.repr n))
    SEP   (data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a)
  POST [ tint ]
    PROP ()
    RETURN (Vint (Int.repr (fold_right Z.min (hd 0 al) al)))
    SEP   (data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a).

Definition Gprog : funspecs :=
      ltac:(with_library prog [minimum_spec]).

(* First approach from "Modular Verification for Computer Security",
  proved using forward_for_simple_bound *)

Lemma body_min: semax_body Vprog Gprog f_minimum minimum_spec.
Proof.
start_function.
assert_PROP (Zlength al = n). {
  entailer!. autorewrite with sublist; auto.
}
forward.  (* min = a[0]; *)
forward_for_simple_bound n
  (EX i:Z,
    PROP()
    LOCAL(temp _min (Vint (Int.repr (fold_right Z.min (Znth 0 al) (sublist 0 i al))));
          temp _a a;
          temp _n (Vlong (Int64.repr n)))
    SEP(data_at Ews (tarray tint n) (map Vint (map Int.repr al)) a)).
* (* Prove that the precondition implies the loop invariant *)
  entailer!.
* (* Prove that the loop body preserves the loop invariant *)
 forward. (* j = a[i]; *)
 forward. (* a[i] = j; *)
 assert (repable_signed (Znth i al))
     by (apply Forall_Znth; auto; lia).
 assert (repable_signed (fold_right Z.min (Znth 0 al) (sublist 0 i al)))
   by (apply Forall_fold_min;
          [apply Forall_Znth; auto; lia
          |apply Forall_sublist; auto]).
 autorewrite with sublist.
 subst POSTCONDITION; unfold abbreviate.
 rewrite (sublist_split 0 i (i+1)) by lia.
 rewrite (sublist_one i (i+1) al) by lia.
 rewrite fold_min_another.
 replace  (upd_Znth i (map Vint (map Int.repr al)) (Vint (Int.repr (Znth i al))))
  with (map Vint (map Int.repr al))
  by list_solve.
 forward_if.
 +
 forward. (* min = j; *)
 entailer!.
 rewrite Z.min_r; auto; lia.
 +
 forward. (* skip; *)
 entailer!.
 rewrite Z.min_l; auto; lia.
* (* After the loop *)
 forward. (* return *)
 entailer!.
 autorewrite with sublist.
 destruct al; simpl; auto.
Qed.


(** * Chapter I *)

Module I1.
  Theorem I1 : forall A B C : Prop,
    (A -> B) -> (B -> C) -> (A -> C).
  Proof.
    intros A B C.
    intros a_imp_b b_imp_c.
    intros a.
    refine (b_imp_c _).
      refine (a_imp_b _).
        exact a.
  Qed.
End I1.

Module I2.
  Theorem I2 : forall A B C : Prop,
    ((A \/ B) -> C) -> ((A -> C) /\ (B -> C)).
  Proof.
    intros A B C.
    intros a_or_b_imp_c.
    refine (conj _ _).
      intros a.
      refine (a_or_b_imp_c _).
        exact (or_introl a).

      intros b.
      refine (a_or_b_imp_c _).
        exact (or_intror b).
  Qed.
End I2.

Module I3.
  Theorem I3 : forall A B C : Prop,
    (A -> (B -> C)) -> ((A /\ B) -> C).
  Proof.
    intros A B C.
    intros a_imp_b_imp_c.
    intros a_and_b.
    destruct a_and_b as [a b].
    refine (a_imp_b_imp_c _ _).
      exact a.

      exact b.
  Qed.
End I3.

Module I4.
  Theorem I4a : forall A B : Prop,
    (A -> B) -> (~ B -> ~ A).
  Proof.
    intros A B.
    intros a_imp_b not_b.
    intros a.
    refine (not_b _).
      refine (a_imp_b _).
        exact a.
  Qed.

  Theorem I4b : forall A : Prop,
      A -> ~ ~ A.
  Proof.
    intros A.
    intros a.
    intros not_a.
    exact (not_a a).
  Qed.
End I4.

Module I5.
  Theorem I5 : forall A B : Prop,
    (A \/ B) -> ((A -> False) /\ (B -> False) -> False).
  Proof.
    intros A B.
    intros a_or_b.
    intros not_a_and_not_b.
    destruct not_a_and_not_b as [not_a not_b].
    destruct a_or_b as [a | b].
      exact (not_a a).

      exact (not_b b).
  Qed.
End I5.

Module I6.
  Theorem I6a : forall A B : Prop,
    (A -> B) /\ (A -> ~ B) -> ~ A.
  Proof.
    intros A B.
    intros a_imp_b_and_a_imp_not_b.
    destruct a_imp_b_and_a_imp_not_b as [a_imp_b a_imp_not_b].
    intros a.
    refine (a_imp_not_b a _).
      exact (a_imp_b a).
  Qed.

  Theorem I6b : forall A B : Prop,
      A /\ ~ A -> B.
  Proof.
    intros A B.
    intros a_and_not_a.
    destruct a_and_not_a as [a not_a].
    pose (proof_of_False := not_a a).
    case proof_of_False.
  Qed.
End I6.

Module I7.
  Definition EM (A : Prop) : Prop := A \/ ~ A.

  Definition DN (A : Prop) : Prop := ~ ~ A -> A.

  Definition CC (A B : Prop) : Prop := (~ A -> B) -> (~ A -> ~ B) -> A.

  Theorem I7a : forall A : Prop,
      EM A -> DN A.
  Proof.
    unfold EM, DN.
    intros A.
    intros a_or_not_a.
    intros not_not_a.
    destruct a_or_not_a as [a | not_a].
      exact a.

      pose (proof_of_False := not_not_a not_a).
      case proof_of_False.
  Qed.

  Theorem I7b : forall A B : Prop,
      DN A -> CC A B.
  Proof.
    unfold DN, CC.
    intros A B.
    intros not_not_a_imp_a not_a_imp_b not_a_imp_not_b.
    refine (not_not_a_imp_a _).
      intros not_a.
      pose (b := not_a_imp_b not_a).
      pose (not_b := not_a_imp_not_b not_a).
      pose (proof_of_False := not_b b).
      case proof_of_False.
  Qed.

  Theorem I7c : forall (A : Prop),
      CC (A \/ ~ A) (~ A) -> EM A.
  Proof.
    unfold CC, EM.
    intros A.
    intros cc.
    refine (cc _ _).
      refine (I4.I4a A (A \/ ~ A) _).
        intros a. exact (or_introl a).

      refine (I4.I4a (~ A) (A \/ ~ A) _).
        intros not_a. exact (or_intror not_a).
  Qed.
End I7.

Module I8.
  Export I7.

  Definition Pierce (A B : Prop) : Prop := ((A -> B) -> A) -> A.

  Theorem I8 : forall (A B : Prop),
      EM A -> Pierce A B.
  Proof.
    unfold EM, Pierce.
    intros A B.
    intros em.
    intros a_imp_b_imp_a.
    destruct em as [a | not_a].
      exact a.

      refine (a_imp_b_imp_a _).
        intros a.
        pose (proof_of_False := not_a a).
        case proof_of_False.
  Qed.
End I8.

Module I9.
  Definition I9 : Prop :=
    forall (x y : nat), exists (z : nat), x <> y -> x < z /\ z < y.
End I9.

Module I10.
  Definition I10a (f : nat -> nat) : Prop :=
    forall (x y : nat), f x = f y -> x = y.

  Definition I10b (f : nat -> nat) : Prop :=
    forall (y : nat), exists (x : nat), f x = y.

  Definition I10c (f : nat -> nat) : Prop :=
    forall (x y : nat), x < y -> f x < f y.
End I10.

Module I11.
  Definition I11 (y : nat) : Prop :=
    forall (x : nat), x < y /\ forall (z : nat), y > z -> exists (x : nat), x > z.

  (** I11

    [y] is free.  the first [x] is bound by [forall x].  the second
    [x] is bound by [forall z]. both [z]s are bound by [forall z].j
   *)
End I11.

Module I12.
  Definition I12 : Prop :=
    forall (z : nat), exists (y : nat), z < y /\ y < z.

  (** I12

    Suppose [s = y + 1].  Then if [i12 : I12], [i12 s] would result in
    the capture of the [y] in [s] by [exists y].  We therefore replace [y]
    with [w] in [exists y] so that if [i12 : I12], then [i12 s] is [exists
    w, y + 1 < w /\ w < y + 1].
   *)

  Hypothesis i12 : I12.

  Variable y : nat.

  Check i12 (y + 1).  (* note how [y] is renamed to [y0] *)
End I12.

Module I13.
  Definition I13 (A : nat -> nat -> Prop) : Prop :=
    (forall (x : nat), exists (y : nat), A x y) -> (exists (y : nat), forall (x : nat), A x y).

  (** I13

    We must show

    (1) [exists y, forall x, A x y]

    on the assumption that

    (2)  [forall x, exists y, A x y].

    What can we do with (2)?  First, we can see that

    (3)  [exists y, A u y]

    where [u] is free.  Then, if we can derive some [P] from the _assumption_
    [A u y], where [y] does not occur free anywhere but [A u y], we can conclude [P]
    from (3) and dismiss the assumption [A u y].

    But now we are stuck--to show (1), we need first to show [forall u, A u y].  But
    we can not do this from the _assumption_ [A u y], since [u] must be arbitrary, i.e.,
    it must not appear in any assumptions from which we conclude [A u y] (which is itself
    the assumption in this case.)
   *)

  Hypothesis A : nat -> nat -> Prop.

  Theorem i13 : I13 A.
  Proof.
    unfold I13.
    intros H.
    refine (ex_intro (fun y => forall (x : nat), A x y) _ _).
      intros x.
      pose (H' := H x).
      refine (ex_ind _ H').
        intros x0.
        intros H''.
  Abort.
End I13.

Module I14.
  Hypothesis A : nat -> Prop.
  Hypothesis B : Prop.

  Definition P : Prop :=
    forall (x : nat), A x -> B.

  Definition Q : Prop :=
    (exists (x : nat), A x) -> B.

  Theorem I14a : P -> Q.
  Proof.
    unfold P, Q.
    intros f e.
    exact (ex_ind f e).
  Qed.

  Theorem I14b : Q -> P.

  Proof.
    unfold P, Q.
    intros p x Ax.
    refine (p _).
      exact (ex_intro _ x Ax).
  Qed.
End I14.

Module I15.
  Hypothesis A : nat -> Prop.

  Definition P : Prop :=
    ~ (exists x, A x).

  Definition Q : Prop :=
    forall x, ~ A x.

  Theorem I15a : P -> Q.
  Proof.
    unfold P, Q.
    intros p x Ax.
    refine (p _).
      exact (ex_intro _ x Ax).
  Qed.

  Theorem I15b : Q -> P.
  Proof.
    unfold P, Q.
    intros q e.
    exact (ex_ind q e).
  Qed.

  Theorem I15c : (exists (x : nat), ~ A x) -> ~ (forall (x : nat), A x).
  Proof.
    intros e f.
    assert (g : forall x : nat, (A x -> False) -> False).
      intros x not_Ax.
      exact (not_Ax (f x)).
      exact (ex_ind g e).
  Qed.

  (** I15
    I would not expect it. . .if we have a proof that [A x] does not hold for all [x],
    it does not mean we have a proof that [A x] does not hold for some particular [x].
   *)

  Theorem I15d : (~ forall x : nat, A x) -> (exists x : nat, ~ A x).
  Proof.
    intros f.
  Abort.
End I15.


(** * Decide: Programming with Decision Procedures *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From VFA Require Import Perm.

(* ################################################################# *)
(** * Using [reflect] to characterize decision procedures *)

(** Thus far in _Verified Functional Algorithms_ we have been using
   - propositions ([Prop]) such as [a<b] (which is Notation for [lt a b])
   - booleans ([bool]) such as [a<?b] (which is Notation for [ltb a b]). *)

Check Nat.lt.  (* : nat -> nat -> Prop *)
Check Nat.ltb.  (* : nat -> nat -> bool *)

(** The [Perm] chapter defined a tactic called [bdestruct] that
    does case analysis on (x <? y) while giving you hypotheses (above
    the line) of the form (x<y).   This tactic is built using the [reflect]
    type and the [ltb_reflect] theorem. *)

Print reflect.
(* Inductive reflect (P : Prop) : bool -> Set :=
    | ReflectT : P -> reflect P true
    | ReflectF : ~ P -> reflect P false  *)

Check ltb_reflect.  (* : forall x y, reflect (x<y) (x <? y) *)

(** The name [reflect] for this type is a reference to _computational
   reflection_,  a technique in logic.  One takes a logical formula, or
   proposition, or predicate,  and designs a syntactic embedding of
   this formula as an "object value" in the logic.  That is, _reflect_ the
   formula back into the logic. Then one can design computations
   expressible inside the logic that manipulate these syntactic object
   values.  Finally, one proves that the computations make transformations
   that are equivalent to derivations (or equivalences) in the logic.

   The first use of computational reflection was by Goedel, in 1931:
   his syntactic embedding encoded formulas as natural numbers, a
   "Goedel numbering."  The second and third uses of reflection were
   by Church and Turing, in 1936: they encoded (respectively)
   lambda-expressions and Turing machines.

   In Coq it is easy to do reflection, because the Calculus of Inductive
   Constructions (CiC) has Inductive data types that can easily encode
   syntax trees.  We could, for example, take some of our propositional
   operators such as [and], [or], and make an [Inductive] type that is an
   encoding of these, and build a computational reasoning system for
   boolean satisfiability.

   But in this chapter I will show something much simpler.  When
   reasoning about less-than comparisons on natural numbers, we have
   the advantage that [nat] already an inductive type; it is "pre-reflected,"
   in some sense.  (The same for [Z], [list], [bool], etc.)  *)

(** Now, let's examine how [reflect] expresses the coherence between
  [lt] and [ltb]. Suppose we have a value [v] whose type is
  [reflect (3<7) (3<?7)].  What is [v]?  Either it is
  - ReflectT [P] (3<?7), where [P] is a proof of [3<7],  and [3<?7] is [true], or
  - ReflectF [Q] (3<?7), where [Q] is a proof of [~(3<7)], and [3<?7] is [false].
  In the case of [3,7], we are well advised to use [ReflectT], because
   (3<?7) cannot match the [false] required by [ReflectF]. *)

Goal (3<?7 = true). Proof. reflexivity. Qed.

(** So [v] cannot be [ReflectF Q (3<?7)] for any [Q], because that would
   not type-check.  Now, the next question:  must there exist a value
   of type [reflect (3<7) (3<?7)]  ?  The answer is yes; that is the
   [ltb_reflect] theorem.  The result of [Check ltb_reflect], above, says that
   for any [x,y], there does exist a value (ltb_reflect x y) whose type
   is exactly [reflect (x<y)(x<?y)].     So let's look at that value!  That is,
   examine what [H], and [P], and [Q] are equal to at "Case 1" and "Case 2": *)

Theorem three_less_seven_1: 3<7.
Proof.
assert (H := ltb_reflect 3 7).
remember (3<?7) as b.
destruct H as [P|Q] eqn:?.
* (* Case 1: H = ReflectT (3<7) P *)
apply P.
* (* Case 2: H = ReflectF (3<7) Q *)
compute in Heqb.
inversion Heqb.
Qed.

(** Here is another proof that uses [inversion] instead of [destruct].
   The [ReflectF] case is eliminated automatically by [inversion]
   because [3<?7] does not match [false]. *)

Theorem three_less_seven_2: 3<7.
Proof.
assert (H := ltb_reflect 3 7).
inversion H as [P|Q].
apply P.
Qed.

(** The [reflect] inductive data type is a way of relating a _decision
   procedure_ (a function from X to [bool]) with a predicate (a function
   from X to [Prop]).   The convenience of [reflect], in the verification
   of functional programs, is that we can do [destruct (ltb_reflect a b)],
   which relates [a<?b] (in the program) to the [a<b] (in the proof).
   That's just how the [bdestruct] tactic works; you can go back
   to [Perm.v] and examine how it is implemented in the [Ltac]
   tactic-definition language. *)

(* ################################################################# *)
(** * Using [sumbool] to Characterize Decision Procedures *)

Module ScratchPad.

(** An alternate way to characterize decision procedures,
   widely used in Coq, is via the inductive type [sumbool].

   Suppose [Q]  is a proposition, that is, [Q: Prop].  We say [Q] is
   _decidable_ if there is an algorithm for computing a proof of
   [Q] or [~Q].  More generally, when [P] is a predicate (a function
   from some type [T] to [Prop]), we say [P] is decidable when
   [forall x:T, decidable(P)].

   We represent this concept in Coq by an inductive datatype: *)

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

(** Let's consider [sumbool] applied to two propositions: *)

Definition t1 := sumbool (3<7) (3>2).
Lemma less37: 3<7. Proof. lia. Qed.
Lemma greater23: 3>2. Proof. lia. Qed.

Definition v1a: t1 := left (3<7) (3>2) less37.
Definition v1b: t1 := right (3<7) (3>2) greater23.

(** A value of type [sumbool (3<7) (3>2)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (3>2).   *)

(** Now let's consider: *)

Definition t2 := sumbool (3<7) (2>3).
Definition v2a: t2 := left (3<7) (2>3) less37.

(** A value of type [sumbool (3<7) (2>3)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (2>3).
  But since there are no proofs of 2>3, only [left] values (such as [v2a])
  exist.  That's OK. *)

(** [sumbool] is in the Coq standard library, where there is [Notation]
   for it:  the expression [ {A}+{B} ] means [sumbool A B]. *)

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

(** A very common use of [sumbool] is on a proposition and its negation.
   For example, *)

Definition t4 := forall a b, {a<b}+{~(a<b)}.

(** That expression, [forall a b, {a<b}+{~(a<b)}], says that for any
 natural numbers [a] and [b], either [a<b] or [a>=b].  But it is _more_
 than that!  Because [sumbool] is an Inductive type with two constructors
 [left] and [right], then given the [{3<7}+{~(3<7)}] you can pattern-match
 on it and learn _constructively_ which thing is true.  *)

Definition v3: {3<7}+{~(3<7)} := left _ _ less37.

Definition is_3_less_7:  bool :=
 match v3 with
 | left _ _ _ => true
 | right _ _ _ => false
 end.

Eval compute in is_3_less_7. (* = true : bool *)

Print t4.  (* = forall a b : nat, {a < b} + {~ a < b} *)

(** Suppose there existed a value [lt_dec] of type [t4].  That would be a
  _decision procedure_ for the less-than function on natural numbers.
  For any nats [a] and [b], you could calculate [lt_dec a b], which would
  be either [left ...] (if [a<b] was provable) or [right ...] (if [~(a<b)] was
  provable).

  Let's go ahead and implement [lt_dec].  We can base it on the function
  [ltb: nat -> nat -> bool] which calculates whether [a] is less than [b],
  as a boolean.  We already have a theorem that this function on booleans
  is related to the proposition [a<b]; that theorem is called [ltb_reflect]. *)

Check ltb_reflect.  (* : forall x y, reflect (x<y) (x<?y) *)

(** It's not too hard to use [ltb_reflect] to define [lt_dec] *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match ltb_reflect a b with
| ReflectT _ P => left (a < b) (~ a < b) P
| ReflectF _ Q => right (a < b) (~ a < b) Q
end.

(** Another, equivalent way to define [lt_dec] is to use
     definition-by-tactic: *)

Definition lt_dec' (a: nat) (b: nat) : {a<b}+{~(a<b)}.
  destruct (ltb_reflect a b) as [P|Q]. left. apply P.  right. apply Q.
Defined.

Print lt_dec.
Print lt_dec'.

Theorem lt_dec_equivalent: forall a b, lt_dec a b = lt_dec' a b.
Proof.
intros.
unfold lt_dec, lt_dec'.
reflexivity.
Qed.

(** Warning: these definitions of [lt_dec] are not as nice as the
  definition in the Coq standard library, because these are not
  fully computable.  See the discussion below. *)

End ScratchPad.

(* ================================================================= *)
(** ** [sumbool] in the Coq Standard Library *)

Module ScratchPad2.
Locate sumbool. (* Coq.Init.Specif.sumbool *)
Print sumbool.

(** The output of [Print sumbool] explains that the first two arguments
   of [left] and [right] are implicit.  We use them as follows (notice that
   [left] has only one explicit argument [P]:  *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match ltb_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

Definition le_dec (a: nat) (b: nat) : {a<=b}+{~(a<=b)} :=
match leb_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

(** Now, let's use [le_dec] directly in the implementation of insertion
   sort, without mentioning [ltb] at all. *)

Fixpoint insert (x:nat) (l: list nat) :=
  match l with
  | nil => x::nil
  | h::t => if le_dec x h then x::h::t else h :: insert x t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

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

(** **** Exercise: 2 stars, standard (insert_sorted_le_dec) *)
Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l H.
  induction H.
  - constructor.
  - unfold insert.
    destruct (le_dec a x) as [ Hle | Hgt].

   (** Look at the proof state now.  In the first subgoal, we have
      above the line, [Hle: a <= x].  In the second subgoal, we have
      [Hgt: ~ (a < x)].  These are put there automatically by the
      [destruct (le_dec a x)].  Now, the rest of the proof can proceed
      as it did in [Sort.v], but using [destruct (le_dec _ _)] instead of
      [bdestruct (_ <=? _)]. *)

(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Decidability and Computability *)

(** Before studying the rest of this chapter, it is helpful to study the
   [ProofObjects] chapter of _Software Foundations volume 1_ if you
   have not done so already.

   A predicate [P: T->Prop] is _decidable_ if there is a computable
   function [f: T->bool] such that, forall [x:T], [f x = true <-> P x].
   The second and most famous example of an _undecidable_ predicate
   is the Halting Problem (Turing, 1936): [T] is the type of Turing-machine
   descriptions, and [P(x)] is, Turing machine [x] halts.  The first, and not
   as famous, example is due to Church, 1936 (six months earlier): test
   whether a lambda-expression has a normal form.  In 1936-37, as a
   first-year PhD student before beginning his PhD thesis work, Turing
   proved these two problems are equivalent.

   Classical logic contains the axiom [forall P, P \/ ~P].  This is not provable
   in core Coq, that is, in the bare Calculus of Inductive Constructions.  But
   its negation is not provable either.   You could add this axiom to Coq
   and the system would still be consistent (i.e., no way to prove [False]).

   But [P \/ ~P] is a weaker statement than [ {P}+{~P} ], that is,
   [sumbool P (~P)].  From [ {P}+{~P} ] you can actually _calculate_ or
   [compute] either [left (x:P)] or [right(y: ~P)].     From [P \/ ~P] you cannot
   [compute] whether [P] is true.  Yes, you can [destruct] it in a proof,
   but not in a calculation.

   For most purposes its unnecessary to add the axiom [P \/ ~P] to Coq,
   because for specific predicates there's a specific way to prove [P \/ ~P]
   as a theorem.  For example,  less-than on natural numbers is decidable,
   and the existence of [ltb_reflect] or [lt_dec] (as a theorem, not as an axiom)
   is a demonstration of that.

   Furthermore, in this "book" we are interested in _algorithms_.  An axiom
   [P \/ ~P] does not give us an algorithm to compute whether P is true.  As
   you saw in the definition of [insert] above, we can use [lt_dec] not only as
   a theorem that either [3<7] or [~(3<7)], we can use it as a function to
   compute whether [3<7].  In Coq, you can't compute with axioms!
   Let's try it: *)

Axiom lt_dec_axiom_1:  forall i j: nat, i<j \/ ~(i<j).

(** Now, can we use this axiom to compute with?  *)

(* Uncomment and try this:
Definition max (i j: nat) : nat :=
   if lt_dec_axiom_1 i j then j else i.
*)

(** That doesn't work, because an [if] statement requires an [Inductive]
  data type with exactly two constructors; but [lt_dec_axiom_1 i j] has
  type [i<j \/ ~(i<j)],  which is not Inductive.  But let's try a different axiom: *)

Axiom lt_dec_axiom_2:  forall i j: nat, {i<j} + {~(i<j)}.

Definition max_with_axiom (i j: nat) : nat :=
   if lt_dec_axiom_2 i j then j else i.

(** This typechecks, because [lt_dec_axiom_2 i j]  belongs to type
     [sumbool (i<j) (~(i<j))]   (also written [ {i<j} + {~(i<j)} ]), which does have
     two constructors.

     Now, let's use this function: *)

Eval compute in max_with_axiom 3 7.
  (*  = if lt_dec_axiom_2 3 7 then 7 else 3
     : nat *)

(** This [compute] didn't compute very much!  Let's try to evaluate it
    using [unfold]: *)

Lemma prove_with_max_axiom:   max_with_axiom 3 7 = 7.
Proof.
unfold max_with_axiom.
try reflexivity.  (* does not do anything, reflexivity fails *)
(* uncomment this line and try it:
   unfold lt_dec_axiom_2.
*)
destruct (lt_dec_axiom_2 3 7).
reflexivity.
contradiction n. lia.
Qed.

(** It is dangerous to add Axioms to Coq: if you add one that's inconsistent,
   then it leads to the ability to prove [False].  While that's a convenient way
   to get a lot of things proved, it's unsound; the proofs are useless.

   The Axioms above, [lt_dec_axiom_1] and [lt_dec_axiom_2], are safe enough:
   they are consistent.  But they don't help in computation.  Axioms are not
   useful here. *)

End ScratchPad2.

(* ################################################################# *)
(** * Opacity of [Qed] *)

(** This lemma [prove_with_max_axiom] turned out to be _provable_, but the proof
    could not go by _computation_.  In contrast, let's use [lt_dec], which was built
    without any axioms: *)

Lemma compute_with_lt_dec:  (if ScratchPad2.lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
(* uncomment this line and try it:
   unfold ltb_reflect.
*)
Abort.

(** Unfortunately, even though [ltb_reflect] was proved without any axioms, it
    is an _opaque theorem_  (proved with [Qed] instead of with [Defined]), and
    one cannot compute with opaque theorems.  Not only that, but it is proved with
    other opaque theorems such as [iff_sym] and [Nat.ltb_lt].  If we want to
    compute with an implementation of [lt_dec] built from [ltb_reflect], then
    we will have to rebuild [ltb_reflect] without using [Qed] anywhere, only [Defined].

    Instead, let's use the version of [lt_dec] from the Coq standard library,
    which _is_ carefully built without any opaque ([Qed]) theorems.
*)

Lemma compute_with_StdLib_lt_dec:  (if lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
reflexivity.
Qed.

(** The Coq standard library has many decidability theorems.  You can
   examine them by doing the following [Search] command. The results
   shown here are only for the subset of the library that's currently
   imported (by the [Import] commands above); there's even more out there. *)

Search ({_}+{~_}).
(*
reflect_dec: forall (P : Prop) (b : bool), reflect P b -> {P} + {~ P}
lt_dec: forall n m : nat, {n < m} + {~ n < m}
list_eq_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall l l' : list A, {l = l'} + {l <> l'}
le_dec: forall n m : nat, {n <= m} + {~ n <= m}
in_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall (a : A) (l : list A), {In a l} + {~ In a l}
gt_dec: forall n m : nat, {n > m} + {~ n > m}
ge_dec: forall n m : nat, {n >= m} + {~ n >= m}
eq_nat_decide: forall n m : nat, {eq_nat n m} + {~ eq_nat n m}
eq_nat_dec: forall n m : nat, {n = m} + {n <> m}
bool_dec: forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}
Zodd_dec: forall n : Z, {Zodd n} + {~ Zodd n}
Zeven_dec: forall n : Z, {Zeven n} + {~ Zeven n}
Z_zerop: forall x : Z, {x = 0%Z} + {x <> 0%Z}
Z_lt_dec: forall x y : Z, {(x < y)%Z} + {~ (x < y)%Z}
Z_le_dec: forall x y : Z, {(x <= y)%Z} + {~ (x <= y)%Z}
Z_gt_dec: forall x y : Z, {(x > y)%Z} + {~ (x > y)%Z}
Z_ge_dec: forall x y : Z, {(x >= y)%Z} + {~ (x >= y)%Z}
*)

(** The type of [list_eq_dec] is worth looking at.  It says that if you
     have  a decidable equality for an element type [A], then
    [list_eq_dec] calculates for you a decidable equality for type [list A].
    Try it out: *)

Definition list_nat_eq_dec:
    (forall al bl : list nat, {al=bl}+{al<>bl}) :=
  list_eq_dec eq_nat_dec.

Eval compute in if list_nat_eq_dec [1;3;4] [1;4;3] then true else false.
 (* = false : bool *)

Eval compute in if list_nat_eq_dec [1;3;4] [1;3;4] then true else false.
 (* = true : bool *)

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

    Use [in_dec] to build this function. *)

Definition list_nat_in: forall (i: nat) (al: list nat), {In i al}+{~ In i al}
 (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example in_4_pi:  (if list_nat_in 4  [3;1;4;1;5;9;2;6] then true else false) = true.
Proof.
simpl.
(* reflexivity. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** In general, beyond [list_eq_dec] and [in_dec], one can construct a
     whole programmable calculus of decidability, using the
     programs-as-proof  language of Coq.  But is it a good idea?  Read on! *)

(* ################################################################# *)
(** * Advantages and Disadvantages of [reflect] Versus [sumbool] *)

(** I have shown two ways to program decision procedures in Coq,
    one using [reflect] and the other using [{_}+{~_}], i.e., [sumbool].

   - With [sumbool], you define _two_ things: the operator in [Prop]
      such as [lt: nat -> nat -> Prop] and the decidability "theorem"
      in [sumbool], such as [lt_dec: forall i j, {lt i j}+{~ lt i j}].  I say
      "theorem" in quotes because it's not _just_ a theorem, it's also
      a (nonopaque) computable function.

   - With [reflect], you define _three_ things:  the operator in [Prop],
      the operator in [bool] (such as [ltb: nat -> nat -> bool], and the
      theorem that relates them (such as [ltb_reflect]).

   Defining three things seems like more work than defining two.
   But it may be easier and more efficient.  Programming in [bool],
   you may have more control over how your functions are implemented,
   you will have fewer difficult uses of dependent types, and you
   will run into fewer difficulties with opaque theorems.

   However, among Coq programmers, [sumbool] seems to be more
   widely used, and it seems to have better support in the Coq standard
   library.  So you may encounter it, and it is worth understanding what
   it does.   Either of these two methods is a reasonable way of programming
   with proof.  *)

(* 2021-08-11 15:15 *)


Require
  MathClasses.interfaces.naturals MathClasses.theory.naturals MathClasses.implementations.peano_naturals MathClasses.theory.integers.
Require Import
  Coq.ZArith.BinInt Coq.setoid_ring.Ring Coq.Arith.Arith Coq.NArith.NArith Coq.ZArith.ZArith Coq.Numbers.Integer.Binary.ZBinary
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers
  MathClasses.implementations.natpair_integers MathClasses.implementations.stdlib_binary_naturals
  MathClasses.interfaces.additional_operations MathClasses.interfaces.orders
  MathClasses.implementations.nonneg_integers_naturals.

(* canonical names: *)
#[global]
Instance Z_equiv: Equiv Z := eq.
#[global]
Instance Z_plus: Plus Z := Zplus.
#[global]
Instance Z_0: Zero Z := 0%Z.
#[global]
Instance Z_1: One Z := 1%Z.
#[global]
Instance Z_mult: Mult Z := Zmult.
#[global]
Instance Z_negate: Negate Z := Z.opp.
  (* some day we'd like to do this with [Existing Instance] *)

#[global]
Instance: Ring Z.
Proof.
  repeat (split; try apply _); repeat intro.
           now apply Zplus_assoc.
          now apply Zplus_0_r.
         now apply Zplus_opp_l.
        now apply Zplus_opp_r.
       now apply Zplus_comm.
      now apply Zmult_assoc.
     now apply Zmult_1_l.
    now apply Zmult_1_r.
   now apply Zmult_comm.
  now apply Zmult_plus_distr_r.
Qed.

(* misc: *)
#[global]
Instance: ∀ x y : Z, Decision (x = y) := Z.eq_dec.

Add Ring Z: (rings.stdlib_ring_theory Z).

(* * Embedding N into Z *)
#[global]
Instance inject_N_Z: Cast N Z := Z_of_N.

#[global]
Instance: SemiRing_Morphism Z_of_N.
Proof.
  repeat (split; try apply _).
   exact Znat.Z_of_N_plus.
  exact Znat.Z_of_N_mult.
Qed.

#[global]
Instance: Injective Z_of_N.
Proof.
  repeat (split; try apply _).
  intros x y E. now apply Znat.Z_of_N_eq_iff.
Qed.

(* SRpair N and Z are isomorphic *)
Definition Npair_to_Z (x : SRpair N) : Z := ('pos x - 'neg x)%mc.

#[global]
Instance: Proper (=) Npair_to_Z.
Proof.
  intros [xp xn] [yp yn] E; do 2 red in E; unfold Npair_to_Z; simpl in *.
  apply (right_cancellation (+) ('yn + 'xn)); ring_simplify.
  now rewrite <-?rings.preserves_plus, E, commutativity.
Qed.

#[global]
Instance: SemiRing_Morphism Npair_to_Z.
Proof.
  repeat (split; try apply _).
   intros [xp xn] [yp yn].
   change ('(xp + yp) - '(xn + yn) = 'xp - 'xn + ('yp - 'yn)).
   rewrite ?rings.preserves_plus. ring.
  intros [xp xn] [yp yn].
  change ('(xp * yp + xn * yn) - '(xp * yn + xn * yp) = ('xp - 'xn) * ('yp - 'yn)).
  rewrite ?rings.preserves_plus, ?rings.preserves_mult. ring.
Qed.

#[global]
Instance: Injective Npair_to_Z.
Proof.
  split; try apply _.
  intros [xp xn] [yp yn] E.
  unfold Npair_to_Z in E. do 2 red. simpl in *.
  apply (injective (cast N Z)).
  rewrite ?rings.preserves_plus.
  apply (right_cancellation (+) ('xp - 'xn)). rewrite E at 1. ring.
Qed.

#[global]
Instance Z_to_Npair: Inverse Npair_to_Z := λ x,
  match x with
  | Z0 => C 0 0
  | Zpos p => C (Npos p) 0
  | Zneg p => C 0 (Npos p)
  end.

#[global]
Instance: Surjective Npair_to_Z.
Proof. split; try apply _. intros [|?|?] ? E; now rewrite <-E. Qed.

#[global]
Instance: Bijective Npair_to_Z := {}.

#[global]
Instance: SemiRing_Morphism Z_to_Npair.
Proof. change (SemiRing_Morphism (Npair_to_Z⁻¹)). split; apply _. Qed.

#[global]
Instance: IntegersToRing Z := integers.retract_is_int_to_ring Npair_to_Z.
#[global]
Instance: Integers Z := integers.retract_is_int Npair_to_Z.

#[global]
Instance Z_le: Le Z := Z.le.
#[global]
Instance Z_lt: Lt Z := Z.lt.

#[global]
Instance: SemiRingOrder Z_le.
Proof.
  assert (PartialOrder Z_le).
   repeat (split; try apply _).
   exact Zorder.Zle_antisym.
  rapply rings.from_ring_order.
   repeat (split; try apply _).
   intros x y E. now apply Zorder.Zplus_le_compat_l.
  intros x E y F. now apply Zorder.Zmult_le_0_compat.
Qed.

#[global]
Instance: TotalRelation Z_le.
Proof.
  intros x y.
  destruct (Zorder.Zle_or_lt x y); intuition.
  right. now apply Zorder.Zlt_le_weak.
Qed.

#[global]
Instance: FullPseudoSemiRingOrder Z_le Z_lt.
Proof.
  rapply semirings.dec_full_pseudo_srorder.
  split.
   intro. split. now apply Zorder.Zlt_le_weak. now apply Zorder.Zlt_not_eq.
  intros [E1 E2]. destruct (Zorder.Zle_lt_or_eq _ _ E1). easy. now destruct E2.
Qed.

(* * Embedding of the Peano naturals into [Z] *)
#[global]
Instance inject_nat_Z: Cast nat Z := Z_of_nat.

#[global]
Instance: SemiRing_Morphism Z_of_nat.
Proof.
  repeat (split; try apply _).
   exact Znat.inj_plus.
  exact Znat.inj_mult.
Qed.

(* absolute value *)
#[global]
Program Instance Z_abs_nat: IntAbs Z nat := λ x,
  match x with
  | Z0 => inl (0:nat)
  | Zpos p => inl (nat_of_P p)
  | Zneg p => inr (nat_of_P p)
  end.
Next Obligation. reflexivity. Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_nat), Znat.Z_of_nat_of_P. Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_nat), Znat.Z_of_nat_of_P. Qed.

#[global]
Program Instance Z_abs_N: IntAbs Z N := λ x,
  match x with
  | Z0 => inl (0:N)
  | Zpos p => inl (Npos p)
  | Zneg p => inr (Npos p)
  end.
Next Obligation. reflexivity. Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_N). Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_N). Qed.

(* Efficient nat_pow *)
#[global]
Program Instance Z_pow: Pow Z (Z⁺) := Z.pow.

#[global]
Instance: NatPowSpec Z (Z⁺) Z_pow.
Proof.
  split; unfold pow, Z_pow.
    intros x1 y1 E1 [x2 Ex2] [y2 Ey2] E2.
    unfold equiv, sig_equiv in E2.
    simpl in *. now rewrite E1, E2.
   intros. now apply Z.pow_0_r.
  intros x n.
  rewrite rings.preserves_plus, rings.preserves_1.
  rewrite <-(Z.pow_1_r x) at 2. apply Z.pow_add_r.
   auto with zarith.
  now destruct n.
Qed.

#[global]
Instance Z_Npow: Pow Z N := λ x n, Z.pow x ('n).

#[global]
Instance: NatPowSpec Z N Z_Npow.
Proof.
  split; unfold pow, Z_Npow.
    solve_proper.
   intros. now apply Z.pow_0_r.
  intros x n.
  rewrite rings.preserves_plus, rings.preserves_1.
  rewrite <-(Z.pow_1_r x) at 2. apply Z.pow_add_r.
   auto with zarith.
  now destruct n.
Qed.

(* Efficient shiftl *)
#[global]
Program Instance Z_shiftl: ShiftL Z (Z⁺) := Z.shiftl.

#[global]
Instance: ShiftLSpec Z (Z⁺) Z_shiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x [n En].
  apply Z.shiftl_mul_pow2.
  now apply En.
Qed.

#[global]
Instance Z_Nshiftl: ShiftL Z N := λ x n, Z.shiftl x ('n).

#[global]
Instance: ShiftLSpec Z N Z_Nshiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x n.
  apply Z.shiftl_mul_pow2.
  now destruct n.
Qed.

#[global]
Program Instance Z_abs: Abs Z := Z.abs.
Next Obligation.
  split; intros E.
   now apply Z.abs_eq.
  now apply Z.abs_neq.
Qed.

#[global]
Instance Z_div: DivEuclid Z := Z.div.
#[global]
Instance Z_mod: ModEuclid Z := Zmod.

#[global]
Instance: EuclidSpec Z _ _.
Proof.
  split; try apply _.
     exact Z.div_mod.
    intros x y Ey. destruct (Z_mod_remainder x y); intuition.
   now intros [].
  now intros [].
Qed.


Require Export XR_lt_INR.

Local Open Scope R_scope.

Lemma lt_1_INR : forall n:nat,
  (1 < n)%nat ->
  R1 < INR n.
Proof.
  intros n hn.
  replace R1 with (INR 1%nat).
  {
    apply lt_INR.
    exact hn.
  }
  {
    simpl.
    reflexivity.
  }
Qed.


Require Import Recdef Div2 Lia FunctionalExtensionality.

(** Counting the number of digits in binary representation. *)

(** Show directly defining this function with Fixpoint is not acceptable.
    Error: Cannot guess decreasing argument of fix. *)
Fail Fixpoint attempt_1 (n r : nat) : nat :=
  match n with
  | 0 => r
  | _ => attempt_1 (Nat.div2 n) (r + 1)
  end.

(** function with decreasing measure. *)
Function attempt_2 (n r : nat) {measure (fun x => x) n} : nat :=
  match n with
  | 0 => r
  | _ => attempt_2 (Nat.div2 n) (r + 1)
  end.
Proof.
  intros. apply lt_div2. lia.
Defined.

Compute attempt_2 1024 0.

(** function with well-founded relation. *)
Function attempt_3 (n r : nat) {wf lt n} : nat :=
  match n with
  | 0 => r
  | _ => attempt_3 (Nat.div2 n) (r + 1)
  end.
Proof.
  + intros. apply lt_div2. lia.
  + apply Wf_nat.lt_wf.
Defined.

Goal
  attempt_2 8 0 = 4.
Proof.
  (** use [xx_equation] to expand the recursive function. *)
  rewrite attempt_2_equation; simpl.
  rewrite attempt_2_equation; simpl.
  rewrite attempt_2_equation; simpl.
  rewrite attempt_2_equation; simpl.
  rewrite attempt_2_equation; simpl.
  reflexivity.
Qed.

(* note that the two above definitions are really just alternate ways of doing
the same thing ([measure] is just a convenience for leveraging the
well-foundedness of [nat]'s [lt]) *)
Theorem attempts_2_and_3_are_the_same :
  attempt_2 = attempt_3.
Proof.
  reflexivity.
Qed.

(** Now we'll redo the above using the standard library's [Fix] combinator,
which provides general well-founded recursion.

 See CPDT's chapter http://adam.chlipala.net/cpdt/html/GeneralRec.html for an
 excellent overview, including a better description of how this approach itself
 works under the hood. *)
Check Fix.
(*
Fix
     : forall (A : Type) (R : A -> A -> Prop),
       well_founded R ->
       forall P : A -> Type,
       (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
       forall x : A, P x

To read this, start at the bottom: we're writing a function of type [forall (x:A), P
x]. The recursion is over [A] and decreases the relation [R], which must be
well-founded (think of [A = nat] and [R = lt] as examples). The body of the
function has the type

[forall (x:A) (F: forall (y:A), R y x -> P y), P x]

[x] is simply the argument to the body. The second argument is what I've called
[F] here: think of this as being the function being defined itself, in order to
support recursion. The catch is in its signature: instead of just taking [y:A],
it also takes [R y x]; that is, in order to call [F] recursively, you must pass
a proof that the argument used is smaller than the outer argument [x]. Because
[R] is well-founded, eventually this body must stop calling itself recursively.
 *)

Lemma div2_smaller : forall n n',
    n = S n' ->
    Nat.div2 n < n.
Proof.
  destruct n; intros.
  discriminate.
  apply lt_div2; lia.
Qed.

Definition numdigits (n: nat) : nat.
  refine
    (Fix Wf_nat.lt_wf (fun _ => nat)
         (fun n (numdigits: forall (n':nat), n' < n -> nat) =>
            (* unfortunately we need to convoy a proof to keep track of the
            value of [n] when proving we decrease the argument to [numdigits] *)
            match n as n0 return (n = n0 -> nat) with
            | 0 => fun _ => 0
            | S n' => fun H => 1 + numdigits (Nat.div2 n) _
            end eq_refl) n).
  eapply div2_smaller; eauto.
Defined.

(* We need to provide a wrapper around the standard library's [Fix_eq], which
describes the computational behavior of a [Fix] as being the same as a one-step
unfolding. However, the theorem also requires one to prove the body is unable to
distinguish between [F] arguments that are extensionally equal; this is true of
any Gallina code but can't be proven within Coq once and for all. *)
Theorem numdigits_eq : forall n,
    numdigits n = match n with
                  | 0 => 0
                  | _ => 1 + numdigits (Nat.div2 n)
                  end.
Proof.
  intros.
  match goal with
  | [ |- ?lhs = _ ] =>
    match eval unfold numdigits in lhs with
    | Fix ?wf ?P ?F _ =>
      rewrite (Fix_eq wf P F)
    end
  end.
  destruct n; reflexivity.

  intros.
  destruct x; auto.
Qed.

Example numdigits_5 : numdigits 8 = 4.
Proof.
  repeat (rewrite numdigits_eq; cbn [Nat.div2 plus]).
  reflexivity.
Qed.


Require Export Iron.Language.Calc.Exp.

Inductive EVAL : tm -> va -> Prop :=
 | EvVal    :  forall v
            ,  EVAL (MVal v)      v

 | EvAdd    :  forall m1 m2 n1 n2
            ,  EVAL m1 (VNat n1) -> EVAL m2 (VNat n2)
            -> EVAL (MAdd m1 m2)   (VNat (n1 + n2))

 | EvLess   :  forall m1 m2 n1 n2
            ,  EVAL m1 (VNat n1) -> EVAL m2 (VNat n2)
            -> EVAL (MLess m1 m2)  (VBool (blt_nat n1 n2))

 | EvAnd    :  forall m1 m2 b1 b2
            ,  EVAL m1 (VBool b1) -> EVAL m2 (VBool b2)
            -> EVAL (MAnd m1 m2)   (VBool (andb b1 b2))

 | IfTrue   :  forall m1 m2 m3 v2
            ,  EVAL m1 (VBool true)
            -> EVAL m2 v2
            -> EVAL (MIf m1 m2 m3) v2

 | IfFalse  :  forall m1 m2 m3 v3
            ,  EVAL m1 (VBool false)
            -> EVAL m3 v3
            -> EVAL (MIf m1 m2 m3) v3.

Hint Constructors EVAL : core.


(*|
###################################################
How to unfold a recursive function just once in Coq
###################################################

:Link: https://stackoverflow.com/q/24304345
|*)

(*|
Question
********

Here is a recursive function ``all_zero`` that checks whether all
members of a list of natural numbers are zero:
|*)

Require Import Lists.List.
Require Import Arith.

Fixpoint all_zero (l : list nat) : bool :=
  match l with
  | nil => true
  | n :: l' => andb (beq_nat n 0) (all_zero l')
  end.

(*| Now, suppose I had the following goal |*)

Goal forall n l', true = all_zero (n :: l').

(*|
And I wanted to use the ``unfold`` tactic to transform it to

.. coq:: none
|*)

  intros. unfold all_zero. fold all_zero.

(*||*)

  Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
Unfortunately, I can't do it with a simple ``unfold all_zero`` because
the tactic will eagerly find and replace all instances of
``all_zero``, including the one in the once-unfolded form, and it
turns into a mess. Is there a way to avoid this and unfold a recursive
function just once?

I know I can achieve the same results by proving an ad hoc equivalence
with ``assert (...) as X``, but it is inefficient. I'd like to know if
there's an easy way to do it similar to ``unfold``.

----

**A:** You could also prove
|*)

Goal forall n l, all_zero (n :: l) = andb (beq_nat n 0) (all_zero l).
Admitted. (* .none *)

(*| and rewrite with that. |*)

(*|
Answer (Volker Stolz)
*********************

Try
|*)

Goal forall n l', true = all_zero (n :: l'). (* .none *)
  unfold all_zero. fold all_zero.

(*| At least here for me that yields: |*)

  Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
----

**Q:** ``unfold`` followed by ``fold`` indeed works for ``all_zero``,
but not for polymorphic recursive functions. Here's one example:
|*)

Fixpoint none {X : Type} (t : X -> bool) (l : list X) : bool :=
  match l with
  | nil => true
  | h :: l' => andb (negb (t h)) (none t l')
  end.

(*|
``unfold none`` followed by ``fold none`` results in the following
error message:

.. coq:: none
|*)

Goal forall (X : Type) (t : X -> bool) h l',
    true = none t l' -> false = t h -> true = none t (h :: l').
  intros.

(*||*)

  unfold none. (* .none *) Fail fold none. (* .unfold .messages *)

(*|
So I think a generic solution for unfolding a recursive function once
will have to avoid using ``unfold`` in the first place, unless there
is some way to supply parametric information to ``fold``.

**A:** You can make the implicit parameter ``X`` of ``none`` explicit
by writing ``@none``. If you write ``fold @none.``, then Coq is able
to give the argument explictly and searches for a suitable ``X`` in
the current context, just as it does for the other all-quantified
variables ``t`` and ``l``. If there is ambiguity you can also specify
the corresponding variables explicitly, i.e. ``fold (@none X)``.
|*)

(*|
Answer (Virgile)
****************

It seems to me that ``simpl`` will do what you want. If you have a
more complicated goal, with functions that you want to apply and
functions that you want to keep as they are, you might need to use the
various options of the ``cbv`` tactic (see
http://coq.inria.fr/distrib/current/refman/Reference-Manual010.html#hevea_tactic127).
|*)


Require Import List.

Theorem map_length:
  forall (A B : Type) (f : A -> B) (xs : list A),
  length (map f xs) = length xs.
Proof.
  intros A B f xs.
  induction xs.
    reflexivity.

    simpl.
    rewrite IHxs.
    reflexivity.
Qed.


From Equations Require Import Equations.
Require Import Arith.
Require Import Lia.
Require Import Coq.Lists.SetoidList. (* For Sorted *)
Require Import Coq.Sorting.Permutation. (* For Permutation *)
Require Import Sumbool.
Import Sigma_Notations.
Require Export JMeq.
Require Import Coq.Program.Tactics.
Require Import Vectors.VectorDef.

Arguments Vector.nil {A}.
Arguments Vector.cons {A} a {n} v : rename.

Notation vector := Vector.t.
Notation Vnil := Vector.nil.
Notation Vcons := Vector.cons.
Notation dec x := (sumbool_of_bool x).

Set Program Mode.

Equations app {A} {n m} (v : vector A n) (w : vector A m) : vector A (n + m) :=
  app Vnil w := w ;
  app (Vcons a v) w := Vcons a (app v w).

Inductive filtered (f:nat->bool) : forall {n}, (vector nat n) -> Prop :=
| filtered_nil : filtered f Vnil
| filtered_cons {h n} {v:vector nat n}: f h = true -> filtered f v -> filtered f (Vcons h v).

Equations len_filtered {n} (v:vector nat n)(f:nat->bool) : nat:=
len_filtered Vnil f := 0;
len_filtered (Vcons h t) f := match dec(f h) with
   | left p0 => 1+len_filtered t f
   | right q0 => len_filtered t f
           end.

Transparent len_filtered.

Equations? filter {n} (v:vector nat n)(f:nat->bool) :
  Σ (p : nat), {w:vector nat p|p = len_filtered v f /\ p<=n /\ filtered f w}:=
filter Vnil f := (0, Vnil);
filter (Vcons h t) f with dec(f h) :=
   { | left p0 => (_, Vcons h ((filter t f).2)) ;
     | right q0 => (_, (filter t f).2)}.

intuition.
apply filtered_nil.
destruct filter as [a [b [d e]]].
simpl.
intuition.
constructor.
intuition.
intuition.
split.
destruct filter as [a [b c]].
intuition.
destruct filter as [a [b c]].
simpl.
intuition.
Defined.

Transparent filter.

Definition filter_lte {n} (a: nat) (v:vector nat n) := filter v (fun x => x <=? a).
Definition filter_gt {n} (a: nat) (v:vector nat n) := filter v (fun x=> negb(x <=? a)).

Lemma len_fixed {l}:
forall (t: vector nat l) (h:nat),
  len_filtered t (fun x : nat => x <=? h) + len_filtered t (fun x : nat => negb (x <=? h)) = l.

intros.
induction t.
intuition.
destruct (dec (h0 <=? h)) as []eqn:?.
simp len_filtered.
rewrite Heqs. simpl.
rewrite e. simpl.
rewrite IHt.
trivial.
simp len_filtered.
rewrite Heqs. simpl.
rewrite e. simpl.
rewrite Nat.add_succ_r.
rewrite IHt.
trivial.
Qed.

Equations? quicksort {n} (l : vector nat n) : vector nat n by wf n lt :=
    quicksort Vnil := Vnil ;
    quicksort (Vcons h t):= app (quicksort (filter_lte h t).2) (Vcons h (quicksort (filter_gt h t).2)).

destruct filter_lte as [a [b [c d]]]. simpl. intuition.
destruct filter_gt as [a [b [c d]]]. simpl. intuition.
destruct filter_lte with (a:=h)(v:= t)as [a [b [c d]]].
destruct filter_gt with (a0:=h)(v:= t) as [e [f [g i]]].
simpl.
rewrite c. rewrite g.
rewrite Nat.add_succ_r.
apply eq_S.
apply len_fixed.
Defined.

Check quicksort_elim.

Equations In {A n} (x : A) (v : vector A n) : Prop :=
  In x Vnil := False;
  In x (Vcons a v) := (x = a) \/ In x v.

(* From Sozeau *)
Inductive All {A : Type} (P : A -> Prop) : forall {n}, vector A n -> Prop :=
| All_nil : All P Vnil
| All_cons {a n} {v : vector A n} : P a -> All P v -> All P (Vcons a v).

(* From Sozeau *)
Lemma All_impl {A : Type} (P Q : A -> Prop) {n} (v : vector A n) :
(forall x, P x -> Q x) -> All P v -> All Q v.

Proof.
induction 2;
constructor;
auto.
Qed.

Derive Signature for All.

(* From Sozeau *)
Lemma In_All {A P n} (v : vector A n) :
    All P v
  <->
    (forall x, In x v -> P x).

Proof.
split.
induction 1.
intros.
depelim H.
auto.
intros x; simpl.
simp In.
intuition.
subst; auto.
induction v; simpl; intros; auto; constructor.
apply H; simp In; auto.
firstorder.
Qed.

Lemma In_app {A n m} :
forall (x: A) (v : vector A n) (w : vector A m),
    In x (app v w)
  ->
    In x v \/ In x w.

intros a l b.
elim l; simpl; auto.
intros.
elim H0; auto.
intro H1.
simp In.
intuition.
intuition.
simp In.
intuition.
Qed.

(* From Sozeau, except for the proof *)
Lemma All_app {A P n m} (v : vector A n) (w : vector A m) :
    All P v
  ->
      All P w
    ->
      All P (app v w).

Proof.
intros.
rewrite In_All.
intros.
rewrite In_All in H.
rewrite In_All in H0.
apply In_app in H1.
destruct H1.
apply H.
apply H1.
apply H0.
apply H1.
Qed.

(* From Sozeau *)
Inductive Sorted {A : Type} (R : A -> A -> Prop) : forall {n}, vector A n -> Prop :=
| Sorted_nil : Sorted R Vnil
| Sorted_cons {a n} {v : vector A n} : All (R a) v -> Sorted R v -> Sorted R (Vcons a v).
Import Sigma_Notations.

Derive Signature for Sorted.

Definition sorted {n } (v : vector nat n) := Sorted (fun x y => x <= y) v.

Lemma sorted_inv {n}:
forall (a : nat) (v:vector nat n),
    sorted (Vcons a v)
  ->
    sorted v /\ All ((fun x y => x <= y)a) v.

intros.
inversion H.
replace v with v0.
auto.
apply Eqdep.EqdepTheory.inj_pair2 with (P:= (fun n : nat => vector nat n)) (p := n).
apply H2.
Qed.

Lemma filtered_All {n} :
forall (x : nat) (R : nat -> bool) (v:vector nat n),
    filtered (fun x : nat => R x ) v
  ->
      In x v
    ->
      R x = true.

intros.
induction H.
contradiction.
simp In in H0.
elim H0.
intros.
rewrite H2.
intuition.
apply IHfiltered.
Qed.

(* -------------------------------------------------------------------------------
    PERMUTATION
------------------------------------------------------------------------------- *)

Print Permutation.

Inductive VPermutation {A}: forall {n m}, (vector A n) -> (vector A m) -> Prop :=
    Vperm_nil : VPermutation Vnil Vnil
  | Vperm_skip {x n m} {v:vector A n} {w:vector A m}:
                VPermutation v w -> VPermutation (Vcons x v) (Vcons x w)
  | Vperm_swap {x y n} {v:vector A n} : VPermutation (Vcons y (Vcons x v)) (Vcons x (Vcons y v))
  | Vperm_trans {n m o} {u:vector A n} {v:vector A m} {w:vector A o}:
                 VPermutation u v -> VPermutation v w -> VPermutation u w.

Transparent In.

Lemma VPermutation_in {n m}:
forall  (w: vector nat m) (v: vector nat n) (a : nat),
    VPermutation v w
  ->
      In a v
    ->
      In a w.

intros w v a H.
induction H.
tauto.
simpl.
tauto.
simpl.
tauto.
tauto.
Qed.

Lemma VPermutation_refl {A n} :
forall (v:vector A n),
  VPermutation v v.

Proof.
induction v; constructor.
intuition.
Qed.

Lemma VPermutation_trans {A n m o}:
forall (u:vector A n) (v:vector A m) (w:vector A o),
    VPermutation u v
  ->
      VPermutation v w
    ->
      VPermutation u w.

Proof.
intros u v w.
exact Vperm_trans.
Qed.

Lemma VPermutation_sym {n m}:
forall  (v: vector nat m) (w: vector nat n),
    VPermutation v w
  ->
    VPermutation w v.

intros l l' Hperm; induction Hperm; auto.
constructor.
apply Vperm_skip.
intuition.
apply Vperm_swap.
apply VPermutation_trans with (v0:= v).
intuition.
intuition.
Qed.

Lemma V_app_comm_cons {n m}:
forall  (v: vector nat m) (w: vector nat n) (a : nat),
  Vcons a (app v w) = app (Vcons a v) w.

intros.
simp app.
trivial.
Qed.

Lemma VPermutation_app_tail {A n m o} :
forall (v:vector A n) (v1:vector A m) (v2:vector A o),
    VPermutation v1 v2
  ->
    VPermutation (app v1 v) (app v2 v).

Proof.
intros.
induction H as [|x l l'|x y l|l l' l''].
simp app.
intuition.
apply VPermutation_refl.
simp app.
apply Vperm_skip.
intuition.
simp app.
apply Vperm_swap.
apply VPermutation_trans with (v1:= app v0 v).
intuition.
intuition.
Qed.

Lemma VPermutation_app_head {A n m o} :
forall (v:vector A n) (v1:vector A m) (v2:vector A o),
    VPermutation v1 v2
  ->
    VPermutation (app v v1) (app v v2).

Proof.
intros.
induction v.
simp app.
simp app.
apply Vperm_skip.
intuition.
Qed.

Lemma VPermutation_app {A n m o p}:
forall (u:vector A n) (v:vector A m) (w:vector A o) (x: vector A p),
    VPermutation u w
  ->
      VPermutation v x
    ->
      VPermutation (app u v) (app w x).

Proof.
intros.
induction H as [|a u w|a y u|u q l''];
repeat rewrite <- app_comm_cons; auto.
simp app.
apply Vperm_skip.
intuition.
simp app.
apply VPermutation_trans with (v1 :=Vcons y (Vcons a (app v0 x))).
apply Vperm_skip.
apply Vperm_skip.
apply VPermutation_app_head.
apply H0.
apply Vperm_swap.
apply VPermutation_trans with (v1 := app v0 v).
apply VPermutation_app_tail.
intuition.
intuition.
Qed.

Lemma perm_app {m n o p q}:
forall (v: vector nat m) (v1: vector nat n) (v2: vector nat o)
(v3: vector nat p) (v4: vector nat q),
    VPermutation v3 v1
  ->
      VPermutation v4 v2
    ->
        VPermutation v (app v3 v4)
      ->
        VPermutation v (app v1 v2).

intros.
apply VPermutation_trans with (v0 := (app v3 v4)).
intuition.
apply VPermutation_app.
intuition.
intuition.
Qed.

Lemma VPermutation_middle {A n m }:
forall (v1: vector A n) (v2: vector A m) (a : A),
  VPermutation (Vcons a (app v1 v2)) (app v1 (Vcons a v2)).

induction v1.
intros.
simp app.
apply VPermutation_refl.
intros.
simp app.
apply VPermutation_trans with (v:= (Vcons h (Vcons a (app v1 v2)))).
apply Vperm_swap.
apply Vperm_skip.
apply IHv1.
Qed.

Lemma VPermutation_cons_app {A n m o}:
forall (v: vector A n) (v2: vector A m) (v1: vector A o) (a : A),
    VPermutation v (app v1 v2)
  ->
    VPermutation (Vcons a v) (app v1 (Vcons a v2)).

intros.
apply VPermutation_trans with (v0 := Vcons a (app v1 v2)).
apply Vperm_skip.
intuition.
apply VPermutation_middle.
Qed.

Lemma perm_lte_gt {n} :
forall (v: vector nat n) (a : nat),
  VPermutation v (app (filter_lte a v).2 (filter_gt a v).2).

intros.
induction v.
simpl.
simp app.
apply Vperm_nil.
apply VPermutation_trans
with (v0:= Vcons h ((app (proj1_sig (filter_lte a v).2) (proj1_sig (filter_gt a v).2)))).
apply Vperm_skip.
apply IHv.
unfold filter_lte.
unfold filter_gt.
simpl.
destruct (dec (h <=? a)) as []eqn:?.
destruct (dec (negb (h <=? a))) as []eqn:?.
inversion e.
inversion e0.
rewrite H0 in H1.
discriminate.
simpl.
simp app.
apply Vperm_skip.
apply VPermutation_refl.
destruct (dec (negb (h <=? a))) as []eqn:?.
simpl.
apply VPermutation_cons_app.
apply VPermutation_refl.
inversion e.
inversion e0.
rewrite Bool.negb_false_iff in H1.
rewrite H0 in H1.
discriminate.
Qed.

Theorem quicksort_permutation {n}:
forall (v : vector nat n),
  VPermutation v (quicksort v).

intros.
apply quicksort_elim.
apply Vperm_nil.
intros.
destruct (quicksort_obligation_3 n0 h t0).
simpl.
apply perm_app with (v3:= (proj1_sig (filter_lte h t0).2)) (v4:= Vcons h (proj1_sig (filter_gt h t0).2)).
apply H.
apply Vperm_skip.
apply H0.
apply VPermutation_cons_app.
apply perm_lte_gt.
Qed.

(* -------------------------------------------------------------------------------
    SORTED
------------------------------------------------------------------------------- *)

Lemma in_lte {n} :
forall (h x: nat) (t: vector nat n),
    In x (proj1_sig (filter_lte h t).2)
  ->
    x <= h.

intros.
destruct filter_lte as [a [b [c d]]].
simpl in H.
intuition.
apply leb_complete.
apply filtered_All with (v:= b) (R:= (fun x : nat => x <=? h)).
intuition.
apply H.
Qed.

Lemma in_gt {n} :
forall (h x : nat) (t: vector nat n),
    In x (proj1_sig (filter_gt h t).2)
  ->
    x > h.

intros.
destruct filter_gt as [a [b [c d]]].
simpl in H.
apply leb_complete_conv.
rewrite <- Bool.negb_true_iff.
apply filtered_All with (v:= b) (R:= (fun x : nat => negb (x <=? h))).
intuition.
apply H.
Qed.

Lemma in_qs {n} :
forall (t: vector nat n) (elem : nat),
    In elem t
  <->
    In elem (quicksort t).

intros.
split.
intros.
apply VPermutation_in with (v:= t).
apply quicksort_permutation.
apply H.
apply VPermutation_in.
apply VPermutation_sym.
apply quicksort_permutation.
Qed.

Lemma sort_app {l l'}:
forall (v : vector nat l) (v': vector nat l') (n : nat),
    sorted v
  ->
      sorted v'
    ->
        All (fun y : nat => y > n) v'
      ->
          All (fun y : nat => y <= n) v
        ->
          sorted (app v (Vcons n v')).

intros.
induction v.
simp app.
apply Sorted_cons.
apply All_impl with (P:=  (fun y : nat => y > n)).
intros.
intuition.
apply H1.
apply H0.
simp app.
apply Sorted_cons.
apply All_app.
apply sorted_inv in H.
intuition.
constructor.
rewrite In_All in H2.
apply H2.
constructor.
trivial.
apply In_All.
intros.
apply Nat.le_trans with (m:= n).
rewrite In_All in H2.
apply H2.
constructor.
trivial.
rewrite In_All in H1.
apply Nat.lt_le_incl.
apply H1.
apply H3.
apply IHv.
apply sorted_inv in H.
intuition.
apply In_All.
intros.
rewrite In_All in H2.
apply H2.
simp In.
intuition.
Qed.

Theorem quicksort_sorted {n} :
forall (v : vector nat n),
  sorted (quicksort v).

intros.
apply quicksort_elim.
constructor.
intros.
destruct (quicksort_obligation_3 n0 h t0).
simpl.
apply sort_app.
apply H.
apply H0.

apply In_All.
intros.
rewrite <- in_qs in H1.
apply in_gt with (t := t0).
apply H1.

apply In_All.
intros.
rewrite <- in_qs in H1.
apply in_lte with (t := t0).
apply H1.
Qed.

(* -------------------------------------------------------------------------------
    CORRECTNESS
------------------------------------------------------------------------------- *)

Theorem quicksort_correct {n} :
forall (v : vector nat n),
  sorted (quicksort v) /\ VPermutation v (quicksort v).

intros.
split.
apply quicksort_sorted.
apply quicksort_permutation.
Qed.


(* Ejercicio 5.5 *)
Section ej55.

(* Ejercicio 5.5.1 *)
Definition Var := nat.

Inductive BoolExpr :=
  | V (x: nat)  : BoolExpr
  | B (b: bool) : BoolExpr
  | AND (e1 e2: BoolExpr) : BoolExpr
  | NOT (e: BoolExpr) : BoolExpr.

Notation "x /\ y" := (AND x y) (at level 80, right associativity).
Notation "~ x" := (NOT x) (at level 75, right associativity).
Notation "¿ x" := (V x) (at level 70, right associativity).

(* Ejercicio 5.5.2 *)
Definition Valor := bool.
Definition Memoria : Set := Var -> Valor.

Definition lookup (m: Memoria) (v: Var) : Valor := m v.

Inductive BEval (m: Memoria) : BoolExpr -> Valor -> Prop :=
  | evar (v: Var)            : BEval m (¿ v) (lookup m v)
  | eboolt                   : BEval m (B true) true
  | eboolf                   : BEval m (B false) false
  | eandl (e1 e2: BoolExpr)  : BEval m e1 false -> BEval m (e1 /\ e2) false
  | eandr (e1 e2: BoolExpr)  : BEval m e2 false -> BEval m (e1 /\ e2) false
  | eandrl (e1 e2: BoolExpr) : BEval m e1 true -> BEval m e2 true -> BEval m (e1 /\ e2) true
  | enott (e: BoolExpr)      : BEval m e true -> BEval m (~ e) false
  | enotf (e: BoolExpr)      : BEval m e false -> BEval m (~ e) true.

(* Ejercicio 5.5.3.a *)
Theorem true_not_false : forall m: Memoria, ~BEval m (B true) false.
Proof.
unfold not.
intros.
inversion H.
Qed.

(* Ejercicio 5.5.3.b *)
Theorem e1_true_w_and : forall (m: Memoria) (e1 e2: BoolExpr) (w: Valor), BEval m e1 true -> BEval m e2 w -> BEval m (e1 /\ e2) w.
Proof.
intros.
destruct w.
apply (eandrl m e1 e2 H H0).
apply (eandr m e1 e2 H0).
Qed.

(* Ejercicio 5.5.3.c *)
Theorem e1_e2_w1_w2_eq : forall (m: Memoria) (e: BoolExpr) (w1 w2: Valor), BEval m e w1 -> BEval m e w2 -> w1 = w2.
Proof.
induction e; intros; auto.
  * inversion H.
    inversion H0.
    reflexivity.
  * inversion H;
    rewrite <- H2 in H0;
    inversion H0;
    reflexivity.
  * inversion H;
    inversion H0;
    auto.
  * inversion H;
    inversion H0;
    auto.
Qed.

(* Ejercicio 5.5.3.d *)
Theorem e1_false_then_not_and : forall (m: Memoria) (e1 e2: BoolExpr), BEval m e1 false -> ~BEval m (e1 /\ e2) true.
Proof.
unfold not.
intros.
inversion H0.
pose (e1_e2_w1_w2_eq m e1 false true H H3).
discriminate.
Qed.

(* Ejercicio 5.5.4 *)
Require Import Coq.Bool.Bool.
Fixpoint beval (m: Memoria) (e: BoolExpr) : Valor :=
    match e with
        | V x => lookup m x
        | B v => v
        | AND e1 e2 => (beval m e1) && (beval m e2)
        | NOT e => negb (beval m e)
    end.

(* Ejercicio 5.5.5 *)
Theorem beval_correct : forall (m: Memoria) (e: BoolExpr), BEval m e (beval m e).
Proof.
intros.
induction e; simpl.
  * constructor.
  * case b; constructor.
  * case (beval m e1), (beval m e2); simpl.
    + apply (eandrl m e1 e2 IHe1 IHe2).
    + apply (eandr m e1 e2 IHe2).
    + apply (eandl m e1 e2 IHe1).
    + apply (eandl m e1 e2 IHe1).
  * destruct (beval m e); simpl.
    + apply (enott m e); assumption.
    + apply (enotf m e); assumption.
Qed.

End ej55.

(* Ejercicio 5.6 y 5.7 *)
Section ej56_ej57.

(* notación BoolExpr *)
Notation "x /\ y" := (AND x y) (at level 80, right associativity).
Notation "~ x" := (NOT x) (at level 75, right associativity).
Notation "* x" := (V x) (at level 70, right associativity).
Notation "'TRUE'" := (B true).
Notation "'FALSE'" := (B false).

(* Ejercicio 5.6.1 *)
Inductive Instr :=
  | NOOP : Instr
  | ASSIGN (x: nat) (y: BoolExpr) : Instr
  | IFS (b: BoolExpr) (t f: Instr) : Instr
  | WHILE (e: BoolExpr) (c: Instr) : Instr
  | REPEAT (n: nat) (c: Instr) : Instr
  | BEGIN (l: LInstr)
with
  LInstr :=
  | EMPTY : LInstr
  | CONS (x: Instr) (y: LInstr).

(* Ejercicio 5.6.2 + extras *)
Notation "'SKIP'" := NOOP.
Notation "x <- y" := (ASSIGN x y) (at level 90, right associativity).
Notation "'IF?' b 'THEN' x 'ELSE' y" := (IFS b x y) (at level 80, right associativity).
Notation "'WHILE' b 'DO' x" := (WHILE b x) (at level 80, right associativity).
Notation "'BEGIN' l 'END'" := (BEGIN l) (at level 90, right associativity).
Notation "x ; y" := (CONS x y) (at level 100, right associativity).
Notation "x ; " := (CONS x EMPTY) (at level 100, right associativity).

(* Ejercicio 5.6.2.a *)
Definition PP (v1 v2: Var) := BEGIN
    v1 <- TRUE;
    v2 <- ~ *v1;
END.

(* Ejercicio 5.6.2.b *)
Definition swap (aux v1 v2: Var) := BEGIN
    aux <- *v1;
    v1  <- *v2;
    v2  <- *aux;
END.

(* Ejercicio 5.6.3 *)
Require Import Coq.Arith.EqNat.

Definition update (m: Memoria) (v: Var) (val: Valor) : Memoria :=
  fun x => if beq_nat x v then val else lookup m x.

(* Ejercicio 5.6.4 *)
Theorem update_works : forall (m: Memoria) (v: Var) (val: Valor), lookup (update m v val) v = val.
Proof.
intros.
unfold lookup, update.
rewrite <- (beq_nat_refl v).
reflexivity.
Qed.

(* Ejercicio 5.6.5 *)
Theorem update_other_works : forall (m: Memoria) (v v': Var) (val: Valor), v <> v' -> lookup (update m v val) v' = lookup m v'.
Proof.
intros.
unfold lookup, update.
apply (beq_nat_false_iff v v') in H.
rewrite <- PeanoNat.Nat.eqb_sym.
rewrite H.
reflexivity.
Qed.

(* Ejercicio 5.7.1 *)
Inductive Execute (m: Memoria) : Instr -> Memoria -> Prop :=
  | xAss (v: Var) (be: BoolExpr) (w: Valor)               : BEval m be w -> Execute m (v <- be) (update m v w)
  | xSkip                                                 : Execute m SKIP m
  | xIFthen (be: BoolExpr) (p1 p2: Instr) (m': Memoria)   : BEval m be true -> Execute m p1 m' -> Execute m (IF? be THEN p1 ELSE p2) m'
  | xIFelse (be: BoolExpr) (p1 p2: Instr) (m': Memoria)   : BEval m be false -> Execute m p2 m' -> Execute m (IF? be THEN p1 ELSE p2) m'
  | xWhileTrue (be: BoolExpr) (p: Instr) (m1 m2: Memoria) : BEval m be true -> Execute m p m1 -> Execute m1 (WHILE be DO p) m2 -> Execute m (WHILE be DO p) m2
  | xWhileFalse (be: BoolExpr) (p: Instr)                 : BEval m be false -> Execute m (WHILE be DO p) m
  | xRepeat0 (p: Instr)                                   : Execute m (REPEAT 0 p) m
  | xRepeatS (p: Instr) (m1 m2: Memoria) (n: nat)         : Execute m p m1 -> Execute m1 (REPEAT n p) m2 -> Execute m (REPEAT (S n) p) m2
  | xBeginEnd (pl: LInstr) (m': Memoria)                  : ExecuteL m pl m' -> Execute m (BEGIN pl END) m'
with ExecuteL (m: Memoria) : LInstr -> Memoria -> Prop :=
  | xEmptyblock                                    : ExecuteL m EMPTY m
  | xNext (p: Instr) (pl: LInstr) (m1 m2: Memoria) : Execute m p m1 -> ExecuteL m1 pl m2 ->ExecuteL m (p; pl) m2.

(* Ejercicio 5.7.2 *)
Theorem if_reversed : forall (m m': Memoria) (e1 e2: Instr), Execute m (IF? ~ FALSE THEN e1 ELSE e2) m' -> Execute m (IF? FALSE THEN e2 ELSE e1) m'.
Proof.
intros.
inversion_clear H.
  * apply xIFelse; auto; constructor.
  * inversion_clear H0.
    inversion_clear H.
Qed.

(* Ejercicio 5.7.3 *)
Lemma bool_contradict : forall (c: bool) (m: Memoria), ~BEval m (~ B c) c.
Proof.
unfold not.
induction c; intros; inversion_clear H; inversion_clear H0.
Qed.

Theorem gen_if_reversed : forall (c: bool) (m m': Memoria) (e1 e2: Instr), Execute m (IF? ~ (B c) THEN e1 ELSE e2) m' -> Execute m (IF? (B c) THEN e2 ELSE e1) m'.
Proof.
intros.
induction c; intros.
inversion_clear H.
  * apply (bool_contradict true m) in H0; contradiction.
  * apply xIFthen; auto; constructor.
  * apply xIFelse; auto.
    - constructor.
    - inversion_clear H; auto.
      apply (bool_contradict false m) in H0; contradiction.
Qed.

(* Ejercicio 5.7.4 *)
Theorem empty_false : forall (m m': Memoria) (p: Instr), Execute m (WHILE FALSE DO p) m' -> m = m'.
Proof.
intros.
inversion H.
  * inversion H2.
  * reflexivity.
Qed.

(* Ejercicio 5.7.5 *)
Theorem expand_while_eq : forall (m m': Memoria) (c: BoolExpr) (p: Instr), ExecuteL m ((IF? c THEN p ELSE SKIP); WHILE c DO p;) m' -> Execute m (WHILE c DO p) m'.
Proof.
intros.
inversion_clear H.
inversion_clear H1.
inversion H2.
rewrite -> H3 in H.
inversion_clear H0.
  * apply (xWhileTrue m c p m1 m' H1 H4 H).
  * inversion H4.
    assumption.
Qed.

(* Ejercicio 5.7.6 *)
Theorem repeat_seq : forall (m m': Memoria) (n: nat) (i: Instr), ExecuteL m (i; REPEAT n i;) m' -> Execute m (REPEAT (S n) i) m'.
Proof.
intros.
inversion_clear H.
inversion_clear H1.
inversion H2.
rewrite -> H3 in H.
apply (xRepeatS m i m1 m' n H0 H).
Qed.

(* Ejercicio 5.7.7 *)
Theorem repeat_sum : forall (n1 n2: nat) (i: Instr) (m1 m2 m3: Memoria), Execute m1 (REPEAT n1 i) m2 -> Execute m2 (REPEAT n2 i) m3 -> Execute m1 (REPEAT (n1+n2) i) m3.
Proof.
induction n1; intros.
  * simpl.
    inversion H.
    assumption.
  * simpl.
    inversion H.
    pose (IHn1 n2 i m0 m2 m3 H5 H0).
    apply (xRepeatS m1 i m0 m3 (n1 + n2) H3 e).
Qed.

(* Ejercicio 5.7.8 *)
Theorem PProof : forall (v1 v2: Var) (m1 m2: Memoria), v1 <> v2 -> Execute m1 (PP v1 v2) m2 -> lookup m2 v1 = true /\ lookup m2 v2 = false.
Proof.
intros.
apply beq_nat_false_iff in H.
inversion_clear H0.
inversion_clear H1.
inversion_clear H2.
inversion H3.
rewrite <- H4.
clear H3.
clear H4.

inversion H0.
inversion H5.
rewrite <- H7 in H3.
clear H7.
clear H5.
clear H4.
clear H2.

inversion H1.
clear H2.
clear H5.
inversion H6.
  * rewrite <- H7 in H4.
    clear H7.
    clear H2.
    clear H5.
    clear H6.
    split; rewrite <- H3; simpl; unfold lookup, update.
      + rewrite -> H.
        unfold lookup.
        rewrite <- (beq_nat_refl v1).
        reflexivity.
      + unfold lookup, update.
        rewrite <- (beq_nat_refl v2).
        reflexivity.
  * rewrite <- H3 in H6.
    rewrite <- H7 in H6.
    inversion H6.
    inversion H9.
    unfold lookup, update in H12.
    rewrite <- (beq_nat_refl v1) in H12.
    discriminate.
Qed.

End ej56_ej57.