(** * SearchTree: Binary Search Trees *)

(** We have implemented maps twice so far: with lists in
    [Lists], and with higher-order functions in [Maps].
    Those are simple but inefficient implementations: looking up the
    value bound to a given key takes time linear in the number of
    bindings, both in the worst and expected case. *)

(** If the type of keys can be totally ordered -- that is, it supports
    a well-behaved [<=] comparison -- then maps can be implemented with
    _binary search trees_ (BSTs).  Insert and lookup operations on
    BSTs take time proportional to the height of the tree.  If the
    tree is balanced, the operations therefore take logarithmic time. *)

(** If you don't recall BSTs or haven't seen them in awhile, see
    Wikipedia or read any standard textbook; for example:

    - Section 3.2 of _Algorithms, Fourth Edition_, by Sedgewick and
      Wayne, Addison Wesley 2011; or

    - Chapter 12 of _Introduction to Algorithms, 3rd Edition_, by
      Cormen, Leiserson, and Rivest, MIT Press 2009. *)

From Coq Require Import String.  (* for an example, and manual grading *)
From Coq Require Import Logic.FunctionalExtensionality.
From VFA Require Import Perm.
From VFA Require Import Maps.
From VFA Require Import Sort.

(* ################################################################# *)
(** * BST Implementation *)

(** We use [nat] as the key type in our implementation of BSTs,
    since it has a convenient total order [<=?] with lots of theorems
    and automation available. *)

Definition key := nat.

(** [E] represents the empty map.  [T l k v r] represents the
    map that binds [k] to [v], along with all the bindings in [l] and
    [r].  No key may be bound more than once in the map. *)

Inductive tree (V : Type) : Type :=
| E
| T (l : tree V) (k : key) (v : V) (r : tree V).

Arguments E {V}.
Arguments T {V}.

(** An example tree:

      4 -> "four"
      /        \
     /          \
  2 -> "two"   5 -> "five"
*)

Definition ex_tree : tree string :=
  (T (T E 2 "two" E) 4 "four" (T E 5 "five" E))%string.

(** [empty_tree] contains no bindings. *)

Definition empty_tree {V : Type} : tree V :=
  E.

(** [bound k t] is whether [k] is bound in [t]. *)

Fixpoint bound {V : Type} (x : key) (t : tree V) :=
  match t with
  | E => false
  | T l y v r => if x <? y then bound x l
                else if x >? y then bound x r
                     else true
  end.

(** [lookup d k t] is the value bound to [k] in [t], or is default
    value [d] if [k] is not bound in [t]. *)

Fixpoint lookup {V : Type} (d : V) (x : key) (t : tree V) : V :=
  match t with
  | E => d
  | T l y v r => if x <? y then lookup d x l
                else if x >? y then lookup d x r
                     else v
  end.

(** [insert k v t] is the map containing all the bindings of [t] along
    with a binding of [k] to [v]. *)

Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
  match t with
  | E => T E x v E
  | T l y v' r => if x <? y then T (insert x v l) y v' r
                 else if x >? y then T l y v' (insert x v r)
                      else T l x v r
  end.

(** Note that [insert] is a _functional_ aka _persistent_
    implementation: [t] is not changed. *)

Module Tests.

(** Here are some unit tests to check that BSTs behave the way we
    expect. *)

  Open Scope string_scope.

  Example bst_ex1 :
    insert 5 "five" (insert 2 "two" (insert 4 "four" empty_tree)) = ex_tree.
  Proof. reflexivity. Qed.

  Example bst_ex2 : lookup "" 5 ex_tree = "five".
  Proof. reflexivity. Qed.

  Example bst_ex3 : lookup "" 3 ex_tree = "".
  Proof. reflexivity. Qed.

  Example bst_ex4 : bound 3 ex_tree = false.
  Proof. reflexivity. Qed.

End Tests.

(** Although we can spot-check the behavior of BST operations with
    unit tests like these, we of course should prove general theorems
    about their correctness.  We will do that later in the chapter. *)

(* ################################################################# *)
(** * BST Invariant *)

(** The implementations of [lookup] and [insert] assume that
    values of type [tree] obey the _BST invariant_: for any non-empty
    node with key [k], all the values of the left subtree are less
    than [k] and all the values of the right subtree are greater than
    [k].  But that invariant is not part of the definition of
    [tree]. For example, the following tree is not a BST: *)

Module NotBst.
  Open Scope string_scope.

  Definition t : tree string :=
    T (T E 5 "five" E) 4 "four" (T E 2 "two" E).

  (** The [insert] function we wrote above would never produce
      such a tree, but we can still construct it by manually applying
      [T]. When we try to lookup [2] in that tree, we get the wrong
      answer, because [lookup] assumes [2] is in the left subtree: *)

  Example not_bst_lookup_wrong :
    lookup "" 2 t <> "two".
  Proof.
    simpl. unfold not. intros contra. discriminate.
  Qed.
End NotBst.

(** So, let's formalize the BST invariant. Here's one way to do
    so.  First, we define a helper [ForallT] to express that idea that
    a predicate holds at every node of a tree: *)

Fixpoint ForallT {V : Type} (P: key -> V -> Prop) (t: tree V) : Prop :=
  match t with
  | E => True
  | T l k v r => P k v /\ ForallT P l /\ ForallT P r
  end.

(** Second, we define the BST invariant:

    - An empty tree is a BST.

    - A non-empty tree is a BST if all its left nodes have a lesser
      key, its right nodes have a greater key, and the left and
      right subtrees are themselves BSTs. *)

Inductive BST {V : Type} : tree V -> Prop :=
| BST_E : BST E
| BST_T : forall l x v r,
    ForallT (fun y _ => y < x) l ->
    ForallT (fun y _ => y > x) r ->
    BST l ->
    BST r ->
    BST (T l x v r).

Hint Constructors BST.

(** Let's check that [BST] correctly classifies a couple example
    trees: *)

Example is_BST_ex :
  BST ex_tree.
Proof.
  unfold ex_tree.
  repeat (constructor; try omega).
Qed.

Example not_BST_ex :
  ~ BST NotBst.t.
Proof.
  unfold NotBst.t. intros contra.
  inv contra. inv H3. omega.
Qed.

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

(** Prove that the empty tree is a BST. *)

Theorem empty_tree_BST : forall (V : Type),
    BST (@empty_tree V).
Proof.
  unfold empty_tree.
  constructor.
Qed.
(** [] *)

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

(** Prove that [insert] produces a BST, assuming it is given one.

    Start by proving this helper lemma, which says that [insert]
    preserves any node predicate. Proceed by induction on [t]. *)

Lemma ForallT_insert : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t -> forall (k : key) (v : V),
      P k v -> ForallT P (insert k v t).
Proof.
  intros V P t H k v H1. induction t.
  - unfold insert. unfold ForallT. split. assumption. split; repeat apply I.
  - intros. inversion H. destruct H2. simpl.
    bdestruct (k0 >? k).  simpl. split. apply H0. split.
    apply IHt1. apply H2. apply H3.
    bdestruct (k >? k0). simpl. split. apply H0. split.
    apply H2. apply IHt2. apply H3.
    simpl. split. assumption. split; repeat assumption.
Qed.

(** Now prove the main theorem. Proceed by induction on the evidence
    that [t] is a BST. *)

Theorem insert_BST : forall (V : Type) (k : key) (v : V) (t : tree V),
    BST t -> BST (insert k v t).
Proof.
  intros. induction t.
  - repeat constructor.
  - inv H. simpl.
    bdestruct (k0 >? k).
    constructor; try apply ForallT_insert; repeat assumption.
    apply IHt1. apply H6.
    bdestruct (k >? k0).
    constructor; try apply ForallT_insert; repeat assumption.
    apply IHt2. apply H7.
    constructor. inversion H. subst. apply H4.
    subst. omega.
    inversion H0. subst. apply H5.
    subst. omega.
    apply H6. apply H7.
Qed.

(** [] *)

(** Since [empty_tree] and [insert] are the only operations that
    create BSTs, we are guaranteed that any [tree] is a BST -- unless
    it was constructed manually with [T].  It would therefore make
    sense to limit the use of [T] to only within the tree operations,
    rather than expose it.  Coq, like OCaml and other functional
    languages, can do this with its module system.  See [ADT] for
    details. *)

(* ################################################################# *)
(** * Correctness of BST Operations *)

(** To prove the correctness of [lookup] and [bound], we need
    specifications for them.  We'll study two different techniques for
    that in this chapter. *)

(** The first is called _algebraic specification_.  With it, we write
    down equations relating the results of operations.  For example,
    we could write down equations like the following to specify the
    [+] and [*] operations:

      (a + b) + c = a + (b + c)
      a + b = b + a
      a + 0 = a
      (a * b) * c = a * (b * c)
      a * b = b * a
      a * 1 = a
      a * 0 = 0
      a * (b + c) = a * b + a * c

    For BSTs, let's examine how [lookup] should interact with
    when applied to other operations.  It is easy to see what needs to
    be true for [empty_tree]: looking up any value at all in the empty
    tree should fail and return the default value:

      lookup d k empty_tree = d

    What about non-empty trees?  The only way to build a non-empty
    tree is by applying [insert k v t] to an existing tree [t]. So it
    suffices to describe the behavior of [lookup] on the result of an
    arbitrary [insert] operation. There are two cases.  If we look up
    the same key that was just inserted, we should get the value that
    was inserted with it:

      lookup d k (insert k v t) = v

    If we look up a different key than was just inserted, the insert
    should not affect the answer -- which should be the same as if we
    did the lookup in the original tree before the insert occured:

      lookup d k' (insert k v t) = lookup d k' t      if k <> k'

    These three basic equations specify the correct behavior of maps.
    Let's prove that they hold. *)

Theorem lookup_empty : forall (V : Type) (d : V) (k : key),
    lookup d k empty_tree = d.
Proof.
  auto.
Qed.

Theorem lookup_insert_eq : forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t)  = v.
Proof.
  induction t; intros; simpl.
  - bdestruct (k <? k); try omega; auto.
  - bdestruct (k <? k0); bdestruct (k0 <? k); simpl; try omega; auto.
    + bdestruct (k <? k0); bdestruct (k0 <? k); try omega; auto.
    + bdestruct (k <? k0); bdestruct (k0 <? k); try omega; auto.
    + bdestruct (k0 <? k0); try omega; auto.
Qed.

(** The basic method of that proof is to repeatedly [bdestruct]
    everything in sight, followed by generous use of [omega] and
    [auto]. Let's automate that. *)

Ltac bdestruct_guard :=
  match goal with
  | |- context [ if ?X =? ?Y then _ else _ ] => bdestruct (X =? Y)
  | |- context [ if ?X <=? ?Y then _ else _ ] => bdestruct (X <=? Y)
  | |- context [ if ?X <? ?Y then _ else _ ] => bdestruct (X <? Y)
  end.

Ltac bdall :=
  repeat (simpl; bdestruct_guard; try omega; auto).

Theorem lookup_insert_eq' :
  forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t) = v.
Proof.
  induction t; intros; bdall.
Qed.

(** The tactic immediately pays off in proving the third
    equation. *)

Theorem lookup_insert_neq :
  forall (V : Type) (t : tree V) (d : V) (k k' : key) (v : V),
   k <> k' -> lookup d k' (insert k v t) = lookup d k' t.
Proof.
  induction t; intros; bdall.
Qed.

(** Perhaps surprisingly, the proofs of these results do not
    depend on whether [t] satisfies the BST invariant.  That's because
    [lookup] and [insert] follow the same path through the tree, so
    even if nodes are in the "wrong" place, they are consistently
    "wrong". *)

(** **** Exercise: 3 stars, standard, optional (bound_correct)  *)

(** Specify and prove the correctness of [bound]. State and prove
    three theorems, inspired by those we just proved for [lookup]. If
    you have the right theorem statements, the proofs should all be
    quite easy -- thanks to [bdall]. *)

(* FILL IN HERE *)

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

(** **** Exercise: 3 stars, standard, optional (bound_default)  *)

(** Prove that if [bound] returns [false], then [lookup] returns
    the default value. Proced by induction on the tree. *)

Theorem bound_default :
  forall (V : Type) (k : key) (d : V) (t : tree V),
    bound k t = false ->
    lookup d k t = d.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ################################################################# *)
(** * BSTs vs. Higher-order Functions (Optional) *)

(** The three theorems we just proved for [lookup] should seem
    familiar: we proved equivalent theorems in [Maps] for maps
    defined as higher-order functions. *)

(** - [lookup_empty] and [t_apply_empty] both state that the empty map
      binds all keys to the default value. *)

Check lookup_empty : forall (V : Type) (d : V) (k : key),
    lookup d k empty_tree = d.

Check t_apply_empty : forall (V : Type) (k : key) (d : V),
    t_empty d k = d.

(** - [lookup_insert_eq] and [t_update_eq] both state that updating a map
      then looking for the updated key produces the updated value. *)

Check lookup_insert_eq : forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t) = v.

Check t_update_eq : forall (V : Type) (m : total_map V) (k : key) (v : V),
    (t_update m k v) k = v.

(** - [lookup_insert_neq] and [t_update_neq] both state that updating
      a map then looking for a different key produces the same value
      as the original map. *)

Check lookup_insert_neq :
  forall (V : Type) (t : tree V) (d : V) (k k' : key) (v : V),
    k <> k' -> lookup d k' (insert k v t) = lookup d k' t.

Check t_update_neq : forall (V : Type) (v : V) (k k' : key) (m : total_map V),
    k <> k' -> (t_update m k v) k' = m k'.

(** In [Maps], we also proved three other theorems about the
    behavior of functional maps on various combinations of updates and
    lookups: *)

Check t_update_shadow : forall (V : Type) (m : total_map V) (v1 v2 : V) (k : key),
    t_update (t_update m k v1) k v2 = t_update m k v2.

Check t_update_same : forall (V : Type) (k : key) (m : total_map V),
    t_update m k (m k) = m.

Check t_update_permute :
  forall (V : Type) (v1 v2 : V) (k1 k2 : key) (m : total_map V),
    k2 <> k1 ->
    t_update (t_update m k2 v2) k1 v1 = t_update (t_update m k1 v1) k2 v2.

(** Let's prove analogues to these three theorems for search trees.

    Hint: you do not need to unfold the definitions of [empty_tree],
    [insert], or [lookup].  Instead, use [lookup_insert_eq] and
    [lookup_insert_neq]. *)

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

Lemma lookup_insert_shadow :
  forall (V : Type) (t : tree V) (v v' d: V) (k k' : key),
    lookup d k' (insert k v (insert k v' t)) = lookup d k' (insert k v t).
Proof.
  intros. bdestruct (k =? k').
  (* FILL IN HERE *) Admitted.

(** [] *)

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

Lemma lookup_insert_same :
  forall (V : Type) (k k' : key) (d : V) (t : tree V),
    lookup d k' (insert k (lookup d k t) t) = lookup d k' t.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

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

Lemma lookup_insert_permute :
  forall (V : Type) (v1 v2 d : V) (k1 k2 k': key) (t : tree V),
    k1 <> k2 ->
    lookup d k' (insert k1 v1 (insert k2 v2 t))
    = lookup d k' (insert k2 v2 (insert k1 v1 t)).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** Our ability to prove these lemmas without reference to the
    underlying tree implementation demonstrates they hold for any map
    implementation that satisfies the three basic equations. *)

(** Each of these lemmas just proved was phrased as an equality
    between the results of looking up an arbitrary key [k'] in two
    maps.  But the lemmas for the function-based maps were phrased as
    direct equalities between the maps themselves.

    Could we state the tree lemmas with direct equalities?  For
    [insert_shadow], the answer is yes: *)

Lemma insert_shadow_equality : forall (V : Type) (t : tree V) (k : key) (v v' : V),
    insert k v (insert k v' t) = insert k v t.
Proof.
  induction t; intros; bdall.
  - rewrite IHt1; auto.
  - rewrite IHt2; auto.
Qed.

(** But the other two direct equalities on BSTs do not necessarily
    hold. *)

(** **** Exercise: 3 stars, standard, optional (direct_equalities_break)  *)

(** Prove that the other equalities do not hold.  Hint: find a counterexample
    first on paper, then use the [exists] tactic to instantiate the theorem
    on your counterexample.  The simpler your counterexample, the simpler
    the rest of the proof will be. *)

Lemma insert_same_equality_breaks :
  exists (V : Type) (d : V) (t : tree V) (k : key),
      insert k (lookup d k t) t <> t.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma insert_permute_equality_breaks :
  exists (V : Type) (v1 v2 : V) (k1 k2 : key) (t : tree V),
    k1 <> k2 /\ insert k1 v1 (insert k2 v2 t) <> insert k2 v2 (insert k1 v1 t).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ################################################################# *)
(** * Converting a BST to a List *)

(** Let's add a new operation to our BST: converting it to an
    _association list_ that contains the key--value bindings from the
    tree stored as pairs.  If that list is sorted by the keys, then
    any two trees that represent the same map would be converted to
    the same list. Here's a function that does so with an in-order
    traversal of the tree: *)

Fixpoint elements {V : Type} (t : tree V) : list (key * V) :=
  match t with
  | E => []
  | T l k v r => elements l ++ [(k, v)] ++ elements r
  end.

Example elements_ex :
    elements ex_tree = [(2, "two"); (4, "four"); (5, "five")]%string.
Proof. reflexivity. Qed.

(** Here are three desirable properties for [elements]:

    1. The list has the same bindings as the tree.

    2. The list is sorted by keys.

    3. The list contains no duplicates.

    Let's formally specify and verify them. *)

(* ================================================================= *)
(** ** Part 1: Same Bindings *)

(** We want to show that a binding is in [elements t] iff it's in
    [t]. We'll prove the two directions of that bi-implication
    separately:

    - [elements] is _complete_: if a binding is in [t] then it's in
      [elements t].

    - [elements] is _correct_: if a binding is in [elements t] then
      it's in [t].  *)

(** Getting the specification of completeness right is a little
    tricky.  It's tempting to start off with something too simple like
    this: *)

Definition elements_complete_broken_spec :=
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    lookup d k t = v ->
    In (k, v) (elements t).

(** The problem with that specification is how it handles the default
    element [d]: the specification would incorrectly require [elements
    t] to contain a binding [(k, d)] for all keys [k] unbound in
    [t]. That would force [elements t] to be infinitely long, since
    it would have to contain a binding for every natural number. We can
    observe this problem right away if we begin the proof: *)

Theorem elements_complete_broken : elements_complete_broken_spec.
Proof.
  unfold elements_complete_broken_spec. intros. induction t.
  - (* t = E *) simpl.
    (** We have nothing to work with, since [elements E] is [[]]. *)
Abort.

(** The solution is to check first to see whether [k] is bound in [t].
    Only bound keys need be in the list of elements: *)

Definition elements_complete_spec :=
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    bound k t = true ->
    lookup d k t = v ->
    In (k, v) (elements t).

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

(** Prove that [elements] is complete. Proceed by induction on [t]. *)
Lemma geimpeq : forall (m : nat) (n : nat), (n >= m ) -> ( m >= n) -> (m = n).
Proof.
 intros. omega.
Qed.

Theorem elements_complete : elements_complete_spec.
Proof.
  unfold elements_complete_spec. intros. bdall. induction t.
  - simpl. discriminate.
  - simpl. apply in_app_iff. simpl. inv H. inv H0.
    simpl in IHt2. simpl in IHt1. bdall. right. left.
    apply geimpeq in H0. rewrite H0. reflexivity.
    apply H.
Qed.
(** [] *)

(** The specification for correctness likewise mentions that the
    key must be bound: *)

Definition elements_correct_spec :=
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    In (k, v) (elements t) ->
    bound k t = true /\ lookup d k t = v.

(** Proving correctness requires more work than completeness.

    [BST] uses [ForallT] to say that all nodes in the left/right
    subtree have smaller/greater keys than the root.  We need to
    relate [ForallT], which expresses that all nodes satisfy a
    property, to [Forall], which expresses that all list elements
    satisfy a property.

    We begin with this lemma about [Forall], which is missing from the
    standard library. *)

Lemma Forall_app : forall (A: Type) (P : A -> Prop) (l1 l2 : list A),
    Forall P l1 -> Forall P l2 -> Forall P (l1 ++ l2).
Proof.
  induction l1; intros; simpl; auto; inv H; constructor; auto.
Qed.

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

(** Prove that if a property [P] holds of every node in a tree [t],
    then that property holds of every pair in [elements t]. Proceed
    by induction on [t].

    There is a little mismatch between the type of [P] in [ForallT]
    and the type of the property accepted by [Forall], so we have to
    _uncurry_ [P] when we pass it to [Forall]. (See [Poly] for
    more about uncurrying.) The single quote used below is the Coq
    syntax for doing a pattern match in the function arguments. *)

Definition uncurry {X Y Z : Type} (f : X -> Y -> Z) '(a, b) :=
  f a b.

Hint Transparent uncurry.

Lemma elements_preserves_forall : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t ->
    Forall (uncurry P) (elements t).
Proof.
  intros. induction t.
  - simpl. constructor.
  - simpl. inversion H. destruct H1. apply Forall_app. apply IHt1. apply H.
    constructor. unfold uncurry. apply H0.
    apply IHt2. apply H2.
Qed.
(** [] *)

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

(** Prove that if all the keys in [t] are in a relation [R] with a
    distinguished key [k'], then any key [k] in [elements t] is also
    related by [R] to [k']. For example, [R] could be [<], in which
    case the lemma says that if all the keys in [t] are less than
    [k'], then all the keys in [elements t] are also less than
    [k'].

    Hint: you don't need induction.  Immediately look for a way
    to use [elements_preserves_forall] and library theorem
    [Forall_forall]. *)

Lemma elements_preserves_relation :
  forall (V : Type) (k k' : key) (v : V) (t : tree V) (R : key -> key -> Prop),
    ForallT (fun y _ => R y k') t
    -> In (k, v) (elements t)
    -> R k k'.
Proof.
  intros. apply elements_preserves_forall in H.
  Search "Forall_forall". rewrite Forall_forall in H.
  apply H in H0. apply H0.
Qed.
(** [] *)

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

(** Prove that [elements] is correct. Proceed by induction on the
    evidence that [t] is a BST. *)

Theorem elements_correct : elements_correct_spec.
Proof.
  unfold elements_correct_spec. intros. induction t.
  -  simpl in H0. inversion H0.
  - inv H.
    simpl in H0. apply in_app_iff in H0. simpl in H0.
    simpl. bdall.
    + destruct H0.
    apply IHt1. apply H7.  assumption.
    apply IHt1. apply H7.
    apply elements_preserves_relation with (k := k) (v := v) in H6.
    omega.
    destruct H0.  apply Nat.lt_neq in H.
    unfold not in H. inversion H0. symmetry in H2. apply H in H2.
    inversion H2.
    apply H0.
    + inv H0. apply elements_preserves_relation with (k := k) (v := v) in H5.
    omega.
    apply H2.
    apply IHt2. apply H8. destruct H2. inv H0.
    omega.
    apply H0.
    + split. reflexivity.
      inv H0. apply elements_preserves_relation with (k := k) (v := v) in H5.
      omega. apply H2.
      inv H2. inv H0. reflexivity.
      apply elements_preserves_relation with (k := k) (v := v) in H6.
      omega. apply H0.
Qed.

(** [] *)

(** The inverses of completeness and correctness also should hold:

    - inverse completeness: if a binding is not in [t] then it's not
      in [elements t].

    - inverse correctness: if a binding is not in [elements t] then
      it's not in [t].

    Let's prove that they do. *)

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

(** This inverse doesn't require induction.  Look for a way to use
    [elements_correct] to quickly prove the result. *)

Theorem elements_complete_inverse :
  forall (V : Type) (k : key) (v : V) (t : tree V),
    BST t ->
    bound k t = false ->
    ~ In (k, v) (elements t).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 4 stars, advanced (elements_correct_inverse)  *)

(** Prove the inverse.  First, prove this helper lemma by induction on
    [t]. *)

Lemma bound_value : forall (V : Type) (k : key) (t : tree V),
    bound k t = true -> exists v, forall d, lookup d k t = v.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove the main result.  You don't need induction. *)

Theorem elements_correct_inverse :
  forall (V : Type) (k : key) (t : tree V),
    BST t ->
    (forall v, ~ In (k, v) (elements t)) ->
    bound k t = false.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Part 2: Sorted (Advanced) *)

(** We want to show that [elements] is sorted by keys.  We follow a
    proof technique contributed by Lydia Symmons et al.*)

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

(** Prove that inserting an intermediate value between two lists
    maintains sortedness. Proceed by induction on the evidence
    that [l1] is sorted. *)

Lemma sorted_app: forall l1 l2 x,
  Sort.sorted l1 -> Sort.sorted l2 ->
  Forall (fun n => n < x) l1 -> Forall (fun n => n > x) l2 ->
  Sort.sorted (l1 ++ x :: l2).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 4 stars, advanced (sorted_elements)  *)

(** The keys in an association list are the first elements of every
    pair: *)

Definition list_keys {V : Type} (lst : list (key * V)) :=
  map fst lst.

(** Prove that [elements t] is sorted by keys. Proceed by induction
    on the evidence that [t] is a BST. *)

Theorem sorted_elements : forall (V : Type) (t : tree V),
    BST t -> Sort.sorted (list_keys (elements t)).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Part 3: No Duplicates (Advanced and Optional) *)

(** We want to show that [elements t] contains no duplicate
    bindings. Tree [t] itself cannot contain any duplicates, so the
    list that [elements] produces shouldn't either. The standard
    library already contains a helpful inductive proposition,
    [NoDup]. *)

Print NoDup.

(** The library is missing a theorem, though, about [NoDup] and [++].
    To state that theorem, we first need to formalize what it means
    for two lists to be disjoint: *)

Definition disjoint {X:Type} (l1 l2: list X) := forall (x : X),
    In x l1 -> ~ In x l2.

(** **** Exercise: 3 stars, advanced, optional (NoDup_append)  *)

(** Prove that if two lists are disjoint, appending them preserves
    [NoDup].  Hint: You might already have proved this theorem in an
    advanced exercise in [IndProp]. *)

Lemma NoDup_append : forall (X:Type) (l1 l2: list X),
  NoDup l1 -> NoDup l2 -> disjoint l1 l2 ->
  NoDup (l1 ++ l2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (elements_nodup_keys)  *)

(** Prove that there are no duplicate keys in the list returned
    by [elements]. Proceed by induction on the evidence that [t] is a
    BST. Make use of library theorems about [map] as needed. *)

Theorem elements_nodup_keys : forall (V : Type) (t : tree V),
    BST t ->
    NoDup (list_keys (elements t)).
Proof.
  (* FILL IN HERE *) Admitted.

(** That concludes the proof of correctness of [elements]. *)

(* ################################################################# *)
(** * A Faster [elements] Implementation *)

(** The implemention of [elements] is inefficient because of how
    it uses the [++] operator.  On a balanced tree its running time is
    linearithmic, because it does a linear number of concatentations
    at each level of the tree. On an unbalanced tree it's quadratic
    time.  Here's a tail-recursive implementation than runs in linear
    time, regardless of whether the tree is balanced: *)

Fixpoint fast_elements_tr {V : Type} (t : tree V)
         (acc : list (key * V)) : list (key * V) :=
  match t with
  | E => acc
  | T l k v r => fast_elements_tr l ((k, v) :: fast_elements_tr r acc)
  end.

Definition fast_elements {V : Type} (t : tree V) : list (key * V) :=
  fast_elements_tr t [].

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

(** Prove that [fast_elements] and [elements] compute the same
    function. *)

Lemma fast_elements_tr_helper :
  forall (V : Type) (t : tree V) (lst : list (key * V)),
    fast_elements_tr t lst = elements t ++ lst.
Proof.
  intros. generalize dependent lst. induction t.
  - simpl. reflexivity.
  - simpl. intros. rewrite IHt1. rewrite IHt2. rewrite <- app_assoc.
    reflexivity.
Qed.

Lemma fast_elements_eq_elements : forall (V : Type) (t : tree V),
    fast_elements t = elements t.
Proof.
  intros. unfold fast_elements. rewrite fast_elements_tr_helper.
  rewrite app_nil_r. reflexivity.
Qed.

(** [] *)

(** Since the two implementations compute the same function, all
    the results we proved about the correctness of [elements]
    also hold for [fast_elements].  For example: *)

Corollary fast_elements_correct :
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    In (k, v) (fast_elements t) ->
    bound k t = true /\ lookup d k t = v.
Proof.
  intros. rewrite fast_elements_eq_elements in *.
  apply elements_correct; assumption.
Qed.

(** This corollary illustrates a general technique:  prove the correctness
    of a simple, slow implementation; then prove that the slow version
    is functionally equivalent to a fast implementation.  The proof of
    correctness for the fast implementation then comes "for free". *)

(* ################################################################# *)
(** * An Algebraic Specification of [elements] *)

(** The verification of [elements] we did above did not adhere to the
    algebraic specifcation approach, which would suggest that we look
    for equations of the form

      elements empty_tree = ...
      elements (insert k v t) = ... (elements t) ...

    The first of these is easy; we can trivially prove the following:
    *)

Lemma elements_empty : forall (V : Type),
    @elements V empty_tree = [].
Proof.
  intros. simpl. reflexivity.
Qed.

(** But for the second equation, we have to express the result of
    inserting [(k, v)] into the elements list for [t], accounting for
    ordering and the possibility that [t] may already contain a pair
    [(k, v')] which must be replaced.  The following rather ugly
    function will do the trick: *)

Fixpoint kvs_insert {V : Type} (k : key) (v : V) (kvs : list (key * V)) :=
  match kvs with
  | [] => [(k, v)]
  | (k', v') :: kvs' =>
    if k <? k' then (k, v) :: kvs
    else if k >? k' then (k', v') :: kvs_insert k v kvs'
         else (k, v) :: kvs'
  end.

(** That's not satisfactory, because the definition of
    [kvs_insert] is so complex. Moreover, this equation doesn't tell
    us anything directly about the overall properties of [elements t]
    for a given tree [t].  Nonetheless, we can proceed with a rather
    ugly verification. *)

(** **** Exercise: 3 stars, standard, optional (kvs_insert_split)  *)
Lemma kvs_insert_split :
  forall (V : Type) (v v0 : V) (e1 e2 : list (key * V)) (k k0 : key),
    Forall (fun '(k',_) => k' < k0) e1 ->
    Forall (fun '(k',_) => k' > k0) e2 ->
    kvs_insert k v (e1 ++ (k0,v0):: e2) =
    if k <? k0 then
      (kvs_insert k v e1) ++ (k0,v0)::e2
    else if k >? k0 then
           e1 ++ (k0,v0)::(kvs_insert k v e2)
         else
           e1 ++ (k,v)::e2.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (kvs_insert_elements)  *)
Lemma kvs_insert_elements : forall (V : Type) (t : tree V),
    BST t ->
    forall (k : key) (v : V),
      elements (insert k v t) = kvs_insert k v (elements t).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Model-based Specifications *)

(** At the outset, we mentioned studying two techniques for
    specifying the correctness of BST operations in this chapter.  The
    first was algebraic specification.

    Another approach to proving correctness of search trees is to
    relate them to our existing implementation of functional partial
    maps, as developed in [Maps]. To prove the correctness of a
    search-tree algorithm, we can prove:

    - Any search tree corresponds to some functional partial map,
      using a function or relation that we write down.

    - The [lookup] operation on trees gives the same result as the
      [find] operation on the corresponding map.

    - Given a tree and corresponding map, if we [insert] on the tree
      and [update] the map with the same key and value, the resulting
      tree and map are in correspondence.

    This approach is sometimes called _model-based specification_: we
    show that our implementation of a data type corresponds to a more
    more abstract _model_ type that we already understand. To reason
    about programs that use the implementation, it suffices to reason
    about the behavior of the abstract type, which may be
    significantly easier.  For example, we can take advantage of laws
    that we proved for the abstract type, like [update_eq] for
    functional maps, without having to prove them again for the
    concrete tree type.

    We also need to be careful here, because the type of functional
    maps as defined in [Maps] do not actually behave quite like
    our tree-based maps. For one thing, functional maps can be defined
    on an infinite number of keys, and there is no mechanism for
    enumerating over the key set. To maintain correspondence with our
    finite trees, we need to make sure that we consider only
    functional maps built by finitely many applications of constructor
    functions ([empty] and [update]). Also, thanks to functional
    extensionality, functional maps obey stronger equality laws than
    our trees do (as we investigated in the [direct_equalities]
    exercise above), so we should not be misled into thinking that
    every fact we can prove about abstract maps necessarily holds for
    concrete ones.

    Compared to the algebraic-specification approach described earlier
    in this chapter, the model-based approach can save some proof
    effort, especially if we already have a well-developed theory for
    the abstract model type.  On the other hand, we have to give an
    explicit _abstraction_ relation between trees and maps, and show
    that it is maintained by all operations. In the end, about the
    same amount of work is needed to show correctness, though the work
    shows up in different places depending on how the abstraction
    relation is defined. *)

(** We now give a model-based specification for trees in terms
    of functional partial maps. It is based on a simple abstraction
    relation that builds a functional map element by element. *)

Fixpoint map_of_list {V : Type} (el : list (key * V)) : partial_map V :=
  match el with
  | [] => empty
  | (k, v) :: el' => update (map_of_list el') k v
  end.

Definition Abs {V : Type} (t : tree V) : partial_map V :=
  map_of_list (elements t).

(** In general, model-based specifications may use an abstraction
    relation, allowing each concrete value to be related to multiple
    abstract values.  But in this case a simple abstraction _function_
    will do, assigning a unique abstract value to each concrete
    one. *)

(** One small difference between trees and functional maps is that
    applying the latter returns an [option V] which might be [None],
    whereas [lookup] returns a default value if key is not bound
    lookup fails.  We can easily provide a function on functional
    partial maps having the latter behavior. *)

Definition find {V : Type} (d : V) (k : key) (m : partial_map V) : V :=
  match m k with
  | Some v => v
  | None => d
  end.

(** We also need a [bound] operation on maps. *)

Definition map_bound {V : Type} (k : key) (m : partial_map V) : bool :=
  match m k with
  | Some _ => true
  | None => false
  end.

(** We now proceed to prove that each operation preserves (or establishes)
    the abstraction relationship in an appropriate way:

    concrete        abstract
    --------        --------
    empty_tree      empty
    bound           map_bound
    lookup          find
    insert          update
*)

(** The following lemmas will be useful, though you are not required
    to prove them. They can all be proved by induction on the list. *)

(** **** Exercise: 2 stars, standard, optional (in_fst)  *)
Lemma in_fst : forall (X Y : Type) (lst : list (X * Y)) (x : X) (y : Y),
    In (x, y) lst -> In x (map fst lst).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (in_map_of_list)  *)
Lemma in_map_of_list : forall (V : Type) (el : list (key * V)) (k : key) (v : V),
    NoDup (map fst el) ->
    In (k,v) el -> (map_of_list el) k = Some v.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (not_in_map_of_list)  *)
Lemma not_in_map_of_list : forall (V : Type) (el : list (key * V)) (k : key),
    ~ In k (map fst el) -> (map_of_list el) k = None.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

Lemma empty_relate : forall (V : Type),
    @Abs V empty_tree = empty.
Proof.
  reflexivity.
Qed.

(** **** Exercise: 3 stars, standard, optional (bound_relate)  *)

Theorem bound_relate : forall (V : Type) (t : tree V) (k : key),
    BST t ->
    map_bound k (Abs t) = bound k t.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 3 stars, standard, optional (lookup_relate)  *)

Lemma lookup_relate : forall (V : Type) (t : tree V) (d : V) (k : key),
    BST t -> find d k (Abs t) = lookup d k t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (insert_relate)  *)
Lemma insert_relate : forall (V : Type) (t : tree V) (k : key) (v : V),
  BST t -> Abs (insert k v t) = update (Abs t) k v.
Proof.
  (* TODO: find a direct proof that doesn't rely on [kvs_insert_elements] *)
    unfold Abs.
  intros.
  rewrite kvs_insert_elements; auto.
  remember (elements t) as l.
  clear -l. (* clear everything not about [l] *)
  (* Hint: proceed by induction on [l]. *)
    (* FILL IN HERE *) Admitted.
(** [] *)

(** The previous three lemmas are in essence saying that the following
    diagrams commute.

             bound k
      t -------------------+
      |                    |
  Abs |                    |
      V                    V
      m -----------------> b
           map_bound k

            lookup d k
      t -----------------> v
      |                    |
  Abs |                    | Some
      V                    V
      m -----------------> Some v
             find d k

            insert k v
      t -----------------> t'
      |                    |
  Abs |                    | Abs
      V                    V
      m -----------------> m'
            update' k v

    Where we define:

      update' k v m = update m k v

*)

(** Functional partial maps lack a way to extract or iterate
    over their elements, so we cannot give an analogous abstract
    operation for [elements]. Instead, we can prove this trivial
    little lemma. *)

Lemma elements_relate : forall (V : Type) (t : tree V),
  BST t ->
  map_of_list (elements t) = Abs t.
Proof.
  unfold Abs. intros. reflexivity.
Qed.

(* ################################################################# *)
(** * An Alternative Abstraction Relation (Optional, Advanced) *)

(** There is often more than one way to specify a suitable abstraction
    relation between given concrete and abstract datatypes. The
    following exercises explore another way to relate search trees to
    functional partial maps without using [elements] as an
    intermediate step.

    We extend our definition of functional partial maps by adding a
    new primitive for combining two partial maps, which we call
    [union].  Our intention is that it only be used to combine maps
    with disjoint key sets; to keep the operation symmetric, we make
    the result be undefined on any key they have in common.  *)

Definition union {X} (m1 m2: partial_map X) : partial_map X :=
  fun k =>
    match (m1 k, m2 k) with
    | (None, None) => None
    | (None, Some v) => Some v
    | (Some v, None) => Some v
    | (Some _, Some _) => None
    end.

(** We can prove some simple properties of lookup and update on unions,
    which will prove useful later. *)

(** **** Exercise: 2 stars, standard, optional (union_collapse)  *)
Lemma union_left : forall {X} (m1 m2: partial_map X) k,
    m2 k = None -> union m1 m2 k = m1 k.
Proof.
(* FILL IN HERE *) Admitted.

Lemma union_right : forall {X} (m1 m2: partial_map X) k,
    m1 k = None ->
    union m1 m2 k = m2 k.
Proof.
(* FILL IN HERE *) Admitted.

Lemma union_both : forall {X} (m1 m2 : partial_map X) k v1 v2,
    m1 k = Some v1 ->
    m2 k = Some v2 ->
    union m1 m2 k = None.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (union_update)  *)
Lemma union_update_right : forall {X} (m1 m2: partial_map X) k v,
    m1 k = None ->
    update (union m1 m2) k v = union m1 (update m2 k v).
Proof.
(* FILL IN HERE *) Admitted.

Lemma union_update_left : forall {X} (m1 m2: partial_map X) k v,
    m2 k = None ->
    update (union m1 m2) k v = union (update m1 k v) m2.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** We can now write a direct conversion function from trees to maps
    based on the structure of the tree, and prove a basic property
    preservation result. *)

Fixpoint map_of_tree {V : Type} (t: tree V) : partial_map V :=
  match t with
  | E => empty
  | T l k v r => update (union (map_of_tree l) (map_of_tree r)) k v
  end.

(** **** Exercise: 3 stars, advanced, optional (map_of_tree_prop)  *)
Lemma map_of_tree_prop : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t ->
    forall k v, (map_of_tree t) k = Some v ->
           P k v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we define our new abstraction function, and prove the
    same lemmas as before. *)

Definition Abs' {V : Type} (t: tree V) : partial_map V :=
  map_of_tree t.

Lemma empty_relate' : forall (V : Type),
    @Abs' V empty_tree = empty.
Proof.
  reflexivity.
Qed.

(** **** Exercise: 3 stars, advanced, optional (bound_relate')  *)
Theorem bound_relate' : forall (V : Type) (t : tree V) (k : key),
    BST t ->
    map_bound k (Abs' t) = bound k t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (lookup_relate')  *)
Lemma lookup_relate' : forall (V : Type) (d : V) (t : tree V) (k : key),
    BST t -> find d k (Abs' t) = lookup d k t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (insert_relate')  *)
Lemma insert_relate' : forall (V : Type) (k : key) (v : V) (t : tree V),
   BST t -> Abs' (insert k v t) = update (Abs' t) k v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The [elements_relate] lemma, which was trivial for our previous [Abs]
    function, is considerably harder this time.  We suggest starting with
    an auxiliary lemma. *)

(** **** Exercise: 3 stars, advanced, optional (map_of_list_app)  *)
Lemma map_of_list_app : forall (V : Type) (el1 el2: list (key * V)),
   disjoint (map fst el1) (map fst el2) ->
   map_of_list (el1 ++ el2) = union (map_of_list el1) (map_of_list el2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, optional (elements_relate')  *)
Lemma elements_relate' : forall (V : Type) (t : tree V),
  BST t ->
  map_of_list (elements t) = Abs' t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Efficiency of Search Trees *)

(** All the theory we've developed so far has been about correctness.
    But the reason we use binary search trees is that they are
    efficient.  That is, if there are [N] elements in a (reasonably
    well balanced) BST, each insertion or lookup takes about [log N]
    time.

    What could go wrong?

     1. The search tree might not be balanced.  In that case, each
        insertion or lookup will take as much as linear time.

        - SOLUTION: use an algorithm that ensures the trees stay
          balanced.  We'll do that in [Redblack].

     2. Our keys are natural numbers, and Coq's [nat] type takes linear
        time per comparison.  That is, computing (j <? k) takes time
        proportional to the value of [k-j].

        - SOLUTION: represent keys by a data type that has a more
          efficient comparison operator.  We used [nat] in this chapter
          because it's something easy to work with.

     3. There's no notion of running time in Coq.  That is, we can't
        say what it means that a Coq function "takes N steps to
        evaluate."  Therefore, we can't prove that binary search trees
        are efficient.

        - SOLUTION 1: Don't prove (in Coq) that they're efficient;
          just prove that they are correct.  Prove things about their
          efficiency the old-fashioned way, on pencil and paper.

        - SOLUTION 2: Prove in Coq some facts about the height of the
          trees, which have direct bearing on their efficiency.  We'll
          explore that in [Redblack].

        - SOLUTION 3: Apply bleeding-edge frameworks for reasoning
          about run-time of programs represented in Coq.

      4. Our functions in Coq are models of implementations in "real"
         programming languages.  What if the real implementations
         differ from the Coq models?

         - SOLUTION: Use Coq's [extraction] feature to derive the real
	   implementation (in Ocaml or Haskell) automatically from the
	   Coq function.  Or, use Coq's [Compute] or [Eval
	   native_compute] feature to compile and run the programs
	   efficiently inside Coq.  We'll explore [extraction] in a
	   [Extract]. *)

(* Mon May 11 23:21:35 EDT 2020 *)


Require Export GeoCoq.Tarski_dev.Definitions.
Require Export GeoCoq.Tactics.finish.

Ltac prolong A B x C D :=
 assert (sg:= segment_construction A B C D);
 ex_and sg x.

Section T1_1.

Context `{Tn:Tarski_neutral_dimensionless}.

Lemma cong_reflexivity : forall A B,
 Cong A B A B.
Proof.
    intros.
    apply (cong_inner_transitivity B A A B); apply cong_pseudo_reflexivity.
Qed.

Lemma cong_symmetry : forall A B C D : Tpoint,
 Cong A B C D -> Cong C D A B.
Proof.
    intros.
    eapply cong_inner_transitivity.
      apply H.
    apply cong_reflexivity.
Qed.

Lemma cong_transitivity : forall A B C D E F : Tpoint,
 Cong A B C D -> Cong C D E F -> Cong A B E F.
Proof.
    intros.
    eapply cong_inner_transitivity; eauto using cong_symmetry.
Qed.

Lemma cong_left_commutativity : forall A B C D,
 Cong A B C D -> Cong B A C D.
Proof.
    intros.
    eapply cong_inner_transitivity.
      apply cong_symmetry.
      apply cong_pseudo_reflexivity.
    assumption.
Qed.

Lemma cong_right_commutativity : forall A B C D,
 Cong A B C D -> Cong A B D C.
Proof.
    intros.
    apply cong_symmetry.
    apply cong_symmetry in H.
    apply cong_left_commutativity.
    assumption.
Qed.

Lemma cong_3421 : forall A B C D,
 Cong A B C D -> Cong C D B A.
Proof.
    auto using cong_symmetry, cong_right_commutativity.
Qed.

Lemma cong_4312 : forall A B C D,
 Cong A B C D -> Cong D C A B.
Proof.
    auto using cong_symmetry, cong_right_commutativity.
Qed.

Lemma cong_4321 : forall A B C D,
 Cong A B C D -> Cong D C B A.
Proof.
    auto using cong_symmetry, cong_right_commutativity.
Qed.

Lemma cong_trivial_identity : forall A B : Tpoint,
 Cong A A B B.
Proof.
    intros.
    prolong A B E A A.
    eapply cong_inner_transitivity.
      apply H0.
    assert(B=E).
      eapply cong_identity.
      apply H0.
    subst.
    apply cong_reflexivity.
Qed.

Lemma cong_reverse_identity : forall A C D,
 Cong A A C D -> C=D.
Proof.
    intros.
    apply cong_symmetry in H.
    eapply cong_identity.
    apply H.
Qed.

Lemma cong_commutativity : forall A B C D,
 Cong A B C D -> Cong B A D C.
Proof.
    intros.
    apply cong_left_commutativity.
    apply cong_right_commutativity.
    assumption.
Qed.

End T1_1.

Hint Resolve cong_commutativity cong_3421 cong_4312 cong_4321 cong_trivial_identity
             cong_left_commutativity cong_right_commutativity
             cong_transitivity cong_symmetry cong_reflexivity : cong.

Ltac Cong := auto 4 with cong.
Ltac eCong := eauto with cong.

Section T1_2.

Context `{Tn:Tarski_neutral_dimensionless}.

(* We pre-compute some trivial lemmas to have more efficient automatic proofs. *)

Lemma not_cong_2134 : forall A B C D, ~ Cong A B C D -> ~ Cong B A C D.
Proof.
auto with cong.
Qed.

Lemma not_cong_1243 : forall A B C D, ~ Cong A B C D -> ~ Cong A B D C.
Proof.
auto with cong.
Qed.

Lemma not_cong_2143 : forall A B C D, ~ Cong A B C D -> ~ Cong B A D C.
Proof.
auto with cong.
Qed.

Lemma not_cong_3412 : forall A B C D, ~ Cong A B C D -> ~ Cong C D A B.
Proof.
auto with cong.
Qed.

Lemma not_cong_4312 : forall A B C D, ~ Cong A B C D -> ~ Cong D C A B.
Proof.
auto with cong.
Qed.

Lemma not_cong_3421 : forall A B C D, ~ Cong A B C D -> ~ Cong C D B A.
Proof.
auto with cong.
Qed.

Lemma not_cong_4321 : forall A B C D, ~ Cong A B C D -> ~ Cong D C B A.
Proof.
auto with cong.
Qed.

End T1_2.

Hint Resolve not_cong_2134 not_cong_1243 not_cong_2143
             not_cong_3412 not_cong_4312 not_cong_3421 not_cong_4321 : cong.

Section T1_3.

Context `{Tn:Tarski_neutral_dimensionless}.

Lemma five_segment_with_def : forall A B C D A' B' C' D',
 OFSC A B C D A' B' C' D' -> A<>B -> Cong C D C' D'.
Proof.
    unfold OFSC.
    intros;spliter.
    apply (five_segment A A' B B'); assumption.
Qed.

Lemma cong_diff : forall A B C D : Tpoint,
 A <> B -> Cong A B C D -> C <> D.
Proof.
    intros.
    intro.
    subst.
    apply H.
    eauto using cong_identity.
Qed.

Lemma cong_diff_2 : forall A B C D ,
 B <> A -> Cong A B C D -> C <> D.
Proof.
    intros.
    intro;subst.
    apply H.
    symmetry.
    eauto using cong_identity, cong_symmetry.
Qed.

Lemma cong_diff_3 : forall A B C D ,
 C <> D -> Cong A B C D -> A <> B.
Proof.
    intros.
    intro;subst.
    apply H.
    eauto using cong_identity, cong_symmetry.
Qed.

Lemma cong_diff_4 : forall A B C D ,
 D <> C -> Cong A B C D -> A <> B.
Proof.
    intros.
    intro;subst.
    apply H.
    symmetry.
    eauto using cong_identity, cong_symmetry.
Qed.

Lemma cong_3_sym : forall A B C A' B' C',
 Cong_3 A B C A' B' C' -> Cong_3 A' B' C' A B C.
Proof.
    unfold Cong_3.
    intuition.
Qed.

Lemma cong_3_swap : forall A B C A' B' C',
  Cong_3 A B C A' B' C' -> Cong_3 B A C B' A' C'.
Proof.
    unfold Cong_3.
    intuition.
Qed.

Lemma cong_3_swap_2 : forall A B C A' B' C',
 Cong_3 A B C A' B' C' -> Cong_3 A C B A' C' B'.
Proof.
    unfold Cong_3.
    intuition.
Qed.

Lemma cong3_transitivity : forall A0 B0 C0 A1 B1 C1 A2 B2 C2,
 Cong_3 A0 B0 C0 A1 B1 C1 -> Cong_3 A1 B1 C1 A2 B2 C2 -> Cong_3 A0 B0 C0 A2 B2 C2.
Proof.
    unfold Cong_3.
    intros.
    spliter.
    repeat split; eapply cong_transitivity; eCong.
Qed.

End T1_3.

Hint Resolve cong_3_sym : cong.
Hint Resolve cong_3_swap cong_3_swap_2 cong3_transitivity : cong3.
Hint Unfold Cong_3 : cong3.

Section T1_4.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma eq_dec_points : forall A B : Tpoint, A=B \/ ~ A=B.
Proof. exact point_equality_decidability. Qed.

Lemma distinct : forall P Q R : Tpoint, P <> Q -> (R <> P \/ R <> Q).
Proof.
    intros.
    induction (eq_dec_points R P).
      subst R.
      right.
      assumption.
    left.
    assumption.
Qed.

Lemma l2_11 : forall A B C A' B' C',
 Bet A B C -> Bet A' B' C' -> Cong A B A' B' -> Cong B C B' C' -> Cong A C A' C'.
Proof.
    intros.
    induction (eq_dec_points A B).
      subst B.
      assert (A' = B') by
     (apply (cong_identity A' B' A); Cong).
      subst; Cong.
    apply cong_commutativity; apply (five_segment A A' B B' C C' A A'); Cong.
Qed.

Lemma bet_cong3 : forall A B C A' B',  Bet A B C -> Cong A B A' B' -> exists C', Cong_3 A B C A' B' C'.
Proof.
    intros.
    assert (exists x, Bet A' B' x /\ Cong B' x B C) by (apply segment_construction).
    ex_and H1 x.
    assert (Cong A C A' x).
      eapply l2_11.
        apply H.
        apply H1.
        assumption.
      Cong.
    exists x;unfold Cong_3; repeat split;Cong.
Qed.

Lemma construction_uniqueness : forall Q A B C X Y,
 Q <> A -> Bet Q A X -> Cong A X B C -> Bet Q A Y -> Cong A Y B C -> X=Y.
Proof.
    intros.
    assert (Cong A X A Y) by (apply cong_transitivity with B C; Cong).
    assert (Cong Q X Q Y) by (apply (l2_11 Q A X Q A Y);Cong).
    assert(OFSC Q A X Y Q A X X) by (unfold OFSC;repeat split;Cong).
    apply five_segment_with_def in H6; try assumption.
    apply cong_identity with X; Cong.
Qed.

Lemma Cong_cases :
 forall A B C D,
 Cong A B C D \/ Cong A B D C \/ Cong B A C D \/ Cong B A D C \/
 Cong C D A B \/ Cong C D B A \/ Cong D C A B \/ Cong D C B A ->
 Cong A B C D.
Proof.
    intros.
    decompose [or] H;clear H; Cong.
Qed.

Lemma Cong_perm :
 forall A B C D,
 Cong A B C D ->
 Cong A B C D /\ Cong A B D C /\ Cong B A C D /\ Cong B A D C /\
 Cong C D A B /\ Cong C D B A /\ Cong D C A B /\ Cong D C B A.
Proof.
    intros.
    repeat split; Cong.
Qed.

End T1_4.


(* This file contains floating point functional models for the summation of
  two lists, as well as theorems regarding their equivalence. *)

Require Import vcfloat.VCFloat.
Require Import List.
Import List ListNotations.

Require Import Sorting Permutation.

Require Import common.

Require Import Reals.
Open Scope R.

Definition sum {A: Type} (sum_op : A -> A -> A) (a b : A) : A := sum_op a b.

Inductive sum_rel {A : Type} (default: A) (sum_op : A -> A -> A) : list A -> A -> Prop :=
| sum_rel_nil  : sum_rel default sum_op [] default
| sum_rel_cons : forall l a s,
    sum_rel default sum_op l s ->
    sum_rel default sum_op (a::l) (sum sum_op a s).

Definition sum_rel_R := @sum_rel R 0%R Rplus.

Lemma sum_rel_R_abs :
forall l s1 s2,
sum_rel_R l s1 -> sum_rel_R (map Rabs l) s2 -> s1 <= s2.
Proof.
induction l.
-
intros.
inversion H.
inversion H0.
nra.
-
intros.
inversion H; subst; clear H.
inversion H0; subst; clear H0.
unfold sum.
eapply Rplus_le_compat.
apply Rle_abs.
fold sum_rel_R in H4.
fold sum_rel_R in H3.
apply IHl;
auto.
Qed.

Lemma sum_rel_R_Rabs_pos :
forall l s,
sum_rel_R (map Rabs l) s -> 0 <= s.
Proof.
induction  l.
-
intros.
inversion H; nra.
-
intros.
inversion H; subst; clear H.
unfold sum.
fold sum_rel_R in H3.
specialize (IHl s0 H3).
apply Rplus_le_le_0_compat; auto;
  try apply Rabs_pos.
Qed.

Lemma sum_rel_R_Rabs_eq :
forall l s,
sum_rel_R (map Rabs l) s -> Rabs s = s.
Proof.
induction  l.
-
intros.
inversion H.
rewrite Rabs_R0.
nra.
-
intros.
inversion H; subst; clear H.
unfold sum.
replace (Rabs(Rabs a + s0)) with
  (Rabs a  + s0); try nra.
symmetry.
rewrite Rabs_pos_eq; try nra.
apply Rplus_le_le_0_compat.
apply Rabs_pos.
eapply Rle_trans with (Rabs s0).
apply Rabs_pos.
eapply Req_le.
apply IHl.
fold sum_rel_R in H3.
auto.
Qed.

Lemma sum_rel_R_Rabs :
forall l s1 s2,
sum_rel_R l s1 -> sum_rel_R (map Rabs l) s2 -> Rabs s1 <= Rabs s2.
Proof.
induction l.
-
intros.
inversion H.
inversion H0.
nra.
-
intros.
inversion H; subst; clear H.
inversion H0; subst; clear H0.
fold sum_rel_R in H4.
fold sum_rel_R in H3.
unfold sum.
eapply Rle_trans.
apply Rabs_triang.
replace (Rabs(Rabs a + s0)) with
  (Rabs a  + s0).
eapply Rplus_le_compat; try nra.
eapply Rle_trans with (Rabs s0).
fold sum_rel_R in H4.
fold sum_rel_R in H3.
apply IHl; auto.
apply Req_le.
eapply sum_rel_R_Rabs_eq; apply H3.
symmetry.
rewrite Rabs_pos_eq; try nra.
apply Rplus_le_le_0_compat.
apply Rabs_pos.
eapply Rle_trans with (Rabs s0).
apply Rabs_pos.
apply Req_le.
eapply sum_rel_R_Rabs_eq; apply H3.
Qed.

Lemma sum_rel_R_single :
forall (a : R) (fs : R), sum_rel_R [a] fs -> fs = a.
Proof.
intros.
inversion H; auto.
inversion H3. subst.
unfold sum; nra.
Qed.

Lemma sum_rel_R_single' :
forall (a : R) , sum_rel_R [a] a.
Proof.
intros.
unfold sum_rel_R.
replace a with (a + 0) at 2 by nra.
apply sum_rel_cons. apply sum_rel_nil.
Qed.

Lemma sum_rel_R_app_cons :
forall l' l'' a s,
sum_rel_R (l' ++  l'') s ->
sum_rel_R (l' ++ a :: l'') (a + s).
Proof.
induction l'; simpl.
{ intros; apply sum_rel_cons; auto. }
intros.
inversion H; subst; clear H.
specialize (IHl' l'' a0 s0 H3).
unfold sum.
replace (a0 + (a + s0)) with (a + (a0 + s0)) by nra.
apply sum_rel_cons; auto.
Qed.

Lemma sum_rel_bound  :
  forall (l : list R) (rs a: R)
  (Hrs : sum_rel_R l rs)
  (Hin : forall x, In x l -> Rabs x <= a),
  Rabs rs <= INR (length l) * a.
Proof.
induction l; intros.
{ inversion Hrs; subst; simpl; rewrite Rabs_R0; nra. }
  inversion Hrs; subst.
  unfold sum; eapply Rle_trans; [apply Rabs_triang|].
  eapply Rle_trans; [apply Rplus_le_compat;
  [apply Hin; simpl; auto| apply IHl;
                        [ apply H2 | intros; apply Hin; simpl; auto ] ] | ].
  apply Req_le. replace (length (a :: l)) with (length l + 1)%nat by (simpl; lia).
  rewrite plus_INR; simpl; nra.
Qed.

Lemma sum_rel_R_permute :
  forall (l l0: list R)
  (Hper: Permutation l l0) (rs: R)
  (Hrs: sum_rel_R l rs),
  sum_rel_R l0 rs.
Proof.
intros ?.
induction l.
{ intros; inversion Hrs; subst.
apply Permutation_nil in Hper; subst; simpl; auto. }
intros.
apply Permutation_sym in Hper.
pose proof Permutation_vs_cons_inv Hper as H.
destruct H as (l' & l'' & H); subst.
apply Permutation_sym in Hper.
pose proof (@Permutation_cons_app_inv R l l' l'' a Hper).
inversion Hrs; subst. fold sum_rel_R in H3.
specialize (IHl (l' ++ l'') H s H3).
unfold sum; clear Hrs.
apply sum_rel_R_app_cons; auto.
Qed.

Lemma sum_rel_R_permute_t :
  forall (t: type) (l l0: list (ftype t))
  (Hper: Permutation l l0) (rs: R)
  (Hrs: sum_rel_R (map FT2R l) rs),
  sum_rel_R (map FT2R l0) rs.
Proof.
intros;
apply sum_rel_R_permute with (map FT2R l); auto.
apply Permutation_map; auto.
Qed.

Section NAN.

From vcfloat Require Import IEEE754_extra.

Lemma plus_zero {NAN: Nans}  a:
Binary.is_finite _ _ a = true ->
(a + -0)%F32 = a.
Proof.
destruct a; simpl; auto;
intros; try discriminate; auto;
destruct s;
cbv; auto.
Qed.

Lemma sum_rel_bound'  :
  forall (t : type) (l : list (ftype t)) (rs a: R)
  (Hrs : sum_rel_R (map FT2R l) rs)
  (Hin : forall x, In x l -> Rabs (FT2R x) <= a),
  Rabs rs <= INR (length l) * a.
Proof.
induction l; intros.
{ inversion Hrs; subst; simpl; rewrite Rabs_R0; nra. }
  inversion Hrs; subst.
  unfold sum; eapply Rle_trans; [apply Rabs_triang|].
  eapply Rle_trans; [apply Rplus_le_compat;
  [apply Hin; simpl; auto| apply IHl;
                        [ apply H2 | intros; apply Hin; simpl; auto ] ] | ].
  apply Req_le. replace (length (a :: l)) with (length l + 1)%nat by (simpl; lia).
  rewrite plus_INR; simpl; nra.
Qed.

Lemma sum_rel_bound''  :
  forall (t : type) (l : list (ftype t)) (rs_abs a: R)
  (Hrs : sum_rel_R (map Rabs (map FT2R l)) rs_abs)
  (Hin : forall x, In x l -> Rabs (FT2R x) <= a),
  rs_abs <= INR (length l) * a.
Proof.
induction l; intros.
{ inversion Hrs; subst; simpl; nra. }
  inversion Hrs; subst.
  unfold sum. fold sum_rel_R in H2.
  eapply Rle_trans; [apply Rplus_le_compat;
  [apply Hin; simpl; auto| apply IHl;
                        [ apply H2 | intros; apply Hin; simpl; auto ] ] | ].
  apply Req_le. replace (length (a :: l)) with (length l + 1)%nat by (simpl; lia).
  rewrite plus_INR; simpl; nra.
Qed.

Lemma sum_rel_R_fold : forall l rs,
   sum_rel_R l rs -> rs = fold_right Rplus 0 l.
Proof.
induction l.
intros; inversion H; simpl; auto.
intros; inversion H.
fold sum_rel_R in H3.
specialize (IHl s H3).
subst; simpl.
unfold sum; auto.
Qed.

Lemma sum_map_Rmult (l : list R) (s a: R):
sum_rel_R l s ->
sum_rel_R (map (Rmult a) l) (a * s).
Proof.
revert l s a. induction l.
{ intros. simpl. inversion H; subst; rewrite Rmult_0_r; auto. }
intros. inversion H. destruct l.
{ simpl; unfold sum. inversion H3; subst. rewrite Rplus_0_r.
  apply sum_rel_R_single'. }
fold sum_rel_R in H3. specialize (IHl s0 a0 H3).
unfold sum; simpl. rewrite Rmult_plus_distr_l; apply sum_rel_cons.
fold sum_rel_R. simpl in IHl; auto.
Qed.

Definition sum_rel_Ft {NAN: Nans} (t: type) := @sum_rel (ftype t) neg_zero (BPLUS ).

Lemma sum_rel_Ft_single {NAN: Nans} t fs a:
Binary.is_finite _ _ fs = true ->
sum_rel_Ft t [a] fs -> fs = a.
Proof.
intros.
inversion H0.
inversion H4; subst.
unfold sum, BPLUS; destruct a; try discriminate;
  simpl; auto.
destruct s; simpl; auto.
Qed.

Lemma sum_rel_R_exists {NAN: Nans}:
  forall (t : type) (l : list (ftype t)) (fs : ftype t)
  (Hfs : sum_rel_Ft t l fs),
  exists rs, sum_rel_R (map FT2R l) rs.
Proof.
intros ?. induction l.
{ simpl; exists 0. apply sum_rel_nil. }
intros. inversion Hfs; subst.
fold (@sum_rel_Ft NAN t) in H2.
destruct (IHl s H2) as (rs & Hrs); clear IHl.
exists (FT2R a + rs); simpl.
apply sum_rel_cons; auto.
Qed.

Lemma sum_rel_R_abs_exists {NAN: Nans}:
  forall (t : type) (l : list (ftype t)) (fs : ftype t)
  (Hfs : sum_rel_Ft t l fs),
  exists rs, sum_rel_R (map Rabs (map FT2R l)) rs.
Proof.
intros ?. induction l.
{ simpl; exists 0. apply sum_rel_nil. }
intros. inversion Hfs; subst.
fold (@sum_rel_Ft NAN t) in H2.
destruct (IHl s H2) as (rs & Hrs); clear IHl.
exists (Rabs (FT2R a) + rs); simpl.
apply sum_rel_cons; auto.
Qed.

Lemma is_finite_in {NAN: Nans} (t : type) :
  forall (l : list (ftype t)) fs,
  sum_rel_Ft t l fs ->
  let e  := @default_abs t in
  let d  := @default_rel t in
  let ov := powerRZ 2 (femax t) in
  Binary.is_finite (fprec t) (femax t) fs = true ->
  forall a, In a l -> Binary.is_finite (fprec t) (femax t) a = true.
Proof.
induction l.
simpl; intros; auto.
intros.
destruct H1; subst.
inversion H.
rewrite <- H2 in H0. clear H2.
unfold sum in H0.
destruct a0, s; auto.
destruct s, s0; simpl in H0; try discriminate.
inversion H.
fold (@sum_rel_Ft NAN t) in H5.
assert (Binary.is_finite (fprec t) (femax t) s = true).
unfold sum in H3.
rewrite <- H3 in H0. clear H3.
destruct a, s; auto.
destruct s, s0; simpl in H0; try discriminate.
specialize (IHl s H5 H6).
apply IHl; auto.
Qed.

Lemma sum_rel_Ft_fold {NAN: Nans} : forall t l fs,
   sum_rel_Ft t l fs -> fs = fold_right (BPLUS ) neg_zero l.
Proof.
induction l.
intros; inversion H; simpl; auto.
intros; inversion H.
fold (@sum_rel_Ft NAN t) in H3.
specialize (IHl s H3).
subst; simpl.
unfold sum; auto.
Qed.

End NAN.


Require Import Arith Lia ZArith.Znat ZArith.Zdiv.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Definition nat_norm := (Nat.add_0_r, Nat.add_succ_r, Nat.sub_0_r, Nat.mul_1_r, Nat.div_1_r).

Lemma div_exact (a b : nat) : a = b * (a / b) <-> a mod b = 0.
Proof.
  rewrite [X in X = _](Nat.div_mod_eq a b). lia.
Qed.

Lemma add_mod (a b n : nat) : (a + b) mod n = (a mod n + b mod n) mod n.
Proof.
  apply: Nat2Z.inj. do ? rewrite !(Nat2Z.inj_mod, Nat2Z.inj_add).
  apply: Zplus_mod.
Qed.

Lemma mod_same (a : nat) : a mod a = 0.
Proof.
  apply: Nat2Z.inj. rewrite Nat2Z.inj_mod.
  apply: Z_mod_same_full.
Qed.

Lemma mod_mod (a n : nat) : (a mod n) mod n = a mod n.
Proof.
  apply: Nat2Z.inj. rewrite !Nat2Z.inj_mod.
  apply: Zmod_mod.
Qed.

Lemma div_mod_pos {n m: nat} : S m / (1 + n) + S m mod (1 + n) <> 0.
Proof.
  move=> ?.
  have /Nat.div_small_iff : S m / (1 + n) = 0 by lia. move /(_ ltac:(lia)).
  have /div_exact : S m mod (1 + n) = 0 by lia.
  by lia.
Qed.

Lemma divides_frac_diff {m n} : m mod (n + 1) = 0 -> (m * (n + 2) / (n + 1) - m) * (1 + n) = m.
Proof.
  rewrite Nat.mul_sub_distr_r.
  move=> /div_exact => ?.
  have -> : m * (n + 2) = ((n+2) * (m / (n + 1))) * (n + 1) by lia.
  by rewrite Nat.div_mul; lia.
Qed.

Lemma div_mul_le m n : (m / n) * n <= m.
Proof. have := Nat.div_mod_eq m n. by lia. Qed.

Lemma transition_le_gt (f: nat -> nat) (x n1 n2: nat):
  n1 <= n2 -> f n1 <= x -> x < f n2 -> exists n, n < n2 /\ f n <= x /\ x < f (1+n).
Proof.
  move=> H Hfn1 Hfn2. have : n1 < n2.
  { suff : n1 <> n2 by lia. by move=> ?; subst; lia. }
  clear H. elim: n2 Hfn2; first by lia.
  move=> n2 IH ??.
  have [?|?] : f n2 <= x \/ x < f n2 by lia.
  - exists n2 => /=. lia.
  - have ? : n1 <> n2 by (move=> ?; subst; lia).
    have [n ?] := IH ltac:(lia) ltac:(lia).
    exists n. lia.
Qed.


Require Export TopologicalSpaces.
Require Export DirectedSets.
Require Export InteriorsClosures.
Require Export Continuity.

Local Unset Standard Proposition Elimination Names.
Set Asymmetric Patterns.

Section Net.

Variable I:DirectedSet.
Variable X:TopologicalSpace.

Definition Net := DS_set I -> point_set X.

Definition net_limit (x:Net) (x0:point_set X) : Prop :=
  forall U:Ensemble (point_set X), open U -> In U x0 ->
  for large i:DS_set I, In U (x i).

Definition net_cluster_point (x:Net) (x0:point_set X) : Prop :=
  forall U:Ensemble (point_set X), open U -> In U x0 ->
  exists arbitrarily large i:DS_set I, In U (x i).

Lemma net_limit_is_cluster_point: forall (x:Net) (x0:point_set X),
  net_limit x x0 -> net_cluster_point x x0.
Proof.
intros.
red; intros.
red; intros.
pose proof (H U H0 H1).
destruct H2.
destruct (DS_join_cond i x1).
destruct H3.
exists x2; split; trivial.
apply H2; trivial.
Qed.

Lemma net_limit_in_closure: forall (S:Ensemble (point_set X))
  (x:Net) (x0:point_set X),
  (exists arbitrarily large i:DS_set I, In S (x i)) ->
  net_limit x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
red; intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
apply H2.
apply closure_closed.
assumption.
destruct H3.
pose proof (H x1).
destruct H4.
contradiction (H3 x2).
tauto.
apply closure_inflationary; tauto.
Qed.

Lemma net_cluster_point_in_closure: forall (S:Ensemble (point_set X))
  (x:Net) (x0:point_set X),
  (for large i:DS_set I, In S (x i)) ->
  net_cluster_point x x0 -> In (closure S) x0.
Proof.
intros.
apply NNPP.
red; intro.
pose proof (H0 (Complement (closure S))).
match type of H2 with | ?A -> ?B -> ?C => assert (C) end.
apply H2.
apply closure_closed.
assumption.
destruct H.
destruct (H3 x1).
destruct H4.
contradiction H5.
apply closure_inflationary.
apply H; trivial.
Qed.

End Net.

Arguments net_limit [I] [X].
Arguments net_cluster_point [I] [X].
Arguments net_limit_is_cluster_point [I] [X].
Arguments net_limit_in_closure [I] [X].
(*Implicit Arguments net_cluster_point_in_closure [[I] [X]].*)
Arguments net_cluster_point_in_closure [I] [X].

Section neighborhood_net.

Variable X:TopologicalSpace.
Variable x:point_set X.

Inductive neighborhood_net_DS_set : Type :=
  | intro_neighborhood_net_DS :
    forall (U:Ensemble (point_set X)) (y:point_set X),
    open U -> In U x -> In U y -> neighborhood_net_DS_set.

Definition neighborhood_net_DS_ord
  (Uy Vz:neighborhood_net_DS_set) : Prop :=
  match Uy, Vz with
  | intro_neighborhood_net_DS U _ _ _ _,
    intro_neighborhood_net_DS V _ _ _ _ =>
    Included V U
  end.

Definition neighborhood_net_DS : DirectedSet.
refine (Build_DirectedSet neighborhood_net_DS_set
  neighborhood_net_DS_ord _ _).
constructor.
red; intros.
destruct x0.
simpl; auto with sets.
red; intros.
destruct x0; destruct y; destruct z.
simpl in H; simpl in H0; simpl.
auto with sets.

intros.
destruct i; destruct j.
assert (open (Intersection U U0)).
apply open_intersection2; trivial.
assert (In (Intersection U U0) x); auto with sets.

exists (intro_neighborhood_net_DS (Intersection U U0) x
  H H0 H0).
simpl; auto with sets.
Defined.

Definition neighborhood_net : Net neighborhood_net_DS X :=
  fun (x:neighborhood_net_DS_set) => match x with
  | intro_neighborhood_net_DS _ y _ _ _ => y
  end.

Lemma neighborhood_net_limit: net_limit neighborhood_net x.
Proof.
red; intros.
exists (intro_neighborhood_net_DS U x H H0 H0).
intros.
destruct j.
simpl in H1.
simpl.
auto with sets.
Qed.

End neighborhood_net.

Lemma net_limits_determine_topology:
  forall {X:TopologicalSpace} (S:Ensemble (point_set X))
  (x0:point_set X), In (closure S) x0 ->
  exists I:DirectedSet, exists x:Net I X,
  (forall i:DS_set I, In S (x i)) /\ net_limit x x0.
Proof.
intros.
assert (forall U:Ensemble (point_set X), open U -> In U x0 ->
  Inhabited (Intersection S U)).
intros.
apply NNPP; red; intro.
assert (Included (closure S) (Complement U)).
apply closure_minimal.
red; rewrite Complement_Complement; assumption.
red; intros.
red; red; red; intros.
contradiction H2.
exists x; auto with sets.
contradict H1.
apply H3.
assumption.
pose (Ssel := fun n:neighborhood_net_DS_set X x0 =>
  match n with
  | intro_neighborhood_net_DS V y _ _ _ => (In S y)
  end).
pose (our_DS_set := {n:neighborhood_net_DS_set X x0 | Ssel n}).
pose (our_DS_ord := fun (n1 n2:our_DS_set) =>
  neighborhood_net_DS_ord X x0 (proj1_sig n1) (proj1_sig n2)).
assert (preorder our_DS_ord).
constructor; red.
intros; red.
apply preord_refl.
apply (@DS_ord_cond (neighborhood_net_DS X x0)).
intros x y z.
unfold our_DS_ord; apply preord_trans.
apply (@DS_ord_cond (neighborhood_net_DS X x0)).
assert (forall i j:our_DS_set, exists k:our_DS_set,
  our_DS_ord i k /\ our_DS_ord j k).
destruct i.
destruct x.
destruct j.
destruct x.
assert (open (Intersection U U0)).
apply open_intersection2; trivial.
assert (In (Intersection U U0) x0).
auto with sets.
assert (Inhabited (Intersection S (Intersection U U0))).
apply H0; trivial.
destruct H4.
destruct H4.
pose (k0 := intro_neighborhood_net_DS X x0
  (Intersection U U0) x H2 H3 H5).
assert (Ssel k0).
red; unfold k0; simpl.
assumption.
exists (exist _ k0 H6).
split; red; simpl; auto with sets.

pose (our_DS := Build_DirectedSet our_DS_set our_DS_ord H1 H2).
exists our_DS.
exists (fun i:our_DS_set => neighborhood_net X x0 (proj1_sig i)).
split.
intros.
destruct i.
destruct x.
simpl.
simpl in s.
assumption.

red; intros.
assert (Inhabited (Intersection S U)).
apply H0; trivial.
destruct H5.
destruct H5.
pose (i0 := intro_neighborhood_net_DS X x0
  U x H3 H4 H6).
assert (Ssel i0).
simpl; assumption.
exists (exist _ i0 H7).
intros.
destruct j.
destruct x1.
simpl in H8.
red in H8; simpl in H8.
simpl.
auto with sets.
Qed.

Section Nets_and_continuity.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.

Lemma continuous_func_preserves_net_limits:
  forall {I:DirectedSet} (x:Net I X) (x0:point_set X),
    net_limit x x0 -> continuous_at f x0 ->
    net_limit (fun i:DS_set I => f (x i)) (f x0).
Proof.
intros.
red; intros V ? ?.
assert (neighborhood V (f x0)).
apply open_neighborhood_is_neighborhood; split; trivial.
pose proof (H0 V H3).
destruct H4 as [U [? ?]].
destruct H4.
pose proof (H U H4 H6).
apply eventually_impl_base with (fun i:DS_set I => In U (x i));
  trivial.
intros.
assert (In (inverse_image f V) (x i)); auto with sets.
destruct H9; trivial.
Qed.

Lemma func_preserving_net_limits_is_continuous:
  forall x0:point_set X,
  (forall (I:DirectedSet) (x:Net I X),
    net_limit x x0 -> net_limit (fun i:DS_set I => f (x i)) (f x0))
  -> continuous_at f x0.
Proof.
intros.
pose proof (H (neighborhood_net_DS X x0)
  (neighborhood_net X x0)
  (neighborhood_net_limit X x0)).
apply continuous_at_open_neighborhoods; intros.
destruct H1.
pose proof (H0 V H1 H2).
destruct H3.
destruct x as [U].
exists U; repeat split; trivial.
pose proof (H3 (intro_neighborhood_net_DS X x0 U x o i H4)).
apply H5.
simpl; auto with sets.
Qed.

End Nets_and_continuity.

Section Subnet.

Variable X:TopologicalSpace.
Variable I:DirectedSet.
Variable x:Net I X.

Inductive Subnet {J:DirectedSet} : Net J X -> Prop :=
  | intro_subnet: forall h:DS_set J -> DS_set I,
    (forall j1 j2:DS_set J, DS_ord j1 j2 ->
       DS_ord (h j1) (h j2)) ->
    (exists arbitrarily large i:DS_set I,
       exists j:DS_set J, h j = i) ->
    Subnet (fun j:DS_set J => x (h j)).

Lemma subnet_limit: forall (x0:point_set X) {J:DirectedSet}
  (y:Net J X), net_limit x x0 -> Subnet y ->
  net_limit y x0.
Proof.
intros.
destruct H0.
red; intros.
pose proof (H U H2 H3).
destruct H4.
destruct (H1 x1).
destruct H5.
destruct H6.
exists x3.
intros.
apply H4.
apply preord_trans with x2.
apply DS_ord_cond.
assumption.
rewrite <- H6.
apply H0.
assumption.
Qed.

Lemma subnet_cluster_point: forall (x0:point_set X) {J:DirectedSet}
  (y:Net J X), net_cluster_point y x0 ->
  Subnet y -> net_cluster_point x x0.
Proof.
intros.
destruct H0 as [h h_increasing h_dominant].
red; intros.
red; intros.
pose proof (h_dominant i).
destruct H2.
destruct H2.
destruct H3.
pose proof (H U H0 H1 x2).
destruct H4.
destruct H4.
exists (h x3).
split; trivial.
apply preord_trans with x1.
apply DS_ord_cond.
assumption.
rewrite <- H3.
apply h_increasing; assumption.
Qed.

Section cluster_point_subnet.

Variable x0:point_set X.
Hypothesis x0_cluster_point: net_cluster_point x x0.
Hypothesis I_nonempty: inhabited (DS_set I).

Record cluster_point_subnet_DS_set : Type := {
  cps_i:DS_set I;
  cps_U:Ensemble (point_set X);
  cps_U_open_neigh: open_neighborhood cps_U x0;
  cps_xi_in_U: In cps_U (x cps_i)
}.

Definition cluster_point_subnet_DS_ord
  (iU1 iU2 : cluster_point_subnet_DS_set) : Prop :=
  DS_ord (cps_i iU1) (cps_i iU2) /\
  Included (cps_U iU2) (cps_U iU1).

Definition cluster_point_subnet_DS : DirectedSet.
refine (Build_DirectedSet
  cluster_point_subnet_DS_set
  cluster_point_subnet_DS_ord
  _ _).
constructor.
red; intros; split; auto with sets.
apply preord_refl.
apply DS_ord_cond.
red; intros.
destruct H; destruct H0.
red; split; auto with sets.
apply preord_trans with (cps_i y); trivial.
apply DS_ord_cond.

intros.
destruct i as [i0 U0 ? ?]; destruct j as [i1 U1 ? ?].
destruct (DS_join_cond i0 i1).
destruct H.
pose proof (x0_cluster_point
  (Intersection U0 U1)).
match type of H1 with | _ -> _ -> ?C =>
  assert C end.
apply H1.
apply open_intersection2;
  (apply cps_U_open_neigh0 ||
   apply cps_U_open_neigh1).
constructor;
  (apply cps_U_open_neigh0 ||
   apply cps_U_open_neigh1).
destruct (H2 x1).
destruct H3.
pose (ki := x2).
pose (kU := Intersection U0 U1).
assert (open_neighborhood kU x0).
split.
apply open_intersection2.
apply cps_U_open_neigh0.
apply cps_U_open_neigh1.
constructor; (apply cps_U_open_neigh0 ||
              apply cps_U_open_neigh1).
assert (In kU (x ki)).
exact H4.

exists (Build_cluster_point_subnet_DS_set
  ki kU H5 H6).
split; red; simpl; split.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
red; intros.
destruct H7; trivial.
apply preord_trans with x1; trivial.
apply DS_ord_cond.
red; intros.
destruct H7; trivial.
Defined.

Definition cluster_point_subnet : Net
  cluster_point_subnet_DS X :=
  fun (iU:DS_set cluster_point_subnet_DS) =>
  x (cps_i iU).

Lemma cluster_point_subnet_is_subnet:
  Subnet cluster_point_subnet.
Proof.
constructor.
intros.
destruct j1; destruct j2.
simpl in H; simpl.
red in H; tauto.

red; intros.
exists i; split.
apply preord_refl; apply DS_ord_cond.
assert (open_neighborhood Full_set x0).
split.
apply open_full.
constructor.
assert (In Full_set (x i)).
constructor.
exists (Build_cluster_point_subnet_DS_set
  i Full_set H H0).
trivial.
Qed.

Lemma cluster_point_subnet_converges:
  net_limit cluster_point_subnet x0.
Proof.
red; intros.
destruct I_nonempty as [i0].
destruct (x0_cluster_point U H H0 i0).
destruct H1.
assert (open_neighborhood U x0).
split; trivial.
exists (Build_cluster_point_subnet_DS_set
  x1 U H3 H2).
intros.
destruct j.
red in H4; simpl in H4.
red in H4; simpl in H4.
unfold cluster_point_subnet; simpl.
destruct H4; auto with sets.
Qed.

Lemma net_cluster_point_impl_subnet_converges:
  exists J:DirectedSet, exists y:Net J X,
  Subnet y /\ net_limit y x0.
Proof.
exists cluster_point_subnet_DS.
exists cluster_point_subnet.
split.
exact cluster_point_subnet_is_subnet.
exact cluster_point_subnet_converges.
Qed.

End cluster_point_subnet.

End Subnet.


Require Import ZArith.

Open Scope Z_scope.

Inductive dtree (A : Type) : nat -> Type :=
  | dleaf : A -> dtree A O
  | dbranch : forall n, dtree A n -> dtree A n -> dtree A (S n).

Arguments dleaf {A} x.
Arguments dbranch {A} {n} l r.

Check dbranch (dbranch (dleaf 42) (dleaf 13)) (dbranch (dleaf 7) (dleaf 20)).

Inductive stree (A : Type) : nat -> Type :=
  | sleaf : A -> stree A O
  | sbranch : forall n m, stree A n -> stree A m -> stree A (S (max n m)).

Arguments sleaf {A} x.
Arguments sbranch {A} {n m} l r.

Check sbranch (sbranch (sleaf 42) (sleaf 13)) (sleaf 7).

(** This is a balanced binary tree with elements only in the leaves. *)
Inductive tree (A : Type) : nat -> Type :=
  | leaf : A -> tree A O
  | branch : forall n, tree A n -> tree A n -> tree A (S n).

Arguments leaf {A} x.
Arguments branch {A} {n} l r.

Check leaf 42.
Check branch (leaf 42) (leaf 13).
Check branch (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf 20)).
Fail Check branch (leaf 42) (branch (leaf 7) (leaf 20)).

Definition lx {A : Type} (t : tree A O) : A :=
  match t with
  | leaf x => x
  end.

Definition bl {A : Type} {n : nat} (t : tree A (S n)) : tree A n :=
  match t with
  | branch l _ => l
  end.

Definition br {A : Type} {n : nat} (t : tree A (S n)) : tree A n :=
  match t with
  | branch _ r => r
  end.

Fixpoint map {A B : Type} (f : A -> B)
  {n : nat} (t : tree A n) : tree B n :=
  match t with
  | leaf x => leaf (f x)
  | branch l r => branch (map f l) (map f r)
  end.

(** This is called the _convoy pattern_. *)
Fixpoint zip' {A1 A2 B : Type} (f : A1 -> A2 -> B)
  {n : nat} (t1 : tree A1 n) (t2 : tree A2 n) : tree B n :=
  match t1 in tree _ n return tree A2 n -> tree B n with
  | leaf x1 => fun t2 => leaf (f x1 (lx t2))
  | branch l1 r1 => fun t2 => branch (zip' f l1 (bl t2)) (zip' f r1 (br t2))
  end t2.

(** This is a second-order convoy. *)
Fixpoint zip {A1 A2 B : Type} (f : A1 -> A2 -> B)
  {n : nat} (t1 : tree A1 n) (t2 : tree A2 n) : tree B n :=
  match n return tree A1 n -> tree A2 n -> tree B n with
  | O => fun t1 t2 => leaf (f (lx t1) (lx t2))
  | S _ => fun t1 t2 => branch (zip f (bl t1) (bl t2)) (zip f (br t1) (br t2))
  end t1 t2.

Compute zip Zplus (leaf 42) (leaf 13).
Compute zip Zplus (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf 20)).
Fail Compute zip Zplus (leaf 42) (branch (leaf 7) (leaf 20)).

Notation "x + y" := (zip Zplus x y).
Notation "x * y" := (map (Zmult x) y).

(* ~ x = x
   ~ (l, r) = (~ l, - (~ r)) *)
Fixpoint aux {A : Type} (fneg : A -> A)
  {n : nat} (t : tree A n) : tree A n :=
  match t with
  | leaf x => leaf x
  | branch l r => branch (aux fneg l) (map fneg (aux fneg r))
  end.

Notation "~ x" := (aux Zopp x).

Compute aux Zopp (branch (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf 20))).

(* x1 /\ x2 = x1 * x2
   (l1, r1) /\ (l2, r2) = (l1 /\ l2, r1 /\ l2 + l1 /\ r2) *)
(** We must run the convoy in reverse here. *)
Fixpoint outer {A : Type} (fadd fmul : A -> A -> A) (fneg : A -> A)
  {n : nat} (t1 : tree A n) (t2 : tree A n) : tree A n :=
  match t2 in tree _ n return tree A n -> tree A n with
  | leaf x2 => fun t1 => leaf (fmul (lx t1) x2)
  | branch l2 r2 => fun t1 => branch
    (outer fadd fmul fneg (bl t1) l2) (zip fadd
    (outer fadd fmul fneg (br t1) l2)
    (outer fadd fmul fneg (aux fneg (bl t1)) r2))
  end t1.

Notation "x /\ y" := (outer Zplus Zmult Zopp x y).

(* x1 ** x2 = x1 * x2
   (l1, r1) ** (l2, r2) = (l1 ** l2) + (r1 ** (~ r2)) *)
Fixpoint inner {A : Type} (fadd fmul : A -> A -> A) (fneg : A -> A)
  {n : nat} (t1 : tree A n) (t2 : tree A n) : A :=
  match t1 in tree _ n return tree A n -> A with
  | leaf x1 => fun t2 => fmul x1 (lx t2)
  | branch l1 r1 => fun t2 => fadd
    (inner fadd fmul fneg l1 (bl t2))
    (* metric signature here *) (inner fadd fmul fneg r1 (aux fneg (br t2)))
  end t2.

Notation "x '.*' y" := (inner Zplus Zmult Zopp x y) (at level 42).

Compute inner Zplus Zmult Zopp
  (branch (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf 69)))
  (branch (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf (Zopp 69)))).

(* Fixpoint flapr {A : Type} (f : forall n, tree A n -> tree A n)
  {n : nat} (t : tree A n) : tree A n :=
  match t with
  | leaf x => leaf x
  | branch l r => branch (flapr f l) (flapr f (f _ r))
  end. *)
Fixpoint flapr {A : Type} (f : forall n, tree A n -> tree A n)
  {n : nat} (t : tree A n) : tree A n :=
  match n in nat return tree A n -> tree A n with
  | O => fun t => leaf (lx t)
  | S n => fun t => branch (flapr f (bl t)) (flapr f (f _ (br t)))
  end t.

(* >< x = x
   >< (l, r) = (>< l, >< (~ r)) *)
Fixpoint rev {A : Type} (fneg : A -> A)
  {n : nat} (t : tree A n) : tree A n :=
  match n in nat return tree A n -> tree A n with
  | O => fun t => leaf (lx t)
  | S n => fun t => branch (rev fneg (bl t)) (rev fneg (aux fneg (br t)))
  end t.

Notation ">< x" := (flapr (aux Zopp) x) (at level 13).

Compute let x := branch (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf 69)) in
  inner Zplus Zmult Zopp x (rev Zopp x).

Fixpoint const {A : Type} (z : A)
  {n : nat} : tree A n :=
  match n with
  | O => leaf z
  | S _ => let b := const z in branch b b
  end.

Compute @const _ 0 2.

Definition inject1 {A : Type} (z : A)
  {n : nat} (t : tree A n) : tree A (S n) :=
  branch t (const z).

Fixpoint inject {A : Type} (z : A)
  {n m : nat} (t : tree A n) : tree A (m + n) :=
  match m in nat return tree A n -> tree A (m + n) with
  | O => fun t => t
  | S _ => fun t => branch (inject z t) (inject z (const z))
  end t.

Compute @inject _ 0 _ 2 (branch (leaf 42) (leaf 13)).

(* This is just [bl]. *)
Definition project1 {A : Type}
  {n : nat} (t : tree A (S n)) : tree A n :=
  match t with
  | branch l r => l
  end.

Fixpoint project {A : Type}
  {n m : nat} (t : tree A (m + n)) : tree A n :=
  match m in nat return tree A (m + n) -> tree A n with
  | O => fun t => t
  | S k => fun t => project (bl t)
  end t.

Compute @project _ _ 1 (branch (branch (leaf 42) (leaf 13)) (branch (leaf 7) (leaf 69))).

(* Now define the free algebra and compute specializations. *)

Inductive free (A : Type) (z : A) : Type :=
  | f_lift : A -> free A z
  | f_add : free A z -> free A z -> free A z
  | f_neg : free A z -> free A z
  | f_mul : free A z -> free A z -> free A z.

Arguments f_lift {A} {z} x.
Arguments f_add {A} {z} x y.
Arguments f_neg {A} {z} x.
Arguments f_mul {A} {z} x y.

Check (@f_lift Z 0 42).

Notation "x + y" := (f_add x y).
Notation "- x" := (f_neg x).
Notation "x * y" := (f_mul x y).

Require Import String.

Open Scope string_scope.

Check (@f_lift string "0" "x").
Compute (f_mul (f_lift "x") (f_add (f_lift "y") (f_lift "0")) : free string "0").

(* Structural equality. *)
Fixpoint f_eq {A : Type} (eq : A -> A -> bool)
  {z : A} (a1 a2 : free A z) : bool :=
  match a1, a2 with
  | f_lift x1, f_lift x2 => eq x1 x2
  | f_add x1 y1, f_add x2 y2 => f_eq eq x1 x2 && f_eq eq y1 y2
  | f_neg x1, f_neg x2 => f_eq eq x1 x2
  | f_mul x1 y1, f_mul x2 y2 => f_eq eq x1 x2 && f_eq eq y1 y2
  | _, _ => false
  end.

(* This is weak. *)
Fixpoint simpl {A : Type} {z : A}
  (eq : A -> A -> bool) (a : free A z) : free A z :=
  match a with
  | f_lift x => f_lift x
  | f_add x y => if f_eq eq (f_lift z) x then simpl eq y else
    if f_eq eq (f_lift z) y then simpl eq x else
    f_add (simpl eq x) (simpl eq y)
  | f_neg x => f_neg (simpl eq x)
  | f_mul x y => if f_eq eq (f_lift z) x then f_lift z else
    if f_eq eq (f_lift z) y then f_lift z else
    f_add (simpl eq x) (simpl eq y)
  end.

Definition string_eq (s1 s2 : string) : bool :=
  if string_dec s1 s2 then true else false.

Compute simpl string_eq
  (f_mul (f_lift "x") (f_add (f_lift "y") (f_lift "0")) : free string "0").

Compute outer f_add f_mul f_neg
  (branch (leaf (f_lift "a")) (leaf (f_lift "x")))
  (branch (leaf (f_lift "b")) (leaf (f_lift "y"))) : tree (free string "0") 1.


(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

Check (fun x: nat => x).

Check (fun x: True => x).

Check I.

Check (fun _: False => I).

Check (fun x: False => x).

Inductive unit: Set :=
| tt.

Check unit.

Check tt.

Theorem unit_singleton: forall x: unit, x = tt.
Proof.
  destruct x. reflexivity.
Qed.

Check unit_ind.

Inductive Empty_set : Set := .

Theorem the_sky_is_faling: forall x: Empty_set, 2 + 2 = 5.
Proof.
  destruct 1.
Qed.

Check Empty_set_ind.

Definition e2u (e: Empty_set) : unit := match e with end.

Check e2u.

Inductive bool: Set :=
| true
| false.

Check bool_ind.

Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | fales => true
  end.

Definition negb' (b : bool) : bool :=
  if b then false else true.

Theorem negb_inverse : forall b : bool, negb (negb b) = b.
Proof.
  destruct b; reflexivity.
Qed.

Theorem negb_ineq' : forall b : bool, negb b = b -> False.
Proof.
  destruct b; discriminate.
Qed.

Theorem negb_ineq : forall b : bool, negb b <> b.
Proof.
  destruct b; discriminate.
Qed.

Check bool_ind.

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

Definition isZero (n : nat) : bool :=
  match n with
  | O => true
  | S _ => false
  end.

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.

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

Theorem O_plus_n : forall n : nat, plus O n = n.
Proof.
  intros. reflexivity.
Qed.

Theorem n_plus_O : forall n : nat, plus n O = n.
  induction n.
  reflexivity.
  simpl. rewrite IHn. reflexivity.
Qed.

Theorem n_plus_O' : forall n : nat, plus n O = n.
  induction n; crush.
Qed.

Check nat_ind.

Theorem S_inj : forall n m : nat, S n = S m -> n = m.
Proof.
  injection 1; trivial.
Qed.

Inductive nat_list : Set :=
| NNil : nat_list
| NCons : nat -> nat_list -> nat_list.

Check nat_list_ind.

Fixpoint nlength (ls : nat_list) : nat :=
  match ls with
  | NNil => O
  | NCons _ ls' => S (nlength ls')
  end.

Fixpoint napp (ls1 ls2 : nat_list) : nat_list :=
  match ls1 with
  | NNil => ls2
  | NCons n ls' => NCons n (napp ls' ls2)
  end.

Theorem nlength_napp : forall ls1 ls2 : nat_list, nlength (napp ls1 ls2) = plus (nlength ls1) (nlength ls2).
Proof.
  induction ls1; crush.
Qed.

Inductive nat_btree : Set :=
| NLeaf : nat_btree
| NNode : nat_btree -> nat -> nat_btree -> nat_btree.

Check nat_btree_ind.

Fixpoint nsize (tr : nat_btree) : nat :=
  match tr with
  | NLeaf => S O
  | NNode tr1' _ tr2' => plus (nsize tr1') (nsize tr2')
  end.

Fixpoint nsplice (tr1 tr2 : nat_btree) : nat_btree :=
  match tr1 with
  | NLeaf => NNode tr2 O NLeaf
  | NNode tr1' n tr2' => NNode (nsplice tr1' tr2) n tr2'
  end.

Theorem plus_assoc : forall n1 n2 n3 : nat, plus (plus n1 n2) n3 = plus n1 (plus n2 n3).
Proof.
  induction n1; crush.
Qed.

Hint Rewrite n_plus_O plus_assoc.

Theorem nsize_nsplice : forall tr1 tr2 : nat_btree, nsize (nsplice tr1 tr2) = plus (nsize tr2) (nsize tr1).
  induction tr1; crush.
Qed.

Check nat_btree_ind.

Inductive list (T : Set) : Set :=
| Nil : list T
| Cons : T -> list T -> list T.

Fixpoint length T (ls : list T) : nat :=
  match ls with
  | Nil => O
  | Cons _ ls' => S (length ls')
  end.

Fixpoint app T (ls1 ls2 : list T) : list T :=
  match ls1 with
  | Nil => ls2
  | Cons n ls' => Cons n (app ls' ls2)
  end.

Theorem length_app : forall (T : Set) (ls1 ls2 : list T), plus (length ls1) (length ls2) = length (app ls1 ls2).
Proof.
  induction ls1; crush.
Qed.

Arguments Nil [T].

Print list.

Check length.

Check list_ind.

Inductive even_list : Set :=
| ENil : even_list
| ECons : nat -> odd_list -> even_list

with odd_list : Set :=
| OCons : nat -> even_list -> odd_list.

Check even_list_ind.

Check odd_list_ind.

Fixpoint elength (el : even_list) : nat :=
  match el with
  | ENil => O
  | ECons _ ol => S (olength ol)
  end

with olength (ol : odd_list) : nat :=
       match ol with
       | OCons _ el => S (elength el)
       end.

Fixpoint eapp (el1 el2 : even_list) : even_list :=
  match el1 with
  | ENil => el2
  | ECons n ol => ECons n (oapp ol el2)
  end

with oapp (ol : odd_list) (el : even_list) : odd_list :=
       match ol with
       | OCons n el' => OCons n (eapp el' el)
       end.

Theorem elength_eapp : forall (el1 el2 : even_list), plus (elength el1) (elength el2) = elength (eapp el1 el2).
  induction el1; crush.
Abort.

Scheme even_list_mut := Induction for even_list Sort Prop
  with odd_list_mut := Induction for odd_list Sort Prop.

Theorem elength_eapp : forall (el1 el2 : even_list), plus (elength el1) (elength el2) = elength (eapp el1 el2).
Proof.
  apply (even_list_mut
           (fun el1 => forall (el2 : even_list), plus (elength el1) (elength el2) = elength (eapp el1 el2))
           (fun ol => forall (el : even_list), plus (olength ol) (elength el) = olength (oapp ol el))); crush.
Qed.

Inductive pformula : Set :=
| Truth : pformula
| Falsehood : pformula
| Conjuction : pformula -> pformula -> pformula.

Fixpoint pformulaDenote (f : pformula) : Prop :=
  match f with
  | Truth => True
  | Falsehood => False
  | Conjuction f1 f2 => pformulaDenote f1 /\ pformulaDenote f2
  end.

Inductive formula : Set :=
| Eq : nat -> nat -> formula
| And : formula -> formula -> formula
| Forall :  (nat -> formula) -> formula.

Fixpoint formulaDenote (f : formula) : Prop :=
  match f with
  | Eq x y => x = y
  | And f1 f2 => (formulaDenote f1) /\ (formulaDenote f2)
  | Forall f' => forall n : nat, formulaDenote (f' n)
  end.

Fixpoint swapper (f : formula) : formula :=
  match f with
  | Eq x y => Eq y x
  | And f1 f2 => And f2 f1
  | Forall f' => Forall (fun n => swapper (f' n))
  end.

Theorem swapper_preserves_truth : forall f, formulaDenote f -> formulaDenote (swapper f).
  induction f; crush.
Qed.

Check formula_ind.

Print nat_ind.

Print nat_rect.

Definition nat_ind' : forall P : nat -> Prop, P O -> (forall n : nat,  P n -> P (S n)) -> forall n : nat,  P n := fun P : nat -> Prop => nat_rect P.

Print nat_rec.

Definition nat_rec' : forall P : nat -> Set, P O -> (forall n : nat,  P n -> P (S n)) -> forall n : nat, P n := fun P => nat_rect P.

Fixpoint plus_recursive (n : nat) : nat -> nat :=
  match n with
  | O => fun m => m
  | S n' => fun m => S (plus_recursive n' m)
  end.

Definition plus_rec : nat -> nat -> nat :=
  nat_rec (fun _ : nat => nat -> nat) (fun m => m) (fun n f =>  (fun m =>  S (f m))).

Definition plus_rec' : nat -> nat -> nat :=
  nat_rec (fun _ : nat => nat -> nat) (fun m => m) (fun _ r m => S (r m)).

Theorem plus_equivalent : plus_recursive = plus_rec.
Proof.
  unfold plus_recursive.
  unfold plus_rec.
  unfold nat_rec.
  unfold nat_rect.
  reflexivity.
Qed.

Print nat_rect.

Fixpoint nat_rect' (P: nat -> Type)
         (HO : P O)
         (HS : forall n, P n -> P (S n)) (n : nat) :=
  match n return P n with
  | O => HO
  | S n' => HS n' (nat_rect' P HO HS n')
  end.

Fixpoint even_list_ind' (PE : even_list -> Prop)
         (PO : odd_list -> Prop)
         (H0 : PE ENil)
         (H1 : forall (n : nat) (lo : odd_list), PO lo -> PE (ECons n lo))
         (H2 : forall (n: nat) (le : even_list), PE le -> PO (OCons n le))
         (le : even_list) :=
  match le return PE le with
  | ENil => H0
  | ECons n lo => H1 n lo (odd_list_ind' PE PO H0 H1 H2 lo)
  end

with odd_list_ind' (PE : even_list -> Prop)
         (PO : odd_list -> Prop)
         (H0 : PE ENil)
         (H1 : forall (n : nat) (lo : odd_list), PO lo -> PE (ECons n lo))
         (H2 : forall (n: nat) (le : even_list), PE le -> PO (OCons n le))
         (lo : odd_list) :=
       match lo return PO lo with
       | OCons n le => H2 n le (even_list_ind' PE PO H0 H1 H2 le)
       end.

Section even_list_mut_from_the_book'.
  Variable Peven : even_list -> Prop.
  Variable Podd : odd_list -> Prop.

  Hypothesis ENil_case : Peven ENil.
  Hypothesis ECons_case : forall (n : nat) (o : odd_list), Podd o -> Peven (ECons n o).
  Hypothesis OCons_case : forall (n : nat) (e : even_list), Peven e -> Podd (OCons n e).

  Fixpoint even_list_mut' (e : even_list) : Peven e :=
    match e with
    | ENil => ENil_case
    | ECons n o => ECons_case n (odd_list_mut' o)
    end
  with odd_list_mut' (o : odd_list) : Podd o :=
         match o with
         | OCons n e => OCons_case n (even_list_mut' e)
         end.
End even_list_mut_from_the_book'.

Fixpoint formula_ind' (P : formula -> Prop)
         (H0 : forall (n0 n1 : nat), P (Eq n0 n1))
         (H1 : forall (f0 f1 : formula), P f0 -> P f1 -> P (And f0 f1))
         (H2 : forall (f : nat -> formula), (forall n : nat, P (f n)) -> P (Forall f))
                                                                         (f : formula) :=
            match f return P f with
            | Eq n0 n1 => H0 n0 n1
            | And f0 f1 => H1 f0 f1 (formula_ind' P H0 H1 H2 f0) (formula_ind' P H0 H1 H2 f1)
            | Forall func => H2 func (fun n => formula_ind' P H0 H1 H2 (func n))
            end.

Inductive nat_tree : Set :=
| NNode' : nat -> list nat_tree -> nat_tree.

Check nat_tree_ind.

Section All.
  Variable T : Set.
  Variable P : T -> Prop.
  Fixpoint All (ls : list T) : Prop :=
    match ls with
    | Nil => True
    | Cons h t => (P h) /\ All t
    end.
End All.

Locate "/\".

Print and.

Print All.

Section nat_tree_ind'.
  Variable P : nat_tree -> Prop.
  Hypothesis NNode'_case : forall (n : nat) (ls : list nat_tree), All P ls -> P (NNode' n ls).
Fixpoint nat_tree_ind' (tr : nat_tree) : P tr :=
  match tr with
  | NNode' n ls => NNode'_case n ls
                               ((fix list_nat_tree_ind (ls : list nat_tree) : All P ls :=
                                   match ls with
                                   | Nil => I
                                   | Cons tr' rest => conj (nat_tree_ind' tr') (list_nat_tree_ind rest)
                                   end
                                ) ls)
  end.
End nat_tree_ind'.

Check nat_tree_ind'.
Section map.
  Variables T T' : Set.
  Variable F : T -> T'.

  Fixpoint map (ls : list T) : list T' :=
    match ls with
    | Nil => Nil
    | Cons h t => Cons (F h) (map t)
    end.
End map.

Fixpoint sum (ls : list nat) : nat :=
  match ls with
  | Nil => O
  | Cons n t => plus n (sum t)
  end.

Fixpoint ntsize (tr : nat_tree) : nat :=
  match tr with
  | NNode' _ trs => S (sum (map ntsize trs))
  end.

Fixpoint ntsize' (tr : nat_tree) : nat :=
  match tr with
  | NNode' _ Nil => S O
  | NNode' _ (Cons tr rest) => S (sum (Cons (ntsize' tr) (map ntsize' rest)))
  end.

Fixpoint ntsplice (tr1 tr2 : nat_tree) : nat_tree :=
  match tr1 with
  | NNode' n Nil => NNode' n (Cons tr2 Nil)
  | NNode' n (Cons tr rest) => NNode' n (Cons (ntsplice tr tr2) rest)
  end.

Lemma plus_S : forall n1 n2 : nat, plus n1 (S n2) = S (plus n1 n2).
  induction n1; crush.
Qed.

Hint Rewrite plus_S.

Theorem ntsize_ntsplice' : forall tr1 tr2 : nat_tree, ntsize' (ntsplice tr1 tr2) = plus (ntsize' tr2) (ntsize' tr1).
  induction tr1 using nat_tree_ind'; crush.
  induction ls; crush.
Qed.

Theorem ntsize_ntsplice : forall tr1 tr2 : nat_tree, ntsize (ntsplice tr1 tr2) = plus (ntsize tr2) (ntsize tr1).
  induction tr1 using nat_tree_ind'; crush.
  Restart.
  Hint Extern 1 (ntsize (match ?LS with Nil => _ | Cons _ _ => _ end) = _) => destruct LS; crush.
  induction tr1 using nat_tree_ind'; crush.
Qed.

Theorem true_neq_false : true <> false.
  red.
  intro H.
  Definition toProp (b : bool) := if b then True else False.
  change (toProp false).
  rewrite <- H.
  simpl.
  trivial.
Qed.

Theorem S_inj' : forall n m : nat, S n = S m -> n = m.
  intros n m H.
  change (pred (S n) = pred (S m)).
  rewrite H.
  reflexivity.
Qed.

Print False_ind.