(** * Redblack: Implementation and Proof of Red-Black Trees *)

(* ################################################################# *)
(** * Required Reading *)

(**
 (1) General background on red-black trees,
   - Section 3.3 of  _Algorithms, Fourth Edition_,
       by Sedgewick and Wayne, Addison Wesley 2011;  or
   - Chapter 13 of _Introduction to Algorithms, 3rd Edition_,
       by Cormen, Leiserson, and Rivest, MIT Press 2009
   - or Wikipedia.

 (2) an explanation of the particular implementation we use here.
 Red-Black Trees in a Functional Setting, by Chris Okasaki.
_Journal of Functional Programming_, 9(4):471-477, July 1999.
 http://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp99redblack.pdf

 (3) Optional reading:
  Efficient Verified Red-Black Trees, by Andrew W. Appel, September 2011.
  http://www.cs.princeton.edu/~appel/papers/redblack.pdf
*)

(** Red-black trees are a form of binary search tree (BST), but with
     _balance_.   Recall that the _depth_ of a node in a tree is the
    distance from the root to that node.  The _height_ of a tree is
    the depth of the deepest node.  The [insert] or [lookup] function
    of the BST algorithm (Chapter [SearchTree]) takes time
    proportional to the depth of the node that is found (or inserted).
    To make these functions run fast, we want trees where the
    worst-case depth (or the average depth) is as small as possible.

    In a perfectly balanced tree of N nodes, every node has depth less
    than or or equal to log N, using logarithms base 2.   In an
    approximately balanced tree, every node has depth less than or
    equal to 2 log N.  That's good enough to make [insert] and [lookup]
    run in time proportional to log N.

    The trick is to mark the nodes Red and Black, and by these marks
    to know when to locally rebalance the tree.  For more explanation
    and pictures, see the Required Reading above.
*)

From VFA Require Import Perm.
From VFA Require Import Extract.
Require Import Coq.Lists.List.
Export ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import ZArith.
Open Scope Z_scope.

Definition key := int.

Inductive color := Red | Black.

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

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

 Definition empty_tree := E.

(** lookup is exactly as in our (unbalanced) search-tree algorithm in
  Extract.v, except that the [T] constructor carries a [color] component,
  which we can ignore here. *)

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

(** The [balance] function is copied directly from Okasaki's paper.
  Now, the nice thing about machine-checked proof in Coq is that you
  can prove this correct without actually understanding it!
  So, do read Okasaki's paper, but don't worry too much about the details
  of this [balance] function.

  In contrast, Sedgewick has proposed _left-leaning red-black trees_,
  which have a simpler balance function (but a more complicated invariant).
  He does this in order to make the proof of correctness easier: there
  are fewer cases in the [balance] function, and therefore fewer cases
  in the case-analysis of the proof of correctness of [balance].  But as you
  will see, our proofs about [balance] will have automated case analyses,
  so we don't care how many cases there are! *)

Definition balance rb t1 k vk t2 :=
 match rb with Red => T Red t1 k vk t2
 | _ =>
 match t1 with
 | T Red (T Red a x vx b) y vy c =>
      T Red (T Black a x vx b) y vy (T Black c k vk t2)
 | T Red a x vx (T Red b y vy c) =>
      T Red (T Black a x vx b) y vy (T Black c k vk t2)
 | a => match t2 with
            | T Red (T Red b y vy c) z vz d =>
                T Red (T Black t1 k vk b) y vy (T Black c z vz d)
            | T Red b y vy (T Red c z vz d)  =>
                T Red (T Black t1 k vk b) y vy (T Black c z vz d)
            | _ => T Black t1 k vk t2
            end
  end
 end.

Definition makeBlack t :=
  match t with
  | E => E
  | T _ a x vx b => T Black a x vx b
  end.

Fixpoint ins x vx s :=
 match s with
 | E => T Red E x vx E
 | T c a y vy b => if ltb x y then balance c (ins x vx a) y vy b
                        else if ltb y x then balance c a y vy (ins x vx b)
                        else T c a x vx b
 end.

Definition insert x vx s := makeBlack (ins x vx s).

(** Now that the program has been defined, it's time to prove its properties.
   A red-black tree has two kinds of properties:
  - [SearchTree]: the keys in each left subtree are all less than the
       node's key, and the keys in each right subtree are greater
  - [Balanced]:  there is the same number of black nodes on any path from
     the root to each leaf; and there are never two red nodes in a row.

  First, we'll treat the [SearchTree] property. *)

(* ################################################################# *)
(** * Proof Automation for Case-Analysis Proofs. *)

Lemma T_neq_E:
  forall c l k v r, T c l k v r <> E.
Proof.
intros. intro Hx. inversion Hx.
Qed.

(** Several of the proofs for red-black trees require a big case analysis
   over all the clauses of the [balance] function. These proofs are very tedious
   to do "by hand," but are easy to automate. *)

Lemma ins_not_E: forall x vx s, ins x vx s <> E.
Proof.
intros. destruct s; simpl.
apply T_neq_E.
remember (ins x vx s1) as a1.
unfold balance.

(** Here we go!  Let's just "destruct" on the topmost case.
   Right, here it's [ltb x k].  We can use [destruct] instead of [bdestruct]
   because we don't need to remember whether [x<k] or [x>=k]. *)

destruct (ltb x k).
(* The topmost test is [match c with...], so just [destruct c] *)
destruct c.
(* This one is easy. *)
apply T_neq_E.
(* The topmost test is [match a1 with...], so just [destruct a1] *)
destruct a1.
(* The topmost test is [match s2 with...], so just [destruct s2] *)
destruct s2.
(* This one is easy by inversion. *)
intro Hx; inversion Hx.

(** How long will this go on?  A long time!  But it will terminate.
    Just keep typing.  Better yet, let's automate.
    The following tactic applies whenever the current goal looks like,
      [match ?c with Red => _ | Black => _  end <> _ ],
     and what it does in that case is, [destruct c] *)

match goal with
| |- match ?c with Red => _ | Black => _  end <> _=> destruct c
end.

(**  The following tactic applies whenever the current goal looks like,

     [match ?s with E => _ | T _ _ _ _ _ => _ end  <> _],

     and what it does in that case is, [destruct s] *)

match goal with
    | |- match ?s with E => _ | T _ _ _ _ _ => _ end  <> _=>destruct s
end.

(** Let's apply that tactic again, and then try it on the subgoals, recursively.
    Recall that the [repeat] tactical keeps trying the same tactic on subgoals. *)

repeat match goal with
    | |- match ?s with E => _ | T _ _ _ _ _ => _ end  <> _=>destruct s
end.
match goal with
  | |- T _ _ _ _ _ <> E => apply T_neq_E
end.

(** Let's start the proof all over again. *)

Abort.

Lemma ins_not_E: forall x vx s, ins x vx s <> E.
Proof.
intros. destruct s; simpl.
apply T_neq_E.
remember (ins x vx s1) as a1.
unfold balance.

(** This is the beginning of the big case analysis.  This time,
  let's combine several tactics together: *)

repeat match goal with
  | |- (if ?x then _ else _) <> _ => destruct x
  | |- match ?c with Red => _ | Black => _  end <> _=> destruct c
  | |- match ?s with E => _ | T _ _ _ _ _ => _ end  <> _=>destruct s
end.

(** What we have left is 117 cases, every one of which can be proved
  the same way: *)

apply T_neq_E.
apply T_neq_E.
apply T_neq_E.
apply T_neq_E.
apply T_neq_E.
apply T_neq_E.
(* Only 111 cases to go... *)
apply T_neq_E.
apply T_neq_E.
apply T_neq_E.
apply T_neq_E.
(* Only 107 cases to go... *)
Abort.

Lemma ins_not_E: forall x vx s, ins x vx s <> E.
Proof.
intros. destruct s; simpl.
apply T_neq_E.
remember (ins x vx s1) as a1.
unfold balance.

(** This is the beginning of the big case analysis.  This time,
  we add one more clause to the [match goal] command: *)

repeat match goal with
  | |- (if ?x then _ else _) <> _ => destruct x
  | |- match ?c with Red => _ | Black => _  end <> _=> destruct c
  | |- match ?s with E => _ | T _ _ _ _ _ => _ end  <> _=>destruct s
  | |- T _ _ _ _ _ <> E => apply T_neq_E
 end.
Qed.

(* ################################################################# *)
(** * The SearchTree Property *)

(** The SearchTree property for red-black trees is exactly the
   same as for ordinary searchtrees (we just ignore the color [c]
   of each node). *)

Inductive SearchTree' : Z -> tree -> Z -> Prop :=
| ST_E : forall lo hi, lo <= hi -> SearchTree' lo E hi
| ST_T: forall lo c l k v r hi,
    SearchTree' lo l (int2Z k) ->
    SearchTree' (int2Z k + 1) r hi ->
    SearchTree' lo (T c l k v r) hi.

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

(** Now we prove that if [t] is a SearchTree, then the rebalanced
     version of [t] is also a SearchTree. *)
Lemma balance_SearchTree:
 forall c  s1 k kv s2 lo hi,
   SearchTree' lo s1 (int2Z k) ->
   SearchTree' (int2Z k + 1) s2 hi ->
   SearchTree' lo (balance c s1 k kv s2) hi.
Proof.
intros.
unfold balance.

(** Use proof automation for this case analysis. *)

repeat  match goal with
  |  |- SearchTree' _ (match ?c with Red => _ | Black => _ end) _ => destruct c
  |  |- SearchTree' _ (match ?s with E => _ | T _ _ _ _ _ => _ end) _ => destruct s
  end.

(** 58 cases to consider! *)

* constructor; auto.
* constructor; auto.
* constructor; auto.
* constructor; auto.
  constructor; auto. constructor; auto.
  (* To prove this one, we have to do [inversion] on  the proof goals above the line. *)
  inv H. inv H0. inv H8. inv H9.
  auto.
  constructor; auto.
  inv H. inv H0. inv H8. inv H9. auto.
  inv H. inv H0. inv H8. inv H9. auto.

(** There's a pattern here.  Whenever we have a hypothesis above the line
    that looks like,
    -  H: SearchTree' _ E _
    -  H: SearchTree' _ (T _ _ _ _ _) _

   we should invert it.   Let's build that idea into our proof automation.
*)

Abort.

Lemma balance_SearchTree:
 forall c  s1 k kv s2 lo hi,
   SearchTree' lo s1 (int2Z k) ->
   SearchTree' (int2Z k + 1) s2 hi ->
   SearchTree' lo (balance c s1 k kv s2) hi.
Proof.
intros.
unfold balance.

(** Use proof automation for this case analysis. *)

repeat  match goal with
  | |- SearchTree' _ (match ?c with Red => _ | Black => _ end) _ =>
             destruct c
  | |- SearchTree' _ (match ?s with E => _ | T _ _ _ _ _ => _ end) _ =>
             destruct s
  | H: SearchTree' _ E _   |- _  => inv H
  | H: SearchTree' _ (T _ _ _ _ _) _   |- _  => inv H
  end.
(** 58 cases to consider! *)

* constructor; auto.
* constructor; auto. constructor; auto. constructor; auto.
* constructor; auto. constructor; auto. constructor; auto. constructor; auto. constructor; auto.
* constructor; auto. constructor; auto. constructor; auto. constructor; auto. constructor; auto.
* constructor; auto. constructor; auto. constructor; auto. constructor; auto. constructor; auto.

(** Do we see a pattern here?  We can add that to our automation! *)

Abort.

Lemma balance_SearchTree:
 forall c  s1 k kv s2 lo hi,
   SearchTree' lo s1 (int2Z k) ->
   SearchTree' (int2Z k + 1) s2 hi ->
   SearchTree' lo (balance c s1 k kv s2) hi.
Proof.
intros.
unfold balance.

(** Use proof automation for this case analysis. *)

repeat  match goal with
  | |- SearchTree' _ (match ?c with Red => _ | Black => _ end) _ =>
              destruct c
  | |- SearchTree' _ (match ?s with E => _ | T _ _ _ _ _ => _ end) _ =>
              destruct s
  | H: SearchTree' _ E _   |- _  => inv H
  | H: SearchTree' _ (T _ _ _ _ _) _   |- _  => inv H
  end;
 repeat (constructor; auto).
Qed.

(** **** Exercise: 2 stars (ins_SearchTree)  *)
(** This one is pretty easy, even without proof automation.
  Copy-paste your proof of insert_SearchTree from Extract.v.
  You will need to apply [balance_SearchTree] in two places.
 *)
Lemma ins_SearchTree:
   forall x vx s lo hi,
                    lo <= int2Z x ->
                    int2Z x < hi ->
                    SearchTree' lo s hi ->
                    SearchTree' lo (ins x vx s) hi.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (valid)  *)

Lemma empty_tree_SearchTree: SearchTree empty_tree.
(* FILL IN HERE *) Admitted.

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

Lemma expand_range_SearchTree':
  forall s lo hi,
   SearchTree' lo s hi ->
   forall lo' hi',
   lo' <= lo -> hi <= hi' ->
   SearchTree' lo' s hi'.
Proof.
induction 1; intros.
constructor.
omega.
constructor.
apply IHSearchTree'1; omega.
apply IHSearchTree'2; omega.
Qed.

Lemma insert_SearchTree: forall x vx s,
    SearchTree s -> SearchTree (insert x vx s).
(* FILL IN HERE *) Admitted.
(** [] *)

Import IntMaps.

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

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

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 (int2Z k).
Proof.  (* Copy your proof from Extract.v, and adapt it. *)
(* FILL IN HERE *) Admitted.
(** [] *)

Lemma Abs_helper:
  forall m' t m, Abs t m' ->    m' = m ->     Abs t m.
Proof.
   intros. subst. auto.
Qed.

Ltac contents_equivalent_prover :=
 extensionality x; unfold t_update, combine, t_empty;
 repeat match goal with
  | |- context [if ?A then _ else _] => bdestruct A
 end;
 auto;
 omega.

(** **** Exercise: 4 stars (balance_relate)  *)
(** You will need proof automation for this one.  Study the methods used
  in [ins_not_E] and [balance_SearchTree], and try them here.
  Add one clause at a time to your [match goal]. *)

Theorem balance_relate:
  forall c l k vk r m,
    SearchTree (T c l k vk r) ->
    Abs (T c l k vk r) m ->
    Abs (balance c l k vk r) m.
Proof.
intros.
inv H.
unfold balance.
repeat match goal with
 | H: Abs E _ |- _ => inv H
end.
(** Add these clauses, one at a time, to your [repeat match goal] tactic,
   and try it out:
   -1. Whenever a clause [H: Abs E _] is above the line, invert it by [inv H].
             Take note: with just this one clause, how many subgoals remain?
   -2. Whenever [Abs (T _ _ _ _ _) _] is above the line, invert it.
             Take note: with just these two clause, how many subgoals remain?
   -3. Whenever [SearchTree' _ E _] is above the line, invert it.
             Take note after this step and each step: how many subgoals remain?
   -4. Same for [SearchTree' _ (T _ _ _ _ _) _].
   -5. When [Abs match c with Red => _ | Black => _ end _] is below the line,
          [destruct c].
   -6. When [Abs match s with E => _ | T ... => _ end _] is below the line,
          [destruct s].
   -7. Whenever [Abs (T _ _ _ _ _) _] is below the line,
                  prove it by [apply Abs_T].   This won't always work;
         Sometimes the "cts" in the proof goal does not exactly match the form
         of the "cts" required by the [Abs_T] constructor.  But it's all right if
         a clause fails; in that case, the [match goal] will just try the next clause.
          Take note, as usual: how many clauses remain?
   -8.  Whenever [Abs E _] is below the line, solve it by [apply Abs_E].
   -9.  Whenever the current proof goal matches a hypothesis above the line,
          just use it.  That is, just add this clause:
       | |- _ => assumption
   -10.  At this point, if all has gone well, you should have exactly 21 subgoals.
       Each one should be of the form, [  Abs (T ...) (t_update...) ]
       What you want to do is replace (t_update...) with a different "contents"
       that matches the form required by the Abs_T constructor.
       In the first proof goal, do this: [eapply Abs_helper].
       Notice that you have two subgoals.
       The first subgoal you can prove by:
           apply Abs_T. apply Abs_T. apply Abs_E. apply Abs_E.
           apply Abs_T. eassumption. eassumption.
       Step through that, one at a time, to see what it's doing.
       Now, undo those 7 commands, and do this instead:
            repeat econstructor; eassumption.
       That solves the subgoal in exactly the same way.
       Now, wrap this all up, by adding this clause to your [match goal]:
       | |- _ =>  eapply Abs_helper; [repeat econstructor; eassumption | ]
   -11.  You should still have exactly 21 subgoals, each one of the form,
             [ t_update... = t_update... ].  Notice above the line you have some
           assumptions of the form,  [ H: SearchTree' lo _ hi ].  For this equality
         proof, we'll need to know that [lo <= hi].  So, add a clause at the end
        of your [match goal] to apply SearchTree'_le in any such assumption,
        when below the line the proof goal is an equality [ _ = _ ].
   -12.  Still exactly 21 subgoals.  In the first subgoal, try:
          [contents_equivalent_prover].   That should solve the goal.
          Look above, at [Ltac contents_equivalent_prover], to see how it works.
          Now, add a clause to  [match goal] that does this for all the subgoals.

   -Qed! *)

(* FILL IN HERE *) Admitted.

(** Extend this list, so that the nth entry shows how many subgoals
    were remaining after you followed the nth instruction in the list above.
    Your list should be exactly 13 elements long; there was one subgoal
    *before* step 1, after all. *)

Definition how_many_subgoals_remaining :=
    [1; 1; 1; 1; 1; 2

  ].
(** [] *)

(** **** Exercise: 3 stars (ins_relate)  *)
Theorem ins_relate:
 forall k v t cts,
    SearchTree t ->
    Abs t cts ->
    Abs (ins k v t) (t_update cts (int2Z k) v).
Proof.  (* Copy your proof from SearchTree.v, and adapt it.
     No need for fancy proof automation. *)
(* FILL IN HERE *) Admitted.
(** [] *)

Lemma makeBlack_relate:
 forall t cts,
    Abs t cts ->
    Abs (makeBlack t) cts.
Proof.
intros.
destruct t; simpl; auto.
inv H; constructor; auto.
Qed.

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

(** OK, we're almost done!  We have proved all these main theorems: *)

Check empty_tree_SearchTree.
Check empty_tree_relate.
Check lookup_relate.
Check insert_SearchTree.
Check insert_relate.

(** Together these imply that this implementation of red-black trees
     (1) preserves the representation invariant, and
     (2) respects the abstraction relation. *)

(** **** Exercise: 4 stars, optional (elements)  *)
(** Prove the correctness of the [elements] function.  Because [elements]
    does not pay attention to colors, and does not rebalance the tree,
    then its proof should be a simple copy-paste from SearchTree.v,
    with only minor edits. *)

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.

Definition elements_property (t: tree) (cts: total_map V) : Prop :=
   forall k v,
     (In (k,v) (elements t) -> cts (int2Z k) = v) /\
     (cts (int2Z k) <> default ->
      exists k', int2Z k = int2Z k' /\ In (k', cts (int2Z k)) (elements t)).

Theorem elements_relate:
  forall t cts,
  SearchTree t ->
  Abs t cts ->
  elements_property t cts.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Proving Efficiency *)

(** Red-black trees are supposed to be more efficient than ordinary search trees,
   because they stay balanced.  In a perfectly balanced tree, any two leaves
   have exactly the same depth, or the difference in depth is at most 1.
   In an approximately balanced tree, no leaf is more than twice as deep as
   another leaf.   Red-black trees are approximately balanced.
   Consequently, no node is more then 2logN deep, and the run time for
   insert or lookup is bounded by a constant times 2logN.

   We can't prove anything _directly_ about the run time, because we don't
   have a cost model for Coq functions.  But we can prove that the trees
   stay approximately balanced; this tells us important information about
   their efficiency. *)

(** **** Exercise: 4 stars (is_redblack_properties)   *)
(** The relation [is_redblack] ensures that there are exactly [n] black
   nodes in every path from the root to a leaf, and that there are never
   two red nodes in a row. *)

 Inductive is_redblack : tree -> color -> nat -> Prop :=
 | IsRB_leaf: forall c, is_redblack E c 0
 | IsRB_r: forall tl k kv tr n,
          is_redblack tl Red n ->
          is_redblack tr Red n ->
          is_redblack (T Red tl k kv tr) Black n
 | IsRB_b: forall c tl k kv tr n,
          is_redblack tl Black n ->
          is_redblack tr Black n ->
          is_redblack (T Black tl k kv tr) c (S n).

Lemma is_redblack_toblack:
  forall s n, is_redblack s Red n -> is_redblack s Black n.
Proof.
(* FILL IN HERE *) Admitted.

Lemma makeblack_fiddle:
  forall s n, is_redblack s Black n ->
            exists n, is_redblack (makeBlack s) Red n.
Proof.
(* FILL IN HERE *) Admitted.

(** [nearly_redblack] expresses, "the tree is a red-black tree, except that
  it's nonempty and it is permitted to have two red nodes in a row at
  the very root (only)."   *)

Inductive nearly_redblack : tree -> nat -> Prop :=
| nrRB_r: forall tl k kv tr n,
         is_redblack tl Black n ->
         is_redblack tr Black n ->
         nearly_redblack (T Red tl k kv tr) n
| nrRB_b: forall tl k kv tr n,
         is_redblack tl Black n ->
         is_redblack tr Black n ->
         nearly_redblack (T Black tl k kv tr) (S n).

Lemma ins_is_redblack:
  forall x vx s n,
    (is_redblack s Black n -> nearly_redblack (ins x vx s) n) /\
    (is_redblack s Red n -> is_redblack (ins x vx s) Black n).
Proof.
induction s; intro n; simpl; split; intros; inv H; repeat constructor; auto.
*
destruct (IHs1 n); clear IHs1.
destruct (IHs2 n); clear IHs2.
specialize (H0 H6).
specialize (H2 H7).
clear H H1.
unfold balance.

(** You will need proof automation, in a similar style to
   the proofs of [ins_not_E] and [balance_relate]. *)

(* FILL IN HERE *) Admitted.

Lemma insert_is_redblack:
  forall x xv s n, is_redblack s Red n ->
                    exists n', is_redblack (insert x xv s) Red n'.
Proof.
  (* Just apply a couple of lemmas:
     ins_is_redblack and makeblack_fiddle *)
(* FILL IN HERE *) Admitted.
(** [] *)

End TREES.

(* ################################################################# *)
(** * Extracting and Measuring Red-Black Trees *)

(** You can run this inside the ocaml top level by:

#use "redblack.ml";;
#use "test_searchtree.ml";;
run_tests();;

On my machine, in the byte-code interpreter this prints,

Insert and lookup 1000000 random integers in 0.889 seconds.
Insert and lookup 20000 random integers in 0.016 seconds.
Insert and lookup 20000 consecutive integers in 0.015 seconds.

You can compile and run this with the ocaml native-code compiler by:

ocamlopt redblack.mli redblack.ml -open Redblack test_searchtree.ml -o test_redblack
./test_redblack

On my machine this prints,

Insert and lookup 1000000 random integers in 0.436 seconds.
Insert and lookup 20000 random integers in 0. seconds.
Insert and lookup 20000 consecutive integers in 0. seconds.
*)

(* ################################################################# *)
(** * Success! *)
(** The benchmark measurements above (and in Extract.v) demonstrate that:
  - On random insertions, red-black trees are slightly faster than ordinary BSTs
     (red-black 0.436 seconds, vs ordinary 0.468 seconds)
  - On consecutive insertions, red-black trees are _much_ faster than ordinary BSTs
     (red-black 0. seconds, vs ordinary 0.374 seconds)
  In particular, red-black trees are almost exactly as fast on the
     consecutive insertions (0.015 seconds) as on the random (0.016 seconds).
*)


Require Import Examples.AutoSep.

(** * Like TrivialMem, but tests use of equality prover in symbolic evaluation *)

Definition readS : spec := SPEC("x", "y") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition read := bmodule "read" {{
  bfunction "read"("x", "y", "z") [readS]
    If ("x" = "y") {
      "z" <-* "y"
    } else {
      "z" <-* "x"
    };;
    Return "z"
  end
}}.

Theorem readOk : moduleOk read.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME  Print Timing Profile. *)
Qed.


(* THESE PROOFS are discussed in the book chapter entitled "Normalization
    of separation logic formulas" *)

Goal forall (P Q R: nat -> Prop),
    (forall z, P z -> Q (S z)) ->
         (exists z, P z) /\ R 0 -> (exists y, Q y).
Proof.
intros P Q R H.
Abort.

Require Import msl.msl_standard.
Require Import msl.normalize.

Section Example.
Context {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{agA: ageable A}{AgeA: Age_alg A}.

Goal forall P Q R: nat -> pred A,
       (forall z, P z |-- Q (S z)) ->
      (EX z:nat, P z) * R 0 |-- (EX y:nat, Q y) * TT.
Proof.
intros.
(* don't do this:    intros ? [a1 [a2 [? [[z ?] ?]]]]. *)
normalize.
intro x.
apply (exp_right (S x)).
apply sepcon_derives; auto.
Qed.

Goal forall (Q: nat -> Prop) (P R: nat -> pred A),
   (forall z, Q z -> Q (S z)) ->
   (forall z, !! Q (S z) && P z |-- R z)  ->
   forall z,  P z && !! Q z |-- !!Q (S z) && R z.
Proof.
intros.
normalize.
eapply derives_trans; [ | apply H0].
normalize.
Qed.

End EXample.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                              PolyList_dlist.v                            *)
(****************************************************************************)

Require Export List.
Require Export Dependent_lists.

Set Implicit Arguments.
Unset Strict Implicit.

Section Transformation.

  Variable A : Set.

  (** Conversion between dependent and non-dependent lists **)

  Fixpoint List_dlist (l : list A) (n : nat) {struct n} :
   length l = n -> d_list A n :=
    match n return (length l = n -> d_list A n) with
    | O => fun _ : length l = 0 => d_nil A
    | S p =>
        match l return (length l = S p -> d_list A (S p)) with
        | nil => fun h : 0 = S p => False_rec (d_list A (S p)) (O_S p h)
        | a :: t =>
            fun h : S (length t) = S p =>
            d_cons a (List_dlist (eq_add_S (length t) p h))
        end
    end.

  (** A more easy to translate a list into a dependent list **)

   Fixpoint list_dlist (l : list A) : d_list A (length l) :=
     match l return (d_list A (length l)) with
     | nil => d_nil A
     | a :: l' => d_cons a (list_dlist l')
     end.

  Fixpoint dlist_List (n : nat) (l : d_list A n) {struct l} :
   list A :=
    match l with
    | d_nil => nil (A:=A)
    | d_cons _ a t => a :: dlist_List t
    end.

End Transformation.

Lemma List_dlist_cons :
 forall (A : Set) (a : A) (l : list A),
 list_dlist (a :: l) = d_cons a (list_dlist l).
auto.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.

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

Reserved Notation "[ 'lens' x1 ; .. ; xn ]"
  (format "[ 'lens'  x1 ;  .. ;  xn ]").
Reserved Notation "[ 'lens' ]" (format "[ 'lens' ]").

(* Utility lemmas *)

Lemma addnLR m n p : m + n = p -> n = p - m.
Proof. move/(f_equal (subn^~ m)); by rewrite addKn. Qed.

Lemma ltn_ordK q (i : 'I_q) : Ordinal (ltn_ord i) = i.
Proof. by apply val_inj. Qed.

Lemma disjointP (T : finType) (a1 a2 : pred T) :
  reflect (forall i, i \in a1 -> ~ i \in a2) [disjoint a1 & a2].
Proof.
case/boolP: [disjoint a1 & a2] => /pred0P Hdisj; constructor.
  move=> i H1 H2. move: (Hdisj i). by rewrite /= H1 H2.
move=> H; elim: Hdisj => i /=.
case H1: (i \in a1) => //.
by apply/negbTE/negP/H.
Qed.

Lemma enum_filterP (T : finType) (P : pred T) :
  [seq x <- enum T | P x] = enum P.
Proof. by rewrite {2}/enum_mem -enumT. Qed.

Section tnth.
Variables (T : Type) (m n : nat) (vl : m.-tuple T) (vr : n.-tuple T).

Lemma cast_tuple_proof : m = n -> size vl == n.
Proof. by rewrite size_tuple => ->. Qed.

Definition cast_tuple (H : m = n) : n.-tuple T := Tuple (cast_tuple_proof H).

Lemma eq_ord_tuple (t1 t2 : n.-tuple 'I_m) :
  (t1 == t2) = (map val t1 == map val t2).
Proof.
case: eqP => [-> | H]; apply/esym/eqP => // /inj_map H'.
by elim H; apply/val_inj/H'/val_inj.
Qed.

Lemma nth_tnth i x0 (H : i < n) : nth x0 vr i = tnth vr (Ordinal H).
Proof. by rewrite (tnth_nth x0). Qed.

Lemma tnth_lshift i : tnth [tuple of vl ++ vr] (lshift n i) = tnth vl i.
Proof.
by rewrite (tnth_nth (tnth vl i)) /= nth_cat size_tuple ltn_ord -tnth_nth.
Qed.

Lemma tnth_rshift i : tnth [tuple of vl ++ vr] (rshift m i) = tnth vr i.
Proof.
rewrite (tnth_nth (tnth vr i)) /= nth_cat size_tuple ltnNge leq_addr /=.
by rewrite addKn -tnth_nth.
Qed.

Lemma eq_from_nth' (s1 s2 : seq T) :
  size s1 = size s2 -> (forall a i, i < size s1 -> nth a s1 i = nth a s2 i) ->
  s1 = s2.
Proof.
case: s1 => [|a s1 Hsz Heq].
   by move/esym/eqP/nilP ->.
exact (eq_from_nth Hsz (Heq a)).
Qed.
End tnth.

Lemma cast_tupleE n T (v : n.-tuple T) (H : n = n) : cast_tuple v H = v.
Proof. exact/val_inj. Qed.

Section tnth_eq.
Variables (A : eqType) (n : nat).
Lemma tnth_inj (t : n.-tuple A) : reflect (injective (tnth t)) (uniq t).
Proof.
apply: (iffP idP).
- move=> /uniqP Hu i j.
  rewrite (tnth_nth (tnth t i)) (tnth_nth (tnth t i) t j).
  move/(Hu (tnth t i) i j)/val_inj => -> //; by rewrite inE size_tuple.
- case: t => -[|a t] // Hlen Hinj.
  apply/(uniqP a) => i j.
  rewrite !inE !size_tuple => Hi Hj.
  by rewrite !nth_tnth => /Hinj [].
Qed.

Lemma index_tuple (t : n.-tuple A) i : (index i t < n) <-> (i \in t).
Proof. by rewrite -index_mem size_tuple. Qed.
End tnth_eq.

Section sorted.
Definition ord_ltn {r} : rel 'I_r := relpre val ltn.

Lemma sorted_enum r : sorted ord_ltn (enum 'I_r).
Proof.
rewrite /is_true -[RHS](iota_ltn_sorted 0 r) -val_enum_ord.
by elim: (enum 'I_r) => //= a [|b l] //= <-.
Qed.

Variables (A : Type) (le : rel A) (le_trans : transitive le).

Lemma sorted_tnth q (lq : q.-tuple A) (a b : 'I_q) :
  sorted le lq -> ord_ltn a b -> le (tnth lq a) (tnth lq b).
Proof.
move=> Hsort ab.
have := @sorted_ltn_nth _ le le_trans (tnth lq a) lq Hsort a b.
rewrite !inE !size_tuple !ltn_ord -!tnth_nth; exact.
Qed.

Lemma sorted_comp q (lq : q.-tuple A) (lr : seq 'I_q) :
  sorted le lq -> sorted ord_ltn lr -> sorted le (map (tnth lq) lr).
Proof.
move=> Hlq /=.
elim: lr => // a [|b lr] IH //= /andP[ab] Hsort.
rewrite sorted_tnth //=; exact: IH.
Qed.
End sorted.

Section lens.
Variables (T : Type) (n m : nat).

Record lens := mkLens {lens_t :> m.-tuple 'I_n ; lens_uniq : uniq lens_t}.
Canonical lens_subType := Eval hnf in [subType for lens_t].
Canonical lens_predType := PredType (pred_of_seq : lens -> pred 'I_n).

Definition endo1 := m.-tuple T -> m.-tuple T.

Variables (l : lens) (f : endo1).

Definition extract (t : n.-tuple T) := [tuple of map (tnth t) l].

Definition lens_sorted (l' : lens) := sorted ord_ltn l'.

Lemma mem_lensE : l =i val (lens_t l).
Proof. done. Qed.

Lemma size_lens : size l = m.
Proof. by rewrite size_tuple. Qed.

Lemma lens_leq : m <= n.
Proof.
rewrite -(size_enum_ord n) -size_lens uniq_leq_size // ?lens_uniq //.
move=> i _; by rewrite mem_enum.
Qed.

Lemma tnth_lensK i : index (tnth l i) l = i.
Proof.
by rewrite (tnth_nth (tnth l i)) index_uniq // (lens_uniq,size_lens).
Qed.

Lemma tnth_extract (v : n.-tuple T) i :
  tnth (extract v) i = tnth v (tnth l i).
Proof. by rewrite tnth_map. Qed.

Lemma eq_lens_tnth (l' : lens) : (tnth l =1 tnth l') -> l = l'.
Proof. by move/eq_from_tnth/val_inj. Qed.

Lemma lens_inj : injective (fun x : lens => x : seq _).
Proof. move=> x y H; exact/val_inj/val_inj. Qed.

Lemma tnth_lens_inj : injective (tnth l).
Proof. exact/tnth_inj/lens_uniq. Qed.

Lemma lens_sortedP :
  reflect (exists p, l = [seq i <- enum 'I_n | p i] :> seq _) (lens_sorted l).
Proof.
case/boolP: (lens_sorted l) => Hl; constructor.
  exists (mem l). apply/(irr_sorted_eq (leT:=ord_ltn)) => //.
  - exact/ltn_trans.
  - by move=> x; rewrite /ord_ltn /= ltnn.
  - rewrite sorted_filter //. exact/ltn_trans. exact/sorted_enum.
    by move=> i; rewrite mem_filter mem_enum andbT.
case => p Hp.
move/negP: Hl; elim.
rewrite /lens_sorted Hp sorted_filter //. exact/ltn_trans. exact/sorted_enum.
Qed.

Section lens_index.
Variables (i : 'I_n) (H : i \in l).

Definition lens_index : 'I_m := Ordinal (proj2 (index_tuple l i) H).

Definition make_lens_index : index i l = lens_index. Proof. by []. Qed.

Lemma tnth_lens_index : tnth l lens_index = i.
Proof. by rewrite (tnth_nth i) nth_index. Qed.
End lens_index.

Lemma lens_indexK i (H : tnth l i \in l) : lens_index H = i.
Proof. by apply/val_inj => /=; rewrite tnth_lensK. Qed.

(* Focusing on subvector *)
Definition inject (t : n.-tuple T) (t' : m.-tuple T) :=
  [tuple nth (tnth t i) t' (index i l) | i < n].
Definition focus1 t := inject t (f (extract t)).

Lemma focus1_out t i : i \notin l -> tnth (focus1 t) i = tnth t i.
Proof.
move=> Hi; by rewrite tnth_mktuple nth_default // memNindex ?size_tuple.
Qed.

Lemma focus1_in t : extract (focus1 t) = f (extract t).
Proof.
apply eq_from_tnth => i.
rewrite !tnth_map !tnth_ord_tuple [RHS](tnth_nth (tnth t (tnth l i))).
case: l => /= s Hu.
by rewrite index_uniq // size_tuple.
Qed.

Lemma nth_lens_index i (H : i \in l) dI (t : m.-tuple T) :
  nth dI t (index i l) = tnth t (lens_index H).
Proof. by rewrite make_lens_index -tnth_nth. Qed.

Lemma nth_lens_out dI (t : m.-tuple T) i :
  i \notin l -> nth dI t (index i l) = dI.
Proof. by move=> Hi; rewrite nth_default // memNindex // !size_tuple. Qed.

Lemma nth_extract_index dI t i :
  i \in l -> nth dI (extract t) (index i l) = tnth t i.
Proof. move=> H; by rewrite nth_lens_index tnth_map tnth_lens_index. Qed.

Lemma tnth_inject t t' i (H : i \in l) :
  tnth (inject t t') i = tnth t' (lens_index H).
Proof. by rewrite tnth_mktuple nth_lens_index. Qed.

Lemma tnth_inject_others t t' i :
  i \notin l -> tnth (inject t t') i = tnth t i.
Proof. by move=> H; rewrite tnth_mktuple nth_lens_out. Qed.

Lemma inject_extract t : inject t (extract t) = t.
Proof.
apply/eq_from_tnth => i.
case/boolP: (i \in l) => H; last by rewrite tnth_inject_others.
by rewrite tnth_inject tnth_extract tnth_lens_index.
Qed.
End lens.

(* Cast *)
Section cast_lens.
Variables (n n' m m' : nat) (l : lens n m) (l' : lens n m').

Definition cast_lens_ord (H : n = n') : lens n' m.
exists (map_tuple (cast_ord H) l).
abstract (by rewrite map_inj_uniq ?lens_uniq // => i j /cast_ord_inj).
Defined.

Definition cast_lens (H : m' = m) : lens n m.
exists (cast_tuple l' H).
apply lens_uniq.
Defined.

Lemma eq_lens_sorted :
  l =i l' -> lens_sorted l -> lens_sorted l' -> l = l' :> seq _.
Proof.
move/irr_sorted_eq; apply.
- exact: ltn_trans.
- by move=> x; rewrite /ord_ltn /= ltnn.
Qed.

Hypothesis H : l = l' :> seq _.

Lemma lens_size_eq : m' = m.
Proof. by rewrite -(size_tuple l') -H size_tuple. Qed.

Lemma lens_eq_cast : l = cast_lens lens_size_eq.
Proof. exact/lens_inj. Qed.

Lemma extract_eq_cast A (v : n.-tuple A) :
 extract l v = cast_tuple (extract l' v) lens_size_eq.
Proof. apply val_inj => /=. by rewrite H. Qed.
End cast_lens.

Lemma cast_lens_ordE n m (l : lens n m) H : cast_lens_ord (n':=n) l H = l.
Proof. apply/eq_lens_tnth => i; rewrite tnth_map; by apply/val_inj. Qed.

Lemma cast_lensE n m (l : lens n m) H : cast_lens (m':=m) l H = l.
Proof. exact/lens_inj. Qed.

(* Identity *)
Section lens_id.
Variable n : nat.
Lemma uniq_ord_tuple : uniq (ord_tuple n). Proof. exact/enum_uniq. Qed.
Definition lens_id := mkLens uniq_ord_tuple.

Lemma lens_sorted_id : lens_sorted lens_id.
Proof. exact: sorted_enum. Qed.

Lemma tnth_lens_id i : tnth lens_id i = i.
Proof. by rewrite tnth_ord_tuple. Qed.

Lemma extract_lens_id I (v : n.-tuple I) : extract lens_id v = v.
Proof. apply eq_from_tnth => i. by rewrite tnth_extract tnth_lens_id. Qed.

Lemma index_lens_id i : index i lens_id = i.
Proof. by rewrite {1}(_ : i = tnth lens_id i) (tnth_ord_tuple,tnth_lensK). Qed.
End lens_id.

(* Composition of lenses *)
Section lens_comp.
Variables (n m p : nat) (l1 : lens n m) (l2 : lens m p).

Definition lens_comp : lens n p.
exists (extract l2 l1).
abstract (by rewrite map_inj_uniq ?lens_uniq // => i j /tnth_lens_inj ->).
Defined.

Lemma tnth_comp i : tnth lens_comp i = tnth l1 (tnth l2 i).
Proof. by rewrite tnth_map. Qed.

Lemma lens_sorted_comp :
  lens_sorted l1 -> lens_sorted l2 -> lens_sorted lens_comp.
Proof. move=> Hl1 Hl2; apply sorted_comp => //; exact: ltn_trans. Qed.

Variable (T : Type).

Lemma extract_comp (t : n.-tuple T) :
  extract lens_comp t = extract l2 (extract l1 t).
Proof. apply eq_from_tnth => i; by rewrite !tnth_extract. Qed.

(* Composition for subvectors *)

Lemma index_lens_comp i (H : i \in l1) :
  index i lens_comp = index (lens_index H) l2.
Proof.
have {1}-> : i = tnth l1 (lens_index H) by rewrite (tnth_nth i) nth_index.
rewrite index_map //; exact/tnth_lens_inj.
Qed.

Lemma mem_lens_comp i (H : i \in l1) :
  (i \in lens_comp) = (lens_index H \in l2).
Proof. by rewrite -!index_mem !size_tuple index_lens_comp. Qed.

Lemma lens_comp_sub :
  {subset lens_comp <= l1}.
Proof.
by move=> i; rewrite mem_lensE => /mapP [j] _ ->; rewrite mem_tnth.
Qed.

Lemma mem_lens_comp_out i : i \notin l1 -> i \notin lens_comp.
Proof. by apply contra => /lens_comp_sub. Qed.

Lemma inject_comp (t : n.-tuple T) t' :
  inject l1 t (inject l2 (extract l1 t) t') = inject lens_comp t t'.
Proof.
apply eq_from_tnth => i.
case/boolP: (i \in l1) => Hl1.
  rewrite tnth_inject [RHS]tnth_mktuple index_lens_comp.
  case/boolP: (lens_index Hl1 \in l2) => Hl2.
    by rewrite tnth_inject make_lens_index -tnth_nth.
  by rewrite tnth_inject_others // tnth_extract tnth_lens_index nth_lens_out.
by rewrite !tnth_inject_others // mem_lens_comp_out.
Qed.

Lemma focus1A (f : p.-tuple T -> p.-tuple T) :
  focus1 l1 (focus1 l2 f) =1 focus1 lens_comp f.
Proof. move=> t; by rewrite /focus1 inject_comp extract_comp. Qed.

(* Commutativity of subvector operations *)

Section disjoint_lenses.
Variables (q r : nat) (l : lens n q) (l' : lens n r) (t : n.-tuple T).
Hypothesis Hdisj : [disjoint l & l'].

Lemma extract_inject t' : extract l (inject l' t t') = extract l t.
Proof.
apply eq_from_tnth => i; rewrite !tnth_extract tnth_mktuple.
by rewrite nth_lens_out // (disjointFr Hdisj) // mem_tnth.
Qed.

Lemma inject_disjointC vj vk :
  inject l' (inject l t vk) vj = inject l (inject l' t vj) vk.
Proof.
apply eq_from_tnth => i.
case/boolP: (i \in l) => Hil.
  have Hil' : i \notin l' by rewrite (disjointFr Hdisj) // mem_tnth.
  by rewrite tnth_inject_others // !tnth_inject.
case/boolP: (i \in l') => Hil'.
  by rewrite tnth_inject tnth_inject_others // tnth_inject.
by rewrite !tnth_inject_others.
Qed.

Lemma focus1_commu_in (f : endo1 T q) (g : endo1 T r) i : i \in l ->
  tnth (focus1 l f (focus1 l' g t)) i = tnth (focus1 l' g (focus1 l f t)) i.
Proof.
move=> Hl; have Hl' : i \notin l' by rewrite (disjointFr Hdisj).
by rewrite (focus1_out _ _ Hl') /focus1 extract_inject // !tnth_inject.
Qed.
End disjoint_lenses.

Lemma focus1C l3 (f : endo1 T m) (g : endo1 T p) :
  [disjoint l1 & l3] ->
  focus1 l1 f \o focus1 l3 g =1 focus1 l3 g \o focus1 l1 f.
Proof.
move=> Hdisj t /=.
apply eq_from_tnth => i.
case/boolP: (i \in l1) => Hl1; first exact: focus1_commu_in.
case/boolP: (i \in l3) => Hl3.
  by rewrite [RHS]focus1_commu_in // disjoint_sym.
by rewrite !focus1_out.
Qed.
End lens_comp.

Section lens_comp_id.
Variables (n m : nat) (l : lens n m).

Lemma lens_comp1l : lens_comp (lens_id n) l = l.
Proof. by apply/eq_lens_tnth => i; rewrite tnth_comp tnth_lens_id. Qed.

Lemma lens_compl1 : lens_comp l (lens_id m) = l.
Proof. by apply/eq_lens_tnth => i; rewrite tnth_comp tnth_lens_id. Qed.
End lens_comp_id.

Section lens_pred.
Variables (n : nat) (p : pred 'I_n).

Let pred_tuple := Tuple (enum_tupleP p).
Lemma uniq_pred_tuple : uniq pred_tuple.
Proof. exact/enum_uniq. Qed.

Definition lens_pred := mkLens uniq_pred_tuple.

Lemma lens_sorted_pred : lens_sorted lens_pred.
Proof. by apply/lens_sortedP; exists (mem p); rewrite enum_filterP. Qed.
End lens_pred.

(* Decomposition into inclusion and permutation *)
Section lens_basis_perm.
Variables (n p : nat) (l : lens n p).

Definition seq_basis := [seq i <- enum 'I_n | i \in l].
Lemma size_basis : size seq_basis == p.
Proof.
apply/eqP.
rewrite /seq_basis.
rewrite (eq_filter (a2:=mem [set i | i in l])); last first.
  move=> i. rewrite !inE.
  case: imsetP.
    by case => x Hx ->.
  by move=> Hx; apply/negP => Hi; move: Hx; elim; exists i.
rewrite enum_filterP /= -cardE card_imset // -[RHS](size_tuple l).
exact/card_uniqP/lens_uniq.
Qed.
Lemma uniq_basis : uniq (Tuple size_basis).
Proof. by rewrite filter_uniq // enum_uniq. Qed.

Definition lens_basis := mkLens uniq_basis.

Lemma mem_lens_basis : lens_basis =i l.
Proof. by move=> i; rewrite mem_filter mem_enum andbT. Qed.

Lemma lens_sorted_basis : lens_sorted lens_basis.
Proof. by apply/lens_sortedP; exists (mem l). Qed.

Lemma lens_basis_sortedE : lens_sorted l -> lens_basis = l.
Proof.
move=> H; exact/lens_inj/eq_lens_sorted/H/lens_sorted_basis/mem_lens_basis.
Qed.

Lemma perm_in_basis i : tnth l i \in lens_basis.
Proof. by rewrite mem_lens_basis mem_tnth. Qed.

Definition tuple_perm := [tuple lens_index (perm_in_basis i) | i < p].
Lemma uniq_perm : uniq tuple_perm.
Proof.
rewrite map_inj_uniq ?uniq_ord_tuple //.
move=> i j /(f_equal (tnth lens_basis)).
by rewrite !tnth_lens_index => /tnth_lens_inj.
Qed.

Definition lens_perm := mkLens uniq_perm.

Lemma lens_basis_perm : lens_comp lens_basis lens_perm = l.
Proof.
apply/eq_lens_tnth => i.
by rewrite tnth_comp tnth_mktuple tnth_lens_index.
Qed.

Lemma lens_perm_sortedE : lens_sorted l -> lens_perm = lens_id p.
Proof.
move=> H; apply/eq_lens_tnth => i.
rewrite tnth_mktuple tnth_ord_tuple.
apply/(tnth_inj lens_basis); first exact/lens_uniq.
by rewrite tnth_lens_index lens_basis_sortedE.
Qed.
End lens_basis_perm.

(* Composition of lenses *)
Section lens_cat.
Variables (n m p : nat) (l1 : lens n m) (l2 : lens n p).
Hypothesis Hdisj : [disjoint l1 & l2].

Definition lens_cat : lens n (m+p).
exists [tuple of l1 ++ l2].
abstract
  (case: l1 l2 Hdisj => l1' Hl1 [l2' Hl2] /= Hdisj';
   rewrite cat_uniq Hl1 Hl2 andbT /=;
   by apply/hasPn => /= i /(disjointFl Hdisj') ->).
Defined.

Lemma tnth_lens_cat_l i : tnth lens_cat (lshift p i) = tnth l1 i.
Proof. exact/tnth_lshift. Qed.

Lemma tnth_lens_cat_r i : tnth lens_cat (rshift m i) = tnth l2 i.
Proof. exact/tnth_rshift. Qed.

Variable (T : eqType).

Lemma extract_cat (t : n.-tuple T) :
  extract lens_cat t = [tuple of extract l1 t ++ extract l2 t].
Proof. apply val_inj => /=. by rewrite map_cat. Qed.
End lens_cat.

Section merge_lens.
Variables (I : Type) (dI : I) (n m : nat) (l : lens n m).

Lemma cards_filter (A : finType) (p : pred A) :
  #|[set a : A | p a]| = size [seq a <- enum A | p a].
Proof.
rewrite cardsE /= cardE -filter_predI.
congr size; apply eq_filter => /= i.
by rewrite !inE andbT.
Qed.

Definition others := [seq i <- enum 'I_n | i \notin l].
Lemma size_others : size others == n - m.
Proof.
move/cardsC/addnLR: [set i in l].
rewrite [LHS]cards_filter.
rewrite (_ : filter _ _ = others); last by apply eq_filter => i; rewrite !inE.
move/card_uniqP: (lens_uniq l).
by rewrite size_tuple cardT size_enum_ord cardsE => -> ->.
Qed.

Lemma mem_others i : (i \in others) = ~~ (i \in l).
Proof. by rewrite mem_filter mem_enum andbT. Qed.

Lemma uniq_others : uniq others.
Proof. by rewrite filter_uniq // enum_uniq. Qed.

Definition lothers : lens n (n-m).
exists (Tuple size_others).
exact uniq_others.
Defined.

Lemma mem_lothers i : (i \in lothers) = (i \notin l).
Proof. by rewrite mem_others. Qed.

Lemma lens_sorted_lothers : lens_sorted lothers.
Proof. exact/sorted_filter/sorted_enum/ltn_trans. Qed.

Definition merge_indices (v : m.-tuple I) (w : (n-m).-tuple I) :=
  [tuple nth (nth dI w (index i lothers)) v (index i l) | i < n].

Lemma tnth_merge_indices i vi vj (Hil : i \in l) :
  tnth (merge_indices vi vj) i = tnth vi (lens_index Hil).
Proof.
by rewrite !tnth_map !tnth_ord_tuple (make_lens_index Hil) -tnth_nth.
Qed.

Lemma tnth_merge_indices_lothers i vi vj (Hil : i \in lothers) :
  tnth (merge_indices vi vj) i = tnth vj (lens_index Hil).
Proof.
have Hil' := Hil; rewrite mem_lothers in Hil'.
rewrite !tnth_map !tnth_ord_tuple nth_lens_out //.
by rewrite (make_lens_index Hil) -!tnth_nth.
Qed.

Lemma extract_merge v1 v2 : extract l (merge_indices v1 v2) = v1.
Proof.
apply eq_from_tnth => i; rewrite tnth_extract.
by rewrite (tnth_merge_indices _ _ (mem_tnth i l)) lens_indexK.
Qed.

Lemma extract_lothers_merge v1 v2 : extract lothers (merge_indices v1 v2) = v2.
Proof.
apply eq_from_tnth => i /=; rewrite tnth_extract.
by rewrite (tnth_merge_indices_lothers _ _ (mem_tnth i lothers)) lens_indexK.
Qed.

Lemma merge_indices_extract_others v1 v2 :
  merge_indices v2 (extract lothers v1) = inject l v1 v2.
Proof.
apply eq_from_tnth => i.
case/boolP: (i \in l) => Hil.
  by rewrite tnth_merge_indices tnth_inject.
rewrite tnth_inject_others //.
rewrite -mem_lothers in Hil.
by rewrite tnth_merge_indices_lothers tnth_extract tnth_lens_index.
Qed.

Lemma merge_indices_extract (v : n.-tuple I) :
  merge_indices (extract l v) (extract lothers v) = v.
Proof. by rewrite merge_indices_extract_others inject_extract. Qed.

Lemma merge_indices_inj vj : injective (fun vi => merge_indices vi vj).
Proof.
move=> vi vi' Hm.
by rewrite -(extract_merge vi vj) -(extract_merge vi' vj) Hm.
Qed.

Lemma extract_merge_disjoint p (l' : lens n p) vi vj :
  [disjoint l & l'] ->
  extract l' (merge_indices vj (extract lothers vi)) = extract l' vi.
Proof.
move=> Hdisj; apply eq_from_tnth => i; rewrite !tnth_extract.
have Hil : tnth l' i \notin l by rewrite (disjointFl Hdisj) // mem_tnth.
have Hilo : tnth l' i \in lothers by rewrite mem_lothers.
by rewrite tnth_merge_indices_lothers tnth_extract tnth_lens_index.
Qed.
End merge_lens.

Lemma eq_lothers n m m' (l : lens n m) (l' : lens n m') :
  l =i l' -> lothers l = lothers l' :> seq _.
Proof. by move=> ll'; apply/eq_filter => i; rewrite ll'. Qed.

Section lens_comp_lothers.
Variables (n m p : nat) (l : lens n m) (l' : lens (n - m) p).

Lemma disjoint_comp_lothers : [disjoint l & lens_comp (lothers l) l'].
Proof.
rewrite disjoint_sym disjoint_has.
rewrite -all_predC.
apply/allP => i Hi /=.
apply/negP => Hi'.
move: Hi => /= /mapP [j Hj] ij.
have : i \notin l.
  by rewrite -mem_lothers ij mem_tnth.
by rewrite Hi'.
Qed.

Lemma lens_comp_lothers :
  lens_comp (lothers l) (lothers l') =
  lothers (lens_cat disjoint_comp_lothers) :> seq _.
Proof.
rewrite /= /others.
rewrite (eq_filter (a2:=preim (tnth (Tuple (size_others l)))
                    (mem (lothers (lens_comp (lothers l) l'))))); last first.
  move=> i /=.
  rewrite mem_lothers mem_lens_comp ?mem_tnth // => H.
  by rewrite lens_indexK.
rewrite -filter_map (_ : map _ _ = lothers l); last first.
  rewrite -(val_ord_tuple (n-m)); set mp := map _ _.
  by rewrite (_ : mp = [tuple of mp]) // -tuple_map_ord.
rewrite -filter_predI.
apply eq_filter => i /=.
by rewrite [in RHS]mem_lensE /= mem_cat negb_or andbC mem_lothers.
Qed.
End lens_comp_lothers.

(* Empty lens *)
Section lens_empty.
Variable n : nat.
Definition lens_empty : lens n 0 := {|lens_t := [tuple]; lens_uniq := erefl|}.

Lemma lens_sorted_empty : lens_sorted lens_empty.
Proof. done. Qed.

Lemma eq_lens_empty (l : lens n 0) : l = lens_empty.
Proof. case: l => -[] [] // Hl Hu; exact/lens_inj. Qed.

Lemma extract_lens_empty T (l : lens n 0) v : extract (T:=T) l v = [tuple].
Proof. apply eq_from_tnth => x. have := ltn_ord x. by rewrite ltn0. Qed.

Lemma lothers_id : lothers (lens_id n) = lens_empty :> seq _.
Proof. apply/nilP. by rewrite /nilp size_tuple subnn. Qed.

Lemma lothers_empty : lothers lens_empty = lens_id n :> seq _.
Proof. by rewrite /lothers /others /= filter_predT. Qed.

Lemma merge_indices_empty (T : eqType) (dI:T) v w :
  merge_indices dI lens_empty v w = cast_tuple w (subn0 n).
Proof.
rewrite /merge_indices.
rewrite (eq_mktuple (tnth (cast_tuple w (subn0 n)))); last first.
  move => i.
  by rewrite nth_lens_out // lothers_empty index_lens_id (tnth_nth dI).
by apply eq_from_tnth => i; rewrite tnth_mktuple.
Qed.

Lemma lens_cat_emptyl m (l : lens n m) (H : [disjoint lens_empty & l]) :
  lens_cat H = l.
Proof. exact/lens_inj. Qed.
End lens_empty.

Section lens_full.
Lemma mem_lens_full n i (l : lens n n) : i \in l.
Proof.
move/card_uniqP: (lens_uniq l) (cardC (mem l)) ->.
rewrite card_ord size_tuple => /(f_equal (subn^~ n)).
rewrite addKn subnn => /card0_eq/(_ i).
by rewrite !inE => /negbFE.
Qed.

Lemma lothers_full n (l : lens n n) : lothers l = lens_empty n :> seq _.
Proof.
rewrite /= /others (eq_filter (a2:=pred0)) ?filter_pred0 //= => i.
by rewrite mem_lens_full.
Qed.

Lemma lothers_comp_full n m (l : lens n m) (l1 : lens m m) :
  lothers (lens_comp l l1) = lothers l.
Proof.
apply/lens_inj/eq_lothers => i.
case/boolP: (i \in l) => Hi. by rewrite mem_lens_comp mem_lens_full.
apply/negbTE; apply: contra Hi. exact/lens_comp_sub.
Qed.
End lens_full.

Section merge_indices_basis.
Variables (I : Type) (dI : I) (n m : nat) (l : lens n m).
Lemma merge_indices_basis vi vj :
  merge_indices dI (lens_basis l) vi vj =
  merge_indices dI l (extract (lens_perm l) vi) vj.
Proof.
apply eq_from_tnth => i.
case/boolP: (i \in lens_basis l) => Hib.
  rewrite tnth_merge_indices.
  have Hil : i \in l.
    by rewrite -(lens_basis_perm l) mem_lens_comp mem_lens_full.
  rewrite tnth_merge_indices tnth_extract.
  congr tnth.
  apply/(tnth_inj (lens_basis l)); first by apply lens_uniq.
  by rewrite -tnth_comp lens_basis_perm !tnth_lens_index.
rewrite -mem_lothers in Hib.
have Hil : i \in lothers l.
  by rewrite -(lens_basis_perm l) lothers_comp_full.
rewrite !tnth_merge_indices_lothers.
congr tnth; apply/val_inj => /=.
congr index.
move/(f_equal (val \o val)): (lothers_comp_full (lens_basis l) (lens_perm l)).
by rewrite lens_basis_perm.
Qed.
End merge_indices_basis.

Section lens_single.
Variables n : nat.

Definition lens_single i : lens n 1 :=
  {|lens_t := [tuple i]; lens_uniq := erefl|}.

Lemma lens_sorted_single i : lens_sorted (lens_single i).
Proof. done. Qed.

Lemma index_lens_single i : index i (lens_single i) = (@ord0 1).
Proof. by rewrite /= eqxx. Qed.

Lemma lens_index_single i j (H : j \in lens_single i) : lens_index H = ord0.
Proof. by apply/val_inj => /=; move: H; rewrite inE eq_sym => ->. Qed.

Lemma tnth_lens_single i j : tnth (lens_single i) j = i.
Proof. by rewrite /= ord1. Qed.

Lemma tnth_merge_indices_single T (dI : T) i vi vj :
  tnth (merge_indices dI (lens_single i) vi vj) i = tnth vi ord0.
Proof.
rewrite tnth_merge_indices. by rewrite inE eqxx.
by move=> H; rewrite ord1.
Qed.
End lens_single.

Lemma tnth_lothers_single n (i : 'I_n.+2) (k : 'I_n.+1) :
    tnth (lothers (lens_single i)) k = lift i k.
Proof.
apply/val_inj; rewrite (tnth_nth i); case: k => /=.
elim: (n.+1) i => {n} [|n IH] i k.
  by rewrite ltn0.
move/eqP: (size_others (lens_single i)); rewrite /others enum_ordSl.
case: k => [|k] /=; rewrite mem_lensE inE.
case: (unliftP ord0 i) => [i'|] -> Hsz.
    by rewrite eq_liftF.
  by rewrite eqxx /= enum_ordSl.
case: (unliftP ord0 i) => [i'|] ->.
  rewrite ltnS => Hsz Hk.
  rewrite eq_liftF /= filter_map size_map in Hsz *.
  rewrite (nth_map i' _ (lift ord0)); last first.
    by rewrite -ltnS Hsz subn1 ltnS.
  rewrite bumpS /= /(bump 0) add1n.
  f_equal.
  rewrite (eq_filter (a2:=fun k => k \notin lens_single i')) //.
  exact: IH.
rewrite eqxx /= filter_map size_map => Hsz Hk.
rewrite (nth_map ord0 _ (lift ord0)); last by rewrite Hsz.
congr bump.
rewrite (eq_filter (a2:=predT)) //.
rewrite ltnS in Hk.
rewrite filter_predT (_ : k.+1 = lift ord0 (Ordinal Hk)) //.
by rewrite nth_ord_enum.
Qed.

Section lens_pair.
Variables (n : nat) (i j : 'I_n).
Lemma uniq_pair : i != j -> uniq [:: i; j].
Proof. by rewrite /= inE andbT. Qed.

Hypothesis ij : i != j.
Definition lens_pair : lens n 2 := mkLens (uniq_pair ij).

Lemma lens_pair0 : lens_comp lens_pair (lens_single ord0) = lens_single i.
Proof. by apply/eq_lens_tnth => k; rewrite tnth_comp !tnth_lens_single. Qed.

Lemma lens_pair1 :
  lens_comp lens_pair (lens_single (lift ord0 ord0)) = lens_single j.
Proof. by apply/eq_lens_tnth => k; rewrite tnth_comp !tnth_lens_single. Qed.
End lens_pair.

(* Ordered lenses *)
Section lens_left_right.
Variables m n : nat.

Definition lens_left : lens (m+n) m.
exists [tuple lshift n i | i < m].
abstract (rewrite map_inj_uniq ? enum_uniq //; exact/lshift_inj).
Defined.

Definition lens_right : lens (m+n) n.
exists [tuple rshift m i | i < n].
abstract (rewrite map_inj_uniq ? enum_uniq //; exact/rshift_inj).
Defined.

Variables (T : Type) (tl : m.-tuple T) (tr : n.-tuple T).
Lemma extract_lens_left : extract lens_left [tuple of tl ++ tr] = tl.
Proof.
apply eq_from_tnth => i; rewrite [LHS](tnth_nth (tnth tl i)) /= -map_comp.
by rewrite (nth_map i) /= ?size_enum_ord // nth_ord_enum tnth_lshift.
Qed.
Lemma extract_lens_right : extract lens_right [tuple of tl ++ tr] = tr.
Proof.
apply eq_from_tnth => i; rewrite [LHS](tnth_nth (tnth tr i)) /= -map_comp.
by rewrite (nth_map i) /= ?size_enum_ord // nth_ord_enum tnth_rshift.
Qed.

Lemma lens_left_right_disjoint : [disjoint lens_left & lens_right].
Proof.
apply/pred0P => /= i.
rewrite simpl_predE /=.
case: (split_ordP i) => j ->.
  suff /negbTE -> : lshift n j \notin lens_right.
    by rewrite andbF.
  apply/mapP => -[k] _ /esym/eqP.
  by rewrite eq_rlshift.
have /negbTE -> // : rshift m j \notin lens_left.
apply/mapP => -[k] _ /eqP.
by rewrite eq_rlshift.
Qed.

Lemma take_enum_lshift : take m (enum 'I_(m + n)) = [tuple lshift n i | i < m].
Proof.
apply/esym/eq_from_nth'.
  by rewrite size_map size_takel -cardT card_ord // leq_addr.
move=> a i.
rewrite size_map -cardT card_ord => Hi.
rewrite nth_tnth tnth_map tnth_ord_tuple nth_take //.
apply val_inj. by rewrite [RHS]nth_enum_ord // (leq_trans Hi) // leq_addr.
Qed.

Lemma drop_enum_rshift : drop m (enum 'I_(m + n)) = [tuple rshift m i | i < n].
Proof.
apply/esym/eq_from_nth'.
  by rewrite size_map size_drop -!cardT !card_ord addKn.
move=> a i.
rewrite size_map -cardT card_ord => Hi.
rewrite nth_tnth tnth_map tnth_ord_tuple nth_drop //.
apply val_inj. by rewrite [RHS]nth_enum_ord //= -addnS leq_add2l.
Qed.

Lemma lens_left_right : lens_cat lens_left_right_disjoint = lens_id (m+n).
Proof.
apply/lens_inj => /=.
by rewrite -[RHS](cat_take_drop m) take_enum_lshift drop_enum_rshift.
Qed.

Lemma lothers_left : lothers lens_left = lens_right :> seq _.
Proof.
rewrite /lothers /others /=.
have /= := f_equal val lens_left_right.
rewrite -(val_ord_tuple (m+n)) => <-.
rewrite filter_cat filter_map -(eq_filter (a1:=pred0)); last first.
  move=> i /=; rewrite mem_lensE mem_map ?mem_enum //; exact/lshift_inj.
rewrite filter_pred0 filter_map -(eq_filter (a1:=predT)) ?filter_predT //.
move=> i /=. rewrite mem_lensE /=.
by apply/esym/mapP => -[x _] /eqP; rewrite eq_shift.
Qed.

Lemma lothers_right : lothers lens_right = lens_left :> seq _.
Proof.
rewrite /lothers /others /=.
have /= := f_equal val lens_left_right.
rewrite -(val_ord_tuple (m+n)) => <-.
rewrite filter_cat filter_map -(eq_filter (a1:=predT)); last first.
  move=> i /=. rewrite mem_lensE /=.
  by apply/esym/mapP => -[x _] /eqP; rewrite eq_shift.
rewrite filter_predT filter_map -(eq_filter (a1:=pred0)).
  by rewrite filter_pred0 cats0.
move=> i /=; rewrite mem_lensE mem_map ?mem_enum //; exact/rshift_inj.
Qed.

Variables (p : nat) (l : lens p m) (l' : lens p n) (H : [disjoint l & l']).

Lemma lens_comp_left : l = lens_comp (lens_cat H) lens_left.
Proof.
by apply/eq_lens_tnth => i; rewrite tnth_comp tnth_mktuple tnth_lshift.
Qed.

Lemma lens_comp_right : l' = lens_comp (lens_cat H) lens_right.
Proof.
by apply/eq_lens_tnth => i; rewrite tnth_comp tnth_mktuple tnth_rshift.
Qed.

Definition lens_perm_left := lens_comp (lens_perm (lens_cat H)) lens_left.
Definition lens_perm_right := lens_comp (lens_perm (lens_cat H)) lens_right.

Lemma lens_perm_disjoint : [disjoint lens_perm_left & lens_perm_right].
Proof.
apply/disjointP => i /mapP [x] Hx -> /mapP [y] Hy.
move/(f_equal (tnth (lens_basis (lens_cat H)))).
rewrite -!tnth_comp lens_basis_perm => /tnth_lens_inj xy.
rewrite -xy in Hy.
by move/disjointP/(_ x): lens_left_right_disjoint; elim.
Qed.

Lemma lens_perm_leftE :
  lens_comp (lens_basis (lens_cat H)) lens_perm_left =
  lens_comp (lens_cat H) lens_left.
Proof.
by apply/eq_lens_tnth => i; rewrite !tnth_comp -tnth_comp lens_basis_perm.
Qed.

Lemma lens_perm_rightE :
  lens_comp (lens_basis (lens_cat H)) lens_perm_right =
  lens_comp (lens_cat H) lens_right.
Proof.
by apply/eq_lens_tnth => i; rewrite !tnth_comp -tnth_comp lens_basis_perm.
Qed.
End lens_left_right.

(* reindexing *)
Section reindex.
Variables (R : Type) (idx : R) (op : Monoid.com_law idx) (I : finType) (dI : I).

Lemma reindex_merge_indices n m (l : lens n m) F :
  \big[op/idx]_i F i = \big[op/idx]_i \big[op/idx]_j F (merge_indices dI l i j).
Proof.
rewrite [RHS](pair_bigA _ (fun i j => F (merge_indices dI l i j))).
rewrite (reindex (fun v : m.-tuple I * (n-m).-tuple I =>
                    merge_indices dI l (fst v) (snd v))) //=.
exists (fun v => (extract l v, extract (lothers l) v)) => // v _.
  by rewrite extract_merge extract_lothers_merge; case: v.
by rewrite /= merge_indices_extract.
Qed.

Lemma reindex_left_right m n (F : m.-tuple I -> n.-tuple I -> R) :
  \big[op/idx]_i \big[op/idx]_j F i j =
  \big[op/idx]_v F (extract (lens_left m n) v) (extract (lens_right m n) v).
Proof.
rewrite pair_bigA /=.
rewrite [LHS](reindex (fun v : (m+n).-tuple I =>
         (extract (lens_left m n) v, extract (lens_right m n) v))) //.
exists (fun v : m.-tuple I * n.-tuple I => [tuple of v.1 ++ v.2]) => /= vj _.
  rewrite -[RHS]extract_lens_id -(lens_left_right m n).
  by apply/val_inj; rewrite /= map_cat.
case: vj => vl vr /=; congr pair; apply eq_from_tnth => i;
by rewrite tnth_map tnth_mktuple (tnth_lshift,tnth_rshift).
Qed.
End reindex.

Section inject_all.
Variables (I : Type) (m n : nat) (lm : lens (m+n) m) (ln : lens (m+n) n).
Hypothesis Hdisj : [disjoint lm & ln].

Lemma lens_all i : (i \in lm) || (i \in ln).
Proof.
have : [set a in lm] == [set a | a \notin ln].
  rewrite eqEcard.
  rewrite cards_filter (eqP (size_others ln)) addnK.
  have -> : #|[set a in lm]| = #|lm| by apply eq_card => j; rewrite inE.
  have/card_uniqP -> := lens_uniq lm.
  rewrite size_tuple leqnn andbT.
  apply/subsetP => j. by rewrite !inE => /(disjointFr Hdisj) ->.
move/eqP/setP/(_ i). rewrite !inE.
by case: (i \in ln) => ->.
Qed.

Lemma inject_all (vi vj : (m+n).-tuple I) :
  (inject ln (inject lm vi (extract lm vj)) (extract ln vj)) = vj.
Proof.
apply eq_from_tnth => i.
rewrite tnth_mktuple.
case/boolP: (i \in ln) => Hi.
  by rewrite (nth_lens_index Hi) tnth_map tnth_lens_index.
rewrite nth_lens_out // tnth_mktuple.
have := lens_all i.
rewrite (negbTE Hi) orbF => Him.
by rewrite (nth_lens_index Him) tnth_map tnth_lens_index.
Qed.
End inject_all.

(* Shifting of disjoint lenses *)
Section make_comp.
Variables (n m p : nat) (l : lens n m) (l' : lens n p).
Hypothesis Hdisj : [disjoint l & l'].

Lemma make_comp_present i :
  tnth l' i \in lothers l.
Proof.
move: (mem_tnth i l').
rewrite mem_lothers => Hl'; apply/negP => Hl.
move: Hdisj; rewrite disjoint_has => /hasP; elim.
by exists (tnth l' i).
Qed.

Definition make_comp :=
  [tuple lens_index (make_comp_present i) | i < p].

Lemma uniq_map_comp : uniq make_comp.
Proof.
rewrite /make_comp/= map_inj_in_uniq ?enum_uniq // => i j _ _.
move/(f_equal (tnth (lothers l))).
by rewrite !tnth_lens_index => /tnth_lens_inj.
Qed.

Definition lmake_comp := mkLens uniq_map_comp.

Lemma lmake_compE : lens_comp (lothers l) lmake_comp = l'.
Proof.
apply/eq_lens_tnth => i.
rewrite tnth_map tnth_mktuple (tnth_nth (tnth l' i)) /=.
by rewrite nth_index // make_comp_present.
Qed.
End make_comp.

(* associativity of focussing *)
Section lens_assoc.
Variables (I : Type) (dI : I) (n m p : nat) (l : lens n m) (l' : lens m p).

Local Notation merge_indices := (merge_indices dI).

Definition lothers_comp := lothers (lens_comp l l').

Lemma others_in_l_present i :
  tnth (lens_comp l (lothers l')) i \in lothers_comp.
Proof.
rewrite mem_lothers; apply/mapP => -[k Hk].
rewrite tnth_comp => /tnth_lens_inj Hi.
by apply/negP: Hk; rewrite -mem_lothers -Hi mem_tnth.
Qed.

Definition others_in_l :=
  [tuple lens_index (others_in_l_present i) | i < m - p].

Lemma uniq_others_in_l : uniq (others_in_l).
Proof.
apply/tnth_inj => i j; rewrite !tnth_mktuple.
set k := lens_index _.
case=> /(f_equal (nth (widen_ord (leq_subr _ _) k) lothers_comp)).
rewrite !nth_index; try by rewrite others_in_l_present.
move/tnth_inj => -> //.
rewrite map_inj_uniq ?(lens_uniq (lothers l')) //; exact/tnth_lens_inj.
Qed.

Definition lothers_in_l := mkLens uniq_others_in_l.

Lemma cast_lothers_notin_l : n - p - (m - p) = n - m.
Proof. rewrite subnBA ?subnK // lens_leq //. exact: (lens_comp l l'). Qed.

Lemma size_lothers_notin_l : size (lothers lothers_in_l) == n - m.
Proof. by rewrite size_tuple cast_lothers_notin_l. Qed.

Definition lothers_notin_l : lens (n-p) (n-m).
exists (Tuple size_lothers_notin_l).
exact (lens_uniq (lothers lothers_in_l)).
Defined.

Lemma lothers_in_l_comp :
  lens_comp lothers_comp lothers_in_l = lens_comp l (lothers l').
Proof.
apply/eq_lens_tnth => i.
by rewrite !tnth_map tnth_ord_tuple tnth_lens_index.
Qed.

Lemma lothers_notin_l_comp :
  lens_comp lothers_comp lothers_notin_l = lothers l.
Proof.
apply/lens_inj/eq_lens_sorted/lens_sorted_lothers/lens_sorted_comp;
  try exact/sorted_filter/sorted_enum/ltn_trans.
move=> /= i; rewrite mem_lothers.
case/boolP: (i \in l) => /= Hi; apply/mapP.
- case=> j; rewrite mem_lothers => Hj Hi'.
  apply/negP: Hj; rewrite negbK; apply/tnthP.
  case/tnthP: Hi => k Hk.
  have Hk' : k \in lothers l'.
    rewrite mem_lothers; apply/tnthP => -[h] Hh.
    have : i \in lothers_comp by rewrite Hi' mem_tnth.
    by rewrite Hk Hh -tnth_comp mem_lothers mem_tnth.
  exists (lens_index Hk').
  apply (tnth_lens_inj (l:=lothers_comp)).
  by rewrite -tnth_comp lothers_in_l_comp tnth_comp -Hi' Hk tnth_lens_index.
- have/tnthP [j Hj] :  i \in lothers_comp.
    rewrite mem_lothers; apply: contra Hi => /mapP [j Hj] ->.
    exact: mem_tnth.
  exists j => //.
  rewrite mem_lothers; apply: contra Hi => /mapP [k _].
  rewrite Hj => ->.
  have Hol := others_in_l_present k.
  by rewrite tnth_lens_index tnth_map mem_tnth.
Qed.

Lemma extract_lothers_comp (v : n.-tuple I) :
  extract lothers_comp v =
  merge_indices lothers_in_l
                (extract (lens_comp lothers_comp lothers_in_l) v)
                (extract (lens_comp lothers_comp (lothers lothers_in_l)) v).
Proof. by rewrite !extract_comp merge_indices_extract. Qed.

Lemma merge_indices_comp vj vk (vl : (n-p - (m-p)).-tuple I)
                               (vm : (n-m).-tuple I) :
  vl = vm :> seq I ->  (* can we use S-prop here? *)
  merge_indices (lens_comp l l') vj (merge_indices lothers_in_l vk vl) =
  merge_indices l (merge_indices l' vj vk) vm.
Proof.
move=> Hlm.
apply/eq_from_tnth => i.
case/boolP: (i \in l) => Hil.
  rewrite (tnth_merge_indices _ _ _ Hil).
  case/boolP: (lens_index Hil \in l') => Hill'.
    rewrite (tnth_merge_indices _ _ _ Hill').
    have Hilcl' : i \in lens_comp l l' by rewrite mem_lens_comp.
    rewrite (tnth_merge_indices _ _ _ Hilcl').
    congr tnth; apply/val_inj => /=; by rewrite -index_lens_comp.
  have Hilo : i \in lothers_comp by rewrite mem_lothers mem_lens_comp.
  rewrite -mem_lothers in Hill'.
  rewrite tnth_merge_indices_lothers [RHS]tnth_merge_indices_lothers.
  have Hic : i \in lens_comp l (lothers l') by rewrite mem_lens_comp.
  have Hilol : lens_index Hilo \in lothers_in_l.
    by rewrite -lothers_in_l_comp mem_lens_comp in Hic.
  rewrite tnth_merge_indices.
  congr tnth; apply (tnth_lens_inj (l:=lens_comp l (lothers l'))).
  by rewrite -{1}lothers_in_l_comp !tnth_comp !tnth_lens_index.
case/boolP: (i \in lens_comp l l') => [/lens_comp_sub|] Hic.
  by rewrite Hic in Hil.
rewrite -!mem_lothers in Hil Hic.
rewrite tnth_merge_indices_lothers [RHS]tnth_merge_indices_lothers.
have Hlil : lens_index Hic \in lothers lothers_in_l.
  rewrite -mem_lens_comp mem_lensE /=.
  by move/(f_equal (val \o val)): lothers_notin_l_comp => /= ->.
rewrite tnth_merge_indices_lothers.
set a := tnth vl _; rewrite /a (tnth_nth a) /= Hlm [RHS](tnth_nth a) /=.
congr nth.
have /(f_equal (val \o val)) := lothers_notin_l_comp; rewrite [RHS]/= => <-.
by rewrite -[LHS](index_lens_comp (lothers lothers_in_l)).
Qed.

(* For focus_others, only uses variables *)
Lemma merge_indices_comp_others (l1 : lens (n-m) p) vi vj :
  merge_indices (lens_comp (lothers l) l1) vj
                (extract (lothers (lens_comp (lothers l) l1)) vi) =
  merge_indices l (extract l vi)
     (merge_indices l1 vj (extract (lens_comp (lothers l) (lothers l1)) vi)).
Proof.
set l2 := lens_comp (lothers l) l1.
apply eq_from_tnth => i.
case/boolP: (i \in l) => Hl.
  rewrite [RHS]tnth_merge_indices.
  have Hl2: i \notin l2.
    apply/negP => /lens_comp_sub; by rewrite mem_others Hl.
  rewrite -mem_lothers in Hl2.
  by rewrite tnth_merge_indices_lothers !tnth_extract !tnth_lens_index.
rewrite -mem_lothers in Hl.
rewrite [RHS]tnth_merge_indices_lothers.
case/boolP: (i \in l2) => Hl2.
  have := Hl2; rewrite mem_lens_comp => Hl1; rewrite !tnth_merge_indices.
  congr tnth; apply/val_inj; by rewrite /= -index_lens_comp.
have := Hl2; rewrite mem_lens_comp => Hl1.
rewrite -!mem_lothers in Hl1 Hl2.
by rewrite !tnth_merge_indices_lothers !tnth_extract !tnth_lens_index.
Qed.

Lemma merge_indices_pair (i i' : 'I_n.+2) (vi vj : 1.-tuple I)
      (vk : (n.+2 - 1 - 1).-tuple I)
      (Hior : i \in lothers (lens_single i'))
      (Hir : i != i') :
  merge_indices (lens_single i') vi
    (merge_indices (lens_single (lens_index Hior)) vj vk) =
  merge_indices (lens_pair Hir) [tuple of vj ++ vi] vk.
Proof.
apply/eq_from_tnth => j.
rewrite !tnth_map !tnth_ord_tuple.
rewrite [index j (lens_single _)]/= [index j (lens_pair _)]/=.
case: ifP => rij.
  rewrite [X in nth _ vi X](_ : 0 = @ord0 1)%N //.
  rewrite ifF; last by rewrite -(negbTE Hir) -(eqP rij).
  case: vj => -[] // a [] //= sza.
  by rewrite -!(tnth_nth _ vi ord0).
rewrite nth_default; last by rewrite size_tuple.
have Hjl : j \in lothers (lens_single i').
  by rewrite mem_lothers mem_lensE inE eq_sym rij.
case: ifPn => ij.
  rewrite -(eqP ij) in Hjl *.
  rewrite make_lens_index -tnth_nth.
  have -> : lens_index Hjl = lens_index Hior by apply/val_inj.
  rewrite tnth_merge_indices_single.
  by case: vj => -[].
rewrite make_lens_index -tnth_nth !tnth_map !tnth_ord_tuple.
rewrite nth_lens_out; last first.
  rewrite mem_lensE inE.
  apply: contra ij => /eqP /(f_equal (tnth (lothers (lens_single i')))).
  by rewrite !tnth_lens_index => ->.
rewrite [RHS]nth_default ?size_tuple //.
congr nth.
rewrite -(index_lens_comp (lothers (lens_single (lens_index Hior))) Hjl).
congr index.
rewrite lens_comp_lothers.
apply eq_lothers => /= k.
by rewrite !mem_lensE !inE tnth_lens_index orbC.
Qed.

Lemma merge_indices_perm (l1 : lens m m) (vi : m.-tuple I) vk :
  merge_indices (lens_comp l l1) (extract l1 vi) vk =
  merge_indices l vi vk.
Proof.
apply/eq_from_tnth => i.
case/boolP: (i \in l) => Hil.
  rewrite [RHS]tnth_merge_indices.
  have Hil1 : i \in lens_comp l l1 by rewrite mem_lens_comp mem_lens_full.
  rewrite tnth_merge_indices tnth_extract.
  congr tnth; apply (tnth_lens_inj (l:=l)).
  by rewrite -tnth_comp !tnth_lens_index.
rewrite -mem_lothers in Hil.
rewrite [RHS]tnth_merge_indices_lothers.
have Hic := Hil; rewrite -(lothers_comp_full _ l1) in Hic.
rewrite tnth_merge_indices_lothers.
congr tnth; apply/val_inj => /=.
by move/(f_equal (val \o val)): (lothers_comp_full l l1) => /= ->.
Qed.
End lens_assoc.

Section lens_rev.
Variables (I : Type) (dI : I) (n : nat).

Lemma uniq_lens_rev : uniq [tuple rev_ord i | i < n].
Proof.
rewrite (map_uniq (f:=@rev_ord n)) // -map_comp (eq_map (f2:=id)).
  by rewrite map_id enum_uniq.
by move=> x /=; rewrite rev_ordK.
Qed.
Definition lens_rev := mkLens uniq_lens_rev.

Lemma tnth_rev A (t : n.-tuple A) i :
  tnth [tuple of rev t] (rev_ord i) = tnth t i.
Proof.
rewrite (tnth_nth (tnth t i)) [RHS](tnth_nth (tnth t i)) /=.
rewrite nth_rev /= size_tuple; last by rewrite rev_ord_proof.
by move/(f_equal val): (rev_ordK i) => /= ->.
Qed.

Lemma merge_indices_rev m (l l' : lens m n)
      (vi vj : n.-tuple I) vk :
  l = rev l' :> seq _ -> vi = rev vj :> seq _ ->
  merge_indices dI l vi vk = merge_indices dI l' vj vk.
Proof.
move=> Hl Hv.
rewrite -(merge_indices_perm dI l' lens_rev).
f_equal.
  apply/eq_lens_tnth => i /=.
  rewrite tnth_extract tnth_mktuple -[LHS]tnth_rev.
  by congr tnth; apply/val_inj; rewrite /= Hl revK.
apply/eq_from_tnth => i.
rewrite tnth_extract tnth_mktuple -[LHS]tnth_rev.
by congr tnth; apply/val_inj; rewrite /= Hv revK.
Qed.
End lens_rev.

(* Computable Ordinal constants *)
Definition succO {n} := lift (@ord0 n).
Fixpoint addnO {n} m (p : 'I_n) : 'I_(m+n) :=
  match m as x return 'I_(x+n) with
  | 0 => p
  | m.+1 => cast_ord (esym (addSnnS m n)) (addnO m (succO p))
  end.
Lemma addnOK n m p : @addnO n m p = m + p :> nat.
Proof. elim: m n p => //= m IH n p. by rewrite IH /= addnS. Qed.

Definition INO {n} m := addnO m (@ord0 n).
Notation "n '%:O'" := (INO n) (at level 2, left associativity, format "n %:O").

Lemma succOS n m : succO m%:O = m.+1%:O :> 'I_(m.+1+n.+1).
Proof. apply/val_inj => /=. by rewrite /bump leq0n !addnOK !(addnC m). Qed.
Lemma succO0 n : succO ord0 = 1%:O :> 'I_n.+2.
Proof. exact/val_inj. Qed.
Definition succOE := (succO0,succOS).

Notation "[ 'lens' ]" := (@mkLens _ _ [tuple] erefl).
Notation "[ 'lens' x1 ; .. ; xn ]" :=
  (@mkLens _ _ [tuple of x1%:O :: .. [:: xn%:O] ..] erefl).

Fixpoint enum_ordinal n : seq 'I_n :=
  match n with
  | 0 => [::]
  | m.+1 => ord0 :: map succO (enum_ordinal m)
  end.

Lemma enum_ordinalE n : enum 'I_n = enum_ordinal n.
Proof.
apply/(@inj_map _ _ (val : 'I_n -> nat)). exact val_inj.
rewrite val_enum_ord.
elim: n => //= n IH.
rewrite -map_comp -(eq_map (f1:=S \o nat_of_ord (n:=n))) //.
by rewrite map_comp -IH (iotaDl 1 0 n).
Qed.

Ltac eq_lens :=
  apply/val_inj/eqP; rewrite ?eq_ord_tuple /= /others /= ?enum_ordinalE.

Section ordinal_examples.
Eval compute in uniq [tuple 0%:O; 1%:O; 2%:O]. (* = true *)

Let lens3_23 : lens 3 2 := [lens 1; 2].
End ordinal_examples.


From CoqMTL Require Import Control.All.

(** A monad that models computations which have access to their control
    context. This makes it possible for them to use complicated control
    constructs, like aborting a computation or throwing an exception. *)
Definition Cont (R A : Type) : Type := (A -> R) -> R.

(** We can map over such computation by composing the function to be
    mapped with the continuation. *)
Definition fmap_Cont
  {R A B : Type} (f : A -> B) (m : Cont R A) : Cont R B :=
    fun g : B -> R => m (f .> g).

#[refine]
#[export]
Instance Functor_Cont (R : Type) : Functor (Cont R) :=
{
  fmap := @fmap_Cont R;
}.
Proof. all: reflexivity. Defined.

(** We can inject a value into the monad by feeding it into the
    continuation. *)
Definition pure_Cont
  {R A : Type} (a : A) : Cont R A :=
    fun f : A -> R => f a.

Definition ap_Cont
  {R A B : Type} (f : Cont R (A -> B)) (x : Cont R A) : Cont R B :=
    fun kb : B -> R => f (fun ka : A -> B => x (ka .> kb)).

#[refine]
#[export]
Instance Applicative_Cont (R : Type) : Applicative (Cont R) :=
{
  is_functor := Functor_Cont R;
  pure := @pure_Cont R;
  ap := @ap_Cont R;
}.
Proof. all: reflexivity. Defined.

(** We can sequence two computations by running the first one with a
    continuation that feeds it to the second one together with the
    continuation. *)
Definition bind_Cont
  {R A B : Type} (x : Cont R A) (f : A -> Cont R B) : Cont R B :=
    fun g : B -> R => x (fun a : A => f a g).

(** It turns out that [Cont] is neither [Alternative] nor commutative.
    It shouldn't surprise us, since it is a "mother of all monads" and
    not all monads have instances of [Alternative] or
    [CommutativeApplicative]. *)

Lemma Cont_not_Alternative :
  (forall R : Type, Alternative (Cont R)) -> False.
Proof.
  unfold Cont. intro. destruct (X False).
  apply aempty with False. trivial.
Qed.

Lemma Cont_not_CommutativeApplicative :
  ~ (forall R : Type, CommutativeApplicative _ (Applicative_Cont R)).
Proof.
  intro. destruct (H bool).
  specialize (ap_comm bool bool _ (fun _ => id) (const true) (const false)).
  compute in ap_comm. apply (f_equal (fun f => f id)) in ap_comm.
  inversion ap_comm.
Qed.

#[refine]
#[export]
Instance Monad_Cont (R : Type) : Monad (Cont R) :=
{
  is_applicative := Applicative_Cont R;
  bind := @bind_Cont R;
}.
Proof. all: reflexivity. Defined.

#[global] Hint Unfold fmap_Cont pure_Cont ap_Cont bind_Cont : CoqMTL.

(** For [Cont R], contrary to [Codensity R], we can define both kinds of
    callCC constructively. The second definition is taken from Purescript's
    Pursuit library. *)

Definition callCC
  {R A B : Type} (f : (A -> Cont R B) -> Cont R A) : Cont R A :=
    fun ar : A -> R => f (fun (a : A) (_ : B -> R) => ar a) ar.

Definition callCC'
  {R A : Type} (f : (forall B : Type, A -> Cont R B) -> Cont R A)
  : Cont R A :=
    fun k : A -> R => f (fun (B : Type) (a : A) (_ : B -> R) => k a) k.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.DownUpSemantics_Fail.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Lemma sound_sepcon_comm {L: Language} {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} {po_R: PreOrder Krelation} {J: Join (Kworlds M)} {SA: SeparationAlgebra (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimunSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {dusSM: DownUpSemantics_Fail.SeparatingSemantics L MD M SM}:
  forall x y: expr,
    forall m,
      KRIPKE: M, m |= x * y --> y * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0 |- *; intros.
  destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  exists m0, m2, m1.
  split; [| split; [| split]]; auto.
  apply join_comm; auto.
Qed.

Lemma sound_sepcon_assoc {L: Language} {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} {po_R: PreOrder Krelation} {J: Join (Kworlds M)} {SA: SeparationAlgebra (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimunSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {dusSM: DownUpSemantics_Fail.SeparatingSemantics L MD M SM}:
  forall x y z: expr,
    forall m,
      KRIPKE: M, m |= x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp.
  split; intros.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon in H0.
    destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
    (* fail *)
Abort.


Require Import RepairSpill RLiveMin RLiveSound LiveMin SpillMaxKill.
Require Import SpillSound Annotation Liveness.Liveness RenamedApart.
Require Import List Map IL Take TakeSet OneOrEmpty AllInRel PickLK.
Require Import RepairSpillInv RegLive PartialOrder.

Set Implicit Arguments.

(** * Idempotence of repair_spill with reg_live *)

Corollary repair_spill_idem k ZL Λ Λ' s lv sl R M G ra VD
  : let rlv := reg_live ZL (fst ⊝ Λ) G s sl in
    renamedApart s ra
    -> R ∪ M ⊆ fst (getAnn ra)
    -> getAnn rlv ⊆ R
    -> live_sound Imperative ZL (merge ⊝ Λ) s lv
    -> live_min k ZL Λ G s sl lv
    -> spill_sound k ZL Λ (R,M) s sl
    -> (forall Rf Mf n, get Λ n (Rf,Mf) -> cardinal Rf <= k)
    -> ann_R (fun x (y : ⦃var⦄ * ⦃var⦄) => (list_union (merge ⊝ snd x)) ⊆ fst y) sl ra
    -> spill_live VD sl lv
    -> poEq Λ Λ'
    -> sl === repair_spill k ZL Λ' R M s rlv lv sl
.
Proof.
  intros rlv rena RM_sub inclR lvSnd lvMin spillSnd rmf_card sl_ra spilli Λeq.
  eapply repair_spill_inv; eauto.
  - eapply reg_live_rlive_min; eauto.
    eapply reg_live_anno; eauto.
  - eapply reg_live_sound; eauto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e336m17_14limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import FP.CoreClasses.Eqv.
Require Import FP.CoreClasses.Setoid.
Require Import FP.CoreClasses.PreOrd.
Require Import FP.CoreClasses.Injection.
Require Import FP.CoreData.Function.
Require Import FP.CoreData.Bool.

Import BoolNotation.

Class PartialOrd T `{! Lte T ,! Eqv T ,! ER_WF T } :=
  { PartialOrd_PreOrd :> PreOrd T
  ; PartialOrd_Antisymmetry :> Antisymmetric T eqv lte
  ; PartialOrd_respect_eqv :> Proper (eqv ==> eqv ==> impl) lte
  }.
Class PartialOrdDec T :=
  { pord_dec : T -> T -> option comparison }.

Section lt_un.
  Context {T} `{! Eqv T ,! Lte T ,! ER_WF T ,! PartialOrd T }.

  Global Instance lt_respect_eqv : Proper (eqv ==> eqv ==> impl) lt.
  Proof.
    unfold Proper,"==>",impl,Basics.impl ; intros.
    destruct H1 ; constructor.
    - rewrite <- H ; rewrite <- H0 ; auto.
    - unfold "~" in * ; intros ; apply H2.
      rewrite H ; rewrite H0 ; auto.
  Qed.

  Global Instance un_respect_eqv : Proper (eqv ==> eqv ==> impl) un.
  Proof.
    unfold Proper,"==>",impl,Basics.impl ; intros.
    destruct H1 ; constructor ; unfold "~" in * ; intros.
    - apply H1.
      rewrite H0 ; rewrite H ; auto.
    - apply H2.
      rewrite H0 ; rewrite H ; auto.
  Qed.
End lt_un.

Class PartialOrd_RDC T `{! Lte T ,! Eqv T ,! ER_WF T ,! PartialOrd T ,! PartialOrdDec T } :=
  { pord_rel_correct_eqv : forall x y, eqv x y -> pord_dec x y = Some Eq
  ; pord_rel_correct_lt : forall x y, lt x y -> pord_dec x y = Some Lt
  ; pord_rel_correct_gt : forall x y, lt y x -> pord_dec x y = Some Gt
  ; pord_rel_correct_un : forall x y, un x y -> pord_dec x y = None
  ; pord_dec_correct_eqv : forall x y, pord_dec x y = Some Eq -> eqv x y
  ; pord_dec_correct_lt : forall x y, pord_dec x y = Some Lt -> lt x y
  ; pord_dec_correct_gt : forall x y, pord_dec x y = Some Gt -> lt y x
  ; pord_dec_correct_un : forall x y, pord_dec x y = None -> un x y
  }.

Section lt_un_IR.
  Context {T U} inj
    `{! Lte T ,! Eqv T ,! ER_WF T ,! PartialOrd T
     ,! Lte U ,! Eqv U ,! ER_WF U ,! PartialOrd U
     ,! InjectionRespect T U inj lte lte
     }.

  Global Instance IR_inj_lt : InjectionRespect T U inj lt lt.
  Proof.
    constructor.
    - unfold Proper,"==>" ; intros.
      destruct H ; constructor.
      + apply InjectionRespect_eta in H ; auto.
      + unfold "~" in * ; intros ; apply H0.
        apply InjectionRespect_beta ; auto.
    - unfold Proper,inverse_respectful ; intros.
      destruct H ; constructor.
      + apply InjectionRespect_beta in H ; auto.
      + unfold "~" in * ; intros ; apply H0.
        apply InjectionRespect_eta ; auto.
  Qed.

  Global Instance IR_inj_un : InjectionRespect T U inj un un.
  Proof.
    constructor.
    - unfold Proper,"==>" ; intros.
      destruct H ; constructor ; unfold "~" in * ; intros.
      + apply H.
        apply InjectionRespect_beta ; auto.
      + apply H0.
        apply InjectionRespect_beta ; auto.
    - unfold Proper,inverse_respectful ; intros.
      destruct H ; constructor ; unfold "~" in * ; intros.
      + apply H.
        apply InjectionRespect_eta ; auto.
      + apply H0.
        apply InjectionRespect_eta ; auto.
  Qed.

End lt_un_IR.

Section lt_un_dec.
  Context {T}
    `{! Lte T ,! Lte T ,! LteDec T ,! Eqv T ,! ER_WF T
     ,! PartialOrd T ,! PartialOrdDec T ,! PartialOrd_RDC T
     }.

  Definition pord_dec_p (x:T) (y:T) : {eqv x y}+{lt x y}+{lt y x}+{un x y}.
  Proof.
    remember (pord_dec x y) as o ; destruct o.
    - destruct c.
      + left ; left ; left ; apply pord_dec_correct_eqv ; auto.
      + left ; left ; right ; apply pord_dec_correct_lt ; auto.
      + left ; right ; apply pord_dec_correct_gt ; auto.
    - right ; apply pord_dec_correct_un ; auto.
  Qed.

  Definition lte_from_pord_dec x y :=
    match pord_dec x y with
    | Some Lt => true
    | Some Eq => true
    | _ => false
    end.

  Definition pord_dec_from_lte x y :=
    match lte_dec x y, lte_dec y x with
    | true, true => Some Gt
    | true, false => Some Lt
    | false, true => Some Gt
    | false, false => None
    end.

  Definition eqv_impl_lte : forall {x y}, eqv x y -> lte x y.
  Proof.
    intros.
    rewrite H ; reflexivity.
  Qed.

  Definition lt_dec x y :=
    match pord_dec x y with Some Lt => true | _ => false end.
  Definition lt_dec_p (x:T) (y:T) : {lt x y}+{~lt x y}.
  Proof.
    pose (pord_dec_p x y) ;
    repeat match goal with
    | [ H : sumbool _ _ |- _ ] => destruct H
    | [ H : sumor _ _ |- _ ] => destruct H
    end.
    - right ; unfold "~" ; intros Hlt ; destruct Hlt.
      symmetry in e ; pose (eqv_impl_lte e) ; auto.
    - left ; auto.
    - right ; destruct l ; unfold "~" ; intros Hlt ; destruct Hlt ; auto.
    - right ; destruct u ; unfold "~" ; intros Hlt ; destruct Hlt ; auto.
  Qed.

  Definition un_dec x y :=
    match pord_dec x y with None => true | _ => false end.
  Definition un_dec_p (x:T) (y:T) : {un x y}+{~un x y}.
  Proof.
    pose (pord_dec_p x y) ;
    repeat match goal with
    | [ H : sumbool _ _ |- _ ] => destruct H
    | [ H : sumor _ _ |- _ ] => destruct H
    end.
    - right ; unfold "~" ; intros Hun ; destruct Hun.
      pose (eqv_impl_lte e) ; auto.
    - right ; destruct l ; unfold "~" ; intros Hun ; destruct Hun ; auto.
    - right ; destruct l ; unfold "~" ; intros Hun ; destruct Hun ; auto.
    - left ; auto.
    Qed.
End lt_un_dec.

Section PartialOrd.
  Context {T} `{! Eqv T ,! Lte T ,! ER_WF T ,! PartialOrd T}.

  Global Instance lt_Asymmetric : Asymmetric lt.
  Proof.
    unfold Asymmetric ; intros.
    destruct H,H0 ; contradiction.
  Qed.
End PartialOrd.

Module PartialOrdNotation.
  Notation "x < y"         := (lt x y)
    (at level 70, no associativity).
  Notation "x < y < z"     := (lt x y /\ lt y z)
    (at level 70, y at next level, no associativity).
  Notation "x > y"         := (lt y x)
    (at level 70, no associativity, only parsing).
  Notation "x > y > z"     := (lt z y /\ lt y x)
    (at level 70, y at next level, no associativity, only parsing).
  Notation "x >< y"        := (un x y)
    (at level 70, no associativity).

  Notation "x <! y"        := (lt_dec x y)
    (at level 35, no associativity).
  Notation "x <! y <! z"   := (lt_dec x y && lt_dec y z)
    (at level 35, y at next level, no associativity).
  Notation "x >! y"        := (lt_dec y x)
    (at level 35, no associativity, only parsing).
  Notation "x >! y >! z"   := (lt_dec z y && lt_dec y x)
    (at level 35, y at next level, no associativity).
  Notation "x ><! y"       := (un_dec x y)
    (at level 35, no associativity).
  Notation "x <~>! y"      := (pord_dec x y)
    (at level 35, no associativity).

  Notation "x <? y"        := (lt_dec_p x y)
    (at level 35, no associativity).
  Notation "x <? y <? z"   := (lt_dec_p x y /\ lt_dec_p y z)
    (at level 35, y at next level, no associativity).
  Notation "x >? y"        := (lt_dec_p y x)
    (at level 35, no associativity, only parsing).
  Notation "x >? y >? z"   := (lt_dec_p z y /\ lt_dec_p y x)
    (at level 35, y at next level, no associativity, only parsing).
  Notation "x ><? y"       := (un_dec_p x y)
    (at level 35, no associativity).
  Notation "x <~>? y"      := (pord_dec_p x y)
    (at level 35, no associativity).
End PartialOrdNotation.


From MetaCoq.Utils Require Import MCList MCOption MCUtils.
From MetaCoq.Common Require Import uGraph.
From MetaCoq.Common Require Import Universes.
Import wGraph.

Definition levels_of_cs (cstr : ConstraintSet.t) : LevelSet.t
  := ConstraintSet.fold (fun '(l1, _, l2) acc => LevelSet.add l1 (LevelSet.add l2 acc)) cstr (LevelSet.singleton Level.lzero).
Lemma levels_of_cs_spec cstr (lvls := levels_of_cs cstr)
  : uGraph.global_uctx_invariants (lvls, cstr).
Proof.
  subst lvls; cbv [levels_of_cs].
  cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants ConstraintSet.For_all declared_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints].
  repeat first [ apply conj
               | progress intros
               | progress destruct ?
               | match goal with
                 | [ |- ?x \/ ?y ]
                   => first [ lazymatch x with context[LevelSet.In ?l (LevelSet.singleton ?l)] => idtac end;
                              left
                            | lazymatch y with context[LevelSet.In ?l (LevelSet.singleton ?l)] => idtac end;
                              right ]
                 | [ H : ConstraintSet.In ?l ?c |- ?x \/ ?y ]
                   => first [ lazymatch x with context[LevelSet.In _ (ConstraintSet.fold _ c _)] => idtac end;
                              left
                            | lazymatch y with context[LevelSet.In _ (ConstraintSet.fold _ c _)] => idtac end;
                              right ]
                 end
               | rewrite !LevelSet.union_spec
               | progress rewrite <- ?ConstraintSet.elements_spec1, ?InA_In_eq in *
               | rewrite ConstraintSetProp.fold_spec_right ].
  all: lazymatch goal with
       | [ |- LevelSet.In Level.lzero (List.fold_right ?f ?init ?ls) ]
         => first [ LevelSetDecide.fsetdec
                  | cut (LevelSet.In Level.lzero init);
                    [ generalize init; induction ls; intros; cbn in *
                    | LevelSetDecide.fsetdec ] ]
       | [ H : List.In ?v ?ls |- LevelSet.In ?v' (List.fold_right ?f ?init (List.rev ?ls)) ]
         => rewrite List.in_rev in H;
            let ls' := fresh "ls" in
            set (ls' := List.rev ls);
            change (List.In v ls') in H;
            change (LevelSet.In v' (List.fold_right f init ls'));
            generalize init; induction ls'; cbn in *
       end.
  all: repeat first [ exfalso; assumption
                    | progress destruct_head'_or
                    | progress subst
                    | progress intros
                    | progress destruct ?
                    | rewrite !LevelSetFact.add_iff
                    | solve [ auto ] ].
Qed.

Definition consistent_dec ctrs : {@consistent ctrs} + {~@consistent ctrs}.
Proof.
  pose proof (@uGraph.is_consistent_spec config.default_checker_flags (levels_of_cs ctrs, ctrs) (levels_of_cs_spec ctrs)) as H.
  destruct uGraph.is_consistent; [ left; apply H | right; intro H'; apply H in H' ]; auto.
Defined.

Definition levels_of_cs2 (cs1 cs2 : ConstraintSet.t) : LevelSet.t
  := LevelSet.union (levels_of_cs cs1) (levels_of_cs cs2).
Lemma levels_of_cs2_spec cs1 cs2 (lvls := levels_of_cs2 cs1 cs2)
  : uGraph.global_uctx_invariants (lvls, cs1)
    /\ uGraph.global_uctx_invariants (lvls, cs2).
Proof.
  split; apply global_uctx_invariants_union_or; constructor; apply levels_of_cs_spec.
Qed.

Definition levels_of_cscs (cs : ContextSet.t) (cstr : ConstraintSet.t) : LevelSet.t
  := LevelSet.union (ContextSet.levels cs) (levels_of_cs2 cstr (ContextSet.constraints cs)).
Lemma levels_of_cscs_spec cs cstr (lvls := levels_of_cscs cs cstr)
  : uGraph.global_uctx_invariants (lvls, ContextSet.constraints cs)
    /\ uGraph.global_uctx_invariants (lvls, cstr).
Proof.
  generalize (levels_of_cs2_spec cstr (ContextSet.constraints cs)).
  split; apply global_uctx_invariants_union_or; constructor; apply levels_of_cs2_spec.
Qed.

Definition levels_of_algexpr (u : LevelAlgExpr.t) : VSet.t
  := LevelExprSet.fold
       (fun gc acc => match LevelExpr.get_noprop gc with
                      | Some l => VSet.add l acc
                      | None => acc
                      end)
       u
       VSet.empty.
Lemma levels_of_algexpr_spec u cstr (lvls := levels_of_algexpr u)
  : gc_levels_declared (lvls, cstr) u.
Proof.
  subst lvls; cbv [levels_of_algexpr gc_levels_declared gc_expr_declared on_Some_or_None LevelExpr.get_noprop]; cbn [fst snd].
  cbv [LevelExprSet.For_all]; cbn [fst snd].
  repeat first [ apply conj
               | progress intros
               | progress destruct ?
               | exact I
               | progress rewrite <- ?LevelExprSet.elements_spec1, ?InA_In_eq in *
               | rewrite LevelExprSetProp.fold_spec_right ].
  all: lazymatch goal with
       | [ H : List.In ?v ?ls |- VSet.In ?v' (List.fold_right ?f ?init (List.rev ?ls)) ]
         => rewrite List.in_rev in H;
            let ls' := fresh "ls" in
            set (ls' := List.rev ls);
            change (List.In v ls') in H;
            change (VSet.In v' (List.fold_right f init ls'));
            generalize init; induction ls'; cbn in *
       end.
  all: repeat first [ exfalso; assumption
                    | progress destruct_head'_or
                    | progress subst
                    | progress intros
                    | progress destruct ?
                    | rewrite !VSetFact.add_iff
                    | solve [ auto ] ].
Qed.

Definition leq0_levelalg_n_dec n ϕ u u' : {@leq0_levelalg_n (uGraph.Z_of_bool n) ϕ u u'} + {~@leq0_levelalg_n (uGraph.Z_of_bool n) ϕ u u'}.
Proof.
  pose proof (@uGraph.gc_leq0_levelalg_n_iff config.default_checker_flags (uGraph.Z_of_bool n) ϕ u u') as H.
  pose proof (@uGraph.gc_consistent_iff config.default_checker_flags ϕ).
  cbv [on_Some on_Some_or_None] in *.
  destruct gc_of_constraints eqn:?.
  all: try solve [ left; cbv [consistent] in *; hnf; intros; exfalso; intuition eauto ].
  pose proof (fun G cstr => @uGraph.leqb_levelalg_n_spec G (LevelSet.union (levels_of_cs ϕ) (LevelSet.union (levels_of_algexpr u) (levels_of_algexpr u')), cstr)).
  pose proof (fun x y => @gc_of_constraints_of_uctx config.default_checker_flags (x, y)) as H'.
  pose proof (@is_consistent_spec config.default_checker_flags (levels_of_cs ϕ, ϕ)).
  specialize_under_binders_by eapply gc_levels_declared_union_or.
  specialize_under_binders_by eapply global_gc_uctx_invariants_union_or.
  specialize_under_binders_by (constructor; eapply gc_of_uctx_invariants).
  cbn [fst snd] in *.
  specialize_under_binders_by eapply H'.
  specialize_under_binders_by eassumption.
  specialize_under_binders_by eapply levels_of_cs_spec.
  specialize_under_binders_by reflexivity.
  destruct is_consistent;
    [ | left; now cbv [leq0_levelalg_n consistent] in *; intros; exfalso; intuition eauto ].
  specialize_by intuition eauto.
  let H := match goal with H : forall (b : bool), _ |- _ => H end in
  specialize (H n u u').
  specialize_under_binders_by (constructor; eapply gc_levels_declared_union_or; constructor; eapply levels_of_algexpr_spec).
  match goal with H : is_true ?b <-> ?x, H' : ?y <-> ?x |- {?y} + {_} => destruct b eqn:?; [ left | right ] end.
  all: intuition.
Defined.

Definition leq_levelalg_n_dec cf n ϕ u u' : {@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u'} + {~@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u'}.
Proof.
  cbv [leq_levelalg_n]; destruct (@leq0_levelalg_n_dec n ϕ u u'); destruct ?; auto.
Defined.

Definition eq0_levelalg_dec ϕ u u' : {@eq0_levelalg ϕ u u'} + {~@eq0_levelalg ϕ u u'}.
Proof.
  pose proof (@eq0_leq0_levelalg ϕ u u') as H.
  destruct (@leq0_levelalg_n_dec false ϕ u u'), (@leq0_levelalg_n_dec false ϕ u' u); constructor; destruct H; split_and; now auto.
Defined.

Definition eq_levelalg_dec {cf ϕ} u u' : {@eq_levelalg cf ϕ u u'} + {~@eq_levelalg cf ϕ u u'}.
Proof.
  cbv [eq_levelalg]; destruct ?; auto using eq0_levelalg_dec.
Defined.

Definition eq_universe__dec {CS eq_levelalg ϕ}
           (eq_levelalg_dec : forall u u', {@eq_levelalg ϕ u u'} + {~@eq_levelalg ϕ u u'})
           s s'
  : {@eq_universe_ CS eq_levelalg ϕ s s'} + {~@eq_universe_ CS eq_levelalg ϕ s s'}.
Proof.
  cbv [eq_universe_]; repeat destruct ?; auto.
Defined.

Definition eq_universe_dec {cf ϕ} s s' : {@eq_universe cf ϕ s s'} + {~@eq_universe cf ϕ s s'} := eq_universe__dec eq_levelalg_dec _ _.

Definition valid_constraints_dec cf ϕ cstrs : {@valid_constraints cf ϕ cstrs} + {~@valid_constraints cf ϕ cstrs}.
Proof.
  pose proof (fun G a b c => uGraph.check_constraints_spec (uGraph.make_graph G) (levels_of_cs2 ϕ cstrs, ϕ) a b c cstrs) as H1.
  pose proof (fun G a b c => uGraph.check_constraints_complete (uGraph.make_graph G) (levels_of_cs2 ϕ cstrs, ϕ) a b c cstrs) as H2.
  pose proof (levels_of_cs2_spec ϕ cstrs).
  cbn [fst snd] in *.
  destruct (consistent_dec ϕ); [ | now left; cbv [valid_constraints valid_constraints0 consistent not] in *; destruct ?; intros; eauto; exfalso; eauto ].
  destruct_head'_and.
  specialize_under_binders_by assumption.
  cbv [uGraph.is_graph_of_uctx MCOption.on_Some] in *.
  cbv [valid_constraints] in *; repeat destruct ?; auto.
  { specialize_under_binders_by reflexivity.
    destruct uGraph.check_constraints_gen; specialize_by reflexivity; auto. }
  { rewrite uGraph.gc_consistent_iff in *.
    cbv [uGraph.gc_of_uctx monad_utils.bind monad_utils.ret monad_utils.option_monad MCOption.on_Some] in *; cbn [fst snd] in *.
    destruct ?.
    all: try congruence.
    all: exfalso; assumption. }
Defined.

Definition valid_constraints0_dec ϕ ctrs : {@valid_constraints0 ϕ ctrs} + {~@valid_constraints0 ϕ ctrs}
  := @valid_constraints_dec config.default_checker_flags ϕ ctrs.

Definition is_lSet_dec cf ϕ s : {@is_lSet cf ϕ s} + {~@is_lSet cf ϕ s}.
Proof.
  apply eq_universe_dec.
Defined.

Definition is_allowed_elimination_dec cf ϕ allowed u : {@is_allowed_elimination cf ϕ allowed u} + {~@is_allowed_elimination cf ϕ allowed u}.
Proof.
  cbv [is_allowed_elimination is_true]; destruct ?; auto;
    try solve [ repeat decide equality ].
  destruct (@is_lSet_dec cf ϕ u), is_propositional; intuition auto.
Defined.