(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Field_cat.
Require Export Ring_facts.
(** Title "Basic properties of fields." *)
Section Lemmas1.
Variable K : FIELD.

Definition field_inverse (x : K) : K := Ap (field_inverse_map K) x.

Definition field_div (x y : K) : K := ring_mult x (field_inverse y).

Lemma FIELD_inverse_r :
 forall x : K,
 ~ Equal x (monoid_unit K) ->
 Equal (ring_mult x (field_inverse x)) (ring_unit K).
exact (field_inverse_r_prf K).
Qed.

Lemma FIELD_inverse_l :
 forall x : K,
 ~ Equal x (monoid_unit K) ->
 Equal (ring_mult (field_inverse x) x) (ring_unit K).
exact (field_inverse_l_prf K).
Qed.

Lemma FIELD_unit_non_zero : ~ Equal (ring_unit K) (monoid_unit K).
exact (field_unit_non_zero K).
Qed.

Lemma FIELD_comp :
 forall x x' : K, Equal x x' -> Equal (field_inverse x) (field_inverse x').
unfold field_inverse in |- *.
auto with algebra.
Qed.
Hint Resolve FIELD_comp FIELD_inverse_r FIELD_inverse_l FIELD_unit_non_zero:
  algebra.

Lemma FIELD_unit_inverse : Equal (field_inverse (ring_unit K)) (ring_unit K).
apply Trans with (ring_mult (field_inverse (ring_unit K)) (ring_unit K));
 auto with algebra.
Qed.
Hint Resolve FIELD_unit_inverse: algebra.

Lemma FIELD_reg_left :
 forall x y z : K,
 ~ Equal x (monoid_unit K) ->
 Equal (ring_mult x y) (ring_mult x z) -> Equal y z.
intros x y z H' H'0; try assumption.
apply Trans with (ring_mult (ring_unit K) y).
auto with algebra.
apply Trans with (ring_mult (ring_mult (field_inverse x) x) y).
apply Sym; auto with algebra.
apply Trans with (ring_mult (field_inverse x) (ring_mult x y)).
auto with algebra.
apply Trans with (ring_mult (field_inverse x) (ring_mult x z)).
auto with algebra.
apply Trans with (ring_mult (ring_mult (field_inverse x) x) z).
auto with algebra.
apply Trans with (ring_mult (ring_unit K) z); auto with algebra.
Qed.

Lemma FIELD_reg_right :
 forall x y z : K,
 ~ Equal x (monoid_unit K) ->
 Equal (ring_mult y x) (ring_mult z x) -> Equal y z.
intros x y z H' H'0; try assumption.
apply Trans with (ring_mult y (ring_unit K)).
auto with algebra.
apply Trans with (ring_mult y (ring_mult x (field_inverse x))).
apply Sym; auto with algebra.
apply Trans with (ring_mult (ring_mult y x) (field_inverse x)).
auto with algebra.
apply Trans with (ring_mult (ring_mult z x) (field_inverse x)).
auto with algebra.
apply Trans with (ring_mult z (ring_mult x (field_inverse x))).
auto with algebra.
apply Trans with (ring_mult z (ring_unit K)).
auto with algebra.
auto with algebra.
Qed.

Lemma FIELD_inverse_non_zero :
 forall x : K,
 ~ Equal x (monoid_unit K) -> ~ Equal (field_inverse x) (monoid_unit K).
intuition.
apply FIELD_unit_non_zero.
apply Trans with (ring_mult (field_inverse x) x:K); auto with algebra.
apply Sym; auto with algebra.
apply Trans with (ring_mult (monoid_unit K) x:K); auto with algebra.
Qed.
Hint Resolve FIELD_inverse_non_zero: algebra.

Lemma FIELD_inverse_inverse :
 forall x : K,
 ~ Equal x (monoid_unit K) -> Equal (field_inverse (field_inverse x)) x.
intros x H'; try assumption.
apply FIELD_reg_right with (field_inverse x); auto with algebra.
apply Trans with (ring_unit K:K); auto with algebra.
apply Sym; auto with algebra.
Qed.
Hint Resolve FIELD_inverse_inverse: algebra.

Lemma FIELD_integral_domain_l :
 forall x y : K,
 ~ Equal (ring_mult x y) (monoid_unit K) -> ~ Equal x (monoid_unit K).
unfold not in |- *.
intros x y H' H'0; try assumption.
absurd (Equal (ring_mult x y) (monoid_unit K)); auto with algebra.
apply Trans with (ring_mult (monoid_unit K) y:K); auto with algebra.
Qed.

Lemma FIELD_integral_domain_r :
 forall x y : K,
 ~ Equal (ring_mult x y) (monoid_unit K) -> ~ Equal y (monoid_unit K).
unfold not in |- *.
intros x y H' H'0; try assumption.
absurd (Equal (ring_mult x y) (monoid_unit K)); auto with algebra.
apply Trans with (ring_mult x (monoid_unit K):K); auto with algebra.
Qed.

Lemma FIELD_law_inverse :
 forall x y : K,
 Equal (ring_mult x y) (ring_unit K) -> Equal (field_inverse x) y.
intros x y H'; try assumption.
apply FIELD_reg_left with x.
apply FIELD_integral_domain_l with y; auto with algebra.
intuition.
absurd (Equal (ring_unit K) (monoid_unit K)); auto with algebra.
apply Trans with (ring_mult x y:K); auto with algebra.
apply Trans with (ring_unit K:K); auto with algebra.
apply FIELD_inverse_r.
intuition.
absurd (Equal (ring_unit K) (monoid_unit K)); auto with algebra.
apply Trans with (ring_mult x y:K); auto with algebra.
apply Trans with (ring_mult (monoid_unit K) y:K); auto with algebra.
Qed.

Lemma FIELD_inverse_law :
 forall x y : K,
 ~ Equal x (monoid_unit K) ->
 ~ Equal y (monoid_unit K) ->
 Equal (field_inverse (ring_mult x y))
   (ring_mult (field_inverse y) (field_inverse x)).
intros x y H' H'0; try assumption.
apply FIELD_law_inverse.
apply
 Trans
  with
    (ring_mult x
       (ring_mult y (ring_mult (field_inverse y) (field_inverse x)))
     :K); auto with algebra.
apply
 Trans
  with
    (ring_mult x
       (ring_mult (ring_mult y (field_inverse y)) (field_inverse x))
     :K); auto with algebra.
apply Trans with (ring_mult x (ring_mult (ring_unit K) (field_inverse x)):K);
 auto with algebra.
apply Trans with (ring_mult x (field_inverse x):K); auto with algebra.
Qed.
Hint Resolve FIELD_inverse_law: algebra.

Lemma FIELD_x_div_x :
 forall x : K,
 ~ Equal x (monoid_unit K) -> Equal (field_div x x) (ring_unit K).
unfold field_div in |- *; auto with algebra.
Qed.
Hint Resolve FIELD_x_div_x: algebra.

Lemma FIELD_simpl_r :
 forall x y : K,
 ~ Equal y (monoid_unit K) -> Equal (ring_mult (field_div x y) y) x.
unfold field_div in |- *.
intros x y H'; try assumption.
apply Trans with (ring_mult x (ring_mult (field_inverse y) y):K);
 auto with algebra.
apply Trans with (ring_mult x (ring_unit K):K); auto with algebra.
Qed.
Hint Resolve FIELD_simpl_r: algebra.

Lemma FIELD_one_div_x :
 forall x : K,
 ~ Equal x (monoid_unit K) ->
 Equal (field_div (ring_unit K) x) (field_inverse x).
unfold field_div in |- *; auto with algebra.
Qed.
Hint Resolve FIELD_one_div_x: algebra.

Lemma FIELD_one_div_xy :
 forall x y : K,
 ~ Equal x (monoid_unit K) ->
 ~ Equal y (monoid_unit K) ->
 Equal (field_div (ring_unit K) (ring_mult x y))
   (ring_mult (field_div (ring_unit K) y) (field_div (ring_unit K) x)).
unfold field_div in |- *.
intros x y H' H'0; try assumption.
apply Trans with (field_inverse (ring_mult x y):K); auto with algebra.
apply Trans with (ring_mult (field_inverse y) (field_inverse x):K);
 auto with algebra.
Qed.
Hint Resolve FIELD_one_div_xy: algebra.

Lemma FIELD_one_div_div :
 forall x y : K,
 ~ Equal x (monoid_unit K) ->
 ~ Equal y (monoid_unit K) ->
 Equal (field_div (ring_unit K) (field_div x y)) (field_div y x).
unfold field_div in |- *.
intros x y H' H'0; try assumption.
apply Trans with (field_inverse (ring_mult x (field_inverse y)):K);
 auto with algebra.
apply
 Trans with (ring_mult (field_inverse (field_inverse y)) (field_inverse x):K);
 auto with algebra.
Qed.
Hint Resolve FIELD_one_div_div: algebra.

Lemma FIELD_div_div :
 forall x y z : K,
 ~ Equal y (monoid_unit K) ->
 ~ Equal z (monoid_unit K) ->
 Equal (field_div x (field_div y z)) (field_div (ring_mult x z) y).
unfold field_div in |- *.
intros x y z H' H'0; try assumption.
apply
 Trans
  with
    (ring_mult x
       (ring_mult (field_inverse (field_inverse z)) (field_inverse y))
     :K); auto with algebra.
apply Trans with (ring_mult x (ring_mult z (field_inverse y)):K);
 auto with algebra.
Qed.
Hint Resolve FIELD_div_div: algebra.
Comments "Normalisation.".

Lemma FIELD_mult_div_l :
 forall x y z : K,
 Equal (ring_mult x (field_div y z)) (field_div (ring_mult x y) z).
intros x y z; try assumption.
unfold field_div in |- *.
auto with algebra.
Qed.
Hint Resolve FIELD_mult_div_l: algebra.

Lemma FIELD_div_div2 :
 forall x y z : K,
 ~ Equal y (monoid_unit K) ->
 ~ Equal z (monoid_unit K) ->
 Equal (field_div (field_div x y) z) (field_div x (ring_mult z y)).
unfold field_div in |- *.
intros x y z H' H'0; try assumption.
apply
 Trans with (ring_mult x (ring_mult (field_inverse y) (field_inverse z)):K);
 auto with algebra.
apply Sym; auto with algebra.
Qed.

Lemma FIELD_inv_div :
 forall x y : K,
 ~ Equal x (monoid_unit K) ->
 ~ Equal y (monoid_unit K) ->
 Equal (field_inverse (field_div x y)) (field_div y x).
unfold field_div in |- *.
intros x y H' H'0; try assumption.
apply
 Trans with (ring_mult (field_inverse (field_inverse y)) (field_inverse x):K);
 auto with algebra.
Qed.
End Lemmas1.
Hint Resolve FIELD_inverse_r FIELD_inverse_l FIELD_unit_non_zero FIELD_comp
  FIELD_unit_inverse FIELD_reg_left FIELD_reg_right FIELD_inverse_non_zero
  FIELD_inverse_inverse FIELD_integral_domain_l FIELD_integral_domain_r
  FIELD_law_inverse FIELD_inverse_law FIELD_x_div_x FIELD_simpl_r
  FIELD_one_div_x FIELD_one_div_xy FIELD_one_div_div FIELD_div_div
  FIELD_mult_div_l FIELD_div_div2 FIELD_inv_div: algebra.


(****
Reflection procedure for sorted (=LocallySorted lt) solves goals of the form:
  forall (a b : A)(p q r : list A),
  sorted(a::p++q++r) -> sorted(p++r++[b]) -> sorted(q++[b]) -> a<b ->
  sorted(p++q++r++[b]).
where A is an ordered class.  Also handles a ∉ l terms.
****)

Set Default Goal Selector "all".

From Coq Require Import Lists.List.
From mindless Require Import ordered.
Import ListNotations.
From Coq Require Export Sorting.Sorted.

Module Reified.

  Inductive List_formula :=
  | LF_nil : List_formula
  | LF_cons : nat -> List_formula -> List_formula
  | LF_list : nat -> List_formula
  | LF_app : List_formula -> List_formula -> List_formula.

  Inductive Sorted_formula :=
  | SF_lt : nat -> nat -> Sorted_formula (*a<b*)
  | SF_sorted : List_formula -> Sorted_formula
  | SF_notin : nat -> List_formula -> Sorted_formula
  | SF_and : Sorted_formula -> Sorted_formula -> Sorted_formula
  | SF_or : Sorted_formula -> Sorted_formula -> Sorted_formula
  | SF_imp : Sorted_formula -> Sorted_formula -> Sorted_formula
  | SF_skip : Prop -> Sorted_formula. (*unreified props*)

End Reified.

Module Notations.

  Notation sorted := (LocallySorted lt).

  Definition NotIn{A}(x : A)(l : list A) := ~In x l.

  Infix "<" := lt (at level 70) : list_scope.

  Infix "∈" := In (at level 55) : list_scope.

  Infix "∉" := NotIn (at level 55) : list_scope.
End Notations.

Module Reflection.
  Export Reified.

  Fixpoint flatten(lf : List_formula) {struct lf} : list nat :=
    match lf with
    | LF_nil => nil
    | LF_cons i lf' => i :: flatten lf'
    | LF_list i => [i]
    | LF_app lf1 lf2 => flatten lf1 ++ flatten lf2
    end.

  Definition Known := list (nat * nat).
  (*There are currently 2 knowns, referred to as kord (ordered knowns produced by sorted an < hyps) and knin (produced by NotIn hyps).  Both share some features, but kord knowns are tansitive through singletons.  Also note that the fst of each pair in knin knowns are always singletons.*)

  Definition add_known(i j:nat)(k:Known) : Known := (i,j)::k.

  Fixpoint add_knowns(i:nat)(k:Known)(js:list nat) : Known :=
    match js with
    | nil => k
    | j::js' => add_knowns i (add_known i j k) js'
    end.

  (*add_known of (i,0) in the i::nil case is a kludge, as 0 is always nil, to allow lone list atoms (sorted l) to be seen as sorted.  This is why we keep index 0 provably pinned to nil in aDenote and isA below*)
  Fixpoint forward_flat(cont:Known->bool)(js:list nat)(kord:Known) : bool :=
    match js with
    | nil => cont kord
    | i::nil => cont (add_known i 0 kord)
    | i::js => forward_flat cont js (add_knowns i kord js)
    end.

  Fixpoint forward(cont:Known->Known->bool)(hyp:Sorted_formula)(kord knin:Known) : bool :=
    let next cont hyp := forward cont hyp kord knin in
    match hyp with
    | SF_lt i j => cont (add_known i j kord) knin
    | SF_sorted lf => forward_flat (fun kord => cont kord knin) (flatten lf) kord
    | SF_notin i lf => cont kord (add_knowns i knin (flatten lf))
    | SF_and h1 h2 => next (forward cont h2) h1
    | SF_or h1 h2 => if next cont h1 then next cont h2 else false
    | _ => cont kord knin
    end.

  Fixpoint is_known (i j:nat)(k:Known) : bool :=
    match k with
    | nil => false
    | (x,y)::k' =>
      if Nat.eqb i x
      then if Nat.eqb j y then true
           else is_known i j k'
      else is_known i j k'
    end.

  (*check needed for sorted of a lone list atom i - only need to check if (i,j) is known for any j, no need to check (j,i) because forward_flat always adds (i,0) at the end*)
  Fixpoint is_kord1 (i:nat)(kord:Known) : bool :=
    match kord with
    | nil => false
    | (x,_)::kord => if Nat.eqb x i then true else is_kord1 i kord
    end.

  Section Backward.
    Variable Singles : list nat.

    Definition isSingleton a := existsb (Nat.eqb a) Singles.

    (*ito_inner and ito_outer are the inner and outer loops for is_trans_ord.  The continuation style (c param) makes the code lighter weight than using well_founded induction.  Both inner and outer loop over Singles, the list of all singletons, looking for chains of singletons related by < from src to dst.  Only singletons are involved because < is transitive with respect to singletons but not list atoms (because list atoms might evaluate to nil)*)
    Fixpoint ito_inner(c: nat -> bool)(kord:Known)(dst src : nat)(l:list nat) : bool :=
      let next := ito_inner c kord dst src in
      match l with
      | mid :: l =>
        if is_known src mid kord
        then if is_known mid dst kord then true
             else if c mid then true
                  else next l
        else next l
      | nil => false
      end.

    Fixpoint ito_outer(kord:Known)(l:list nat)(dst src:nat) : bool :=
      match l with
      | _::l => ito_inner (ito_outer kord l dst) kord dst src Singles
      | nil => false
      end.

    Definition is_trans_ord(i j:nat)(kord:Known) :=
      if is_known i j kord then true else ito_outer kord Singles j i.

    (*all_ord i k l := i is known to be <# every j in l
    Note that we could test to see if i must be nil first, to avoid all further checks, but this is rare, so we put it off until other checks fail *)
    Fixpoint all_ord(i:nat)(kord:Known)(l:list nat) : bool :=
      match l with
      | nil => if isSingleton i then true else is_kord1 i kord
      | j::l' =>
        if is_trans_ord i j kord
        then if isSingleton j then true else all_ord i kord l'
        else if is_trans_ord i i kord (*i is nil*) then true
             else if is_trans_ord j j kord (*j is nil*)
                  then if isSingleton j then true else all_ord i kord l'
                  else false
      end.

    Fixpoint backward_flat_ord(kord:Known)(l:list nat) :=
      match l with
      | nil => true
      | i::l => if all_ord i kord l then backward_flat_ord kord l else false
      end.

    (*i is not in l iff forall j in l:
      - i is known to not be in j
      - i < j
      - j < i
      - j is nil (j < j) *)
    Fixpoint backward_flat_nin(kord knin:Known)(i:nat)(l:list nat) :=
      let next := backward_flat_nin kord knin i in
      match l with
      | nil => true
      | j::l =>
        if is_known i j knin then next l
        else if is_trans_ord i j kord then next l
             else if is_trans_ord j i kord then next l
                  else if is_trans_ord j j kord then next l
                       else false
      end.

    (*true if there exists singleton i with i <# i including by transitivity, which is a contradiction because < is irreflexive.*)
    Fixpoint lt_self(kord : Known) : bool :=
      match kord with
      | nil => false
      | (i,j)::kord' => if isSingleton i then is_trans_ord i i kord else lt_self kord'
      end.

    (*true if there exists singleton i with NotIn i [..i..], which is a contradiction*)
    Fixpoint nin_self(knin : Known) : bool :=
      match knin with
      | nil => false
      | (i,j)::kmin =>
        if Nat.eqb i j then
          if isSingleton i then true
          else nin_self kmin
        else nin_self kmin
      end.

    Definition has_contra(kord knin: Known) : bool :=
      if nin_self knin then true else lt_self kord.

    (*Note that in backward we may end up calling has_contra more than once even if it is true, because backward does not separate out the top-level of conclusion from subformulae.  Every time backward hits SF_imp, the f2 part is a new sub conclusion that may need its own has_contra call (because it can have more knowns due to f1), so we cannot have just one top-level has_contra call.  This leads to some complex wiring - so the easiest thing to do is just test has_contra after each potential low-level conclusion *)
    Fixpoint backward(f:Sorted_formula)(kord knin:Known) : bool :=
      let next f := backward f kord knin in
      match f with
      | SF_lt i j =>
        if is_trans_ord i j kord then true else has_contra kord knin
      | SF_sorted lf =>
        if backward_flat_ord kord (flatten lf) then true else has_contra kord knin
      | SF_notin i lf =>
        if isSingleton i then (*because reflection doesn't know reifier isn't cheating*)
          if backward_flat_nin kord knin i (flatten lf) then true
          else has_contra kord knin
        else has_contra kord knin
      | SF_and f1 f2 =>
        if next f1 then next f2 else false
      | SF_or f1 f2 =>
        if next f1 then true else next f2
      | SF_imp f1 f2 => forward (backward f2) f1 kord knin
      | SF_skip _ => has_contra kord knin
      end.

  End Backward.
End Reflection.

Module Reflection_Proof.
  Import Reflection.
  Import Notations.

  Tactic Notation "deif" :=
    lazymatch goal with
    | |- context[match ?C with _ => _ end] => destruct (C)
    end.

  Tactic Notation "deif" "as" ident(E) :=
    lazymatch goal with
    | |- context[match ?C with _ => _ end] => destruct (C) eqn:E
    end.

  Tactic Notation "deif" hyp(H) :=
    lazymatch type of H with
    | context[match ?C with _ => _ end] => destruct (C)
    end.

  Tactic Notation "deif" hyp(H) "as" ident(E) :=
    lazymatch type of H with
    | context[match ?C with _ => _ end] => destruct (C) eqn:E
    end.

  Local Ltac recon := idtac + (constructor; recon).

  Local Ltac tea := subst; try (cbn in *;intuition (congruence + (recon; eassumption))).

  Local Ltac eappit := match goal with H:_ |- _ => eapply H; solve [tea | eappit] end.

  Definition nat_eq_dec(i j:nat) : {i=j}+{i<>j}.
  Proof.
    decide equality.
  Defined.

  Set Mangle Names.
  Set Mangle Names Prefix "α".

  Lemma ifeqtrue : forall (b:bool), (if b then true else false) = true <-> b = true.
  Proof with tea.
    intros []...
  Qed.

  Lemma ifeqtrue2 : forall (b1 b2:bool),
      (if b1 then true else b2) = true <-> b1 = true \/ b2 = true.
  Proof with tea.
    intros [] ? ...
  Qed.

  Lemma ifeqtrue3: forall (b1 b2:bool),
      (if b1 then b2 else false) = true <-> b1 = true /\ b2 = true.
  Proof with tea.
    intros [] ? ...
  Qed.

  Lemma ifeqtrue4: forall (b1 b2:bool), (if b1 then b2 else b2) = true <-> b2 = true.
  Proof with tea.
    intros [] ? ...
  Qed.

  Lemma nat_eqb_eq: forall i j, Nat.eqb i j = true <-> i=j.
  Proof with tea.
    intro i. induction i. intros []. cbn...
    split. intro H.
    - f_equal. eappit.
    - injection H. eappit.
  Qed.

  Lemma nat_eqb_self: forall i, Nat.eqb i i = true.
  Proof with tea.
    intro i. induction i...
  Qed.

  Lemma neq_nat_eqb: forall i j, i<>j -> Nat.eqb i j = false.
  Proof with tea.
    intros i j H. destruct (Nat.eqb i j) eqn:E...
    apply nat_eqb_eq in E...
  Qed.

  Local Ltac dorws :=
    repeat first[rewrite ifeqtrue4 in *
                |rewrite ifeqtrue in *
                |rewrite ifeqtrue2 in *
                |rewrite ifeqtrue3 in *
                |rewrite nat_eqb_self in *
                |rewrite nat_eqb_eq in *
                |rewrite neq_nat_eqb in * by congruence].

  Section Reflect_Proof.
    Context {A : Set}.
    Context {ordA : Ordered A}.

    Inductive Atom := Aatom(_:A) | Latom(_:list A).

    Section With_Atomics.
      Variable atomics : list Atom.
      Hypothesis atomics0nil : nth 0 atomics (Latom nil) = (Latom nil).

      Definition aDenote i : list A :=
       match (nth i atomics (Latom nil)) with
       | Aatom a => [a]
       | Latom l => l
        end.

      Definition isA i : bool :=
        match (nth i atomics (Latom nil)) with
        | Aatom _ => true
        | Latom _ => false
        end.

      Fixpoint lfDenote(lf : List_formula) : list A :=
        match lf with
        | LF_nil => nil
        | LF_cons i lf' => aDenote i ++ lfDenote lf'
        | LF_list i => aDenote i
        | LF_app lf1 lf2 => lfDenote lf1 ++ lfDenote lf2
        end.

      Fixpoint fDenote(l: list nat) : list A :=
        match l with
        | nil => nil
        | i::l => aDenote i ++ fDenote l
        end.

      Notation "X '<#' Y" := (sorted (aDenote X ++ aDenote Y)) (at level 70) : list_scope.

      (*lemmas showing that flattening is correct*)

      Lemma flatten_app : forall l1 l2, fDenote (l1++l2) = fDenote l1 ++ fDenote l2.
      Proof with tea.
        intro l1. induction l1. intros... cbn. rewrite <-app_assoc...
      Qed.

      Lemma flatten_valid: forall lf, lfDenote lf = fDenote (flatten lf).
      Proof with tea.
        intro lf. induction lf. cbn...
        - apply app_nil_end.
        - rewrite flatten_app...
      Qed.

      (**)

      Definition nin i lf :=
        match (aDenote i) with
        | [a] => a ∉ (lfDenote lf)
        | _ => False
        end.

      (*flattened version of nin*)
      Definition ninf i l :=
        match (aDenote i) with
        | [a] => a ∉ (fDenote l)
        | _ => False
        end.

      Lemma ninf2nin : forall{i l}, ninf i (flatten l) <-> nin i l.
      Proof with tea.
        intros i l. split. intro H. hnf in *. rewrite flatten_valid in * ...
      Qed.

      Local Ltac denin :=
        let x:=fresh in
        lazymatch goal with
        | H: isA ?i = true |- _ =>
          unfold nin,ninf in *;
          unfold isA in H; cbn in *;
          set(x:=(aDenote i)) in *;
          unfold aDenote in x;
          destruct (nth _ atomics _);
          subst x;
          cbn in *
        end.

      Fixpoint sfDenote(sf : Sorted_formula) : Prop :=
        match sf with
        | SF_lt i j =>
          (*kludge needed here because proofs don't know i and j are always singletons*)
          match (aDenote i), (aDenote j) with
          | [a], [b] => a<b (*for convertibility, we cannot use i <# j*)
          | _, _ => i <# j (*should not occur, but needed for correctness*)
          end
        | SF_sorted lf => sorted (lfDenote lf)
        | SF_notin i lf => nin i lf
        | SF_and sf1 sf2 => sfDenote sf1 /\ sfDenote sf2
        | SF_or sf1 sf2 => sfDenote sf1 \/ sfDenote sf2
        | SF_imp sf1 sf2 => sfDenote sf1 -> sfDenote sf2
        | SF_skip p => p
        end.

      (*prevent sfDenote (SF_lt i j) from reducing to the < vs. <# kludge:*)
      Lemma sflt_norm: forall i j, sfDenote (SF_lt i j) <-> i <# j.
      Proof with tea.
        intros i j. split. intro H. cbn in *.
        do 2 destruct (aDenote _) as [|? []]... inversion H...
      Qed.

      (*lemmas about sorted - all are opaque*)

      Lemma sorted_left : forall {l1 l2}, sorted (l1++l2) -> sorted l1.
      Proof with tea.
        intro l1. induction l1 as [ |a l1 IHl1]...
        intros l2 H. destruct l1... inversion H... constructor... eapply IHl1...
      Qed.

      Lemma sorted_right : forall {l1 l2}, sorted (l1++l2) -> sorted l2.
      Proof with tea.
        intro l1. induction l1 as [|a l1 IHl1].
        intros l2 H... destruct l1. inversion H... eapply IHl1...
      Qed.

      Lemma sorted_tail : forall {l a}, sorted (a::l) -> sorted l.
      Proof with tea.
        intros l a H. inversion H...
      Qed.

      Lemma sorted_combine : forall {l1 l2 a}, sorted(l1++[a]) -> sorted([a]++l2) -> sorted(l1++[a]++l2).
      Proof with tea.
        intro l1. induction l1 as [|a l1 IHl1]. intros l2 ? H1 H2...
        destruct l1. cbn in *. constructor... inversion H1... apply IHl1...
      Qed.

      Lemma sorted_overlap : forall {l1 l2 l3 a b},
          sorted(l1++a::l2) -> sorted(l2++b::l3) -> a<b -> sorted(l1++a::l2++b::l3).
      Proof with tea.
        intro l1. induction l1 as [|a l1 IHl1]. intros l2 l3 ? ? H H0 H1.
        - destruct l2... inversion H...
        - destruct l1. cbn in *. inversion H. subst. constructor... eapply IHl1...
      Qed.

      Lemma sorted2lt : forall {l1 l2 a b}, sorted (a::l1++b::l2) -> a<b.
      Proof with tea.
        intro l1. induction l1 as [|a l1 IHl1]. intros ? ? ? H. inversion H...
        transitivity a... eapply IHl1...
      Qed.

      Lemma sorted_delmid : forall {l1 l2 l3}, sorted (l1++l2++l3) -> sorted (l1++l3).
      Proof with tea.
        intro l1. induction l1 as [|a l1 IHl1]. intros l2 l3 H.
        - eapply sorted_right...
        - destruct l1.
          + destruct l3... constructor.
            * do 2 apply sorted_right in H...
            * apply sorted2lt in H...
          + inversion H... cbn. constructor... eapply IHl1...
      Qed.

      Lemma sorted_3way : forall {l1 l2 l3}, sorted(l1++l2) -> sorted(l2++l3) -> sorted(l1++l3) -> sorted(l1++l2++l3).
      Proof with tea.
        intros l1 [] [] H1 H2 H3. cbn in *. rewrite ?app_nil_r in *...
        eapply sorted_overlap...
        - eapply sorted_tail...
        - eapply sorted2lt...
      Qed.

      (*lemmas about NotIn*)

      Lemma NotInBoth: forall {l1 l2}{x:A}, x ∉ (l1++l2) <-> (x ∉ l1 /\ x ∉ l2).
      Proof with tea.
        intros l1 l2 x. split.
        - intro H1. split. intro H2. apply H1. apply in_or_app...
        - intros (H1 & H2) H3. apply in_app_or in H3...
      Qed.

      Lemma NotInl: forall {l x}, sorted (x::l) -> x ∉ l.
      Proof with tea.
        intro l. induction l as [|y l IHl]. intros x H. unfold NotIn...
        cbn. intros [H1|H1]. subst.
        - eapply irreflexivity. inversion H...
        - eapply IHl... change (x::y::l) with ([x]++[y]++l) in H.
          apply sorted_delmid in H...
      Qed.

      Lemma NotInr: forall {l x}, sorted (l++[x]) -> x ∉ l.
      Proof with tea.
        intro l. induction l as [|y l IHl]. intros x H. unfold NotIn...
        cbn. intros [H1|H1]. subst.
        - change ((x::l)++[x]) with ([x]++l++[x]) in H.
          apply sorted_delmid in H. eapply irreflexivity. inversion H...
        - cbn in H. apply sorted_tail in H. eapply IHl...
      Qed.

      (**)

      Fixpoint allOrdered(kord:Known) : Prop :=
        match kord with
        | nil => True
        | (i, j)::kord' => i <# j /\ allOrdered kord'
        end.

      Fixpoint allNotIn(knin:Known) : Prop :=
        match knin with
        | nil => True
        | (i, j)::knin' => nin i (LF_list j) /\ allNotIn knin'
        end.

      Lemma in_allOrdered: forall{kord i j}, allOrdered kord -> In (i, j) kord -> i <# j.
      Proof with tea.
        intro kord. induction kord as [|a kord IHk]. intros i j. cbn...
        intros H [->|]... destruct a. apply IHk...
      Qed.

      Lemma sorted_single: forall{a}, isA a = true -> sorted (aDenote a).
      Proof with tea.
        intros a H. unfold isA in H. unfold aDenote. deif... deif...
      Qed.

      Lemma sorted_alone: forall{kord a},
          allOrdered kord -> is_kord1 a kord = true -> sorted (aDenote a).
      Proof with tea.
        intro kord. induction kord as [|[i j] kord IHk]. intros n H1 H2... cbn in *.
        dorws. destruct H1, H2. subst.
        - eapply sorted_left...
        - eappit.
      Qed.

      Lemma is_known_In: forall{k i j}, is_known i j k = true -> In (i,j) k.
      Proof with tea.
        intro k. induction k as [|[x y] k IHk]. intros i j H... cbn in H.
        destruct (nat_eq_dec i x). subst. dorws. 1:destruct H... right. eappit.
      Qed.

      Lemma known_ord: forall{kord i j}, is_known i j kord = true -> allOrdered kord -> i <# j.
      Proof with tea.
        intros. eapply in_allOrdered... eapply is_known_In...
      Qed.

      Lemma known_nin: forall{knin i j},
          is_known i j knin = true -> allNotIn knin -> nin i (LF_list j).
      Proof with tea.
        intro knin. induction knin as [|[x y] k IHk]. intros i j H1 []... cbn in H1.
        destruct (nat_eq_dec i x). subst. dorws... 1:destruct H1... eappit.
      Qed.

      Lemma ord_trans: forall {a b c},
          a <# b -> sorted(aDenote b ++ fDenote c) -> isA b = true -> sorted(aDenote a ++ fDenote c).
      Proof with tea.
        intros a b c H1 H2 H3. unfold isA in H3.
        set (xb := aDenote b) in *. unfold aDenote in xb. subst xb.
        deif H3... eapply sorted_delmid... eapply sorted_combine...
      Qed.

      Lemma ord_trans1: forall {a b c}, a <# b -> b <# c -> isA b = true -> a <# c.
      Proof with tea.
        intros a b c H1 H2 H3.
        replace (aDenote c) with (fDenote [c]) in * by (apply app_nil_r).
        eapply ord_trans...
      Qed.

      Fixpoint is_sings(l:list nat) : Prop :=
        match l with
        | s::l => isA s = true /\ is_sings l
        | nil => True
        end.

      Lemma ito_inner_valid : forall{kord l c i j},
          (forall m, isA m = true -> i <# m -> c m = true -> i <# j) ->
          allOrdered kord -> is_sings l -> ito_inner c kord j i l = true -> i <# j.
      Proof with tea.
        intros kord l. induction l as [|m l IHl]. intros c i j H H1 H2 H3...
        destruct H2. cbn in H3. deif H3 as E1. 2:eapply IHl...
        apply known_ord in E1... dorws. destruct H3 as [|[]].
        - eapply ord_trans1... eapply known_ord...
        - eapply H...
        - eapply IHl...
      Qed.

      Fixpoint is_lsings(ll:list (list nat)) : Prop :=
        match ll with
        | l :: ll => is_sings l /\ is_lsings ll
        | nil => True
        end.

      Lemma ito_outer_valid : forall{kord l1 l2 i j},
          allOrdered kord -> is_sings l1 -> is_sings l2 ->
          ito_outer l1 kord l2 j i = true -> i <# j.
      Proof with tea.
        intros kord l1 l2. induction l2. intros i j H1 H2 H3 H4...
        eapply ito_inner_valid in H4... intros. eapply ord_trans1... eappit.
      Qed.

      Lemma ito_valid : forall{i j l kord},
          allOrdered kord -> is_sings l -> is_trans_ord l i j kord = true -> i <# j.
      Proof with tea.
        intros i j l kord H1 H2 H3. unfold is_trans_ord in H3. deif H3 as E.
        - eapply known_ord...
        - eapply ito_outer_valid...
      Qed.

      Lemma ord_self_single : forall{i}, i <# i -> isA i = true -> False.
      Proof with tea.
        intros i H1 H2. unfold aDenote in H1. unfold isA in H2.
        deif H2... eapply irreflexivity. inversion H1...
      Qed.

      Lemma ord_self_nil : forall{i}, i <# i -> aDenote i = nil.
      Proof with tea.
        intros i H. destruct (aDenote i)... cbn in H. eelim irreflexivity. eapply sorted2lt...
      Qed.

      Lemma sing_sing: forall{i sl}, is_sings sl -> isSingleton sl i = true -> isA i = true.
      Proof with tea.
        intros i sl. induction sl as [|j sl IHsl]. cbn... intros [] H.
        destruct (nat_eq_dec i j). subst. dorws...
      Qed.

      Lemma sorted_push: forall{i kord sl l},
          allOrdered kord -> is_sings sl -> all_ord sl i kord l = true -> sorted (fDenote l) ->
          sorted (aDenote i ++ fDenote l).
      Proof with tea.
        intros i kord sl l H0 H1 H2 H3. induction l. cbn in H2.
        { rewrite app_nil_r. dorws. destruct H2.
          - eapply sorted_single... eapply sing_sing...
          - eapply sorted_alone... }
        cbn [fDenote] in *. apply sorted_right in H3 as H4. deif H2 as E1. dorws.
        { apply ito_valid in E1... eapply sorted_3way... destruct H2... eapply ord_trans...
          eapply sing_sing... }
        destruct H2 as [H2|[H2 []]]. eapply ito_valid in H2...
        - rewrite (ord_self_nil H2)...
        - eapply ord_self_single in H2... eapply sing_sing...
        - rewrite (ord_self_nil H2)...
      Qed.

      Lemma backward_flat_ord_valid: forall{kord sl l},
          is_sings sl -> allOrdered kord -> backward_flat_ord sl kord l = true ->
          sorted (fDenote l).
      Proof with tea.
        intros kord sl l H1 H2. induction l as [|a l IHl]. intro H3... cbn in H3.
        destruct l. dorws.
        - cbn in *. rewrite app_nil_r. dorws. destruct H3.
          + eapply sorted_single... eapply sing_sing...
          + eapply sorted_alone...
        - destruct H3. eapply sorted_push...
      Qed.

      Lemma backward_flat_nin_valid: forall{i kord knin sl l},
          allOrdered kord -> allNotIn knin -> isA i = true -> is_sings sl ->
          backward_flat_nin sl kord knin i l = true -> ninf i l.
      Proof with tea.
        intros i kord knin sl l H1 H2 H3 H4. induction l as [|j l IHl]. intro E. cbn in E.
        - denin... deif H3... unfold NotIn...
        - deif E as E0.
          { eapply known_nin in E0... denin... deif H3... eapply NotInBoth... }
          deif E as E1.
          { eapply ito_valid in E1... denin... deif H3... rewrite NotInBoth. split... apply NotInl... }
          deif E as E2.
          { eapply ito_valid in E2... denin... deif H3... rewrite NotInBoth. split... apply NotInr... }
          deif E as E3...
          eapply ito_valid in E3... eapply ord_self_nil in E3... unfold ninf. cbn. rewrite E3...
      Qed.

      Lemma allOrdered_adds: forall{i js kord},
          allOrdered kord -> sorted (fDenote (i::js)) -> allOrdered (add_knowns i kord js).
      Proof with tea.
        intros i js. induction js as [|j js IHjs]. intros k H1 H2... cbn in *. apply IHjs.
        - split... eapply sorted_left... rewrite <-app_assoc...
        - eapply sorted_delmid...
      Qed.

      Lemma nilrule : forall a, sorted (aDenote a ++ []) <-> a <# 0.
      Proof with tea.
        intro a. unfold aDenote at 3. rewrite atomics0nil...
      Qed.

      Lemma forward_flat_valid: forall{c l kord},
          allOrdered kord -> sorted (fDenote l) -> forward_flat c l kord = true ->
          exists kord' : Known, allOrdered kord' /\ c kord' = true.
      Proof with tea.
        intros c l. induction l as [|a l IHl]. intros kord H1 H2 H3.
        - eexists...
        - eapply allOrdered_adds in H1... cbn in H3. destruct l as [|b l].
          + cbn in H1. exists (add_known a 0 kord). cbn in H2. apply nilrule in H2. split...
          + eapply IHl... cbn [fDenote] in *. eapply sorted_right...
      Qed.

      Lemma allNotIn_add: forall{i l knin},
          allNotIn knin -> ninf i l -> allNotIn (add_knowns i knin l).
      Proof with tea.
        intros i l. induction l as [|j l IHl]. intros knin H1 H2... apply IHl. 1: split...
        unfold nin, ninf in *. deif... deif... cbn in *. rewrite NotInBoth in H2...
      Qed.

      Lemma forward_valid: forall{f kord knin c},
          allOrdered kord -> allNotIn knin -> sfDenote f -> forward c f kord knin = true ->
          exists kord' knin', allOrdered kord' /\ allNotIn knin' /\ c kord' knin' = true.
      Proof with tea.
        intro f. induction f as [i j|l|i l|f1 IHf1 f2 IHf2|f1 IHf1 f2 IHf2| |].
        intros kord knin c H1 H2 H3 H4. 1:apply sflt_norm in H3. cbn in *.
        - exists (add_known i j kord), knin...
        - apply forward_flat_valid in H4 as [k H4]...
          + exists k, knin...
          + rewrite <-flatten_valid...
        - exists kord. exists (add_knowns i knin (flatten l)). repeat split...
          eapply allNotIn_add... apply ninf2nin...
        - destruct H3. eapply IHf1 in H4 as [? []]... eapply IHf2...
        - dorws. destruct H4, H3. eappit.
        - repeat eexists...
        - repeat eexists...
      Qed.

      Lemma lt_self_valid: forall{sl kord},
          is_sings sl -> allOrdered kord -> lt_self sl kord = true -> False.
      Proof with tea.
        intros sl kord. induction kord as [|[i j] kord IHkord]. intros H0 H1 H2...
        cbn in H2. deif H2 as E.
        - apply ito_valid in H2... eapply ord_self_single... eapply sing_sing...
        - destruct H1...
      Qed.

      Lemma nin_self_valid: forall{sl knin},
          is_sings sl -> allNotIn knin -> nin_self sl knin = true -> False.
      Proof with tea.
        intros sl knin. induction knin as [|[i j] knin IHknin]. intros H0 H1 H2...
        destruct H1 as (N1 & H1). cbn in H2. deif H2 as E. dorws...
        destruct H2 as [H2|H2]... unfold nin in N1. deif N1 as E2...
        deif N1 as E3... cbn in N1. rewrite E2 in N1. apply N1...
      Qed.

      Lemma has_contra_valid: forall{kord knin sl},
          is_sings sl -> allOrdered kord -> allNotIn knin -> has_contra sl kord knin = true ->
          False.
      Proof with tea.
        intros kord knin sl H0 H1 H2. unfold has_contra. dorws. intros [].
        - eapply nin_self_valid...
        - eapply lt_self_valid...
      Qed.

      Lemma backward_valid: forall{sl f kord knin},
          is_sings sl -> allOrdered kord -> allNotIn knin -> backward sl f kord knin = true ->
          sfDenote f.
      Proof with tea.
        intros sl f.
        induction f as [i j|l|i l|f1 IHf1 f2 IHf2|f1 IHf1 f2 IHf2|f1 IHF1 f2 IHf2|].
        intros kord knin H0 H1 H2 H3. 1:apply sflt_norm. cbn in H3. dorws. cbn [sfDenote].
        - destruct H3...
          + eapply ito_valid...
          + eelim has_contra_valid...
        - destruct H3.
          + rewrite flatten_valid. eapply backward_flat_ord_valid...
          + eelim has_contra_valid...
        - deif H3 as E1. 2:eelim has_contra_valid...
          deif H3 as E2. 2:eelim has_contra_valid...
          apply ninf2nin. eapply backward_flat_nin_valid... eapply sing_sing...
        - split. eappit.
        - destruct H3. (left + right); eappit.
        - intro. apply forward_valid in H3 as [? []]... eappit.
        - eelim has_contra_valid...
      Qed.
    End With_Atomics.

    Fixpoint all_sings(i:nat)(l:list Atom) : list nat :=
      match l with
      | (Aatom _) :: l => i :: all_sings (S i) l
      | _ :: l => all_sings (S i) l
      | nil => nil
      end.

    Lemma all_sings_above:
      forall (l:list Atom) i j, In j (all_sings i l) -> i <= j.
    Proof with tea.
      intro l. induction l as [|[] l IHl]. intros i j H...
      - destruct H as [H|H]. subst... apply IHl in H... transitivity (S i)...
      - apply IHl in H... transitivity (S i)...
    Qed.

    Lemma all_sings_ok_above:
      forall l i j, In (i + j) (all_sings j l) <-> isA l i = true.
    Proof with tea.
      intro l. induction l as [|b l IHl]. intros i j. split. intro H...
      - destruct i...
      - destruct i.
        + destruct b... cbn in H. apply all_sings_above in H.
          apply PeanoNat.Nat.nle_succ_diag_l in H...
        + rewrite PeanoNat.Nat.add_succ_comm in H. destruct b.
          * destruct H as [H|H]. 2:erewrite IHl in H...
            contradict H. apply PeanoNat.Nat.lt_neq.
            apply PeanoNat.Nat.lt_lt_add_l. apply PeanoNat.Nat.lt_succ_diag_r.
          * erewrite IHl in H...
      - destruct i...
        + destruct b. cbn in * ...
        + cbn. rewrite plus_n_Sm. destruct b.
          1:right. erewrite IHl...
    Qed.

    Lemma all_sings_ok: forall i l, In i (all_sings 0 l) <-> isA l i = true.
    Proof with tea.
      intros i l. rewrite (plus_n_O i) at 1. apply all_sings_ok_above.
    Qed.

    Lemma to_is_sings:
      forall l ats, (forall i, In i l -> isA ats i = true) -> is_sings ats l.
    Proof with tea.
      intro l. induction l as [|n l IHl]. intros ats H. cbn... split.
      - apply H...
      - apply IHl. intros. apply H...
    Qed.

    (*maybe needed in completeness proof*)
    Lemma from_is_sings:
      forall l ats i, is_sings ats l -> In i l -> isA ats i = true.
    Proof with tea.
      intro l. induction l as [|n l IHl]. intros ats i H1 H2. cbn in H2...
      cbn in H1. destruct H1 as (H1 & H3). destruct H2 as [H2|H2]...
      apply IHl...
    Qed.

    Lemma all_sings_is_sings: forall ats, is_sings ats (all_sings 0 ats).
    Proof with tea.
      intros. apply to_is_sings. intros. apply all_sings_ok...
    Qed.

    Lemma do_reflection: forall atomics f,
        let ats := (Latom nil) :: atomics in (*add nil as 0th atom*)
        let singles := all_sings 0 ats in
        if backward singles f [] [] then sfDenote ats f else True.
    Proof with tea.
      intros atomics f. cbn. deif as E... eapply backward_valid in E...
      apply all_sings_is_sings.
    Qed.

  End Reflect_Proof.

End Reflection_Proof.

(*Reification tactics*)

Module Reifier.
  Import Reified.
  Import Notations.
  Import Reflection_Proof.

  (*cont is denoted -> max -> xs -> ()*)

  Ltac reifyAtom cont n max a xs axs :=
    lazymatch xs with
    | a::_ => cont n max axs
    | _::?xs => lazymatch n with
                | S ?n => reifyAtom cont n max a xs axs
                | 0 => let n:=constr:(S max) in cont n n constr:(a::axs)
                end
    | _ => fail 999 "reifyAtom invariant broken" max a
    end.

  Ltac reifyAvar cont a max xs := reifyAtom cont max max constr:(Aatom a) xs xs.
  Ltac reifyLvar cont a max xs := reifyAtom cont max max constr:(Latom a) xs xs.

  Ltac reifyList cont l max xs :=
    lazymatch l with
    | ?l1 ++ ?l2 => reifyList ltac:(fun d1 => reifyList ltac:(fun d2 => cont uconstr:(LF_app d1 d2)) l2) l1 max xs
    | ?a :: ?l   => reifyAvar ltac:(fun da => reifyList ltac:(fun dl => cont uconstr:(LF_cons da dl)) l) a max xs
    | nil       => cont uconstr:(LF_nil) max xs
    | ?l        => reifyLvar ltac:(fun d => cont uconstr:(LF_list d)) l max xs
    end.

  Ltac reifyTerm cont e max xs :=
    lazymatch e with
    | ?e1 -> ?e2 => reifyTerm ltac:(fun d1 => reifyTerm ltac:(fun d2 => cont uconstr:(SF_imp d1 d2)) e2) e1 max xs
    | sorted ?l     => reifyList ltac:(fun d => cont uconstr:(SF_sorted d)) l max xs
    | ?e1 /\ ?e2 => reifyTerm ltac:(fun d1 => reifyTerm ltac:(fun d2 => cont uconstr:(SF_and d1 d2)) e2) e1 max xs
    | ?e1 \/ ?e2 => reifyTerm ltac:(fun d1 => reifyTerm ltac:(fun d2 => cont uconstr:(SF_or d1 d2)) e2) e1 max xs
    | ?a < ?b   => reifyAvar ltac:(fun da => reifyAvar ltac:(fun db => cont uconstr:(SF_lt da db)) b) a max xs
    | ?a ∉ ?l   => reifyAvar ltac:(fun da => reifyList ltac:(fun dl => cont uconstr:(SF_notin da dl)) l) a max xs
    | ~ ?a ∈ ?l => reifyAvar ltac:(fun da => reifyList ltac:(fun dl => cont uconstr:(SF_notin da dl)) l) a max xs
    | _         => cont uconstr:(SF_skip e) max xs
    end.

  Ltac reverse xs ys :=
    lazymatch xs with
    | ?h::?xs => reverse xs constr:(h::ys)
    | _ => ys
    end.

  Ltac reify_and_reflect finish :=
    let X := lazymatch type of (_:Ordered _) with
               Ordered ?A => A
             end in
    lazymatch goal with
      |- ?G =>
      let cont d max xs :=
          let atoms := reverse xs constr:(nil:list (@Atom X))
          in
          lazymatch atoms with
            (*remove leading nil so that reflector can put it back and prove its there*)
          | _ :: ?atoms => finish atoms d
          end
      in
      (*atom index 0 is reserved for nil, so start xs with Latom nil:*)
      reifyTerm cont G 0 constr:([@Latom X nil])
    end.

  (*Solver tactic, X is the element type:*)

  Ltac do_reverts :=
    repeat (*revert Props only*)
      match goal with
      | H : ?T |- _ => let x:=constr:(T:Prop) in revert H
      end.

  Ltac ss finish :=
    intros; do_reverts;
    reify_and_reflect finish || fail "solve_sorted failed on goal".

  Ltac finish atoms f :=
    abstract (vm_cast_no_check (do_reflection atoms f)).

  Ltac finishdebug atoms f :=
    let a:=fresh "atoms" in
    let r:=fresh "reified" in
    let d:=fresh "denoted" in
    pose ((Latom nil)::atoms) as a; pose f as r;
    pose (sfDenote a r) as d.

End Reifier.

Ltac solve_sorted := Reifier.ss Reifier.finish.
Ltac debug_solve_sorted := Reifier.ss Reifier.finishdebug.

Unset Mangle Names.

Module Examples.

  Context {A : Set}.
  Context {ordA : Ordered A}.
  Import Notations.

  Notation ss := ltac:(solve_sorted) (only parsing).

  Implicit Types a b c d e f : A.
  Implicit Types l p q r s t u v w x z: list A.

  (*check that solve_sorted fails prior to Qed*)
  Example invalid: forall l1 l2, sorted l1 -> sorted l2.
  Fail solve_sorted.
  Abort.

  Example realeasy: forall a l, sorted (a::l) -> sorted (a::l) := ss.

  Example nolistatoms: forall a b c d e f,
      sorted (a::(b::(c::d::nil)++e::nil)++f::nil) -> sorted(a::c::f::nil).
  Proof.
    solve_sorted.
  Qed.

  Example listsonly: forall p q r, sorted(p++q++r) -> sorted(p++r).
  Proof.
    solve_sorted.
  Qed.

  Example ltonly: forall a b, a<b -> a<b.
  Proof.
    solve_sorted.
  Qed.

  Example trans: forall a b c, a<b -> b<c -> a<c.
  Proof.
    solve_sorted.
  Qed.

  Example interesting:
    forall a b p q r, sorted(a::p++q++r) -> sorted(p++r++[b]) -> sorted(q++[b]) -> a<b ->
                 sorted(p++q++r++[b]).
  Proof.
    solve_sorted.
  Qed.

  Example big:
    forall p q r s t u v a b c d e f l,
      sorted(p++[a]++(q++[b])++r++l++([c]++(s++[d])++t++[e])++(u++[f])++v) ->
      sorted(q++([c]++t)++[e]++v).
  Proof.
    solve_sorted.
  Qed.

  (*cases like this degenerate test are where the (nil,l) known kludge is needed*)
  Example degenerate: forall l, sorted l -> sorted l.
  Proof.
    solve_sorted.
  Qed.

  (*proof by contradiction, by finding a cycle among singletons*)
  Example contra2: forall a b c, a<b -> b<a -> a<c.
  Proof.
    solve_sorted.
  Qed.

  Example bigger:
    forall p q r s t u v w x y z a b c,
      sorted(p++q++r++s++t++[a]) -> a<b -> a<c -> sorted(b::u++v++w) ->
      sorted(c::x++y) -> sorted(c::x++z) /\ sorted(c::y++z) ->
      sorted(u++v++w++[c]) \/ b<c ->
      b<c \/ sorted(p++q++r++s++t++u++v++w++x++y++z) /\ sorted(q++s++u++w++y).
  Proof.
    solve_sorted.
  Qed.

  (*determine that some lists must be nil*)
  Example pnil: forall p a b,
      sorted(p++[a]) -> sorted(a::p) -> sorted(p++b::p).
  Proof.
    solve_sorted.
  Qed.

  Example notin1: forall a l, sorted(a::l) -> a ∉ l.
  Proof.
    solve_sorted.
  Qed.

  Example notin2: forall a p q, a ∉ p -> a ∉ q -> a ∉ (p++q).
  Proof.
    solve_sorted.
  Qed.

  Example notin3: forall a b l, sorted (l++[a]) -> a<b -> b ∉ l.
  Proof.
    solve_sorted.
  Qed.

  Example notin4: forall a, ~ a ∈ [a] -> False.
  Proof.
    solve_sorted.
  Qed.

  Example notin5: forall a b c l1 l2,
      b ∉ l2 -> a<c -> c<b -> sorted(l1++a::l2) -> b ∉ (l1++a::l2).
  Proof.
    solve_sorted.
  Qed.

  Example notin6: forall a b l1 l2,
      b ∉ l2 -> sorted (b::l1) -> sorted(l1++a::l2) -> a<b -> b ∉ (l1++a::l2).
  Proof.
    solve_sorted.
  Qed.

  Example notin7: forall a l, sorted (l++l) -> a ∉ l.
  Proof.
    solve_sorted.
  Qed.

  Example notin8: forall a b l, sorted (l++[b]) -> sorted(b::l) -> a ∉ l.
  Proof.
    solve_sorted.
  Qed.

  Example not_strict_total: forall a b, a ∉ [b] -> a<b \/ b<a.
  Proof.
     (*Ord is a Strict Order but not necessarily a Strict Total Order, so we do not have access to a decidable comparison.  If we did, it would be difficult to incorporate into the reflection procedure.*)
    Fail solve_sorted.
  Abort.

  Example nil_omitted: forall a d, a < d -> sorted(a::d::nil).
  Proof.
    (*fails if nil isn't reified properly (by LF_nil, not LF_list 0)*)
    solve_sorted.
  Qed.

  Example oops: forall l, sorted(nil++l) -> sorted l.
  Proof.
    solve_sorted.
  Qed.

  Example withfun: forall l (P:A -> Prop), sorted l -> sorted l.
  Proof.
    solve_sorted.
  Qed.

End Examples.

(* Local Variables: *)
(* company-coq-local-symbols: (("++" . ?⧺) ("..." . ?…) ("sorted" . ?⊿) ("<#" . ?⧏) ("Known" . ?Ǩ) ("tea" . ?🍵)) *)
(* End: *)


(* -------------------------------------------------------------------- *)
From Coq      Require Import PArray Uint63.
From mathcomp Require Import all_ssreflect finmap.

From Polyhedra Require Import extra_misc.
Require Import refinement.

Require Import extra_int extra_array.
Require Import NArith.BinNat NArith.BinNatDef.
Require Import PArith.BinPos PArith.BinPosDef.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

(* -------------------------------------------------------------------- *)
Import Order.Theory.

(* -------------------------------------------------------------------- *)
Module ArrayInterComputation.

Definition array_inter_step {t : Type} (lt_t : rel t) (a b : array t):=
  fun '(i,j,c)=>
    if (i <? length a)%uint63 then
      if (j <? length b)%uint63 then
        if (lt_t a.[i] b.[j]) then (Uint63.succ i,j,c) else
        if (lt_t b.[j] a.[i]) then (i,Uint63.succ j, c) else
        (Uint63.succ i, Uint63.succ j, Uint63.succ c)
      else (i,j,c)
    else (i,j,c).

Definition array_inter {t : Type} (lt_t : rel t) (a b : array t):=
  (IFold.ifold (fun _ ijc => array_inter_step lt_t a b ijc) (length a + length b)%uint63 (0%uint63, 0%uint63, 0%uint63)).2.

End ArrayInterComputation.

Module AIC := ArrayInterComputation.

Section ArrayInterEquiv.

Definition array_inter_step {t : Type} (lt_t : rel t) (a b : array t):=
  fun '(i,j,c)=>
    if (i < length a)%O then
      if (j < length b)%O then
        if (lt_t a.[i] b.[j]) then (succ i,j,c) else
        if (lt_t b.[j] a.[i]) then (i,succ j, c) else
        (succ i, succ j, succ c)
      else (i,j,c)
    else (i,j,c).

Definition array_inter {t : Type} (lt_t : rel t) (a b : array t):=
  (ifold (fun _ ijc => array_inter_step lt_t a b ijc) (length a + length b)%uint63 (0%uint63, 0%uint63, 0%uint63)).2.

Lemma array_interE {t : Type} (lt_t : rel t) (a b : array t):
  AIC.array_inter lt_t a b = array_inter lt_t a b.
Proof.
rewrite /AIC.array_inter /array_inter ifoldE /ifold.
by elim: (irange0 _).
Qed.

End ArrayInterEquiv.

Section ArrayInter.
(* Hypothesis (r ==> r ==> eq) lt_t lt_T *)

Definition eq_3uple {T : Type} (x y : T * T * T) := [/\ x.1.1 = y.1.1, x.1.2 = y.1.2 & x.2 = y.2].

Lemma rel_array_inter_step {t T : Type}
  (r : t -> T -> Prop)
  (lt_t : rel t) (lt_T : rel T) (i j c: Uint63.int):
  (r =~> r =~> eq) lt_t lt_T ->
  (rel_array r =~> rel_array r =~> eq_3uple)
    (fun a b=> array_inter_step lt_t a b (i,j,c)) (fun a b=> array_inter_step lt_T a b (i,j,c)).
Proof.
move=> lt_tT a A aA b B bB /=.
rewrite -(rel_array_length aA) -(rel_array_length bB).
case/boolP: (i < length a)%O=> [i_a|]; last by split.
case/boolP: (j < length b)%O=> [j_b|]; last by split.
under lt_tT; [exact/(rel_array_r aA)|exact/(rel_array_r bB)| ].
case: (lt_T A.[i] B.[j]); first by split.
under lt_tT; [exact/(rel_array_r bB)|exact/(rel_array_r aA)| ].
by case: (lt_T B.[j] A.[i]); split.
Qed.

Lemma rel_array_inter
  {t T : Type} (r : t -> T -> Prop)
  (lt_t : rel t) (lt_T : rel T) :
  (r =~> r =~> eq) lt_t lt_T ->
  (rel_array r =~> rel_array r =~> eq) (array_inter lt_t) (array_inter lt_T).
Proof.
move=> lt_tT a A aA b B bB.
rewrite /array_inter (rel_array_length aA) (rel_array_length bB) !ifold_iter.
set e := iter _ _ _; set E := iter _ _ _.
suff: eq_3uple e E by case.
rewrite {}/e {}/E; elim: (int_to_nat (length A + length B)%uint63); first by split.
move=> k [] /=; set e := iter k _ _; set E := iter k _ _.
case: e=> -[i j] c; case: E=> -[I J] C /= -> -> ->.
apply/rel_array_inter_step; [exact:lt_tT|exact:aA|exact:bB].
Qed.

End ArrayInter.

Section ArraySetInter.

Context {T : finType} (lt_T : rel T).
Hypothesis irr_lt_T : irreflexive lt_T.
Hypothesis tra_lt_T : transitive lt_T.
Hypothesis eq_lt_T : forall x y, ~~ lt_T x y -> ~~lt_T y x -> x = y.

(* Definition rel_array_set_ord (a : array T) (A : {set T}) i :=
  rel_sorted lt_T a /\ A = [set a.[k] | k in irange0 i].

Lemma rel_array_set_ord_len a A: rel_array_set_ord a A (length a)= rel_array_set lt_T a A.
Proof. by []. Qed. *)

Definition inter_step_inv a b i j (c : int) :=
  [/\
    ((j < length b)%O -> forall k, (k < i)%O -> lt_T a.[k] b.[j]),
    ((i < length a)%O -> forall k, (k < j)%O -> lt_T b.[k] a.[i]),
    (c <= i)%O, (c <= j)%O &
    #|[set a.[k]| k in irange0 i] :&: [set b.[k]| k in irange0 j]| = c
  ].

Lemma array_inter_stepP a b i j c:
  rel_sorted lt_T a -> rel_sorted lt_T b->
  inter_step_inv a b i j c -> let: (i',j',c'):= array_inter_step lt_T a b (i,j,c) in
  inter_step_inv a b i' j' c'.
Proof.
move=> st_a st_b [bj_max ai_max c_i c_j c_inter]; rewrite /array_inter_step.
case: ifP=> // i_a; case:ifP=> // j_b; case: ifP; try case: ifP.
- move=> ai_bj; split=> //.
  + move=> _ k /ltiS_ltVeqS; move/(_ (lt_length_lt_max i_a))=> [k_i|-> //]; exact/bj_max.
  + move=> Si_a k /(ai_max i_a); move/tra_lt_T; apply.
    rewrite sorted_rel_eq //; exact/ltiSi/lt_length_lt_max/i_a.
  + apply/(le_trans c_i)/ltW/ltiSi/lt_length_lt_max/i_a.
  + rewrite -{}c_inter; apply/eq_card=> z; rewrite !inE; apply/idP/idP.
    * case/andP=> /imsetP [ki + z_aki] /imsetP [kj + z_bkj].
      rewrite !mem_irangeE !le0x /=; move/(ltiS_ltVeqS (lt_length_lt_max i_a)).
      case; [by move=> ??; rewrite {1}z_aki z_bkj !imset_f // !mem_irangeE !le0x|].
      move=> ki_i kj_j; move: z_aki; rewrite z_bkj ki_i=> abs.
      by move: (ai_max i_a)=> /(_ kj kj_j); rewrite abs irr_lt_T.
    * case/andP=> /imsetP [ki + z_aki] /imsetP [kj + z_bkj].
      rewrite !mem_irangeE !le0x /= => ki_i kj_j.
      rewrite {1}z_aki z_bkj !imset_f ?mem_irangeE ?le0x //=.
      exact/(lt_trans ki_i)/ltiSi/lt_length_lt_max/i_a.
- move=> bj_ai; split=> //.
  + move=> Sj_b k /(bj_max j_b); move/tra_lt_T; apply.
    rewrite sorted_rel_eq //; exact/ltiSi/lt_length_lt_max/j_b.
  + move=> _ k /ltiS_ltVeqS; move/(_ (lt_length_lt_max j_b))=> [k_i|-> //]; exact/ai_max.
  + apply/(le_trans c_j)/ltW/ltiSi/lt_length_lt_max/j_b.
  + rewrite -{}c_inter; apply/eq_card=> z; rewrite !inE; apply/idP/idP.
    * case/andP=> /imsetP [ki + z_aki] /imsetP [kj + z_bkj].
      rewrite !mem_irangeE !le0x /=; move=> ki_i /(ltiS_ltVeqS (lt_length_lt_max j_b)).
      case; [by move=> ?; rewrite {1}z_aki z_bkj !imset_f // !mem_irangeE !le0x|].
      move=> kj_j; move: z_bkj; rewrite z_aki kj_j=> abs.
      by move: (bj_max j_b)=> /(_ ki ki_i); rewrite abs irr_lt_T.
    * case/andP=> /imsetP [ki + z_aki] /imsetP [kj + z_bkj].
      rewrite !mem_irangeE !le0x /= => ki_i kj_j.
      rewrite {1}z_aki z_bkj !imset_f ?mem_irangeE ?le0x //=.
      exact/(lt_trans kj_j)/ltiSi/lt_length_lt_max/j_b.
- move=> bj_ai ai_bj; move: (@eq_lt_T a.[i] b.[j]); rewrite {}ai_bj {}bj_ai=> /(_ isT isT) ai_bj.
  split.
  + move=> Sj_b k /(ltiS_ltVeqS (lt_length_lt_max i_a)).
    case=> [k_i|->]; [apply/(@tra_lt_T a.[i])|] ; try (rewrite ai_bj sorted_rel_eq ?ltiSi //; exact: (lt_length_lt_max j_b)).
    rewrite sorted_rel_eq //; exact/(lt_trans k_i).
  + move=> Si_a k /(ltiS_ltVeqS (lt_length_lt_max j_b)).
    case=> [k_j|->]; [apply/(@tra_lt_T b.[j])|] ; try (rewrite -ai_bj sorted_rel_eq ?ltiSi //; exact: (lt_length_lt_max i_a)).
    rewrite sorted_rel_eq //; exact/(lt_trans k_j).
  + rewrite -succ_int_mono //; [apply/(le_lt_trans c_i)|]; exact:(lt_length_lt_max i_a).
  + rewrite -succ_int_mono //; [apply:(le_lt_trans c_j)|]; exact:(lt_length_lt_max j_b).
  + set S := _ :&: _; suff ->: S = [set a.[k] | k in irange0 i] :&: [set b.[k] | k in irange0 j] :|: [set a.[i]].
      * rewrite (eqTleqif (leq_card_setU _ _)) ?cards1 ?c_inter ?addn1 ?succ_intE //;
          last exact/(le_lt_trans c_i)/lt_length_lt_max/i_a.
        rewrite disjoint_sym disjoints1 !inE negb_and; apply/orP; left.
        apply/negP=> /imsetP [k]; rewrite mem_irangeE le0x /= => /[dup] k_i + ai_ak.
        rewrite -(sorted_rel_eq irr_lt_T tra_lt_T st_a) // ?ai_ak ?irr_lt_T //.
        exact/(lt_trans k_i).
    apply/setP=> z; rewrite !inE; apply/idP/idP.
      * case/andP=> /imsetP [ki + z_aki] /imsetP [kj + z_bkj].
        rewrite !irange0_succ; try apply/lt_length_lt_max; [exact:i_a|exact:j_b|].
        rewrite !mem_rcons !inE; case/orP=> [/eqP <-|ki_i]; [rewrite z_aki eqxx orbT //|].
        case/orP; [rewrite ai_bj z_bkj=> /eqP <-; rewrite eqxx orbT //|move=> kj_j].
        by rewrite {1}z_aki z_bkj !imset_f.
      * case/orP=> [|/eqP ->];
          [|rewrite {2}ai_bj !imset_f ?mem_irangeE ?le0x ?ltiSi //; apply/lt_length_lt_max; [exact:i_a|exact:j_b]].
        case/andP=> /imsetP [ki ki_i z_aki] /imsetP [kj kj_j z_bkj].
        rewrite {1}z_aki z_bkj !imset_f ?irange0_succ ?mem_rcons ?in_cons ?ki_i ?kj_j ?orbT //;
          apply/lt_length_lt_max; [exact:i_a|exact:j_b].
Qed.

Lemma array_inter_foldP a b n:
  rel_sorted lt_T a -> rel_sorted lt_T b ->
  let: (i,j,c) := (ifold (fun _ ijc => array_inter_step lt_T a b ijc) n (0%uint63, 0%uint63, 0%uint63)) in
  inter_step_inv a b i j c.
Proof.
move=> st_a st_b.
rewrite /ifold; elim/last_ind: (irange0 n)=> [|h t]; last first.
  rewrite foldl_rcons; set F := foldl _ _ _; case: F=> -[i j] c; exact:array_inter_stepP.
rewrite /=; split; rewrite ?lexx /irange0 ?irangee //=; try (by move=> _ k; rewrite ltx0).
by apply/eqP; rewrite cards_eq0 -subset0; apply/subsetP=> x; rewrite inE=> /andP [/imsetP []].
Qed.

Definition stop_inv (a b : array T) i j (n : int):=
  [/\ (i <= length a)%O, (j <= length b)%O &
  (i < length a)%O -> (j < length b)%O -> (n <= i + j)%nat
  ].

Lemma array_inter_fold_stop a b n:
  rel_sorted lt_T a -> rel_sorted lt_T b ->
  let: (i,j,c) := (ifold (fun _ ijc => array_inter_step lt_T a b ijc) n (0%uint63, 0%uint63, 0%uint63)) in
  stop_inv a b i j n.
Proof.
move=> st_a st_b;
set F := ifold _ _ _; case F_eq: F=> [[i j] c].
suff: inter_step_inv a b i j c /\ stop_inv a b i j n by case.
move: F_eq.
rewrite {}/F /ifold irange0_iota /stop_inv.
elim: (int_to_nat n) i j c=> [|n' IHn] i' j' c'.
- move: (array_inter_foldP 0%uint63 st_a st_b)=> /=; rewrite /ifold /irange0 irangee /=.
  by move=> ? [<- <- <-]; split=> //; split=> //; rewrite le0x.
- rewrite iotaS_rcons add0n map_rcons foldl_rcons.
  case F_eq: (foldl _ _ _)=> [[i j] c]; case: (IHn _ _ _ F_eq).
  move=> /[dup] ijc_inv [bj_max ai_max c_i c_j c_eq] [i_a j_a n_le] step_ijc'.
  split; first by (move:(array_inter_stepP st_a st_b ijc_inv); rewrite step_ijc').
  move: step_ijc'=> /=; case: ifP=> i_len; last by (case=> [<- <- _]; split=> //; rewrite i_len).
  case: ifP=> j_len; last by (case=> [<- <- _]; split=> //; rewrite j_len).
  case: ifP; try case:ifP.
  + move=> _ [<- <- _]; split=> //; rewrite ?leEint_nat ?succ_intE -?ltEint_nat //; try apply/lt_length_lt_max/i_len.
    by move=> Si_a _; apply/(leq_ltn_trans (n_le i_len j_len)); rewrite addSnnS addnS.
  + move=> _ _ [<- <- _]; split=> //; rewrite ?leEint_nat ?succ_intE -?ltEint_nat //; try apply/lt_length_lt_max/j_len.
    by move=> _ _; apply/(leq_ltn_trans (n_le i_len j_len)); rewrite addnS.
  + move=> _ _ [<- <- _]; split; rewrite ?leEint_nat ?succ_intE -?ltEint_nat //;
      try apply/lt_length_lt_max/i_len; try apply/lt_length_lt_max/j_len.
    by move=> _ _; apply/(leq_ltn_trans (n_le i_len j_len)); rewrite addSnnS !addnS.
Qed.

Lemma rel_array_set_inter: (rel_array_set lt_T =~> rel_array_set lt_T =~> rel_int)
  (array_inter lt_T) (fun A B=> #|A :&:B|).
Proof.
move=> a A [st_a ->] b B [st_b ->]; rewrite /rel_int /= /array_inter.
move: (array_inter_foldP (length a + length b)%uint63 st_a st_b).
move: (array_inter_fold_stop (length a + length b)%uint63 st_a st_b).
case: (ifold _ _ _)=> -[i j] c /= [i_a j_b Slen_ij] [bj_max ai_max _ _ <-].
apply/eq_card=> z; rewrite !inE.
move: i_a j_b; rewrite !le_eqVlt; case/orP=> + /orP [].
- by move=> /eqP -> /eqP ->.
- move=> /eqP + /[dup] j_b /bj_max; move=> -> lt_bj.
  apply/idP/idP; last (case/andP=> /imsetP [ka ka_a z_aka] /imsetP [kb kb_j z_bkb];
    rewrite {1}z_aka z_bkb !imset_f //; move: kb_j; rewrite !mem_irangeE !le0x /=; move/lt_trans; exact).
  case/andP=> /imsetP [ka ka_a z_aka] /imsetP [kb kb_b z_bkb]; rewrite {1}z_aka z_bkb !imset_f //=.
  move: ka_a; rewrite !mem_irangeE !le0x /= => /lt_bj; rewrite -z_aka z_bkb.
  by rewrite sorted_rel_eq //; move: kb_b; rewrite mem_irangeE le0x.
- move=> /[dup] /ai_max + i_a /eqP; move=> /[swap] -> bk_ai.
  apply/idP/idP; last by (case/andP=> /imsetP [ki + z_aki] /imsetP [kj kj_j z_bkj];
    rewrite mem_irangeE le0x /= => ki_i; rewrite {1}z_aki z_bkj !imset_f // mem_irangeE le0x (lt_trans ki_i i_a)).
  case/andP=> /imsetP [ki ki_a z_aki] /imsetP [kj kj_b z_bkj].
  apply/andP; split; last rewrite z_bkj imset_f //.
  rewrite z_aki imset_f //; move: kj_b; rewrite !mem_irangeE !le0x /=.
  move/bk_ai; rewrite -z_bkj z_aki sorted_rel_eq //.
  by move: ki_a; rewrite mem_irangeE le0x.
- move=> i_a j_b; move: (Slen_ij i_a j_b); rewrite -sum_length.
  move: i_a j_b; rewrite !ltEint_nat=> /leq_add /[apply].
  move/leq_trans=> /[apply]; rewrite addSnnS !addnS.
  elim: (i + j)=> //.
Qed.

End ArraySetInter.

Section BasisInter.

Context {t : Type} (T : finType) (r : t -> T -> Prop).
Context {lt_t : rel t} {lt_T : rel T}.

Hypothesis lt_tT : (r =~> r =~> eq) lt_t lt_T.
Hypothesis irr_lt_T : irreflexive lt_T.
Hypothesis tr_lt_T : transitive lt_T.
Hypothesis eq_lt_T : forall x y, ~~ lt_T x y -> ~~lt_T y x -> x = y.

Lemma rel_arr_set_r_inter :
  (@rel_arr_set_r _ _ r lt_T =~> @rel_arr_set_r _ _ r lt_T =~> rel_int)
    (array_inter lt_t) (fun A B=> #|A :&: B|).
Proof.
apply/rel_equiv_func2; [exact:rel_equiv_refl|exact: rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func2;
  [exact:(rel_array_inter lt_tT)|exact:rel_array_set_inter].
Qed.

End BasisInter.

(* Section ArraySet.
Definition array_set_i (a : array int) (i : int) (S : {set int}) :=
  S =i [seq a.[k] | k <- irange i (length a)].

Definition array_set (a : array int) (S : {set int}):= array_set_i a 0%uint63 S.

Lemma array_set0 (a : array int) (i : int) (S : {set int}):
  length a = 0%uint63 -> array_set_i a i S -> S = set0.
Proof.
move=> len_a array_seta; apply/setP=> x; rewrite array_seta inE.
move: isT; apply/contraTF=> /mapP [y].
by rewrite mem_irangeE len_a ltx0 andbF.
Qed.

Lemma array_set_length (a : array int) (S : {set int}):
  array_set_i a (length a) S -> S = set0.
Proof.
move=> array_setS; apply/setP=> x; rewrite array_setS !inE.
move: isT; apply/contraTF=> /mapP [y].
rewrite mem_irangeE=> /andP [].
by move/le_lt_trans=> /[apply]; rewrite ltxx.
Qed.

Lemma array_set_mono (a : array int) (i j : int) (I J : {set int}):
  lti_sorted a -> (j <= length a)%O -> (i <= length a)%O ->
  array_set_i a i I -> array_set_i a j J ->
  (i <= j)%O = (J \subset I).
Proof.
move=> stta j_len i_len as_iI as_jJ; apply/idP/idP.
- move=> i_le_j; apply/subsetP=> x.
  rewrite as_jJ=> /mapP [k]; rewrite mem_irangeE=> /andP [j_le_k k_len] ->.
  rewrite as_iI; apply/mapP; exists k=> //; rewrite mem_irangeE k_len andbT.
  exact/(le_trans i_le_j).
- move: j_len; rewrite le_eqVlt; case/orP; first by move/eqP=> ->.
  move=> j_len /subsetP /(_ a.[j]).
  have aj_J: a.[j] \in J by rewrite as_jJ map_f // mem_irangeE j_len lexx.
  move/(_ aj_J); rewrite as_iI=> /mapP [j']; rewrite mem_irangeE.
  by case/andP=> i_le_j' j'_len /(lti_sorted_inj stta j_len j'_len) ->.
Qed.

Lemma array_set_succ (a : array int) (i : int) (A : {set int}):
  (i < succ i)%O -> lti_sorted a -> array_set_i a i A -> array_set_i a (succ i) (A :\ a.[i]).
Proof.
move=> i_Si stta array_seta x; apply/idP/idP.
- rewrite !inE=> /andP [x_n_ai]; rewrite array_seta.
  case/mapP=> k; rewrite mem_irangeE=> /andP [ik k_len] x_eq.
  apply/mapP; exists k=> //; rewrite mem_irangeE; apply/andP; split=> //.
  move: ik; rewrite le_eqVlt; case/orP.
  + by move/eqP=> ki; move: x_n_ai; rewrite x_eq ki eqxx.
  + by rewrite ltEint_nat leEint_nat (succ_int_ltE i_Si).
- case/mapP=> k; rewrite mem_irangeE=> /andP [Si_k k_len] ->.
  rewrite !inE array_seta; apply/andP; split.
  + apply/contraT; rewrite negbK=> /eqP.
    move/(@lti_sorted_inj _ stta k i k_len).
    move: (lt_le_trans i_Si Si_k)=> i_k; move/(_ (lt_trans i_k k_len)).
    by move/eqP; rewrite eq_sym; move/lt_eqF: i_k=> ->.
  + apply/mapP; exists k=> //; rewrite mem_irangeE k_len andbT.
    exact/ltW/(lt_le_trans i_Si).
Qed.

Lemma array_set_stt_notin (a : array int) (i : int) (A : {set int}) x:
  lti_sorted a -> array_set_i a i A -> (i < length a)%O -> (x < a.[i])%O ->
  x \notin A.
Proof.
move=> stta array_seta i_len x_ai; rewrite array_seta.
apply/contraT; rewrite negbK; case/mapP=> k.
rewrite mem_irangeE=> /andP [ik k_len] x_eq.
by move: x_ai; rewrite x_eq (lti_sorted_eq stta k_len i_len) ltNge ik.
Qed.

Definition arr_to_set (a : array int):=
  [set i | i in arr_to_seq a].

Lemma arr_to_setP a: array_set a (arr_to_set a).
Proof. by move=> x; rewrite /arr_to_set mem_imset_eq. Qed.

Lemma card_arr_to_set a: lti_sorted a -> #|arr_to_set a| = length a.
Proof.
move=> stta; rewrite cardE -size_arr_to_seq.
apply/perm_size/uniq_perm; rewrite ?enum_uniq //; first exact/lti_sorted_uniq.
by move=> x; rewrite mem_enum /arr_to_set mem_imset_eq.
Qed.

End ArraySet.
(* -------------------------------------------------------------------- *)

Module PArrayIUtils.
Definition parrayI (I J : array int):=
  fun '(i, j, c)=>
    if (i <? length I)%uint63 then
      if (j <? length J)%uint63 then
        if (I.[i] <? J.[j])%uint63 then
          ((succ i)%uint63, j, c)
        else if (J.[j] <? I.[i])%uint63 then
          (i, (succ j)%uint63, c)
        else
          ((succ i)%uint63, (succ j)%uint63, (succ c)%uint63)
      else (i, j, c)
    else (i, j, c).

Definition parrayI_iter (I J : array int) (n : int) d :=
  IFold.ifold
    (fun _ acc=> (parrayI I J) acc) n d.

Definition parrayI_final (I J : array int) :=
  let res := (parrayI_iter I J (length I) (0%uint63, 0%uint63, 0%uint63)) in
  (parrayI_iter I J (length J) res).2.

End PArrayIUtils.

Section PArrayI.
Definition parrayI_iter (I J : array int) (n : int) d:=
  ifold
    (fun _ acc=> (PArrayIUtils.parrayI I J) acc)
    n d.

Definition parrayI_final (I J : array int):=
  let res := (parrayI_iter I J (length I) (0%uint63, 0%uint63, 0%uint63)) in
  (parrayI_iter I J (length J) res).2.

Section Equiv.

Lemma parrayI_iterE (I J : array int) (n : int) d:
  PArrayIUtils.parrayI_iter I J n d= parrayI_iter I J n d.
Proof. exact: ifoldE. Qed.

Lemma parrayI_finalE (I J : array int):
  PArrayIUtils.parrayI_final I J = parrayI_final I J.
Proof. by congr snd; rewrite /PArrayIUtils.parrayI_iter !ifoldE. Qed.

End Equiv.

(* -------------------------------------------------------------------- *)
Definition pair_map1 {T T' U : Type} (f : T -> T') (x : T * U) :=
  (f x.1, x.2).

Definition pair_map2 {T U U' : Type} (g : U -> U') (x : T * U) :=
  (x.1, g x.2).

Definition pswap {T U : Type} (x : T * U) := (x.2, x.1).

Lemma parrayI_sym (a b : array int) (ia ib c : int) :
  PArrayIUtils.parrayI a b (ia, ib, c) =
  pair_map1 pswap (PArrayIUtils.parrayI b a (ib, ia, c)).
Proof.
rewrite /PArrayIUtils.parrayI.
do 4 case: ifP=> //=; rewrite -ltEint; move/lt_trans=> /[apply].
by rewrite ltxx.
Qed.

(* -------------------------------------------------------------------- *)
Lemma parrayI_done (a b : array int) (ia ib c : int) :
  (ia >= length a)%O || (ib >= length b)%O ->
    PArrayIUtils.parrayI a b (ia, ib, c) = ((ia, ib), c).
Proof.
rewrite /PArrayIUtils.parrayI -!lteEint 2!ltNge.
by do 2! case: (leP (length _)) => //= _.
Qed.

(* -------------------------------------------------------------------- *)
Lemma parrayIP (a b : array int) (A B : {set int}) (ia ib c : int) :
     (c <= Order.max ia ib)%O
  -> (ia <= length a)%O
  -> (ib <= length b)%O
  -> array_set_i a ia A
  -> array_set_i b ib B
  -> lti_sorted a
  -> lti_sorted b
  -> let: (ia', ib', c') := PArrayIUtils.parrayI a b (ia, ib, c) in [/\
         [/\ (ia <= ia')%O & (ib <= ib')%O]
       , [/\ (ia' <= length a)%O & (ib' <= length b)%O]
       , [&& ia <? length a & ib <? length b]%uint63 -> ((ia <? ia') || (ib <? ib'))%uint63
       , (c' <= Order.max ia' ib')%O
       & exists A' B', [/\
             array_set_i a ia' A'
           , array_set_i b ib' B'
           , (B' :&: (A :\: A') = set0)
           , (A' :&: (B :\: B') = set0)
           & c' = c + #|(A :\: A') :&: (B :\: B')| :> nat]
     ].
Proof.
move=> le_c; rewrite -!lteEint.
case/boolP: ((ia < length a) && (ib < length b))%O; last first.
- rewrite negb_and -!leNgt=> /(@parrayI_done a b) -> /= -> -> ????.
  do !split=> //; exists A, B; split=> //.
  - by rewrite setDv setI0.
  - by rewrite setDv setI0.
  - by rewrite !setDv setI0 cards0 addn0.
move=> + _ _ => /andP[].
wlog: A B a b ia ib le_c / (a.[ia] <= b.[ib])%O => [wlog|].
- case: (leP a.[ia] b.[ib]); first by apply: wlog.
  move/ltW=> le_bib_aia lt_ia_a lt_ib_b array_seta array_setb stt_a stt_b.
  have := wlog B A b a ib ia; rewrite maxC => /(_ le_c).
  move/(_ le_bib_aia lt_ib_b lt_ia_a array_setb array_seta stt_b stt_a).
  rewrite parrayI_sym; case: PArrayIUtils.parrayI => [[ia' ib'] c'] /=.
  case=> -[-> ->] -[-> ->] /(_ isT); rewrite orbC => -> le_c'.
  case=> [B'] [A'] h; do! split=> //; first by rewrite maxC.
  exists A', B'; case: h => *; split=> //.
  by rewrite setIC.
move=> le_aia_bib lt_ia_a lt_ib_b array_seta array_setb stt_a stt_b.
have lt_iaS: (ia < Uint63.succ ia)%O by
  rewrite ltEint_nat (succ_int_ltE lt_ia_a) ltnSn.
have lt_ibS: (ib < Uint63.succ ib)%O by
  rewrite ltEint_nat (succ_int_ltE lt_ib_b) ltnSn.
rewrite /PArrayIUtils.parrayI -!lteEint !(lt_ia_a, lt_ib_b).
rewrite [(b.[ib] < _)%O]ltNge le_aia_bib /=.
move: le_aia_bib; rewrite le_eqVlt orbC.
case: ltP => /= [lt_aia_bib _|_ /eqP eq_aia_bib].
- do! split=> //; try (by apply: ltW || by move=> _; rewrite !(lt_iaS, lt_ibS)).
  - rewrite leEint_nat (succ_int_ltE lt_ia_a) // -ltEint_nat //.
  - by apply/(le_trans le_c); rewrite le_maxl !le_maxr lexx (ltW lt_iaS) /= orbT.
  exists (A :\ a.[ia]), B; split => //.
  - exact: array_set_succ.
  - rewrite setDDr setDv set0U; apply: disjoint_setI0.
    rewrite disjoint_sym disjoint_subset; apply/subsetP=> x.
    rewrite !inE=> /andP [_ /eqP ->]; exact: (array_set_stt_notin stt_b array_setb).
  - by rewrite setDv setI0.
  - by rewrite setDv setI0 cards0 addn0.
- do! split=> //; try (by apply: ltW || by move=> _; rewrite !(lt_iaS, lt_ibS)).
  - rewrite leEint_nat (succ_int_ltE lt_ia_a) // -ltEint_nat //.
  - rewrite leEint_nat (succ_int_ltE lt_ib_b) // -ltEint_nat //.
  - rewrite (succ_int_lt_max lt_ia_a lt_ib_b).
    set M := (Order.max (length a) (length b)).
    suff ? : (Order.max ia ib < M)%O by
      rewrite -(@succ_int_lt_mono _ _ M M) //; exact/(le_lt_trans le_c).
    by rewrite lt_maxl !lt_maxr lt_ia_a lt_ib_b /= orbT.
  exists (A :\ a.[ia]), (B :\ b.[ib]); split.
  - exact: array_set_succ. (* OK: a is uniq and we remove the first element *)
  - exact: array_set_succ. (* OK: b is uniq and we remove the first element *)
  - rewrite setDDr setDv set0U; apply: disjoint_setI0.
    rewrite disjoint_sym disjoint_subset; apply/subsetP=> x.
    by rewrite !inE=> /andP [_ /eqP ->]; rewrite eq_aia_bib eqxx.
  - rewrite setDDr setDv set0U; apply: disjoint_setI0.
    rewrite disjoint_sym disjoint_subset; apply/subsetP=> x.
    by rewrite !inE=> /andP [_ /eqP ->]; rewrite eq_aia_bib eqxx.
  - set M := (Order.max (length a) (length b)).
    rewrite (@succ_int_ltE _ M); first apply/(le_lt_trans le_c).
    - by rewrite lt_maxl !lt_maxr lt_ia_a lt_ib_b /= orbT.
    rewrite -addn1; congr (_ + _).
    rewrite [X in (X :&: _)](_ : _ = [set a.[ia]]).
    - rewrite setDDr setDv set0U; apply/setIidPr/subsetP=> x.
      rewrite inE=> /eqP ->; rewrite array_seta.
      by apply/mapP; exists ia=> //; rewrite mem_irangeE lexx lt_ia_a.
    rewrite [X in (_ :&: X)](_ : _ = [set b.[ib]]).
    - rewrite setDDr setDv set0U; apply/setIidPr/subsetP=> x.
      rewrite inE=> /eqP ->; rewrite array_setb.
      by apply/mapP; exists ib=> //; rewrite mem_irangeE lexx lt_ib_b.
    by rewrite eq_aia_bib setIid cards1.
Qed.

Lemma set_cond {T : finType} {A B A' B' A'' B'': {set T}}:
  (A'' :&: (B' :\: B'')) = set0 -> (A' :&: (B :\: B')) = set0 ->
  (B' \subset B) -> (A'' \subset A') ->
  (A'' :&: (B :\: B'')) = set0.
Proof.
move=> A''_eq A'_eq B'_sub A''_sub.
apply/setP=> x; rewrite !inE; move: isT; apply/contraTF=> /=.
case/and3P=> xA'' xnB''; rewrite -(setID B B') (setIidPr B'_sub) inE.
case/orP.
- by move=> xB'; move/setP: A''_eq=> /(_ x); rewrite !inE xA'' xnB'' xB'.
- move=> xBnB'; move/subsetP: A''_sub=> /(_ _ xA'') xA'.
  by move/setP: A'_eq=> /(_ x); rewrite inE xA' xBnB' inE.
Qed.

Lemma set_cond2 {T : finType} {A B A' B' A'' B'' : {set T}}:
  A' \subset A -> A'' \subset A' ->
  B' \subset B -> B'' \subset B' ->
  B' :&: (A :\: A') = set0 ->
  A' :&: (B :\: B') = set0 ->
  B'' :&: (A' :\: A'') = set0 ->
  A'' :&: (B' :\: B'') = set0 ->
  (A :\: A') :&: (B :\: B') :|: (A' :\: A'') :&: (B' :\: B'') =
  (A :\: A'') :&: (B :\: B'').
Proof.
move=> subA subA' subB subB' B'_IA A'_IB B''_IA A''_IB.
apply/setP=> x; rewrite !inE.
move: B'_IA A'_IB B''_IA A''_IB=> /setP/(_ x) + /setP/(_ x) + /setP/(_ x) + /setP/(_ x).
rewrite !inE.
case/boolP: (x \in A'')=> /=; first by move/subsetP: subA'=> /[apply] ->.
case/boolP: (x \in B'')=> /=; rewrite ?andbF.
  by move/subsetP: subB'=> /[apply] ->; rewrite !andbF /=.
case/boolP: (x \in A')=> /=; case/boolP: (x \in B')=> //=; rewrite ?andbF ?orbF //.
- by move/subsetP: subB=> /[apply] ->; move/subsetP: subA=> /[apply] ->.
- by move=> _ _ _ _ _ ->; rewrite andbF.
- by move=> _ _ _ _ ->.
Qed.

Lemma parrayI_iter_n (a b : array int) (n n': int) d:
  let res := parrayI_iter a b n d in
  parrayI_iter a b n' res =
  iter (int_to_nat n + int_to_nat n')%nat (PArrayIUtils.parrayI a b) d.
Proof. by rewrite /parrayI_iter !ifold_iter addnC iterD. Qed.

Lemma parrayI_iterP (a b : array int) (A B : {set int}) (n : nat):
  lti_sorted a -> lti_sorted b ->
  array_set_i a 0%uint63 A -> array_set_i b 0%uint63 B ->
  let: (ia', ib', c') :=
    iter n (PArrayIUtils.parrayI a b) (0%uint63, 0%uint63, 0%uint63) in
  [/\ (ia' <= length a)%O, (ib' <= length b)%O,
    (c' <= Order.max ia' ib')%O &
    ((ia' < length a)%O && (ib' < length b)%O -> (n <= (ia' + ib'))%nat) /\
    exists A' B', [/\
    array_set_i a ia' A'
  , array_set_i b ib' B'
  , (B' :&: (A :\: A') = set0)
  , (A' :&: (B :\: B') = set0)
  & c' = #|(A :\: A') :&: (B :\: B')| :> nat]].
Proof.
move=> stta sttb array_seta array_setb.
elim: n=> /= [|n].
- split; rewrite ?le0x //; split=> //.
  by exists A, B; rewrite !setDv !setI0 ?cards0; split.
- case: (iter n _ _)=> -[i j] c.
  case=> i_len_a j_len_b c_max [n_h] /[dup] AB'_ex [A'] [B'].
  case=> arr_setA' arr_setB' B'_IA A'_IB c_eq.
  move: (parrayIP c_max i_len_a j_len_b arr_setA' arr_setB' stta sttb).
  case: (PArrayIUtils.parrayI _ _ _)=> -[i' j' c'].
  case=> -[ii' jj'] [i'_len_a j'_len_b] len_ltb c'_max.
  case=> A'' [B''] [arr_setA'' arr_setB'' B''_AI A''_BI c'_eq].
  split=> //; split.
  + case/andP=> i'_len_ltb j'_len_ltb.
    move: (le_lt_trans ii' i'_len_ltb) (le_lt_trans jj' j'_len_ltb)=> i_len_ltb j_len_ltb.
    apply/(leq_ltn_trans (n_h _)); rewrite ?i_len_ltb ?j_len_ltb //.
    move: len_ltb; rewrite -ltEint i_len_ltb j_len_ltb /=.
    case/(_ isT)/orP; rewrite ltEint_nat.
    * rewrite addnC [X in _ -> (_ < X)%nat]addnC.
      by apply/leq_ltn_addn; rewrite -leEint_nat.
    * by apply/leq_ltn_addn; rewrite -leEint_nat.
  + exists A'', B''; split=> //.
    * apply:(set_cond B''_AI B'_IA)=> //.
      - rewrite -(array_set_mono stta _ _ array_seta arr_setA') ?le0x //.
      - rewrite -(array_set_mono sttb _ _ arr_setB' arr_setB'') //.
    * apply:(set_cond A''_BI A'_IB)=> //.
      - rewrite -(array_set_mono sttb _ _ array_setb arr_setB') ?le0x //.
      - rewrite -(array_set_mono stta _ _ arr_setA' arr_setA'') //.
      * rewrite c'_eq c_eq -(eqTleqif (leq_card_setU _ _)).
        - rewrite disjoint_subset; apply/subsetP=> x.
          rewrite !inE !negb_and !negbK.
          by case/and3P=> /andP [-> _ -> _]; rewrite orbT.
        - congr card; congr mem; congr pred_of_set.
          rewrite set_cond2 //.
          + by rewrite -(array_set_mono stta _ _ array_seta arr_setA') ?le0x.
          + by rewrite -(array_set_mono stta _ _ arr_setA' arr_setA'').
          + by rewrite -(array_set_mono sttb _ _ array_setb arr_setB') ?le0x.
          + by rewrite -(array_set_mono sttb _ _ arr_setB' arr_setB'').
Qed.

Lemma parrayI_finalP a b A B:
  lti_sorted a -> lti_sorted b ->
  array_set a A -> array_set b B ->
  parrayI_final a b = #| A :&: B| :> nat.
Proof.
move=> stta sttb array_seta array_setb.
rewrite /parrayI_final parrayI_iter_n.
have:= (parrayI_iterP _ stta sttb array_seta array_setb).
move/(_ (length a + length b)%nat).
case: (iter _ _ _) => -[ia ib] c [ia_len ib_len c_max] [n_max].
case=> A' [B'] [array_set_ia array_set_ib A'_eq B'_eq] /= ->.
have: ia = length a \/ ib = length b.
- move: ia_len; rewrite le_eqVlt=> /orP [/eqP ->|ia_len]; first by left.
  move: ib_len; rewrite le_eqVlt=> /orP [/eqP ->|ib_len]; first by right.
  move: n_max; rewrite ia_len ib_len /= => /(_ isT).
  move: ia_len ib_len; rewrite !ltEint_nat=> /ltnW/leq_add /[apply].
  by rewrite addnS ltnNge => /negPf ->.
wlog : A B A' B' ia ib a b stta sttb array_seta array_setb n_max ia_len ib_len array_set_ia array_set_ib c_max A'_eq B'_eq/
  ia = length a => [wlog|].
- move/[dup]; case; [apply: (wlog _ _ _ _ _ _ _ _ _ _ _ _)=> // |].
  move=> + /or_comm; rewrite setIC [(A :&: B)]setIC.
  have:= (wlog B A B' A' ib ia b a _ _ _ _).
  apply=> //; rewrite 1?andbC 1?add_comm 1?[(ib + ia)%uint63]add_comm 1?maxC //.
  by rewrite addnC [ib + ia]addnC.
- move=> ia_eq _; move: array_set_ia; rewrite ia_eq=> /array_set_length A'_0.
  move: A'_eq; rewrite A'_0 setD0 setIDA=> B'A.
  congr card; congr mem; congr pred_of_set.
  apply/setP=> x; move/setP: B'A=> /(_ x).
  by rewrite !inE; case: (x \in B')=> //= ->.
Qed.

End PArrayI.
Section ArraySetOrd.

Context {m : nat}.
Definition set_int_ord (A : {set int}) (B : {set 'I_m}):=
  [forall i : 'I_m, val i \in [seq int_to_nat i | i in A] == (i \in B)] &&
  [forall i : int, i \in A == (int_to_nat i \in [seq val i | i in B])].

Lemma set_int_ordP (A : {set int}) (B : {set 'I_m}):
  reflect
    ([seq int_to_nat i | i in A] =i [seq val i | i in B])
    (set_int_ord A B).
Proof.
apply/(iffP idP).
- case/andP=> /forallP hA /forallP hB x.
  apply/idP/idP.
  + case/mapP=> x'; rewrite mem_enum.
    by move/eqP: (hB x')=> -> + ->.
  + case/mapP=> x'; rewrite mem_enum.
    by move/eqP: (hA x')=> <- + ->.
- move=> h; apply/andP; split.
  + apply/forallP=> x; rewrite h mem_map ?mem_enum //.
    exact/val_inj.
  + apply/forallP=> x; rewrite -h mem_map ?mem_enum //.
    exact/int_to_nat_inj.
Qed.

Lemma set_int_ord_card A B: set_int_ord A B -> #|A| = #|B|.
Proof.
move/set_int_ordP/uniq_perm; rewrite !map_inj_uniq;
  [exact: int_to_nat_inj|exact: val_inj | ].
move/(_ (enum_uniq _) (enum_uniq _))/perm_size.
by rewrite !cardE !size_map.
Qed.

Definition array_set_ord (a : array int) (A : {set 'I_m}) : bool :=
  set_int_ord (arr_to_set a) A.

Lemma array_set_ord_card a A: lti_sorted a -> array_set_ord a A -> #|A| = length a.
Proof. by move=> stta /set_int_ord_card <-; rewrite card_arr_to_set. Qed.

Lemma array_set_ord_inj (a b : array int) (A B : {set 'I_m}):
  lti_sorted a -> lti_sorted b ->
  array_set_ord a A -> array_set_ord b B ->
  reflect (A = B) (eq_array_int a b).
Proof.
move=> stta sttb as_aA as_bB; apply/(iffP idP).
- case/eq_array_intP=> eq_len nth_eq; apply/setP=> x.
  move/set_int_ordP: as_aA=> /(_ (val x)); rewrite mem_map ?mem_enum; first exact: val_inj.
  move/set_int_ordP: as_bB=> /(_ (val x)); rewrite mem_map ?mem_enum; first exact: val_inj.
  move=> <- <-; congr in_mem; congr mem.
  apply/eq_image=> // y; rewrite !arr_to_setP -eq_len.
  congr in_mem; congr mem; apply/eq_in_map=> k.
  rewrite mem_irangeE le0x /=; exact: nth_eq.
- move=> eq_AB; apply/eq_array_intP.
  suff: arr_to_seq a = arr_to_seq b.
  + move=> a2s_ab.
    split; move/(congr1 size): (a2s_ab); rewrite !size_arr_to_seq.
      by move/int_to_nat_inj.
    move=> len_ab i; rewrite ltEint_nat => /[dup] i_len_a.
    rewrite len_ab => i_len_b.
    move: (nth_arr_to_seq i_len_a) (nth_arr_to_seq i_len_b).
    rewrite int_to_natK => <- <-; rewrite a2s_ab.
    by apply/nth_eq_dflt; rewrite size_arr_to_seq.
  apply/lt_sorted_eq=> // x.
  move/set_int_ordP: as_aA=> /(_ (int_to_nat x)).
  move/set_int_ordP: as_bB=> /(_ (int_to_nat x)).
  rewrite !mem_image; try exact: int_to_nat_inj.
  by rewrite !mem_imset_eq // => -> ->; rewrite eq_AB.
Qed.

Lemma array_set_ord_mem (a : array int) (A : {set 'I_m}) (i : 'I_m):
  array_set_ord a A -> i \in A ->
  exists2 j : int, (j < length a)%O & int_to_nat a.[j] = val i.
Proof.
case/andP=> /forallP /(_ i) /eqP <- _.
case/mapP=> ?; rewrite mem_enum=> /imsetP [?].
case/mapP=> j; rewrite mem_irangeE le0x /=.
by move=> ? -> -> ->; exists j.
Qed.

Lemma parrayI_final_ord a b A B:
  lti_sorted a -> lti_sorted b ->
  array_set_ord a A -> array_set_ord b B ->
  #|A :&: B| = parrayI_final a b.
Proof.
move=> stta sttb as_aA as_bB.
move: (arr_to_setP a) (arr_to_setP b)=> a2s_a a2s_b.
rewrite (parrayI_finalP stta sttb a2s_a a2s_b).
rewrite -(size_image int_to_nat) -(size_image (@nat_of_ord m)).
apply/perm_size/uniq_perm; rewrite ?map_inj_uniq ?enum_uniq //.
  exact: val_inj. exact: int_to_nat_inj.
move=> x; apply/idP/idP.
- case/imageP=> x'; rewrite inE=> /andP [].
  move/(image_f val)=> + /(image_f val).
  move:as_aA as_bB=> /set_int_ordP <- /set_int_ordP <-.
  case/imageP=> i i_a i_eq /imageP [j j_b].
  rewrite i_eq=> /int_to_nat_inj ij ->.
  by apply/imageP; exists i=> //; rewrite inE i_a ij j_b.
- case/imageP=> i; rewrite inE=> /andP [].
  move/(image_f int_to_nat)=> + /(image_f int_to_nat).
  move: as_aA as_bB=> /set_int_ordP -> /set_int_ordP ->.
  case/imageP=> p pA p_eq /imageP [q qB]; rewrite p_eq=> /val_inj pq ->.
  by apply/imageP; exists p=> //; rewrite inE pA pq qB.
Qed.

Section ArrToSetOrd.

Definition arr_to_set_ord (a : array int) : {set 'I_m} := [set j : 'I_m | nat_to_int j \in arr_to_set a].

Lemma arr_to_set_ordP (a : array int):
  (m < int_threshold)%nat ->
  (forall i, (i < length a)%O -> (a.[i] < m)%nat) ->
  array_set_ord a (arr_to_set_ord a).
Proof.
move=> m_threshold a_m.
apply/set_int_ordP; move=> x; apply/idP/idP.
- case/imageP=> j /[swap] ->; rewrite arr_to_setP.
  case/mapP=> i; rewrite mem_irangeE le0x /= => /[dup] i_len /a_m ai_m ->.
  apply/imageP; exists (Ordinal ai_m)=> //.
  rewrite inE int_to_natK arr_to_setP.
  by apply/mapP; exists i=> //; rewrite mem_irangeE le0x i_len.
- case/imageP=> /= j /[swap] ->; rewrite inE=> j_arr2set.
  apply/mapP; exists (nat_to_int j); rewrite ?mem_enum //.
  rewrite nat_to_intK // inE; exact/(@ltn_trans m).
Qed.

End ArrToSetOrd.

End ArraySetOrd. *)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Commutativity_B.

Coq < Goal forall p q:Prop, (p /\ q) <-> (q /\ p).
1 subgoal

  ============================
   forall p q : Prop, p /\ q <-> q /\ p

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  ============================
   p /\ q <-> q /\ p

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Section Commutativity_B.
Goal forall p q:Prop, (p /\ q) <-> (q /\ p).
intros.
tauto.
Qed.