(** * SearchTree: Binary Search Trees *)

(** Binary search trees are an efficient data structure for
   lookup tables, that is, mappings from keys to values.
   The [total_map] type from Maps.v is an _inefficient_
   implementation: if you add N items to your total_map,
   then looking them up takes N comparisons in the worst case,
   and N/2 comparisons in the average case.

   In contrast, if your [key] type is a total order -- that is,
   if it has a less-than comparison that's transitive and
   antisymmetric [ a<b <->  ~(b<a) ] -- then one can implement
   binary search trees (BSTs).   We will assume you know how BSTs
   work; you can learn this from:
   - 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.

   Our focus here is to _prove the correctness of an implementation_
   of binary search trees. *)

Require Import VFA.Perm.
Require Import FunctionalExtensionality.

(* ################################################################# *)
(** * Total and Partial Maps *)

(** Recall the [Maps] chapter of Volume 1 (Logical Foundations),
    describing functions from identifiers to some arbitrary type [A].
    VFA's [Maps] module is almost exactly the same, except that it
    implements functions from [nat] to some arbitrary type [A]. *)

Require Import VFA.Maps.

(* ################################################################# *)
(** * Sections *)

(** We will use Coq's [Section] feature to structure this development,
     so first a brief introduction to Sections.  We'll use the example
     of lookup tables implemented by lists. *)

Module SectionExample1.
  Definition mymap (V: Type) := list (nat*V).
  Definition empty (V: Type) : mymap V := nil.
  Fixpoint lookup (V: Type) (default: V) (x: nat) (m: mymap V) : V :=
    match m with
    | (a,v)::al => if x =? a then v else lookup V default x al
    | nil => default
    end.
  Theorem lookup_empty (V: Type) (default: V):
       forall x, lookup V default x (empty V) = default.
   Proof. reflexivity. Qed.
End SectionExample1.

(** It sure is tedious to repeat the [V] and [default] parameters
     in every definition and every theorem.  The [Section] feature
     allows us to declare them as parameters to every definition
     and theorem in the entire section: *)

Module SectionExample2.
  Section MAPS.
  Variable V : Type.
  Variable default: V.

  Definition mymap  := list (nat*V).
  Definition empty : mymap := nil.
  Fixpoint lookup (x: nat) (m: mymap) : V :=
    match m with
    | (a,v)::al => if x =? a then v else lookup x al
    | nil => default
    end.
  Theorem lookup_empty:
       forall x, lookup x empty = default.
   Proof. reflexivity. Qed.
  End MAPS.
End SectionExample2.

(** At the close of the section, this produces exactly the same
     result:  the functions that "need" to be parametrized by
     [V] or [default] are given extra parameters.  We can test
     this claim, as follows: *)

Goal SectionExample1.empty = SectionExample2.empty.
Proof. reflexivity.
Qed.

Goal SectionExample1.lookup = SectionExample2.lookup.
Proof.
  unfold SectionExample1.lookup, SectionExample2.lookup.
  try reflexivity. (* doesn't do anything. *)

  (** Well, not exactly the same; but certainly equivalent.
   Functions [f] and [g] are "extensionally equal" if, for every
   argument [x], [f x = g x].  The Axiom of Extensionality
   says that if two functions are "extensionally equal" then they
   are _equal_.  The [extensionality] tactic is just a convenient
   way of applying the axiom of extensionality. *)

  extensionality V; extensionality default; extensionality x.
  extensionality m; simpl.
  induction m as [| [? ?] ]; auto.
  destruct (x=?n); auto.
Qed.

(* ################################################################# *)
(** * Program for Binary Search Trees *)

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := nat.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint elements' (s: tree) (base: list (key*V)) : list (key * V) :=
 match s with
 | E => base
 | T a k v b => elements' a ((k,v) :: elements' b base)
 end.

Definition elements (s: tree) : list (key * V) := elements' s nil.

(* ################################################################# *)
(** * Search Tree Examples *)

Section EXAMPLES.
Variables v2 v4 v5 : V.
Eval compute in insert 5 v5 (insert 2 v2 (insert 4 v5 empty_tree)).
  (*      = T (T E 2 v2 E) 4 v5 (T E 5 v5 E) *)
Eval compute in lookup 5 (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).
  (*      = v5 *)
Eval compute in lookup 3 (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).
  (*      = default *)
Eval compute in elements (T (T E 2 v2 E) 4 v5 (T E 5 v5 E)).
  (*      = [(2, v2); (4, v5); (5, v5)] *)
End EXAMPLES.

(* ################################################################# *)
(** * What Should We Prove About Search trees? *)

(** Search trees are meant to be an implementation of maps.
   That is, they have an [insert] function that corresponds to the
   [update] function of a map, and a [lookup] function that
   corresponds to applying the map to an argument.  To prove the
   correctness of a search-tree algorithm, we can prove:
   - Any search tree corresponds to some map, using a function or
         relation that we demonstrate.
   - The lookup function gives the same result as applying the map
   - The insert function returns a corresponding map.
   - Maps have the properties we actually wanted.  It would do no
     good to prove that searchtrees correspond to some abstract
     type X, if X didn't have useful properties!

  What properties do we want searchtrees to have?  If I insert
  the binding [(k,v)] into a searchtree [t], then look up [k], I
  should get [v]. If I look up [k'] in [insert (k,v) t], where [k'<>k],
  then I should get the same result as [lookup k t].  There are several
  more properties. Fortunately, all these properties are already proved
  about [total_map] in the [Maps] module: *)

Check t_update_eq. (*  : forall (A : Type) (m : total_map A) (x : id) (v : A),
       t_update m x v x = v   *)
Check t_update_neq.  (* : forall (X : Type) (v : X) (x1 x2 : id) (m : total_map X),
       x1 <> x2 -> t_update m x1 v x2 = m x2    *)
Check t_update_shadow.  (* : forall (A : Type) (m : total_map A) (v1 v2 : A) (x : id),
       t_update (t_update m x v1) x v2 = t_update m x v2    *)
Check t_update_same.  (* : forall (X : Type) (x : id) (m : total_map X),
        t_update m x (m x) = m    *)
Check t_update_permute. (* forall (X : Type) (v1 v2 : X) (x1 x2 : id) (m : total_map X),
       x2 <> x1 ->
       t_update (t_update m x2 v2) x1 v1 =
         t_update (t_update m x1 v1) x2 v2    *)
Check t_apply_empty. (* : forall (A : Type) (x : id) (v : A),
       t_empty v x = v *)

(** So, if we like those properties that [total_map] is proved to have,
   and we can prove that searchtrees behave like maps, then we don't
   have to reprove each individual property about searchtrees.

   More generally:  a job worth doing is worth doing well.
   It does no good to prove the "correctness" of a program, if you
   prove that it satisfies a wrong or useless specification. *)

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

(** We use binary search trees because they are efficient.  That is,
     if there are [N] elements in a (reasonably well balanced) BST,
     each insertion or lookup takes about logN 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, such as "red-black trees",
	   that ensures the trees stay balanced.  We'll do that in
           Chapter [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 just use [nat] in this
           chapter because it's something you're already familiar with.

     3.  There's no notion of "run 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 later chapters.

      4.  Our functions in Coq aren't real implementations; they are
          just pretend models of real implementations.  What if there
          are bugs in the correspondence between the Coq function and
          the real implementation?

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

(* ################################################################# *)
(** * Proof of Correctness *)

(** We claim that a [tree] "corresponds" to a [total_map].
     So we must exhibit an "abstraction relation"
     [Abs: tree -> total_map V -> Prop].

    The idea is that [Abs t m] says that tree [t]
    is a representation of map [m]; or that map [m]
    is an abstraction of tree [t].  How should we
    define this abstraction relation?

    The empty tree is easy:   [Abs E (fun x => default)].

    Now, what about this tree?: *)

Definition example_tree (v2 v4 v5 : V) :=
   T (T E 2 v2 E) 4 v4 (T E 5 v5 E).

(** **** Exercise: 2 stars (example_map)  *)
(* Fill in the definition of example_map with a total_map that
  you think example_tree should correspond to.  Use
  [t_update] and [(t_empty default)]. *)

Definition example_map (v2 v4 v5: V) : total_map V
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(** [] *)

(** To build the [Abs] relation, we'll use these two auxiliary
     functions that construct maps: *)

Definition combine {A} (pivot: key) (m1 m2: total_map A) : total_map A :=
  fun x => if x <? pivot  then m1 x else m2 x.

(** [combine pivot a b] uses the map [a] on any input less than
   [pivot], and uses map [b] on any input [ >= pivot]. *)

Inductive Abs:  tree -> total_map V -> Prop :=
| Abs_E: Abs E (t_empty default)
| Abs_T: forall a b l k v r,
      Abs l a ->
      Abs r b ->
      Abs (T l k v r)  (t_update (combine k a b) k v).

(** **** Exercise: 3 stars (check_example_map)  *)
(** Prove that your [example_map] is the right one.
     If it isn't, go back and fix your definition of [example_map].
     You will probably need the [bdestruct] tactic, and [omega]. *)

Lemma check_example_map:
  forall v2 v4 v5, Abs (example_tree v2 v4 v5) (example_map v2 v4 v5).
Proof.
intros.
unfold example_tree.
evar (m: total_map V).
replace (example_map v2 v4 v5) with m; subst m.
repeat constructor.
extensionality x.
(* HINT:
  First,    [unfold example_map, t_update, combine, t_empty, beq_id.]
  Then, repeat the following procedure:  If you see something like
  [if 4 =? x then ... else ...],    use the tactic [bdestruct (4 =? x)].
  If the arithmetic facts above the line can't all be true, use [omega].
  If you're too lazy to check for yourself whether they are true,
   use [bdestruct (4 =? x); try omega].
*)
(* FILL IN HERE *) Admitted.
(** [] *)

(** You can ignore this lemma, unless it fails. *)
Lemma check_too_clever: forall v2 v4 v5: V, True.
Proof.
intros.
evar (m: total_map V).
assert (Abs (example_tree v2 v4 v5) m).
repeat constructor.
(change m with (example_map v2 v4 v5) in H || auto);
(* auto; *)
fail "Did you use copy-and-paste, from your check_example_map proof,
       into your example_map definition?  If so, very clever.
       Please try it again with an example_map definition that
       you make up from first principles.  Or, to skip that,
       uncomment the (* auto; *) above.".
Qed.

Theorem empty_tree_relate: Abs empty_tree (t_empty default).
Proof.
constructor.
Qed.

(** **** Exercise: 3 stars (lookup_relate)  *)
Theorem lookup_relate:
  forall k t cts ,
    Abs t cts -> lookup k t =  cts k.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars (insert_relate)  *)
Theorem insert_relate:
 forall k v t cts,
    Abs t cts ->
    Abs (insert k v t) (t_update cts k v).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Correctness Proof of the [elements] Function *)

(** How should we specify what [elements] is supposed to do?
     Well, [elements t] returns a list of pairs
     [(k1,v1);(k2;v2);...;(kn,vn)] that ought to correspond to
     the total_map, [t_update ... (t_update (t_update (t_empty default)
                     (Id k1) v1) (Id k2) v2) ... (Id kn) vn].

    We can formalize this quite easily.  *)

Fixpoint list2map (el: list (key*V)) : total_map V :=
 match el with
 | nil => t_empty default
 | (i,v)::el' => t_update (list2map el') i v
 end.

(** **** Exercise: 3 stars (elements_relate_informal)  *)
Theorem elements_relate:
  forall t cts,  Abs t cts -> list2map (elements t) = cts.
Proof.
(** Don't prove this yet.  Instead, explain in your own words, with
   examples, why this must be true.  It's OK if your explanation is
   not a formal proof; it's even OK if your explanation is subtly
   wrong!  Just make it convincing. *)

  (* FILL IN YOUR EXPLANATION HERE *)
Abort.
(** [] *)

(** Instead of doing a _formal_ proof that [elements_relate] is true,
     prove that it's false!  That is, as long as type [V] contains at
     least two distinct values. *)

(** **** Exercise: 4 stars (not_elements_relate)  *)
Theorem not_elements_relate:
  forall v, v <> default ->
  ~ (forall t cts,  Abs t cts -> list2map (elements t) = cts).
Proof.
intros.
intro.
pose (bogus := T (T E 3 v E) 2 v E).
pose (m := t_update (t_empty default) 2 v).
pose (m' := t_update
        (combine 2
           (t_update (combine 3 (t_empty default) (t_empty default)) 3 v)
           (t_empty default)) 2 v).
assert (Paradox: list2map (elements bogus) = m /\ list2map (elements bogus) <> m).
split.
(** To prove the first subgoal, prove that [m=m'] (by [extensionality]) and
      then use [H].

     To prove the second subgoal, do an [intro] so that you can assume
      [update_list (t_empty default) (elements bogus) = m], then show that
      [update_list (t_empty default) (elements bogus) (Id 3) <> m (Id 3)].
      That's a contradiction.

      To prove the third subgoal, just destruct [Paradox] and use the
      contradiction.

      In all 3 goals, when you need to unfold local definitions such
      as [bogus] you can use [unfold bogus] or [subst bogus].  *)

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

(** What went wrong?  Clearly, [elements_relate] is true; you just
    explained why.  And clearly, it's not true, because
    [not_elements_relate] is provable in Coq.  The problem is that the
    tree [(T (T E 3 v E) 2 v E)] is bogus: it's not a well-formed
    binary search tree, because there's a 3 in the left subtree of the
    2 node, and 3 is not less than 2.

    If you wrote a good answer to the [elements_relate_informal]
    exercise, (that is, an answer that is only subtly wrong), then the
    subtlety is that you assumed that the search tree is well formed.
    That's a reasonable assumption; but we will have to prove that all
    the trees we operate on will be well formed.  *)

(* ################################################################# *)
(** * Representation Invariants *)

(** A [tree] has the [SearchTree] property if, at any node with key
     [k], all the keys in the left subtree are less than [k], and all
     the keys in the right subtree are greater than [k].  It's not
     completely obvious how to formalize that!  Here's one way: it's
     correct, but not very practical. *)

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

Definition SearchTreeX (t: tree) :=
 forall_nodes t
   (fun l k v r =>
      forall_nodes l (fun _ j _ _ => j<k) /\
      forall_nodes r (fun _ j _ _ => j>k)).

Lemma example_SearchTree_good:
   forall v2 v4 v5, SearchTreeX (example_tree v2 v4 v5).
Proof.
intros.
hnf. simpl.
repeat split; auto.
Qed.

Lemma example_SearchTree_bad:
   forall v, ~SearchTreeX (T (T E 3 v E) 2 v E).
Proof.
intros.
intro.
hnf in H; simpl in H.
do 3 destruct H.
omega.
Qed.

Theorem elements_relate_second_attempt:
  forall t cts,
  SearchTreeX t ->
  Abs t cts ->
  list2map (elements t) = cts.
Proof.

(** This is probably provable.  But the [SearchTreeX] property is
   quite unwieldy, with its two Fixpoints nested inside a Fixpoint.
   Instead of using [SearchTreeX], let's reformulate the searchtree
   property as an inductive proposition without any nested
   induction. *)

Abort.

Inductive SearchTree' : key -> tree -> key -> Prop :=
| ST_E : forall lo hi, lo <= hi -> SearchTree' lo E hi
| ST_T: forall lo l k v r hi,
    SearchTree' lo l k ->
    SearchTree' (S k) r hi ->
    SearchTree' lo (T l k v r) hi.

Inductive SearchTree: tree -> Prop :=
| ST_intro: forall t hi, SearchTree' 0 t hi -> SearchTree t.

Lemma SearchTree'_le:
  forall lo t hi, @SearchTree' lo t hi -> lo <= hi.
Proof.
induction 1; omega.
Qed.

(** Before we prove that [elements] is correct, let's consider a simpler version. *)

Fixpoint slow_elements (s: tree) : list (key * V) :=
 match s with
 | E => nil
 | T a k v b => slow_elements a ++ [(k,v)] ++ slow_elements b
 end.

(** This one is easier to understand than the [elements] function,
    because it doesn't carry the [base] list around in its recursion.
    Unfortunately, its running time is quadratic, because at each of
    the [T] nodes it does a linear-time list-concatentation.  The
    original [elements] function takes linear time overall; that's
    much more efficient.

   To prove correctness of [elements], it's actually easier to first
   prove that it's equivalent to [slow_elements], then prove the
   correctness of [slow_elements].  We don't care that [slow_elements]
   is quadratic, because we're never going to really run it; it's just
   there to support the proof. *)

(** **** Exercise: 3 stars, optional (elements_slow_elements)  *)
Theorem elements_slow_elements: elements = slow_elements.
Proof.
extensionality s.
unfold elements.
assert (forall base, elements' s base = slow_elements s ++ base).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (slow_elements_range)  *)
Lemma slow_elements_range:
 forall k v lo t hi,
  SearchTree' lo t hi ->
  In (k,v) (slow_elements t) ->
  lo <= k < hi.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Auxiliary Lemmas About [In] and [list2map] *)

Lemma In_decidable:
  forall (al: list (key*V)) (i: key),
  (exists v, In (i,v) al) \/ (~exists v, In (i,v) al).
Proof.
intros.
induction al as [ | [k v]].
right; intros [w H]; inv H.
destruct IHal as [[w H] | H].
left; exists w; right; auto.
bdestruct (k =? i).
subst k.
left; eauto.
exists v; left; auto.
right. intros [w H1].
destruct H1. inv H1. omega.
apply H; eauto.
Qed.

Lemma list2map_app_left:
  forall (al bl: list (key*V)) (i: key) v,
     In (i,v) al -> list2map (al++bl) i = list2map al i.
Proof.
intros.
revert H; induction al as [| [j w] al]; intro; simpl; auto.
inv H.
destruct H. inv H.
unfold t_update.
bdestruct (i=?i); [ | omega].
auto.
unfold t_update.
bdestruct (j=?i); auto.
Qed.

Lemma list2map_app_right:
  forall (al bl: list (key*V)) (i: key),
     ~(exists v, In (i,v) al) -> list2map (al++bl) i = list2map bl i.
Proof.
intros.
revert H; induction al as [| [j w] al]; intro; simpl; auto.
unfold t_update.
bdestruct (j=?i).
subst j.
contradiction H.
exists w; left; auto.
apply IHal.
contradict H.
destruct H as [u ?].
exists u; right; auto.
Qed.

Lemma list2map_not_in_default:
 forall (al: list (key*V)) (i: key),
   ~(exists v, In (i,v) al) -> list2map al i = default.
Proof.
intros.
induction al as [| [j w] al].
reflexivity.
simpl.
unfold t_update.
bdestruct (j=?i).
subst.
contradiction H.
exists w; left; auto.
apply IHal.
intros [v ?].
apply H. exists v; right; auto.
Qed.

(** **** Exercise: 3 stars, optional (elements_relate)  *)
Theorem elements_relate:
  forall t cts,
  SearchTree t ->
  Abs t cts ->
  list2map (elements t) = cts.
Proof.
rewrite elements_slow_elements.
intros until 1. inv H.
revert cts; induction H0; intros.
* (* ST_E case *)
inv H0.
reflexivity.
* (* ST_T case *)
inv H.
specialize (IHSearchTree'1 _ H5). clear H5.
specialize (IHSearchTree'2 _ H6). clear H6.
unfold slow_elements; fold slow_elements.
subst.
extensionality i.
destruct (In_decidable (slow_elements l) i)  as [[w H] | Hleft].
rewrite list2map_app_left with (v:=w); auto.
pose proof (slow_elements_range _ _ _ _ _ H0_ H).
unfold combine, t_update.
bdestruct (k=?i); [ omega | ].
bdestruct (i<?k); [ | omega].
auto.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Preservation of Representation Invariant *)

(** How do we know that all the trees we will encounter (particularly,
  that the [elements] function will encounter), have the [SearchTree]
  property?  Well, the empty tree is a [SearchTree]; and if you insert
  into a tree that's a [SearchTree], then the result is a
  [SearchTree]; and these are the only ways that you're supposed to
  build trees.  So we need to prove those two theorems. *)

(** **** Exercise: 1 star (empty_tree_SearchTree)  *)
Theorem empty_tree_SearchTree:  SearchTree empty_tree.
Proof.
clear default.  (* This is here to avoid a nasty interaction between Admitted
   and Section/Variable.  It's also a hint that the [default] value
   is not needed in this theorem. *)
(* FILL IN HERE *) Admitted.
(** [] *)

Remark omega_on_keys:
   forall i j : key, ~ (i > j) -> ~ (i < j) -> i=j.
Proof.
intros.
try omega.  (* Oops! [omega] cannot solve this one.
    The problem is that [i] and [j] have type [key] instead of type [nat].
    The solution is easy enough: *)

(** So, if you get stuck on an [omega] that ought to work,
   try unfolding the types from [key] to [nat] *)

Qed.

(** **** Exercise: 3 stars (insert_SearchTree)  *)
Theorem insert_SearchTree:
  forall k v t,
   SearchTree t -> SearchTree (insert k v t).
Proof.
clear default. (* This is here to avoid a nasty interaction between Admitted and Section/Variable *)
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * We Got Lucky *)

(** Recall the statement of [lookup_relate]: *)

Check lookup_relate.
(*  forall (k : key) (t : tree) (cts : total_map V),
       Abs t cts -> lookup k t = cts (Id k)  *)

(** In general, to prove that a function satisfies the abstraction relation,
   one also needs to use the representation invariant.  That was certainly
   the case with [elements_relate]: *)

Check elements_relate.
(*  : forall (t : tree) (cts : total_map V),
       SearchTree t -> Abs t cts -> elements_property t cts   *)

(** To put that another way, the general form of [lookup_relate] should be: *)

Lemma lookup_relate':
  forall (k : key) (t : tree) (cts : total_map V),
     SearchTree t -> Abs t cts -> lookup k t = cts k.

(** That is certainly provable, since it's a weaker statement than what we proved: *)

Proof.
intros.
apply lookup_relate.
apply H0.
Qed.

Theorem insert_relate':
 forall k v t cts,
    SearchTree t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts k v).
Proof. intros. apply insert_relate; auto.
Qed.

(** The question is, why did we not need the representation invariant in
   the proof of [lookup_relate]?  The answer is that our particular Abs
   relation is much more clever than necessary:  *)

Print Abs.
(* Inductive Abs : tree -> total_map V -> Prop :=
    Abs_E : Abs E (t_empty default)
  | Abs_T : forall (a b: total_map V) (l: tree) (k: key) (v: V) (r: tree),
            Abs l a ->
            Abs r b ->
	    Abs (T l k v r) (t_update (combine k a b) (Id k) v)
*)
(** Because the [combine] function is chosen very carefully, it turns out
  that this abstraction relation even works on bogus trees! *)

Remark abstraction_of_bogus_tree:
 forall v2 v3,
   Abs (T (T E 3 v3 E) 2 v2 E) (t_update (t_empty default) 2 v2).
Proof.
intros.
evar (m: total_map V).
replace  (t_update (t_empty default) 2 v2) with m; subst m.
repeat constructor.
extensionality x.
unfold t_update, combine, t_empty.
bdestruct (2 =? x).
auto.
bdestruct (x <? 2).
bdestruct (3 =? x).
(* LOOK HERE! *)
omega.
bdestruct (x <? 3).
auto.
auto.
auto.
Qed.

(** Step through the proof to [LOOK HERE], and notice what's going on.
   Just when it seems that [(T (T E 3 v3 E) 2 v2 E)] is about to produce [v3]
  while [(t_update (t_empty default) (Id 2) v2)] is about to produce [default],
  [omega] finds a contradiction.  What's happening is that [combine 2]
  is careful to ignore any keys >= 2 in the left-hand subtree.

  For that reason, [Abs] matches the _actual_ behavior of [lookup],
  even on bogus trees.  But that's a really strong condition!  We should
  not have to care about the behavior of [lookup] (and [insert]) on
  bogus trees.  We should not need to prove anything about it, either.

  Sure, it's convenient in this case that the abstraction relation is able to
  cope with ill-formed trees.  But in general, when proving correctness of
  abstract-data-type (ADT) implementations, it may be a lot of extra
  effort to make the abstraction relation as heavy-duty as that.
  It's often much easier for the abstraction relation to assume that the
  representation is well formed.  Thus, the general statement of our
  correctness theorems will be more like [lookup_relate'] than like
  [lookup_relate].  *)

(* ################################################################# *)
(** * Every Well-Formed Tree Does Actually Relate to an Abstraction *)

(** We're not quite done yet.  We would like to know that
    _every tree that satisfies the representation invariant, means something_.

   So as a general sanity check, we need the following theorem: *)

(** **** Exercise: 2 stars (can_relate)  *)
Lemma can_relate:
 forall t,  SearchTree t -> exists cts, Abs t cts.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Now, because we happen to have a super-strong abstraction relation, that
   even works on bogus trees, we can prove a super-strong can_relate function: *)

(** **** Exercise: 2 stars (unrealistically_strong_can_relate)  *)
Lemma unrealistically_strong_can_relate:
 forall t,  exists cts, Abs t cts.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * It Wasn't Really Luck, Actually *)

(** In the previous section, I said, "we got lucky that the abstraction
    relation that I happened to choose had this super-strong property."

    But actually, the first time I tried to prove correctness of search trees,
    I did _not_ get lucky.  I chose a different abstraction relation: *)

Definition AbsX (t: tree) (m: total_map V) : Prop :=
    list2map (elements t) = m.

(** It's easy to prove that [elements] respects this abstraction relation: *)

Theorem elements_relateX:
  forall t cts,
  SearchTree t ->
  AbsX t cts ->
  list2map (elements t) = cts.
Proof.
intros.
apply H0.
Qed.

(** But it's not so easy to prove that [lookup] and [insert] respect this
    relation.  For example, the following claim is not true. *)

Theorem naive_lookup_relateX:
  forall k t cts ,
    AbsX t cts -> lookup k t =  cts k.
Abort.  (* Not true *)

(** In fact, [naive_lookup_relateX] is provably false,
     as long as the type [V] contains at least two different values. *)

Theorem not_naive_lookup_relateX:
   forall v, default <> v ->
    ~ (forall k t cts , AbsX t cts -> lookup k t =  cts k).
Proof.
unfold AbsX.
intros v H.
intros H0.
pose (bogus := T (T E 3 v E) 2 v E).
pose (m := t_update (t_update (t_empty default) 2 v) 3 v).
assert (list2map (elements bogus) = m).
  reflexivity.
assert (~ lookup 3 bogus = m 3). {
  unfold bogus, m, t_update, t_empty.
  simpl.
  apply H.
}
(** Right here you see how it is proved.  [bogus] is our old friend,
    the bogus tree that does not satisfy the [SearchTree] property.
    [m] is the [total_map] that corresponds to the elements of [bogus].
    The [lookup] function returns [default] at key [3],
    but the map [m] returns [v] at key [3].  And yet, assumption [H0]
    claims that they should return the same thing. *)
apply H2.
apply H0.
apply H1.
Qed.

(** **** Exercise: 4 stars, optional (lookup_relateX)  *)
Theorem lookup_relateX:
  forall k t cts ,
    SearchTree t -> AbsX t cts -> lookup k t =  cts k.
Proof.
intros.
unfold AbsX in H0. subst cts.
inv H. remember 0 as lo in H0.
clear - H0.
rewrite elements_slow_elements.
(** To prove this, you'll need to use this collection of facts:
   [In_decidable], [list2map_app_left], [list2map_app_right],
   [list2map_not_in_default], [slow_elements_range].  The point is,
   it's not very pretty. *)

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

(* ================================================================= *)
(** ** Coherence With [elements] Instead of [lookup] *)
(** The first definition of the abstraction relation, [Abs], is "coherent"
     with the [lookup] operation, but not very coherent with the [elements]
     operation.  That is, [Abs] treats all trees, including ill-formed ones,
     much the way [lookup] does, so it was easy to prove [lookup_relate].
     But it was harder to prove [elements_relate].

    The alternate abstraction relation, [AbsX], is coherent with [elements],
    but not very coherent with [lookup].  So proving [elements_relateX] is
    trivial, but proving [lookup_relate] is difficult.

    This kind of thing comes up frequently.  The important thing to remember
    is that you often have choices in formulating the abstraction relation,
    and the choice you make will affect the simplicity and elegance of your
    proofs.   If you find things getting too difficult, step back and reconsider
    your abstraction relation. *)

End TREES.


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Wf.

Unset Printing Records.

(** Constructive type-theoretic ordinals.

In this development, I attempt to reconstruct enough of classical
ordinal theory to both be useful.

My first (and primary) goal was for these ordinals to represent a
practical proof techinque for, e.g., constructing termination measures
of recursive programs and building acyclicity proofs invovling
complicated data structures.

My secondary goal was to climb the first part of the way into
"Cantor's attic" by constructing the Veblen hierarchy, the
Feferman-Shütte ordinal Γ₀, and perhaps up to the small Veblen ordinal
(SVO), which is formed as the limit of the extended Veblen functions
on finitely-many variables.
*)

Declare Scope ord_scope.
Delimit Scope ord_scope with ord.
Open Scope ord_scope.

(** * Ordinals, represented as Type-indexed trees of potentially
      infinite width, but finite depth.

   Note we do not restrict ourselves here to countably-wide trees,
   which (I believe) would give us the countable ordinals instead.
   This might make some of the development more managable, but make
   them less convenient.

   The current definition allows us to view ordinals both as objects
   of their own interest, but also as a collection of canonical
   structures that assign a distingushed way to measure the size of
   values.  *)
Inductive Ord : Type :=
  ord { ordCarrier :> Type
      ; ordSize :> ordCarrier -> Ord
      }.

Definition sz {A:Ord} (x:A) : Ord := ordSize A x.
Coercion sz : ordCarrier >-> Ord.
Add Printing Coercion sz.

(** We define < and ≤ essentially by mutual
    recursion on the structure of ordinals. The ordering
    relation has an elegant game semantics flavor, defined
    by the quantifier nesting structure.
  *)
Fixpoint ord_lt (x y:Ord) {struct x}: Prop :=
  match x, y with
  | ord A f, ord B g =>
    exists b:B, forall a:A, ord_lt (f a) (g b)
  end.

Definition ord_le (x y:Ord) : Prop :=
  match x with
  | ord A f => forall a:A, ord_lt (f a) y
  end.

Definition ord_eq (x y:Ord) : Prop :=
  ord_le x y /\ ord_le y x.

Notation "x > y" := (ord_lt y x) : ord_scope.
Notation "x < y" := (ord_lt x y) : ord_scope.
Notation "x >= y" := (ord_le y x) : ord_scope.
Notation "x <= y" := (ord_le x y) : ord_scope.
Notation "x ≥ y" := (ord_le y x) (at level 70, no associativity) : ord_scope.
Notation "x ≤ y" := (ord_le x y) (at level 70, no associativity) : ord_scope.
Notation "x ≈ y" := (ord_eq x y) (at level 70, no associativity) : ord_scope.

(*  The notation "x ◃ y" indicates that "x" has a strictly smaller ordinal measure
    than "y".  Note that "x" and "y" do not need to have the same type.

    Likewise "x ⊴ y" indicates that "x" has an ordinal measure no larger than "y".
 *)
Notation "x ◃ y" := (sz x < sz y)%ord (at level 80, no associativity).
Notation "x ⊴ y" := (sz x ≤ sz y)%ord (at level 80, no associativity).

(** Characteristic equation for less-than *)
Lemma ord_lt_unfold x y :
  x < y = exists b:y, x ≤ y b.
Proof.
  destruct x; destruct y; simpl; auto.
Qed.

(** Characteristic equation for less-equal *)
Lemma ord_le_unfold x y :
  x ≤ y = forall a:x, x a < y.
Proof.
  destruct x; destruct y; simpl; auto.
Qed.

Global Opaque ord_le ord_lt.

(** Another way to unfold the definition of <= *)
Lemma ord_le_subord x y :
  x <= y ->
  forall i, exists j, x i <= y j.
Proof.
  intros H i.
  rewrite ord_le_unfold in H.
  specialize (H i).
  rewrite ord_lt_unfold in H.
  auto.
Qed.

(** Less-than implies less-equal
  *)
Lemma ord_lt_le : forall b a,
  a < b -> a ≤ b.
Proof.
  induction b as [B g]. intros a Ha.
  rewrite ord_lt_unfold in Ha.
  destruct Ha as [b Hb].
  destruct a as [A f].
  rewrite ord_le_unfold in *.
  intro a.
  specialize (Hb a).
  rewrite ord_lt_unfold.
  exists b. apply H. auto.
Qed.

(** Less-equal is a reflexive relation
  *)
Lemma ord_le_refl x : x ≤ x.
Proof.
  induction x as [A f].
  rewrite ord_le_unfold.
  intros a.
  rewrite ord_lt_unfold.
  exists a.
  apply H.
Qed.

Lemma index_lt : forall (a:Ord) (i:a), a i < a.
Proof.
  intros.
  rewrite ord_lt_unfold.
  exists i. apply ord_le_refl.
Qed.

Lemma index_le : forall (a:Ord) (i:a), a i ≤ a.
Proof.
  intros.
  apply ord_lt_le.
  apply index_lt.
Qed.

Global Hint Resolve ord_lt_le ord_le_refl index_lt index_le : ord.

(** These various transitivity-releated facts need to
    be proved simultaneuously.
  *)
Lemma ord_trans :
  forall b a c,
    (a ≤ b -> b ≤ c -> a ≤ c) /\
    (a ≤ b -> b < c -> a < c) /\
    (a < b -> b ≤ c -> a < c).
Proof.
  induction b as [B g].
  intros.
  repeat split; intros.
  - rewrite ord_le_unfold.
    rewrite ord_le_unfold in H0.
    intro ai.
    specialize (H0 ai).
    rewrite ord_lt_unfold in H0.
    destruct H0 as [bi ?].
    rewrite ord_le_unfold in H1.
    specialize (H1 bi).
    specialize (H bi (a ai) c); intuition.
  - rewrite ord_lt_unfold.
    rewrite ord_lt_unfold in H1.
    destruct H1 as [ci ?].
    exists ci.
    rewrite ord_le_unfold in H1.
    rewrite ord_le_unfold.
    rewrite ord_le_unfold in H0.
    intros ai.
    specialize (H0 ai).
    rewrite ord_lt_unfold in H0.
    destruct H0 as [bi ?].
    specialize (H1 bi).
    specialize (H bi (a ai) (c ci)); intuition.
  - rewrite ord_lt_unfold in H0.
    destruct H0 as [bi ?].
    rewrite ord_le_unfold in H1.
    specialize (H1 bi).
    destruct (H bi a c); intuition.
Qed.

(** Less-equal is transitive.
  *)
Lemma ord_le_trans a b c :
    a ≤ b -> b ≤ c -> a ≤ c.
Proof.
  intros. destruct (ord_trans b a c); intuition.
Qed.

(** Less-than is transitive *)
Lemma ord_lt_trans a b c :
    a < b -> b < c -> a < c.
Proof.
  intros. destruct (ord_trans b a c); intuition.
Qed.

(** Less-equal preserves less-than *)
Lemma ord_lt_le_trans a b c :
  a < b -> b ≤ c -> a < c.
Proof.
  intros. destruct (ord_trans b a c); intuition.
Qed.

Lemma ord_le_lt_trans a b c :
  a ≤ b -> b < c -> a < c.
Proof.
  intros. destruct (ord_trans b a c); intuition.
Qed.

Lemma ord_le_intro x y :
  (forall a, a < x -> a < y) -> x <= y.
Proof.
  intros.
  rewrite ord_le_unfold; intro a.
  apply H; auto with ord.
Qed.

Lemma ord_le_elim x y :
  x <= y ->
  (forall a, a < x -> a < y).
Proof.
  intros.
  apply ord_lt_le_trans with x; auto.
Qed.

(** The less-than ordering on ordinals is well-founded.
  *)
Lemma ord_lt_acc : forall x y,  y ≤ x -> Acc ord_lt y.
Proof.
  induction x as [A f]; intros z Hz.
  constructor. intros y Hy.
  assert (Hyx : y < ord A f).
  { apply ord_lt_le_trans with z; auto. }

  rewrite ord_lt_unfold in Hyx.
  destruct Hyx as [b ?].
  apply (H b).
  auto.
Defined.

Theorem ord_lt_wf : well_founded ord_lt.
Proof.
  red; intros.
  apply ord_lt_acc with a.
  apply ord_le_refl.
Defined.

(* The workhorse for proving properties about ordinals. *)
Definition ordinal_induction
  : forall P : Ord -> Set,
     (forall x : Ord, (forall y : Ord, y < x -> P y) -> P x) ->
     (forall a : Ord, P a)
  := well_founded_induction ord_lt_wf.

(* An induction principle for the elements of an ordinal. *)
Definition size_induction (A:Ord) :
  forall (P:A -> Prop),
  (forall x:A, (forall y, y ◃ x -> P y) -> P x) ->
  (forall x:A, P x)
 := well_founded_induction (measure_wf ord_lt_wf sz).

(** The less-than order is irreflexive, a simple corollary of well-foundedness. *)
Corollary ord_lt_irreflexive : forall x, x < x -> False.
Proof.
  induction x using ordinal_induction; firstorder.
Qed.

(** * Ordinal equality is an equality relation *)

Lemma ord_eq_refl : forall x, x ≈ x.
Proof.
  intros; split; apply ord_le_refl.
Qed.

Lemma ord_eq_trans : forall x y z, x ≈ y -> y ≈ z -> x ≈ z.
Proof.
  unfold ord_eq; intuition; eapply ord_le_trans; eauto.
Qed.

Lemma ord_eq_sym : forall x y, x ≈ y -> y ≈ x.
Proof.
  unfold ord_eq; intuition.
Qed.

Add Parametric Relation : Ord ord_le
    reflexivity proved by ord_le_refl
    transitivity proved by ord_le_trans
    as ord_le_rel.

Add Parametric Relation : Ord ord_lt
    transitivity proved by ord_lt_trans
    as ord_lt_rel.

Add Parametric Relation : Ord ord_eq
    reflexivity proved by ord_eq_refl
    symmetry proved by ord_eq_sym
    transitivity proved by ord_eq_trans
    as ord_eq_rel.

Instance ord_lt_le_subreleation : subrelation ord_lt ord_le.
Proof.
  red. intros; apply ord_lt_le; auto.
Qed.

Instance ord_eq_le_subrelation : subrelation ord_eq ord_le.
Proof.
  red. unfold ord_eq. intuition.
Qed.

Instance ord_eq_flip_le_subrelation : subrelation ord_eq (flip ord_le).
Proof.
  red. unfold ord_eq. intuition.
Qed.

Add Parametric Morphism : ord_lt with signature
    ord_le --> ord_le ++> impl as ord_lt_mor.
Proof.
  repeat intro.
  apply ord_le_lt_trans with x; auto.
  apply ord_lt_le_trans with x0; auto.
Qed.

Add Parametric Morphism : ord_lt with signature
    ord_le ++> ord_le --> flip impl as ord_lt_mor'.
Proof.
  repeat intro.
  apply ord_le_lt_trans with y; auto.
  apply ord_lt_le_trans with y0; auto.
Qed.

Lemma increasing_inflationary f :
  (forall x y, x < y -> f x < f y) ->
  forall a, a ≤ f a.
Proof.
  intro Hinc.
  induction a using ordinal_induction.
  apply ord_le_intro; intros z Hz.
  rewrite (H z); auto.
Qed.

(** * Definitions of zero, limit, and successor ordinals.

    In a classical setting, we would show that all ordinals
    fall into one of these three classes. Without the excluded
    middle, we cannot prove this.  However, we can show that these
    classes are mutually exclusive and demonstrate some properties
    that they have.
 *)

Definition hasMaxElement A (f:A -> Ord) :=
  exists a, forall a', f a ≥ f a'.

Definition ascendingSet A (f:A -> Ord) :=
  forall a, exists a', f a < f a'.

Definition zeroOrdinal (x:Ord) : Prop :=
  match x with
  | ord A f => ~inhabited A
  end.

Definition successorOrdinal (x:Ord) : Prop :=
  match x with
  | ord A f => hasMaxElement A f
  end.

Definition limitOrdinal (x:Ord) : Prop :=
  match x with
  | ord A f => inhabited A /\ ascendingSet A f
  end.

Lemma hasMax_ascending_contradiction A f : hasMaxElement A f -> ascendingSet A f -> False.
Proof.
  intros.
  destruct H as [a Ha].
  destruct (H0 a) as [a' Ha'].
  apply ord_lt_irreflexive with (f a').
  apply ord_le_lt_trans with (f a); auto.
Qed.

(** An ordinal cannot be both zero and a successor *)
Lemma zero_not_successor : forall x, zeroOrdinal x -> successorOrdinal x -> False.
Proof.
  intros [A f]; simpl; intros Hz Hsucc.
  destruct Hsucc as [a Ha]; auto.
Qed.

(** An ordinal cannot be both zero and a limit *)
Lemma zero_not_limit : forall x, zeroOrdinal x -> limitOrdinal x -> False.
Proof.
  intros [A f]; simpl; intros Hz [Hnz _]; auto.
Qed.

(** An ordinal cannot be both a successor and a limit *)
Lemma successor_not_limit : forall x, successorOrdinal x -> limitOrdinal x -> False.
Proof.
  intros [A f]; simpl; intros Hsucc [_ Hlim].
  apply (hasMax_ascending_contradiction A f); auto.
Qed.

Require Import List.
Import ListNotations.

Fixpoint each {A:Type} (P:A -> Prop) (xs:list A) : Prop :=
  match xs with
  | [] => True
  | (x::xs) => P x /\ each P xs
  end.

Lemma each_implies A (P Q:A -> Prop) (xs: list A) :
  (forall x, P x -> Q x) ->
  each P xs -> each Q xs.
Proof.
  induction xs; simpl; intuition.
Qed.

Lemma each_map A B : forall (P:B -> Prop) (f:A->B) (xs:list A),
    each P (map f xs) <-> each (fun x => P (f x)) xs.
Proof.
  induction xs; simpl; intuition.
Qed.

Inductive pairwise {A B} (R:A -> B -> Prop) : list A -> list B -> Prop :=
  | pairwise_nil : pairwise R nil nil
  | pairwise_cons : forall x xs y ys,
      R x y -> pairwise R xs ys -> pairwise R (x::xs) (y::ys).

Lemma pairwise_length A B (R:A -> B -> Prop) xs ys :
  pairwise R xs ys -> length xs = length ys.
Proof.
  intro H; induction H; simpl; auto.
Qed.

Lemma pairwise_le_refl xs : pairwise ord_le xs xs.
Proof.
  induction xs; constructor; auto with ord.
Qed.

Lemma pairwise_eq_refl xs : pairwise ord_eq xs xs.
Proof.
  induction xs; constructor; auto with ord.
  reflexivity.
Qed.


Theorem NotNot_LEM : forall P : Prop, ~ ~(P \/ ~P).
Proof.
  intros.
  intro.
  absurd (P \/ ~ P).
  assumption.
  right.
  intro.
  absurd (P \/ ~ P).
  assumption.
  left.
  assumption.
Qed.


Require Export ProjectiveGeometry.Dev.pp_decidability.
Require Export ProjectiveGeometry.Dev.proof_irrevelance.

Section s_ProjectivePlane'LinesBijection.

Context `{PP : ProjectivePlane'}.
Context `{PI : ProofIrrevelance}.

Definition inj (A B:Type)(f:A->B) : Prop :=
forall x y:A, f x = f y -> x = y.

Definition surj (A B:Type)(f:A->B) : Prop :=
forall y:B, exists x: A, y = f x.

Definition bij (A B:Type)(f:A->B) : Prop := inj A B f /\ surj A B f.

Definition line_as_set_of_points (l:Line) := { x : Point | Incid x l}.

Arguments bij [ A B ].

Theorem line_set_of_points :
forall l1 l2:Line, exists f : (line_as_set_of_points l1) -> (line_as_set_of_points l2), bij f.
Proof.
intros l1 l2.
elim (outsider l1 l2).
intros newP (HnewPl1,HnewPl2).
(* explicit construction of f *)
pose (f :=  (fun (ls1:line_as_set_of_points l1) => let (A1, HA1) := ls1 in
         let (delta', Hdelta') := a1_exist A1 newP in
           match Hdelta' with
             | conj H1delta' H2delta' => let (A2,HA2) := (a2_exist delta' l2) in
               match HA2 with
                 | conj HA2delta' HA2l2 => exist (fun x : Point => Incid x l2) A2 HA2l2
               end
           end)).
exists f.
split.
(* one-to-one *)
unfold inj.
intros ls1 ls1'; case ls1; case ls1'.
intros A1 HA1 B1 HB1; simpl.
elim (a1_exist B1 newP).
intros d (HdB1, HdnewP).
elim (a2_exist d l2).
intros B2 (HdB2,HB2l2).

elim (a1_exist A1 newP).
intros d' (HA1d',HnewPd').
elim (a2_exist d' l2).
intros A2 (HA2d',HA2l2).
intros H.
inversion H.
subst B2.
assert (A1=B1).
assert (d=d').
assert (HA2newP:(A2<>newP)).
intros HA2newP.
subst A2.
apply HnewPl2.
assumption.
apply (a1_unique A2 newP d d' HA2newP); assumption.
subst d'.
assert (Hl1d:(l1<>d)).
intros Hl1d.
subst l1.
apply HnewPl1.
assumption.
apply (a2_unique l1 d A1 B1 Hl1d); assumption.
subst A1.
rewrite (proof_irr _ HA1 HB1).
reflexivity.

(* onto *)
unfold surj.
intros ls2; case ls2.
intros A2 HA2.
elim (a1_exist A2 newP).
intros d (HA2d,HnewPd).
elim (a2_exist l1 d).
intros A1 (HA1l1,HA1d).
exists (exist (fun (A:Point) => (Incid A l1)) A1 HA1l1).
simpl.
elim (a1_exist A1 newP).
intros d' (HA1d',HnewPd').
elim (a2_exist d' l2).
intros B2 (HA2d', HA1l2).
assert (A2=B2).
assert (d=d').
assert (HA1newP:(A1<>newP)).
intros HA1newP.
subst A1.
apply HnewPl1.
assumption.
apply (a1_unique A1 newP d d' HA1newP); assumption.
subst d'.
assert (Hl2d:(l2<>d)).
intros Hl2d.
subst l2.
apply HnewPl2.
assumption.
apply (a2_unique l2 d A2 B2 Hl2d); assumption.
subst A2.
rewrite (proof_irr _ HA2 HA1l2).
reflexivity.
Qed.

End s_ProjectivePlane'LinesBijection.


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Export LTactics GenEncode.
Require Import Undecidability.Shared.Libs.PSL.Numbers.

Require Import Nat.
From Undecidability.L Require Import Datatypes.LBool Functions.EqBool Datatypes.LProd.
Import GenEncode. Import Nat.
(* ** Encoding of natural numbers *)

MetaCoq Run (tmGenEncodeInj "nat_enc" nat).
#[export] Hint Resolve nat_enc_correct : Lrewrite.

#[global]
Instance termT_S : computable S.
Proof.
  extract constructor.
Qed.

#[global]
Instance termT_pred : computable pred.
Proof.
  extract.
Qed.

#[global]
Instance termT_plus' : computable add.
Proof.
  extract.
Qed.

#[global]
Instance termT_mult : computable mult.
Proof.
  extract.
Qed.

#[global]
Instance term_sub : computable Nat.sub.
Proof.
  extract.
Qed.

#[global]
Instance termT_leb : computable leb.
Proof.
  extract.
Qed.

#[global]
Instance term_ltb : computable Nat.ltb.
Proof.
  extract.
Qed.

#[global]
Instance eqbNat_inst : eqbClass Nat.eqb.
Proof.
  exact Nat.eqb_spec.
Qed.

#[global]
Instance eqbComp_nat : eqbComp nat.
Proof.
  constructor. unfold Nat.eqb.
  extract.
Qed.

#[global]
Instance termT_nat_min : computable Nat.min.
Proof.
  extract.
Qed.

#[global]
Instance termT_nat_max : computable Nat.max.
Proof.
  extract.
Qed.

#[global]
Instance termT_pow:
  computable Init.Nat.pow.
Proof.
  extract.
Qed.

#[global]
Instance termT_divmod :
  computable divmod.
Proof.
  extract.
Qed.

#[global]
Instance termT_modulo :
  computable Init.Nat.modulo.
Proof.
  extract.
Qed.

(* now some more encoding-related properties:*)

Fixpoint nat_unenc (s : term) :=
  match s with
  | lam (lam #1) => Some 0
  | lam (lam (app #0 s)) => match nat_unenc s with Some n => Some (S n) | x=>x end
  | _ => None
  end.

Lemma unenc_correct m : (nat_unenc (nat_enc m)) = Some m.
Proof.
  induction m; simpl; now try rewrite IHm.
Qed.

Lemma unenc_correct2 t n : nat_unenc t = Some n -> nat_enc n = t.
Proof with try solve [Coq.Init.Tactics.easy].
  revert n. eapply (size_induction (f := size) (p := (fun t => forall n, nat_unenc t = Some n -> nat_enc n = t))). clear t. intros t IHt n H.
  destruct t as [ | | t]. easy. easy.
  destruct t as [ | | t]. easy. easy.
  destruct t. 3:easy.
  -destruct n0. easy. destruct n0. 2:easy. inv H. easy.
  -destruct t1. 2-3:easy. destruct n0. 2:easy. simpl in H. destruct (nat_unenc t2) eqn:A.
   +apply IHt in A;simpl;try lia. destruct n. inv H. simpl. congruence.
   +congruence.
Qed.

Lemma dec_enc t : dec (exists n, t = nat_enc n).
Proof.
  destruct (nat_unenc t) eqn:H.
  - left. exists n. now eapply unenc_correct2 in H.
  - right. intros [n A]. rewrite A in H. rewrite unenc_correct in H. inv H.
Qed.


Time Require Import Sets.
Require Import ZArith.
Open Scope Z_scope.

(** Generating reeeeally-pseudo-random numbers *)
Definition seed := 50.
Definition a := 31415821.
Definition c := 1.
Definition max := 100000000.

Definition next z := (c+a*z) mod max.

Fixpoint mk_list z (acc : list Z) (n : nat) :=
  match n with
    | O => (z, acc)
    | S n0 => mk_list (next z) (z::acc) n0
  end.
Definition mk_randoms n := snd (mk_list seed nil n).
Time Eval vm_compute in mk_randoms 1000.

Module WithTypeClasses.
(** Filling in a set with random numbers *)
  Fixpoint fill_ (s : set Z) (c : Z) (n : nat) :=
    match n with
      | O => s
      | S n0 => fill_ {c; s} (next c) n0
    end.
  Definition fill := fill_ {} seed.
  Time Eval vm_compute in elements (fill 1000).

  (** Testing membership *)
  Fixpoint check_ (s : set Z) (c : Z) (n : nat) :=
    match n with
      | O => true
      | S n0 =>
        if c \in s then check_ s (next c) n0 else false
    end.
  Definition check n := check_ (fill n) seed n.

  Time Eval vm_compute in check 1000.
End WithTypeClasses.

(* obsolete with v8.3 *)
(* Module WithModules. *)
(*   Require Import FSetList OrderedTypeEx.  *)
(*   Require Bridge FSets.OrderedTypeEx. *)

(*   Module Z_OT <: Bridge.S.  *)
(*     Definition t := Z. *)
(*     Definition Ht : OrderedType Z := SOT_as_OT. *)
(*   End Z_OT. *)
(*   Module Z_FOT := Bridge.OT_to_FOT Z_OT. *)
(*   Print Z_FOT.compare. *)
(*   Print FSets.OrderedTypeEx.Z_as_OT.compare. *)
(*   Module S := Make(Z_FOT). *)

(*   (** Filling in a set with random numbers *) *)
(*   Fixpoint fill_ (s : S.t) (c : Z) (n : nat) := *)
(*     match n with *)
(*       | O => s *)
(*       | S n0 => fill_ (S.add c s) (next c) n0 *)
(*     end. *)
(*   Definition fill := fill_ S.empty seed. *)
(*   Time Eval vm_compute in S.elements (fill 1000). *)

(*   (** Testing membership *) *)
(*   Fixpoint check_ (s : S.t) (c : Z) (n : nat) := *)
(*     match n with *)
(*       | O => true *)
(*       | S n0 =>  *)
(*         if S.mem c s then check_ s (next c) n0 else false *)
(*     end. *)
(*   Definition check n := check_ (fill n) seed n. *)

(*   Time Eval vm_compute in check 1000. *)
(* End WithModules. *)

(** Benchmarking comparison of sets *)
Section ParamSets.
  Variable SSS : @FSet Z _.

  Fixpoint s_of_l (l : list Z) : set Z :=
    match l with
      | nil => {}
      | a::q => {a; s_of_l q}
    end.

  Fixpoint mk_random_sets (z : Z) (size n: nat) : list (set Z) :=
    match n with
      | O => nil
      | S n0 =>
        let (z', l) := mk_list z nil size in
          (s_of_l l)::(mk_random_sets z' size n0)
    end.

  Definition example :=
    List.map elements (mk_random_sets seed 100 20).

  Fixpoint make_compares (z : Z) (n size : nat) (s : list (set Z)) :=
    match n with
      | O => tt
      | S n0 =>
        let z1 := next z in
        let z2 := next z1 in
        let n1 := Z.abs_nat (z1 mod (Z_of_nat size)) in
        let n2 := Z.abs_nat (z2 mod (Z_of_nat size)) in
          match nth n1 s {} =?= nth n2 s {} with
            | _ => make_compares (next z2) n0 size s
          end
    end.
  Definition bench (size n comps : nat) :=
    let sets := mk_random_sets seed size n in
      make_compares seed comps size sets.
  Definition bench0 := bench 100 20 50.

  Fixpoint sofl (l : list (set Z)) :
    set (FSet:=SetAVLInstance.SetAVL_FSet) (set Z) :=
    match l with
      | nil => {}
      | a::q => {a; sofl q}
    end.
  Definition bench1 := List.map elements
    (elements (sofl (mk_random_sets seed 100 20))).
End ParamSets.

(** Same time for building the initial list of sets for AVLs and lists *)
Require SetListInstance.
Time Eval vm_compute in (example SetListInstance.SetList_FSet).
Time Eval vm_compute in (bench1 SetListInstance.SetList_FSet).
Time Eval vm_compute in (bench0 SetListInstance.SetList_FSet).
Require SetAVLInstance.
Time Eval vm_compute in (example SetAVLInstance.SetAVL_FSet).
Time Eval vm_compute in (bench1 SetAVLInstance.SetAVL_FSet).
Time Eval vm_compute in (bench0 SetAVLInstance.SetAVL_FSet).


(******************************)
(*  Definitions of the Board  *)
(*  Author: Shuangquan Feng   *)
(*  Date:    Apr 29. 2018     *)
(******************************)

(* Possible symbols on the board: X O and E(mpty) *)
Inductive sym : Type:=
  | X : sym
  | O : sym
  | E : sym.

(* two symbols are the same *)
Inductive sym_eq: sym->sym->Prop :=
  | eqX : sym_eq X X
  | eqO : sym_eq O O
  | eqE : sym_eq E E.

Definition beq_sym (x y:sym) : bool :=
  match x,y with
  | X,X
  | O,O
  | E,E => true
  | _,_ =>false
  end.

(* symbol equals Empty *)
Definition beq_E (x:sym) :bool := beq_sym x E.

Hint Constructors sym.

(* a board has nine symbols *)
Inductive board: Type :=
  | bd:sym->sym->sym->sym->sym->sym->sym->sym->sym->board.

Definition empty_board:=
  bd E E E E E E E E E.

(* nine cell names of the board *)
Inductive cell: Type :=
  | c00 : cell
  | c01 : cell
  | c02 : cell
  | c10 : cell
  | c11 : cell
  | c12 : cell
  | c20 : cell
  | c21 : cell
  | c22 : cell.

(* two cell names are equal *)
Inductive cell_eq: cell->cell->Prop :=
  | eq00: cell_eq c00 c00
  | eq01: cell_eq c01 c01
  | eq02: cell_eq c02 c02
  | eq10: cell_eq c10 c10
  | eq11: cell_eq c11 c11
  | eq12: cell_eq c12 c12
  | eq20: cell_eq c20 c20
  | eq21: cell_eq c21 c21
  | eq22: cell_eq c22 c22.

Definition isE (b:board) (c:cell):Prop :=
  match b with
  | bd s00 s01 s02 s10 s11 s12 s20 s21 s22=>
    match c with
    | c00 => sym_eq s00 E
    | c01 => sym_eq s01 E
    | c02 => sym_eq s02 E
    | c10 => sym_eq s10 E
    | c11 => sym_eq s11 E
    | c12 => sym_eq s12 E
    | c20 => sym_eq s20 E
    | c21 => sym_eq s21 E
    | c22 => sym_eq s22 E
    end
  end.

(* one step made by a player,
   pick a cell, put a symbol(X or O) *)
Inductive step: Type :=
  | st : cell->sym->step.

(* a round consists of two steps, one for each player.
   For a round to be valid, following conditions should be met *)
Definition valid_round (b:board) (x y:step): Prop :=
  match x,y with
  | st c1 s1, st c2 s2 =>
  (sym_eq s1 X) /\ (sym_eq s2 O)  (*P1 put X, P2 put O *)
  /\ (not (cell_eq c1 c2))        (*not put in a same cell*)
  /\ (isE b c1) /\ (isE b c2)     (*both cells are initially empty*)
  end.

(* In case P1 only needs one step to win
   so this only apply to X. *)
Definition valid_move (b:board) (x:step): Prop :=
  match x with
  | st c s => (sym_eq s X) /\ (isE b c)
  end.

(* Change the states of the board according to the step
   just change the corresponding symbol *)
Definition move (b:board) (st:step): board :=
  match st,b with
  | st c x,
    bd s00 s01 s02 s10 s11 s12 s20 s21 s22=>
    match c with
    | c00 => bd x s01 s02 s10 s11 s12 s20 s21 s22
    | c01 => bd s00 x s02 s10 s11 s12 s20 s21 s22
    | c02 => bd s00 s01 x s10 s11 s12 s20 s21 s22
    | c10 => bd s00 s01 s02 x s11 s12 s20 s21 s22
    | c11 => bd s00 s01 s02 s10 x s12 s20 s21 s22
    | c12 => bd s00 s01 s02 s10 s11 x s20 s21 s22
    | c20 => bd s00 s01 s02 s10 s11 s12 x s21 s22
    | c21 => bd s00 s01 s02 s10 s11 s12 s20 x s22
    | c22 => bd s00 s01 s02 s10 s11 s12 s20 s21 x
    end
  end.

(* possible state of the board *)
Inductive state : Type :=
  | win : state        (* P1(X) wins, P2(O) loses *)
  | lose: state        (* P1(X) loses, P2(O) wins *)
  | tie : state        (* no one wins, no empty cells to proceed *)
  | incomplete: state. (* no one wins yet, still has empty cells *)

(* check if P1(X) wins *)
Definition final_x_win (b:board) : bool :=
  match b with
  | bd X _ _ X _ _ X _ _ => true
  | bd _ X _ _ X _ _ X _ => true
  | bd _ _ X _ _ X _ _ X => true
  | bd X X X _ _ _ _ _ _ => true
  | bd _ _ _ X X X _ _ _ => true
  | bd _ _ _ _ _ _ X X X => true
  | bd X _ _ _ X _ _ _ X => true
  | bd _ _ X _ X _ X _ _ => true
  | bd _ _ _ _ _ _ _ _ _ => false
  end.

(* check if P2(O) wins *)
Definition final_o_win (b:board) : bool :=
  match b with
  | bd O _ _ O _ _ O _ _ => true
  | bd _ O _ _ O _ _ O _ => true
  | bd _ _ O _ _ O _ _ O => true
  | bd O O O _ _ _ _ _ _ => true
  | bd _ _ _ O O O _ _ _ => true
  | bd _ _ _ _ _ _ O O O => true
  | bd O _ _ _ O _ _ _ O => true
  | bd _ _ O _ O _ O _ _ => true
  | bd _ _ _ _ _ _ _ _ _ => false
  end.

(* check if the board still has any empty cells *)
Definition has_empty (b:board) : bool :=
  match b with
  | bd s00 s01 s02 s10 s11 s12 s20 s21 s22=>
  if (beq_E s00) then true else
  if (beq_E s01) then true else
  if (beq_E s02) then true else
  if (beq_E s10) then true else
  if (beq_E s11) then true else
  if (beq_E s12) then true else
  if (beq_E s20) then true else
  if (beq_E s21) then true else
  if (beq_E s22) then true else false
  end.

(* get the state of the board *)
Definition get_state (b:board) : state :=
  (* check lose condition first,
     in case there are both 3Xs and 3Os in a row,
     we should return lose.  *)
  if (final_o_win b)
    then lose
  else if (final_x_win b)
    then win
  else if (has_empty b)
    then incomplete
  else
    tie.

(* one handy helper theorem *)
Theorem sym_eq_iff:
 forall (x y:sym),
  sym_eq x y -> x=y.
Proof.
  intros.
  induction H; reflexivity.
Qed.


(** Isomorphism.v *)

From Babel Require Import TerminalDogma.
From Coq Require Import Relations.

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

Declare Scope Iso_scope.
Global Open Scope Iso_scope.

(** A and B are isomorphic types, if there exists a bijection between A and B *)
Definition isomorphic (A B : Type) := bijection A B.
Notation " A '≅' B " := (isomorphic A B) (at level 25) : Iso_scope.

(*
Lemma isomorphic_refl : reflexive _ isomorphic.
Proof. rewrite /reflexive => X.
    exists ssrfun.id. econstructor. by apply id_bijective.
Qed.

Lemma isomorphic_symm : Relation_Definitions.symmetric _ isomorphic.
Proof. rewrite /Relation_Definitions.symmetric.
    move => X Y [f Hbij]. have [g Hg] := (bij_has_inv Hbij).
        by exists g; apply g.
Qed.

Lemma isomorphic_trans : Relation_Definitions.transitive _ isomorphic.
Proof. rewrite /Relation_Definitions.transitive => X Y Z [f Hf] [g Hg].
    exists (g ◦ f). by apply comp_bijective.
Qed.

Add Parametric Relation (X Y : Type) : Type isomorphic
    reflexivity proved by isomorphic_refl
    symmetry proved by isomorphic_symm
    transitivity proved by isomorphic_trans as rel_iso.
*)

Definition IsomorphicExtensionality := forall A B:Type, A ≅ B -> A = B.

(** Open question : if pred_replace has the following form:

        isomorphic A B -> (P A <-> P B)

    Then the [isomorphic_extensionality] axiom is not necessary for theory
    transport.
*)

Theorem iso_comp (A B C D : Type) : A ≅ B -> C ≅ D -> (A -> C) ≅ (B -> D).
Abort.


From Coq Require Import ssreflect ssrfun.
From Mon Require Export Base.
From Mon Require Import SPropBase.
From Coq Require Import RelationClasses Morphisms Relation_Definitions.

Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

(*********************************************************)
(**       Order-enriched Category                       **)
(*********************************************************)

Section Category.
  Reserved Notation "f ⪷ g" (at level 65).
  Reserved Notation "f ∙ g" (at level 55).

  Cumulative Record ord_category : Type :=
    mkOrdCategory
      { Obj :> Type
      ; Hom : Obj -> Obj -> Type
      ; ord_cat_le : forall {A B}, relation (Hom A B)
      where "f ⪷ g" := (ord_cat_le f g)
      ; ord_cat_le_preorder : forall A B, PreOrder (@ord_cat_le A B)
      ; Id : forall A, Hom A A
      ; Comp : forall {A B C}, Hom B C -> Hom A B -> Hom A C
        where "f ∙ g" := (Comp f g)
      ; Comp_proper : forall {A B C},
          Proper (@ord_cat_le B C ==> @ord_cat_le A B ==> @ord_cat_le A C) Comp
      ; ord_cat_law1 : forall A B (f : Hom A B), Id _ ∙ f = f
      ; ord_cat_law2 : forall A B (f : Hom A B), f ∙ Id _ = f
      ; ord_cat_law3 : forall A B C D (f : Hom A B) (g : Hom B C) (h : Hom C D),
          h ∙ (g ∙ f) = (h ∙ g) ∙ f
      }.

  Global Existing Instance ord_cat_le_preorder.
  Global Existing Instance Comp_proper.
End Category.

Notation "C ⦅ A ; B ⦆" := (Hom C A B) (at level 60).
Notation "f ∙ g" := (Comp _ f g) (at level 55).
Notation "f ⪷ g" := (ord_cat_le _ f g) (at level 65).
Arguments Id {_} _.

(*********************************************************)
(**       Functor, identity, composition                **)
(*********************************************************)

Section Functor.
  Context (C D : ord_category).

  Cumulative Record ord_functor : Type :=
    mkOrdFunctor
      { ofmapObj :> C -> D
      ; ofmap : forall {A B}, C⦅A;B⦆ -> D⦅ofmapObj A;ofmapObj B⦆
      ; ofmap_proper : forall A B, Proper (@ord_cat_le C A B ==> @ord_cat_le D _ _) ofmap
      ; ord_functor_law1 : forall A, ofmap (Id A) = Id _
      ; ord_functor_law2 : forall (X Y Z: C) (g : C⦅X;Y⦆) (f:C⦅Y;Z⦆),
          ofmap (f ∙ g) = (ofmap f) ∙ (ofmap g)
      }.

  Global Existing Instance ofmap_proper.
End Functor.

Arguments mkOrdFunctor {_ _} _ _ _ _ _.
Arguments ofmap {_ _} _ {_ _} _.

Section FunctorId.
  Context (C:ord_category).

  Program Definition ord_functor_id : ord_functor C C :=
    mkOrdFunctor (fun A => A) (fun _ _ f => f) _ _ _.
  Next Obligation. cbv ; intuition. Qed.
End FunctorId.

Section FunctorComposition.
  Context {C D E : ord_category} (F : ord_functor C D) (G : ord_functor D E).
  Program Definition ord_functor_comp : ord_functor C E :=
    mkOrdFunctor (fun A => G (F A)) (fun A B f=> ofmap G (ofmap F f)) _ _ _.
  Next Obligation. cbv ; intuition; do 2 apply: ofmap_proper=> //. Qed.
  Next Obligation. do 2 rewrite ord_functor_law1=> //. Qed.
  Next Obligation. do 2 rewrite ord_functor_law2=> //. Qed.
End FunctorComposition.

(*********************************************************)
(**           Product of two categories,                **)
(**        diagonal and projection functors,            **)
(**        product of two functors                      **)
(*********************************************************)

Section ProductCat.
  Context (C D : ord_category).

  Import SPropNotations.
  Program Definition prod_cat : ord_category :=
    mkOrdCategory (C × D)
                  (fun A B => C⦅nfst A ; nfst B⦆ × D⦅nsnd A ; nsnd B⦆)
                  (fun _ _ f g => nfst f ⪷ nfst g /\ nsnd f ⪷ nsnd g)
                  _
                  (fun A => ⟨Id (nfst A), Id (nsnd A)⟩)
                  (fun _ _ _ f g => ⟨nfst f ∙ nfst g, nsnd f ∙ nsnd g⟩)
                  _ _ _ _.
  Next Obligation.
    constructor ; cbv ; intuition ; etransitivity ; eassumption.
  Qed.
  Next Obligation.
    cbv ; intuition; apply Comp_proper=> //.
  Qed.
  Next Obligation. rewrite 2!ord_cat_law1 //. Qed.
  Next Obligation. rewrite 2!ord_cat_law2 //. Qed.
  Next Obligation. rewrite 2!ord_cat_law3 //. Qed.
End ProductCat.

Section FunctorToProdCat.
  Context {I C1 C2} (F1 : ord_functor I C1) (F2 : ord_functor I C2).

  Program Definition functor_to_prod_cat : ord_functor I (prod_cat C1 C2) :=
    mkOrdFunctor (fun A => ⟨F1 A, F2 A⟩) (fun _ _ f => ⟨ofmap F1 f, ofmap F2 f⟩) _ _ _.
  Next Obligation. cbv ; intuition; apply ofmap_proper=> //. Qed.
  Next Obligation. rewrite 2!ord_functor_law1 //. Qed.
  Next Obligation. rewrite 2!ord_functor_law2 //. Qed.
End FunctorToProdCat.

Definition diagonal_functor (C:ord_category) :=
  functor_to_prod_cat (ord_functor_id C) (ord_functor_id C).

Section ProjectionsFunctors.
  Context (C D : ord_category).

  Program Definition left_proj_functor : ord_functor (prod_cat C D) C :=
    mkOrdFunctor nfst (fun _ _ => nfst) _ _ _.
  Solve All Obligations with cbv ; intuition.

  Program Definition right_proj_functor : ord_functor (prod_cat C D) D :=
    mkOrdFunctor nsnd (fun _ _ => nsnd) _ _ _.
  Solve All Obligations with cbv ; intuition.
End ProjectionsFunctors.

Section ProductFunctor.
  Context {C1 C2 D1 D2 : ord_category} (F1 : ord_functor C1 D1) (F2 : ord_functor C2 D2).

  Program Definition prod_functor
    : ord_functor (prod_cat C1 C2) (prod_cat D1 D2) :=
    mkOrdFunctor (fun A => ⟨F1 (nfst A), F2 (nsnd A)⟩)
                 (fun _ _ f => ⟨ofmap F1 (nfst f), ofmap F2 (nsnd f)⟩)
                 _ _ _.
  Next Obligation. cbv ; intuition ; apply ofmap_proper=> //. Qed.
  Next Obligation. rewrite 2!ord_functor_law1 //. Qed.
  Next Obligation. rewrite 2!ord_functor_law2 //. Qed.
End ProductFunctor.

(** Should I implement lax natural transformations ? *)
(* (*********************************************************) *)
(* (**   Natural transformations, id, comp, whiskering     **) *)
(* (*********************************************************) *)
(* Section NaturalTrans. *)
(*   Context {C D : ord_category} (F G : ord_functor C D). *)

(*   Cumulative Record natTrans := *)
(*     mkNatTrans *)
(*       { nt_map :> forall {A}, D⦅F A;G A⦆ *)
(*       ; nt_natural : forall {A B} (f : C⦅A ; B⦆), *)
(*           nt_map ∙ fmap F f ∼ fmap G f ∙ nt_map *)
(*       }. *)

(* End NaturalTrans. *)

(* Section NaturalTransformationId. *)
(*   Context {C D : category} (F : functor C D). *)

(*   Program Definition natTrans_id : natTrans F F := *)
(*     mkNatTrans _ _ (fun=> Id _) _. *)
(*   Next Obligation. rewrite cat_law1 cat_law2 ; reflexivity. Qed. *)

(* End NaturalTransformationId. *)

(* Section NaturalTransformationComp. *)
(*   Context {C D : category} {F G H : functor C D} *)
(*           (phi : natTrans F G) (psi : natTrans G H). *)

(*   Program Definition natTrans_comp : natTrans F H := *)
(*     mkNatTrans _ _ (fun A => psi A ∙ phi A) _. *)
(*   Next Obligation. *)
(*     rewrite -cat_law3 nt_natural cat_law3 nt_natural !cat_law3. *)
(*     reflexivity. *)
(*   Qed. *)
(* End NaturalTransformationComp. *)

(* Section NaturalTransformationRightWhiskering. *)
(*   Context {C D E: category} {F G : functor C D} (H : functor D E) *)
(*           (phi : natTrans F G). *)

(*   Program Definition natTrans_whisker_right : natTrans (functor_comp F H) (functor_comp G H) := *)
(*     mkNatTrans _ _ (fun A => fmap H (phi A)) _. *)
(*   Next Obligation. *)
(*     rewrite -!functor_law2 !nt_natural ; reflexivity. *)
(*   Qed. *)
(* End NaturalTransformationRightWhiskering. *)

(* Section NaturalTransformationLeftWhiskering. *)
(*   Context {C D E: category} {F G : functor D E}  *)
(*           (phi : natTrans F G) (H : functor C D). *)

(*   Program Definition natTrans_whisker_left : natTrans (functor_comp H F) (functor_comp H G) := *)
(*     mkNatTrans _ _ (fun A => phi (H A)) _. *)
(*   Next Obligation. rewrite nt_natural. reflexivity. Qed. *)
(* End NaturalTransformationLeftWhiskering. *)

(*********************************************************)
(**   Natural isomorphisms, id, comp, whiskering        **)
(**   unitality and associativity laws for functors     **)
(*********************************************************)
Section NaturalIso.
  Context {C D : ord_category} (F G : ord_functor C D).

  Cumulative Record natIso :=
    mkNatIso
      { ni_map :> forall {A}, D⦅F A;G A⦆
      ; ni_inv : forall {A}, D⦅G A;F A⦆
      ; ni_natural : forall {A B} (f : C⦅A ; B⦆),
          ni_map ∙ ofmap F f = ofmap G f ∙ ni_map
      ; ni_rightinv : forall {A}, ni_map ∙ ni_inv = Id (G A)
      ; ni_leftinv : forall {A}, ni_inv ∙ ni_map = Id (F A)
      }.

  Lemma natIso_inv_natural (phi:natIso) {A B} (f : C⦅A ; B⦆) :
    ni_inv phi ∙ ofmap G f = ofmap F f ∙ ni_inv phi.
  Proof.
    rewrite -[in RHS](ord_cat_law1 _ _ _ (ofmap _ _))
      -(ni_leftinv phi) -(ord_cat_law3 _ _ _ _ _ _ _ (ni_inv phi))
      ni_natural -!ord_cat_law3 ni_rightinv ord_cat_law2 //.
  Qed.

End NaturalIso.

Arguments ni_inv {_ _ _ _} _ _.

Section NaturalIsoSym.
  Context {C D : ord_category} {F G : ord_functor C D}.

  Program Definition natIso_sym (phi : natIso F G) : natIso G F :=
    mkNatIso _ _ (ni_inv phi) phi _ _ _.
  Next Obligation. apply natIso_inv_natural. Qed.
  Next Obligation. apply ni_leftinv. Qed.
  Next Obligation. apply ni_rightinv. Qed.
End NaturalIsoSym.

(* Section NaturalIsoToNaturalTrans. *)
(*   Context {C D : category}. *)

(*   Definition iso_to_natTrans {F G : functor C D } (phi : natIso F G) *)
(*     : natTrans F G := *)
(*     mkNatTrans _ _ phi (@ni_natural _ _ _ _ phi). *)

(*   Definition iso_to_natTrans_inv {F G : functor C D } (phi : natIso F G) *)
(*     : natTrans G F := *)
(*     iso_to_natTrans (natIso_sym phi). *)
(* End NaturalIsoToNaturalTrans. *)

Section IdToNaturalIso.
  Context {C D : ord_category} (F: ord_functor C D).

  Program Definition natIso_id : natIso F F :=
    mkNatIso F F (fun=> Id _) (fun=> Id _) _ _ _.
  Next Obligation. rewrite ord_cat_law1 ord_cat_law2 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.
End IdToNaturalIso.

Section NaturalIsoComp.
  Context {C D : ord_category} {F G H : ord_functor C D}
          (phi : natIso F G) (psi : natIso G H).

  Program Definition natIso_comp : natIso F H :=
    mkNatIso _ _ (fun A => psi A ∙ phi A)
             (fun A => ni_inv phi A ∙ ni_inv psi A) _ _ _.
  Next Obligation.
    rewrite -ord_cat_law3 ni_natural ord_cat_law3 ni_natural !ord_cat_law3 //.
  Qed.
  Next Obligation.
    rewrite ord_cat_law3 -(ord_cat_law3 _ _ _ _ _ _ _ (psi _)).
    rewrite ni_rightinv ord_cat_law2 ni_rightinv //.
  Qed.
  Next Obligation.
    rewrite -ord_cat_law3 (ord_cat_law3 _ _ _ _ _ (phi _)).
    rewrite ni_leftinv ord_cat_law1 ni_leftinv //.
  Qed.

End NaturalIsoComp.

Section NaturalIsoLeftWhiskering.
  Context {C D E: ord_category} {F G : ord_functor D E}
          (phi : natIso F G) (H : ord_functor C D).

  Program Definition natIso_whisker_left : natIso (ord_functor_comp H F) (ord_functor_comp H G) :=
    mkNatIso _ _ (fun A => phi (H A)) (fun A => ni_inv phi (H A)) _ _ _.
  Next Obligation. rewrite ni_natural; reflexivity. Qed.
  Next Obligation. rewrite ni_rightinv ; reflexivity. Qed.
  Next Obligation. rewrite ni_leftinv ; reflexivity. Qed.
End NaturalIsoLeftWhiskering.

Section NaturalIsoRightWhiskering.
  Context {C D E: ord_category} {F G : ord_functor C D} (H : ord_functor D E)
          (phi : natIso F G).

  Program Definition natIso_whisker_right : natIso (ord_functor_comp F H) (ord_functor_comp G H) :=
    mkNatIso _ _ (fun A => ofmap H (phi A)) (fun A => ofmap H (ni_inv phi A)) _ _ _.
  Next Obligation. rewrite -!ord_functor_law2 ni_natural //. Qed.
  Next Obligation. rewrite -ord_functor_law2 ni_rightinv ord_functor_law1 //. Qed.
  Next Obligation. rewrite -ord_functor_law2 ni_leftinv ord_functor_law1 //. Qed.
End NaturalIsoRightWhiskering.

Section FunctorCompId.
  Context {C D : ord_category} (F : ord_functor C D).

  Program Definition ord_functor_unit_left
    : natIso (ord_functor_comp (ord_functor_id _) F) F
    := mkNatIso _ _ (fun=> Id _) (fun=> Id _) _ _ _.
  Next Obligation. rewrite ord_cat_law1 ord_cat_law2 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.

  Program Definition ord_functor_unit_right
    : natIso (ord_functor_comp F (ord_functor_id _)) F
    := mkNatIso _ _ (fun=> Id _) (fun=> Id _) _ _ _.
  Next Obligation. rewrite ord_cat_law1 ord_cat_law2 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.

End FunctorCompId.

Section FunctorCompAssoc.
  Context {C1 C2 C3 C4} (F12 : ord_functor C1 C2) (F23 : ord_functor C2 C3) (F34 : ord_functor C3 C4).

  Program Definition ord_functor_assoc
    : natIso (ord_functor_comp F12 (ord_functor_comp F23 F34))
             (ord_functor_comp (ord_functor_comp F12 F23) F34)
    := mkNatIso _ _ (fun=> Id _) (fun=> Id _) _ _ _.
  Next Obligation. rewrite ord_cat_law1 ord_cat_law2 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.
  Next Obligation. rewrite ord_cat_law1 //. Qed.

End FunctorCompAssoc.

(*********************************************************)
(**     Monad relative to a functor, morphisms          **)
(**     underlying functor, monads as relative monads   **)
(*********************************************************)
Section RelativeMonad.
  Context {C D : ord_category} {J : ord_functor C D}.

  Cumulative Record ord_relativeMonad :=
    mkOrdRelativeMonad
      { ord_relmonObj :> C -> D
      ; ord_relmon_unit : forall A, D⦅J A; ord_relmonObj A⦆
      ; ord_relmon_bind : forall {A B}, D⦅J A; ord_relmonObj B⦆ -> D⦅ord_relmonObj A; ord_relmonObj B⦆
      ; ord_relmon_bind_proper : forall A B,
          Proper (@ord_cat_le D (J A) (ord_relmonObj B) ==> ord_cat_le D) ord_relmon_bind
      ; ord_relmon_law1 : forall A, ord_relmon_bind (ord_relmon_unit A) = Id _
      ; ord_relmon_law2 : forall A B (f : D⦅J A; ord_relmonObj B⦆),
          ord_relmon_bind f ∙ ord_relmon_unit A = f
      ; ord_relmon_law3 : forall A B C (f : D⦅J B; ord_relmonObj C⦆) (g:D⦅J A; ord_relmonObj B⦆),
          ord_relmon_bind (ord_relmon_bind f ∙ g) = ord_relmon_bind f ∙ ord_relmon_bind g
      }.
  Global Existing Instance ord_relmon_bind_proper.
End RelativeMonad.

Arguments ord_relativeMonad {_ _} J.

Section RelativeLaxMonadMorphism.
  Context {C D1 D2 : ord_category} {J1 : ord_functor C D1} (J12 : ord_functor D1 D2) {J2 : ord_functor C D2}
          (phi : natIso J2 (ord_functor_comp J1 J12)) (psi := ni_inv phi)
          (M1 : ord_relativeMonad J1) (M2: ord_relativeMonad J2).

  Notation η := ord_relmon_unit.
  Notation rbind := ord_relmon_bind.

  Cumulative Record relativeMonadMorphism :=
    mkRelMonMorph
      { rmm_map :> forall {A}, D2⦅J12 (M1 A); M2 A⦆
      ; rmm_law1 : forall A, rmm_map ∙ ofmap J12 (η M1 A) = η M2 A ∙ psi _
      ; rmm_law2 : forall A B (f : D1⦅J1 A; M1 B⦆),
          rmm_map ∙ ofmap J12 (rbind M1 f) =
                  rbind M2 (rmm_map ∙ ofmap J12 f ∙ phi _) ∙ rmm_map
      }.

  Cumulative Record relativeLaxMonadMorphism :=
    mkRelLaxMonMorph
      { rlmm_map :> forall {A}, D2⦅J12 (M1 A); M2 A⦆
      ; rlmm_law1 : forall A, rlmm_map ∙ ofmap J12 (η M1 A) ⪷ η M2 A ∙ psi _
      ; rlmm_law2 : forall A B (f : D1⦅J1 A; M1 B⦆),
          rlmm_map ∙ ofmap J12 (rbind M1 f) ⪷
                  rbind M2 (rlmm_map ∙ ofmap J12 f ∙ phi _) ∙ rlmm_map
      }.

  Program Definition relativeMonadMorphism_to_lax
          (θ : relativeMonadMorphism) : relativeLaxMonadMorphism
    := mkRelLaxMonMorph θ _ _.
  Next Obligation. rewrite rmm_law1; reflexivity. Qed.
  Next Obligation. rewrite rmm_law2; reflexivity. Qed.
  Coercion relativeMonadMorphism_to_lax : relativeMonadMorphism >-> relativeLaxMonadMorphism.
End RelativeLaxMonadMorphism.

Section RelativeMonadToFunctor.
  Context {C D:ord_category} {J:ord_functor C D} (M : ord_relativeMonad J).

  Program Definition rmon_to_ord_functor : ord_functor C D :=
    mkOrdFunctor M (fun A B f => ord_relmon_bind M (ord_relmon_unit M _ ∙ ofmap J f)) _ _ _.
  Next Obligation.
    cbv ; intuition.
    apply ord_relmon_bind_proper, Comp_proper; [reflexivity| apply ofmap_proper; assumption].
  Qed.
  Next Obligation. rewrite ord_functor_law1 ord_cat_law2 ord_relmon_law1 //. Qed.
  Next Obligation.
    rewrite ord_functor_law2 ord_cat_law3
            -ord_relmon_law3 ord_cat_law3 ord_relmon_law2 //.
  Qed.
End RelativeMonadToFunctor.

(* Section RmonadUnit. *)
(*   Context {I C:ord_category} {J:ord_functor I C} *)
(*           (M0 : ord_relativeMonad J) (M := rmon_to_ord_functor M0). *)

(*   Program Definition rmon_unit : natTrans J M := *)
(*     mkNatTrans _ _ (relmon_unit M0) _. *)
(*   Next Obligation. rewrite (relmon_law2 M0) ; reflexivity. Qed. *)
(* End RmonadUnit. *)

(* Section RMonadAsMonad. *)
(*   Context {C:category} (M0 : relativeMonad (functor_id C)) (M := rmon_to_functor M0). *)

(*   Program Definition rmon_id_mult : natTrans (functor_comp M M) M := *)
(*     mkNatTrans _ _ (fun=> relmon_bind M0 (Id _)) _. *)
(*   Next Obligation. *)
(*     rewrite -!relmon_law3 cat_law3 (relmon_law2 M0) cat_law1 cat_law2. *)
(*     reflexivity. *)
(*   Qed. *)

(*   Notation η := (@rmon_unit C C (functor_id C) _ _). *)
(*   Notation μ := (rmon_id_mult _). *)

(*   Lemma rmon_id_law1 {A} : μ ∙ (fmap M η) ∼ Id (M A). *)
(*   Proof. cbv. rewrite -relmon_law3 cat_law3 (relmon_law2 M0) cat_law1 relmon_law1. reflexivity. Qed. *)

(*   Lemma rmon_id_law2 {A} : μ ∙ η ∼ Id (M A). *)
(*   Proof. cbv. rewrite (relmon_law2 M0). reflexivity. Qed. *)

(*   Lemma rmon_id_law3 {A} : μ ∙ μ ∼ μ ∙ fmap M (rmon_id_mult A). *)
(*   Proof. *)
(*     cbv. rewrite -!relmon_law3 !cat_law3 (relmon_law2 M0) cat_law2 cat_law1. *)
(*     reflexivity. *)
(*   Qed. *)
(* End RMonadAsMonad. *)

(* transport a J1-relative monad into a J2-relative monad along a natural isomorphism *)
Section RelativeMonadIso.
  Context {I C} {J1 J2 : ord_functor I C} (M : ord_relativeMonad J1)
          (phi : natIso J1 J2).

  Program Definition rmon_transp_natIso : ord_relativeMonad J2 :=
    mkOrdRelativeMonad M (fun A => ord_relmon_unit M A ∙ ni_inv phi A)
                    (fun A B f => ord_relmon_bind M (f ∙ phi A))
                    _ _ _ _.
  Next Obligation.
    cbv ; intuition; apply: ord_relmon_bind_proper; apply: Comp_proper=> //; reflexivity. Qed.
  Next Obligation.
    rewrite -ord_cat_law3 ni_leftinv ord_cat_law2 ord_relmon_law1 //.
  Qed.
  Next Obligation.
    rewrite ord_cat_law3 ord_relmon_law2 -ord_cat_law3 ni_rightinv ord_cat_law2 //.
  Qed.
  Next Obligation.
    rewrite -ord_cat_law3 ord_relmon_law3 //.
  Qed.
  (* Surprisingly, we never use naturality... *)
End RelativeMonadIso.

(* Given functors
     J1 : I1 -> C1
     J2 : I2 -> C2,
  J1-relative monad M1 and
  J2-relative monad M2
  builds a J1×J2-relative monad I1 × I2 -> C1 × C2
 *)
Section ProductRelativeMonad.
  Context {I1 I2 C1 C2} {J1 : ord_functor I1 C1} {J2 : ord_functor I2 C2}
          (M1 : ord_relativeMonad J1) (M2 : ord_relativeMonad J2).

  Program Definition product_rmon : ord_relativeMonad (prod_functor J1 J2) :=
    mkOrdRelativeMonad (fun A => ⟨M1 (nfst A), M2 (nsnd A)⟩)
                    (fun A => ⟨ord_relmon_unit M1 (nfst A), ord_relmon_unit M2 (nsnd A)⟩)
                    (fun _ _ f => ⟨ord_relmon_bind M1 (nfst f), ord_relmon_bind M2 (nsnd f)⟩) _ _ _ _.
  Next Obligation.
    cbv ; intuition; apply: ord_relmon_bind_proper=> //.
  Qed.
  Next Obligation. intuition; rewrite !ord_relmon_law1 //. Qed.
  Next Obligation. intuition; rewrite !ord_relmon_law2 //. Qed.
  Next Obligation. intuition; rewrite !ord_relmon_law3 //. Qed.

End ProductRelativeMonad.

(*********************************************************)
(** Precomposition is functorial on relative monads     **)
(*********************************************************)
Section RelativeMonadPrecomposition.
  Context {I I'} (J : ord_functor I I').

  Section OnObjects.
    Context {C : ord_category} {JC : ord_functor I' C} (J' := ord_functor_comp J JC)
            (M : ord_relativeMonad JC).

    Program Definition relativeMonad_precomposition
      : ord_relativeMonad J' :=
      mkOrdRelativeMonad (fun A => M (J A))
                         (fun A => ord_relmon_unit M (J A))
                         (fun A B f => ord_relmon_bind M f)
                      _ _ _ _.
    Next Obligation. cbv ; intuition. apply: ord_relmon_bind_proper=> //. Qed.
    Next Obligation. rewrite !ord_relmon_law1 => //. Qed.
    Next Obligation. rewrite !ord_relmon_law2 => //. Qed.
    Next Obligation. rewrite !ord_relmon_law3 => //. Qed.
  End OnObjects.

  Local Notation "J*" := relativeMonad_precomposition.

  Section OnMorphism.
    Context {C1 C2 : ord_category} {JC1 : ord_functor I' C1} {JC2 : ord_functor I' C2}.
    Context {M1 : ord_relativeMonad JC1} {M2 : ord_relativeMonad JC2}
            {JC12 : ord_functor C1 C2} (phi : natIso _ _)
            (θ : relativeMonadMorphism JC12 phi M1 M2)
            (θl : relativeLaxMonadMorphism JC12 phi M1 M2).

    Program Definition relativeMonad_precomposition_morph
      : relativeMonadMorphism JC12
                              (natIso_comp (natIso_whisker_left phi J)
                                           (ord_functor_assoc _ _ _))
                              (J* M1) (J* M2) :=
      mkRelMonMorph _ _ _ _ (fun A => θ (J A)) _ _.
    Next Obligation. rewrite ord_cat_law2 ; apply: rmm_law1. Qed.
    Next Obligation. rewrite ord_cat_law1 ; apply: rmm_law2. Qed.

    Program Definition relativeMonad_precomposition_lax_morph
      : relativeLaxMonadMorphism JC12
                              (natIso_comp (natIso_whisker_left phi J)
                                           (ord_functor_assoc _ _ _))
                              (J* M1) (J* M2) :=
      mkRelLaxMonMorph _ _ _ _ (fun A => θl (J A)) _ _.
    Next Obligation. rewrite ord_cat_law2 ; apply: rlmm_law1. Qed.
    Next Obligation. rewrite ord_cat_law1 ; apply: rlmm_law2. Qed.
  End OnMorphism.

  (* TODO : show the functorial laws *)
End RelativeMonadPrecomposition.

(*********************************************************)
(** Postcomposition by a *full and faithful* functor is **)
(** functorial on relative monads                       **)
(*********************************************************)

Section FullyFaithfulFunctor.
  Context {C D : ord_category} (F : ord_functor C D).

  Record ff_struct :=
    { ff_invmap :> forall {X Y}, D⦅F X;F Y⦆ -> C⦅X;Y⦆
    ; ff_inv_proper : forall {X Y}, Proper (ord_cat_le D ==> ord_cat_le C) (@ff_invmap X Y)
    ; ff_section : forall {X Y} (f : D⦅F X;F Y⦆), ofmap F (ff_invmap f) = f
    ; ff_retraction : forall {X Y} (f : C⦅X;Y⦆), ff_invmap (ofmap F f) = f
    }.

  Global Existing Instance ff_inv_proper.

  Lemma invert_comp (Fff : ff_struct) {X Y Z}
    (f:D⦅F Y;F Z⦆) (g:D⦅F X;F Y⦆): Fff _ _ (f ∙ g) = Fff _ _ f ∙ Fff _ _ g.
  Proof.
    rewrite -{1}(ff_section Fff f) -{1}(ff_section Fff g) -ord_functor_law2 ff_retraction ; reflexivity.
  Qed.
End FullyFaithfulFunctor.

Section RelativeMonadPostcomposition.
  Context {I C D} {J: ord_functor I C} (M:ord_relativeMonad J)
          (F : ord_functor C D) (Fff : ff_struct F).

  Let FJ := ord_functor_comp J F.
  Program Definition relativeMonad_postcomposition : ord_relativeMonad FJ :=
    mkOrdRelativeMonad (fun A => F (M A))
                       (fun A => ofmap F (ord_relmon_unit M A))
                       (fun A B f => ofmap F (ord_relmon_bind M (Fff _ _ f)))
                    _ _ _ _.
  Next Obligation. cbv ; intuition; apply: ofmap_proper; apply: ord_relmon_bind_proper; apply: ff_inv_proper=> //. Qed.
  Next Obligation.
    rewrite ff_retraction ord_relmon_law1 ord_functor_law1 //.
  Qed.
  Next Obligation.
    rewrite -ord_functor_law2 ord_relmon_law2 ff_section //.
  Qed.
  Next Obligation.
    rewrite invert_comp ff_retraction ord_relmon_law3 ord_functor_law2 //.
  Qed.
End RelativeMonadPostcomposition.

(* From Equations Require Import Equations. *)

(* Section IdNatIso. *)
(*   Import EqNotations. *)

(*   Lemma rew_comp (C : ord_category) X Y Y' Z (f : C⦅X;Y⦆) (g : C⦅Y;Z⦆) (H : Y = Y') : *)
(*     g ∙ f = rew [fun y=> C⦅y;_⦆] H in g ∙ rew H in f. *)
(*   Proof. dependent elimination H=> //. Qed. *)

(*   Lemma rew_target (C : ord_category) X Y Z Z' (f : C⦅X;Y⦆) (g : C⦅Y;Z⦆) (H : Z = Z') : *)
(*     rew H in g ∙ f = rew H in (g ∙ f). *)
(*   Proof. dependent elimination H=> //. Qed. *)

(*   Context {I C D} {JC: ord_functor I C} {JD: ord_functor I D} *)
(*           (F : ord_functor C D) *)
(*           (JCF := ord_functor_comp JC F) *)
(*           (Hobj : forall x: I, JD x = JCF x) *)
(*           (Hmap : forall x y (f : I⦅x;y⦆), *)
(*               rew [fun x' => D⦅x'; _⦆](Hobj x) in *)
(*                 rew [fun y' => D⦅_; y'⦆] (Hobj y) in *)
(*                 ofmap JD f = ofmap JCF f). *)

(*   Goal natIso JD (ord_functor_comp JC F). *)
(*     unshelve econstructor. *)
(*     move=> A ; rewrite -(Hobj A); apply Id. *)
(*     move=> A ; rewrite -(Hobj A); apply Id. *)
(*     move=> A B f /=. *)
(*     rewrite [ofmap _ (ofmap _ _)]/(ofmap JCF f) -Hmap. *)
(*     set H1 := Hobj A. *)
(*     set H2 := Hobj B. *)
(*     move: H1 H2 => H2 H1. *)
(*     rewrite -rew_comp rew_target ord_cat_law2 ord_cat_law1 //. *)
(*     move=> ? /=. *)
(*     set H := (Hobj _). *)
(*     move: H => H. *)

(*     (* Rem.: This is totally getting out of hand !!!! *) *)

(* End IdNatIso. *)

Section RelativeMonadLifting.

  Section LiftingDatum.
    Context {I C D} {JC: ord_functor I C} {JD: ord_functor I D}
            (F : ord_functor C D)
            (JCF := ord_functor_comp JC F)
            (ϕ : natIso JD JCF)
            (MC:ord_relativeMonad JC)
            (MD:ord_relativeMonad JD).

    Let uMC := rmon_to_ord_functor MC.
    Let uMCF := ord_functor_comp uMC F.
    Let uMD := rmon_to_ord_functor MD.

    Definition lifts_object := natIso uMD uMCF.
    Definition lifts_ret (ψ : lifts_object):=
      forall (x:I), ofmap F (ord_relmon_unit MC x) ∙ ϕ _ = ψ _ ∙ ord_relmon_unit MD x.
    Definition lifts_bind (ψ : lifts_object):=
      forall (x y:I) (f: C⦅JC x; MC y⦆),
        ni_inv ψ _ ∙ ofmap F (ord_relmon_bind MC f) ∙ ψ _ =
        ord_relmon_bind MD (ni_inv ψ _ ∙ ofmap F f ∙ ϕ _).
  End LiftingDatum.

  Arguments lifts_ret {_ _ _ _ _ _} _ { _ _} _.
  Arguments lifts_bind {_ _ _ _ _ _} _ {_ _} _.

  Section LiftingOf.
    Context {I C D} (JC: ord_functor I C) {JD: ord_functor I D}
            (F : ord_functor C D)
            (JCF := ord_functor_comp JC F)
            (ϕ : natIso JD JCF)
            (MD:ord_relativeMonad JD).

    Record lifting_of :=
      mkLiftingOf {
          lifting_carrier :> ord_relativeMonad JC ;
          lifting_obj : lifts_object F lifting_carrier MD;
          lifting_ret : lifts_ret ϕ lifting_obj ;
          lifting_bind : lifts_bind ϕ lifting_obj ;
        }.

  End LiftingOf.
End RelativeMonadLifting.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2014: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Derived_Terms Axioms Derived_Pairs Derived_Products.
Set Implicit Arguments.

Module Make(Import M: Memory.T).
  Module Export Derived_RulesExp := Derived_Products.Make(M).

(* --- Derived Rules --- *)

 Lemma weak_refl: forall X Y (f: term Y X), f ~~ f.
 Proof. intros. apply strong_to_weak. apply strong_refl. Qed.

 Lemma zero_weak_to_strong: forall X Y (f g: term Y X),
 PURE f -> PURE g -> f ~~ g  -> f == g.
 Proof. intros. apply one_weak_to_strong; decorate. Qed.

 Lemma weak_final_unit: forall X (f: term unit X), f ~~ forget.
 Proof. intros. apply weak_final_unique. Qed.

 Lemma E_1_1: forall X (f g: term unit X), RO f -> RO g -> f == g.
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma E_0_1: forall X (f g : term unit X), PURE f -> PURE g -> f == g.
 Proof. intros. apply one_weak_to_strong; try decorate. apply weak_final_unique. Qed.

 Lemma E_1_2: forall X (f: term unit X), RO f -> f == forget.
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma E_0_2: forall X (f: term unit X), PURE f -> f == forget.
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma E_1_3: forall X Y (g: term unit Y) (h: term unit X)
 (f: term Y X),  RO g -> RO h -> RO f -> h == g o f.
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma E_0_3: forall X Y (g: term unit Y) (h: term unit X)
 (f: term Y X), PURE g -> PURE h -> PURE f -> h == g o f.
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma E_1_4: forall X (f: term X unit), RO f -> forget o f == (@id unit).
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma E_0_4: forall X (f: term X unit), PURE f -> forget o f == (@id unit).
 Proof. intros. apply one_weak_to_strong; (solve[decorate] || idtac). apply weak_final_unique. Qed.

 Lemma strong_unit_pi1__prod_forget: forall X Y: Type,
       forget o pi1 == (@prod_forget X Y).
 Proof.
     intros. specialize(@E_0_3 _ _ forget prod_forget (@pi1 X Y)).
     intros. apply strong_sym. apply H; decorate.
 Qed.

 Lemma strong_unit_pi2__prod_forget: forall X Y: Type,
       forget o pi2 == (@prod_forget X Y).
 Proof.
     intros. specialize(@E_0_3 _ _ forget prod_forget (@pi2 X Y)).
     intros. apply strong_sym. apply H; decorate.
 Qed.

Lemma strong_pi1_inv_pi1__id: forall X: Type, pi1 o inv_pi1 == (@id X).
 Proof. intros. apply strong_proj_pi1_purepure; decorate. Qed.

 Lemma strong_pi2_inv_pi1__unit: forall X: Type, pi2 o inv_pi1 == (@forget X).
 Proof. intros. apply strong_proj_pi2_purepure; decorate. Qed.

 Lemma strong_pi1_permut__pi2: forall X Y: Type, pi1 o permut == (@pi2 X Y).
 Proof. intros. apply strong_proj_pi1_purepure; decorate. Qed.

 Lemma strong_pi2_permut__pi1: forall X Y: Type, pi2 o permut == (@pi1 X Y).
 Proof. intros. apply strong_proj_pi2_purepure; decorate. Qed.

 Lemma unicity_rect: forall X X' Y Y'(f g: term (Y*Y') (X*X')),
   (pi1 o f ~~ pi1 o g) -> (pi2 o f ~~ pi2 o g) -> f ~~ g.
 Proof. intros. apply unicity; assumption. Qed.

 Lemma strong_unicity: forall X Y Y'(f g: term (Y*Y') X),
   (pi1 o f ~~ pi1 o g) -> (pi2 o f == pi2 o g) -> f == g.
 Proof.
     intros. apply comp_final_unique. remember sc.
     specialize (@E_0_1 _ (forget) (forget o (@pi2 Y Y'))). intros.
     rewrite H1; (solve[decorate] || idtac). repeat rewrite <- assoc. apply sc.
     apply strong_refl. assumption.
     apply unicity. assumption. apply strong_to_weak. assumption.
 Qed.

 Lemma strong_perm_unicity: forall X Y Y'(f g: term (Y'*Y) X),
   (pi1 o f == pi1 o g) -> (pi2 o f ~~ pi2 o g) -> f == g.
 Proof.
     intros. apply comp_final_unique. remember sc.
     specialize (@E_0_1 _ (forget) (forget o (@pi1 Y' Y))). intros.
     rewrite H1; (solve[decorate] || idtac). repeat rewrite <- assoc. apply sc.
     apply strong_refl. assumption.
     apply unicity. apply strong_to_weak. assumption. assumption.
 Qed.

 Lemma strong_unicity_rect: forall X X' Y Y'(f g: term (Y*Y') (X*X')),
   (pi1 o f ~~ pi1 o g) -> (pi2 o f == pi2 o g) -> f == g.
 Proof. intros. apply strong_unicity; assumption. Qed.

 Lemma strong_perm_unicity_rect: forall X X' Y Y'(f g: term (Y*Y') (X*X')),
   (pi1 o f == pi1 o g) -> (pi2 o f ~~ pi2 o g) -> f == g.
 Proof. intros. apply strong_perm_unicity; assumption. Qed.

 Lemma permuted_pair: forall X Y' Y (f1: term Y X) (f2: term Y' X),
  RO f1 -> permut o perm_pair f2 f1 == pair f1 f2.
 Proof.
     intros. apply strong_unicity. rewrite assoc. remember wsc.
     rewrite strong_pi1_permut__pi2. rewrite weak_perm_proj_pi2_rwro; (solve[decorate] || idtac).
     apply weak_sym. apply weak_proj_pi1_rorw; decorate.
     rewrite assoc. remember sc. rewrite strong_pi2_permut__pi1.
     rewrite strong_perm_proj_pi1_rwro; (solve[decorate] || idtac). apply strong_sym.
     apply strong_proj_pi2_rorw; decorate.
 Qed.

 Lemma obs_local_global_2: forall X Y (f g : term Y X),
 (forall i: Loc, lookup i o forget o f ~~ lookup i o forget o g) ->  f ~~ g -> f == g.
 Proof.
     intros. apply comp_final_unique. apply observation. intros.
     rewrite assoc. rewrite assoc. apply H. assumption.
 Qed.

 (* additional lemmas about [passbool] and [copair] *)
 Lemma passbool_true: passbool o constant true == copi1.
 Proof.
     unfold passbool. unfold constant. rewrite pure_pure. unfold copi1.
     apply pure_eq. intros. simpl. rewrite x. reflexivity.
 Qed.

 Lemma passbool_false: passbool o constant false == copi2.
 Proof.
    unfold passbool. unfold constant. setoid_rewrite pure_pure.
    apply pure_eq.  now intros [].
 Qed.

 Lemma copair_true A f g: @copair _ _ A f g o (passbool o constant true) == f.
 Proof. rewrite passbool_true. apply strong_coproj_copi1_rwrw. Qed.

 Lemma copair_false A f g: @copair _ _ A f g o (passbool o constant false) == g.
 Proof. rewrite passbool_false. apply strong_coproj_copi2_rwrw. Qed.

(* -------------------- End of Derived Rules -------------------- *)

End Make.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.bachmann_s_lotschnittaxiom_variant.
Require Import GeoCoq.Tarski_dev.Ch11_angles.

Section weak_triangle_circumscription_principle_bachmann_s_lotschnittaxiom.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma weak_triangle_circumscription_principle__bachmann_s_lotschnittaxiom :
  weak_triangle_circumscription_principle -> bachmann_s_lotschnittaxiom.
Proof.
intro HP.
apply bachmann_s_lotschnittaxiom_aux.
intros A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD Hd1 Hd2 HPerp1 HPerp2 HPerp3.
intros HCol1 HCol2 HCol3 HCol4 HCol5 HCol6 HCop1 HCop2 HCop3 HCop4.
destruct (symmetric_point_construction IAB IAC) as [E HE].
destruct (symmetric_point_construction IAB IBD) as [F HF].
assert_diffs.
assert (HPerp4 : Perp E IAB IAB F).
  {
  apply perp_col0 with B1 B2; [apply perp_col0 with A1 A2|..]; ColR.
  }
assert (~ Col IAC IAB IBD).
  apply per_not_col; auto; apply per_col with F; Col; apply l8_2, per_col with E; Perp; Col.
assert (Coplanar E F IAB D1) by CopR.
assert (Coplanar E F IAB D2) by CopR.
assert (Coplanar E F IAB C1) by CopR.
assert (Coplanar E F IAB C2) by CopR.
destruct (HP E F IAB D1 D2 C1 C2) as [I [HC7 HC8]]; auto;
[apply not_col_permutation_1, perp_not_col| |split..|exists I; split; Col]; Perp; split.
  exists IBD; split; auto.
  left; apply perp_col0 with B1 B2; ColR.
  exists IAC; split; auto.
  left; apply perp_col0 with A1 A2; ColR.
Qed.

End weak_triangle_circumscription_principle_bachmann_s_lotschnittaxiom.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool eqtype ssrnat seq fintype ssrfun tuple finset.
From Bits
     Require Import bits ssrextra.tuple.
Require Import spec min.

Definition keep_min {n} (bs: BITS n): BITS n
  := andB bs (negB bs).

Lemma keep_min_repr:
  forall n (bs: BITS n) E x, repr bs E -> x \in E ->
    repr (keep_min bs) [set [arg min_(k < x in E) k]].
Proof.
  move=> n bs.
  rewrite /keep_min.
  have ->: andB bs (negB bs) = setBit #0 (index true bs) true.
  elim: n bs=> [bs|n IHn /tupleP[b bs]].
  + (* bs ~ [tuple] *)
    by rewrite tuple0.
  + (* bs ~ [tuple of b :: bs] *)
    case: b.
    - (* b ~ true *)
      by rewrite /negB /incB /invB /andB /=
                 liftUnOpCons !tuple.beheadCons liftBinOpCons andbT
                 -/andB -/invB andB_invB fromNat0.
    - (* b ~ false *)
      by rewrite /negB /incB /invB /andB /=
                 liftUnOpCons tuple.theadCons !tuple.beheadCons liftBinOpCons andbF
                 -/andB -/invB -/incB -/negB IHn.
  move=> E x HE Hx.
  rewrite (@index_repr n bs x E)=> //.
  by apply singleton_repr.
Qed.


Require Import Arith.
Require Import List.

(*
Require Import Peano.
Require Import Peano_dec.
*)

Inductive Ty : nat -> Set :=
| TV : forall n, Ty (S n)
| Imp : forall n, Ty n -> Ty n -> Ty n
| All : forall n, Ty (S n) -> Ty n
| TW : forall n, Ty n -> Ty (S n).

Implicit Arguments TW [n].
Implicit Arguments Imp [n].
Implicit Arguments All [n].

Inductive Term : Set :=
| V : nat -> Term
| App : Term -> Term -> Term
| TApp : forall n, Term -> Ty n -> Term
| Abs : forall n, Ty n -> Term -> Term
| Lam : Term -> Term.

Implicit Arguments TApp [n].
Implicit Arguments Abs [n].

Inductive Holds : Set :=
| H : forall n, list (Ty n) -> Term -> Ty n -> Holds.

Notation "n ; l |= t @ ty" := (H n l t ty) (at level 60).
Open Scope list_scope.

Definition tyshift : forall i (ty : Ty i) (d : nat), Ty (S i).
Proof.
  refine
    (fix tyshift (i : nat) (ty : Ty i) (d : nat) {struct ty} : Ty (S i) :=
      (match ty in Ty i' return (i=i' -> Ty (S i)) with
         | TV m =>
           (fun p =>
             if le_lt_dec d m
               then _
               else _)
         | Imp i' t s => (fun t' s' p => _) (tyshift i' t d) (tyshift i' s d)
         | All i' t => (fun t' p => All _) (tyshift (S i') t (d+1))
         | TW i' t => (fun t' p => TW _) (tyshift i' t d)
       end) (refl_equal i)).
  (* d <= m *)
  rewrite p. exact (TV (S m)).
  (* d > m *)
  rewrite p. exact (TW (TV m)).
  (* Imp *)
  rewrite p. exact (Imp t' s').
  (* All *)
  rewrite p. exact t'.
  (* TW *)
  rewrite p. exact t'.
Defined.

Print tyshift.

Eval compute in (tyshift.

(*
Fixpoint tyshift (i : nat) (ty : Ty i) (d : nat) {struct ty} : Ty (S i):=
  match ty with
    | TV m => if le_lt_dec d m then TV (m+1) else TV m
    | Imp t s => Imp (tyshift t d) (tyshift s d)
    | All t => All (tyshift t (d+1))
  end.
  *)

Fixpoint tysub (ty : Ty) (d : nat) (n : nat) (s : Ty) {struct ty} : Ty :=
  match ty with
    | TV m =>
      if eq_nat_dec n m
        then s
        else if le_lt_dec d m
          then TV m
          else TV (m+1)
    | Imp ty1 ty2 => Imp (tysub ty1 d n s) (tysub ty2 d n s)
    | All t => All (tysub t (d+1) (n+1) (tyshift s d))
  end.

Fixpoint tysubt (t : Term) (d : nat) (n : nat) (s : Ty) {struct t} : Term :=
  match t with
    | V m => V m
    | Abs ty t => Abs (tysub ty d n s) (tysubt t d n s)
    | Lam t => Lam (tysubt t (d+1) n s)
    | App f g => App (tysubt f d n s) (tysubt g d n s)
    | TApp f ty => TApp (tysubt f d n s) (tysub ty d n s)
  end.

Inductive Derivation : Holds -> Set :=
| ImpIntro : forall n l t ty xty,
  Derivation (n  ; l |= t @ ty) ->
  Derivation (n ; xty::l |= (Abs xty t) @ (Imp xty ty))
| ImpElim : forall n l t f ty xty,
  Derivation (n ; l |= t @ xty) ->
  Derivation (n ; l |= f @ (Imp xty ty)) ->
  Derivation (n ; l |= (App f t) @ ty)
| AllIntro : forall n l t ty,
  Derivation (S n ; l |= t @ ty) ->
  Derivation (n ; l |= (Lam t) @ All ty)
| AllElim : forall n l t ty tyx,
  Derivation (n ; l |= (TApp t tyx) @ ty) ->
  Derivation (S n ; l |= t @ (tysub ty n n tyx))
| VarIntro : forall n l ty,
  Derivation (n ; ty::l |= V (length l) @ ty)
| Weaken : forall n l t ty,
  Derivation (n ; l |= t @ ty) ->
  Derivation (

Definition Zero := (All (TV 0)).
Definition One := (Imp Zero Zero).

Definition check : forall n l t ty, option (Derivation (n ; l |= t @ ty)).
Proof.
  induction t.