From Hammer Require Import Hammer.

Require Import Bool BinPos Orders OrdersEx MSetInterface.

Set Implicit Arguments.
Local Open Scope lazy_bool_scope.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.

Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.

Module E:=PositiveOrderedTypeBits.

Definition elt := positive : Type.

Inductive tree :=
| Leaf : tree
| Node : tree -> bool -> tree -> tree.

Scheme tree_ind := Induction for tree Sort Prop.

Definition t := tree : Type.

Definition empty : t := Leaf.

Fixpoint is_empty (m : t) : bool :=
match m with
| Leaf => true
| Node l b r => negb b &&& is_empty l &&& is_empty r
end.

Fixpoint mem (i : positive) (m : t) {struct m} : bool :=
match m with
| Leaf => false
| Node l o r =>
match i with
| 1 => o
| i~0 => mem i l
| i~1 => mem i r
end
end.

Fixpoint add (i : positive) (m : t) : t :=
match m with
| Leaf =>
match i with
| 1 => Node Leaf true Leaf
| i~0 => Node (add i Leaf) false Leaf
| i~1 => Node Leaf false (add i Leaf)
end
| Node l o r =>
match i with
| 1 => Node l true r
| i~0 => Node (add i l) o r
| i~1 => Node l o (add i r)
end
end.

Definition singleton i := add i empty.

Definition node (l : t) (b: bool) (r : t) : t :=
if b then Node l b r else
match l,r with
| Leaf,Leaf => Leaf
| _,_ => Node l false r end.

Fixpoint remove (i : positive) (m : t) {struct m} : t :=
match m with
| Leaf => Leaf
| Node l o r =>
match i with
| 1 => node l false r
| i~0 => node (remove i l) o r
| i~1 => node l o (remove i r)
end
end.

Fixpoint union (m m': t) : t :=
match m with
| Leaf => m'
| Node l o r =>
match m' with
| Leaf => m
| Node l' o' r' => Node (union l l') (o||o') (union r r')
end
end.

Fixpoint inter (m m': t) : t :=
match m with
| Leaf => Leaf
| Node l o r =>
match m' with
| Leaf => Leaf
| Node l' o' r' => node (inter l l') (o&&o') (inter r r')
end
end.

Fixpoint diff (m m': t) : t :=
match m with
| Leaf => Leaf
| Node l o r =>
match m' with
| Leaf => m
| Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
end
end.

Fixpoint equal (m m': t): bool :=
match m with
| Leaf => is_empty m'
| Node l o r =>
match m' with
| Leaf => is_empty m
| Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
end
end.

Fixpoint subset (m m': t): bool :=
match m with
| Leaf => true
| Node l o r =>
match m' with
| Leaf => is_empty m
| Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
end
end.

Fixpoint rev_append (y x : elt) : elt :=
match y with
| 1 => x
| y~1 => rev_append y x~1
| y~0 => rev_append y x~0
end.
Infix "@" := rev_append (at level 60).
Definition rev x := x@1.

Section Fold.

Variables B : Type.
Variable f : positive -> B -> B.

Fixpoint xfold (m : t) (v : B) (i : positive) :=
match m with
| Leaf => v
| Node l true r =>
xfold r (f (rev i) (xfold l v i~0)) i~1
| Node l false r =>
xfold r (xfold l v i~0) i~1
end.
Definition fold m i := xfold m i 1.

End Fold.

Section Quantifiers.

Variable f : positive -> bool.

Fixpoint xforall (m : t) (i : positive) :=
match m with
| Leaf => true
| Node l o r =>
(negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
end.
Definition for_all m := xforall m 1.

Fixpoint xexists (m : t) (i : positive) :=
match m with
| Leaf => false
| Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
end.
Definition exists_ m := xexists m 1.

Fixpoint xfilter (m : t) (i : positive) : t :=
match m with
| Leaf => Leaf
| Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
end.
Definition filter m := xfilter m 1.

Fixpoint xpartition (m : t) (i : positive) : t * t :=
match m with
| Leaf => (Leaf,Leaf)
| Node l o r =>
let (lt,lf) := xpartition l i~0 in
let (rt,rf) := xpartition r i~1 in
if o then
let fi := f (rev i) in
(node lt fi rt, node lf (negb fi) rf)
else
(node lt false rt, node lf false rf)
end.
Definition partition m := xpartition m 1.

End Quantifiers.

Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
match m with
| Leaf => a
| Node l false r => xelements l i~0 (xelements r i~1 a)
| Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
end.

Definition elements (m : t) := xelements m 1 nil.

Fixpoint cardinal (m : t) : nat :=
match m with
| Leaf => O
| Node l false r => (cardinal l + cardinal r)%nat
| Node l true r => S (cardinal l + cardinal r)
end.

Fixpoint choose (m: t) : option elt :=
match m with
| Leaf => None
| Node l o r => if o then Some 1 else
match choose l with
| None => option_map xI (choose r)
| Some i => Some i~0
end
end.

Fixpoint min_elt (m: t) : option elt :=
match m with
| Leaf => None
| Node l o r =>
match min_elt l with
| None => if o then Some 1 else option_map xI (min_elt r)
| Some i => Some i~0
end
end.

Fixpoint max_elt (m: t) : option elt :=
match m with
| Leaf => None
| Node l o r =>
match max_elt r with
| None => if o then Some 1 else option_map xO (max_elt l)
| Some i => Some i~1
end
end.

Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.

Definition compare_bool a b :=
match a,b with
| false, true => Lt
| true, false => Gt
| _,_ => Eq
end.

Fixpoint compare (m m': t): comparison :=
match m,m' with
| Leaf,_ => if is_empty m' then Eq else Lt
| _,Leaf => if is_empty m then Eq else Gt
| Node l o r,Node l' o' r' =>
lex (compare_bool o o') (lex (compare l l') (compare r r'))
end.

Definition In i t := mem i t = true.
Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
Definition Subset s s' := forall a : elt, In a s -> In a s'.
Definition Empty s := forall a : elt, ~ In a s.
Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).

Definition eq := Equal.
Definition lt m m' := compare m m' = Lt.

Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.In_compat".
intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition.
Qed.

Local Instance eq_equiv : Equivalence eq.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.eq_equiv".   firstorder. Qed.

Lemma mem_spec: forall s x, mem x s = true <-> In x s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.mem_spec".   unfold In. intuition. Qed.

Lemma mem_Leaf: forall x, mem x Leaf = false.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.mem_Leaf".   destruct x; trivial. Qed.

Lemma empty_spec : Empty empty.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.empty_spec".   unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.

Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.mem_node".
intros x l o r.
case o; trivial.
destruct l; trivial.
destruct r; trivial.
destruct x; reflexivity.
Qed.
Local Opaque node.

Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.is_empty_spec".
unfold Empty, In.
induction s as [|l IHl o r IHr]; simpl.
firstorder.
rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr.
destruct o; simpl; split.
intuition discriminate.
intro H. elim (H 1). reflexivity.
intros H [a|a|]; apply H || intro; discriminate.
intro H. split. split. reflexivity.
intro a. apply (H a~0).
intro a. apply (H a~1).
Qed.

Lemma subset_Leaf_s: forall s, Leaf [<=] s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.subset_Leaf_s".   intros s i Hi. apply empty_spec in Hi. elim Hi. Qed.

Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.subset_spec".
induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
split; intros. apply subset_Leaf_s. reflexivity.

split; intros. apply subset_Leaf_s. reflexivity.

rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec.
destruct o; simpl.
split.
intuition discriminate.
intro H. elim (@empty_spec 1). apply H. reflexivity.
split; intro H.
destruct H as [[_ Hl] Hr].
intros [i|i|] Hi.
elim (Hr i Hi).
elim (Hl i Hi).
discriminate.
split. split. reflexivity.
unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption.
unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption.

rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear.
destruct o; simpl.
split; intro H.
destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
intros i Hi. destruct i.
apply (Hr i). assumption.
apply (Hl i). assumption.
assumption.
split. split.
destruct o'; trivial.
specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
intros i Hi. apply (H i~0). apply Hi.
intros i Hi. apply (H i~1). apply Hi.
split; intros.
intros i Hi. destruct i; destruct H as [[H Hl] Hr].
apply (Hr i). assumption.
apply (Hl i). assumption.
discriminate Hi.
split. split. reflexivity.
intros i Hi. apply (H i~0). apply Hi.
intros i Hi. apply (H i~1). apply Hi.
Qed.

Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.equal_subset".
induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
destruct o. reflexivity. rewrite andb_comm. reflexivity.
rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
rewrite 7andb_true_iff, eqb_true_iff.
rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
destruct o'; reflexivity.
destruct o'; reflexivity.
destruct o; auto. destruct o'; trivial.
Qed.

Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.equal_spec".
intros. rewrite equal_subset. rewrite andb_true_iff.
rewrite 2subset_spec. unfold Equal, Subset. firstorder.
Qed.

Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.eq_dec".
unfold eq.
intros. case_eq (equal s s'); intro H.
left. apply equal_spec, H.
right. rewrite <- equal_spec. congruence.
Defined.

Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
lex u v = CompOpp (lex u' v').
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.lex_Opp".   intros ? ? u' ? -> ->. case u'; reflexivity. Qed.

Lemma compare_bool_inv: forall b b',
compare_bool b b' = CompOpp (compare_bool b' b).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_bool_inv".   intros [|] [|]; reflexivity. Qed.

Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_inv".
induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
unfold compare. case is_empty; reflexivity.
unfold compare. case is_empty; reflexivity.
simpl. rewrite compare_bool_inv.
case compare_bool; simpl; trivial; apply lex_Opp; auto.
Qed.

Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.lex_Eq".   intros u v; destruct u; intuition discriminate. Qed.

Lemma compare_bool_Eq: forall b1 b2,
compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_bool_Eq".   intros [|] [|]; intuition discriminate. Qed.

Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_equal".
induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
simpl. tauto.
unfold compare, equal. case is_empty; intuition discriminate.
unfold compare, equal. case is_empty; intuition discriminate.
simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
Qed.

Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_gt".
unfold lt. intros s s'. rewrite compare_inv.
case compare; trivial; intros; discriminate.
Qed.

Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_eq".
unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
Qed.

Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s').
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_spec".
intros. case_eq (compare s s'); intro H; constructor.
apply compare_eq, H.
assumption.
apply compare_gt, H.
Qed.

Section lt_spec.

Inductive ct: comparison -> comparison -> comparison -> Prop :=
| ct_xxx: forall x, ct x  x  x
| ct_xex: forall x, ct x  Eq x
| ct_exx: forall x, ct Eq x  x
| ct_glx: forall x, ct Gt Lt x
| ct_lgx: forall x, ct Lt Gt x.

Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_cxe".   destruct x; constructor. Qed.

Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_xce".   destruct x; constructor. Qed.

Lemma ct_lxl: forall x, ct Lt x Lt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_lxl".   destruct x; constructor. Qed.

Lemma ct_gxg: forall x, ct Gt x Gt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_gxg".   destruct x; constructor. Qed.

Lemma ct_xll: forall x, ct x Lt Lt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_xll".   destruct x; constructor. Qed.

Lemma ct_xgg: forall x, ct x Gt Gt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_xgg".   destruct x; constructor. Qed.

Local Hint Constructors ct: ct.
Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
Ltac ct := trivial with ct.

Lemma ct_lex: forall u v w u' v' w',
ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_lex".
intros u v w u' v' w' H H'.
inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
Qed.

Lemma ct_compare_bool:
forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_compare_bool".
intros [|] [|] [|]; constructor.
Qed.

Lemma compare_x_Leaf: forall s,
compare s Leaf = if is_empty s then Eq else Gt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_x_Leaf".
intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
Qed.

Lemma compare_empty_x: forall a, is_empty a = true ->
forall b, compare a b = if is_empty b then Eq else Lt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_empty_x".
induction a as [|l IHl o r IHr]; trivial.
destruct o. intro; discriminate.
simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
intros [Hl Hr].
destruct b as [|l' [|] r']; simpl compare; trivial.
rewrite Hl, Hr. trivial.
rewrite (IHl Hl), (IHr Hr). simpl.
case (is_empty l'); case (is_empty r'); trivial.
Qed.

Lemma compare_x_empty: forall a, is_empty a = true ->
forall b, compare b a = if is_empty b then Eq else Gt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_x_empty".
setoid_rewrite <- compare_x_Leaf.
intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
Qed.

Lemma ct_compare:
forall a b c, ct (compare a b) (compare b c) (compare a c).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.ct_compare".
induction a as [|l IHl o r IHr]; intros s' s''.
destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
rewrite compare_inv. ct.
unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'.
rewrite (compare_empty_x _ H'). ct.
unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
rewrite (compare_x_empty _ H''), H'. ct.
ct.

destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
ct.
unfold compare at 2. rewrite compare_x_Leaf.
case_eq (is_empty (Node l o r)); intro H.
rewrite (compare_empty_x _ H). ct.
case_eq (is_empty (Node l'' o'' r'')); intro H''.
rewrite (compare_x_empty _ H''), H. ct.
ct.

rewrite 2 compare_x_Leaf.
case_eq (is_empty (Node l o r)); intro H.
rewrite compare_inv, (compare_x_empty _ H). ct.
case_eq (is_empty (Node l' o' r')); intro H'.
rewrite (compare_x_empty _ H'), H. ct.
ct.

simpl compare. apply ct_lex. apply ct_compare_bool.
apply ct_lex; trivial.
Qed.

End lt_spec.

Instance lt_strorder : StrictOrder lt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.lt_strorder".
unfold lt. split.
intros x H.
assert (compare x x = Eq).
apply compare_equal, equal_spec. reflexivity.
congruence.
intros a b c. assert (H := ct_compare a b c).
inversion_clear H; trivial; intros; discriminate.
Qed.

Local Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_compat_1".
intros x x' Hx y y' Hy. subst y'.
unfold eq in *. rewrite <- equal_spec, <- compare_equal in *.
assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto.
Qed.

Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.compare_compat".
intros x x' Hx y y' Hy. rewrite Hx.
rewrite compare_inv, Hy, <- compare_inv. reflexivity.
Qed.

Local Instance lt_compat : Proper (eq==>eq==>iff) lt.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.lt_compat".
intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition.
Qed.

Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.add_spec".
unfold In. intros s x y; revert x y s.
induction x; intros [y|y|] [|l o r]; simpl mem;
try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
Qed.

Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.remove_spec".
unfold In. intros s x y; revert x y s.
induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
intuition congruence.
Qed.

Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.singleton_spec".
unfold singleton. intros x y. rewrite add_spec. intuition.
unfold In in *. rewrite mem_Leaf in *. discriminate.
Qed.

Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.union_spec".
unfold In. intros s s' x; revert x s s'.
induction x; destruct s; destruct s'; simpl union; simpl mem;
try (rewrite IHx; clear IHx); try intuition congruence.
apply orb_true_iff.
Qed.

Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.inter_spec".
unfold In. intros s s' x; revert x s s'.
induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
apply andb_true_iff.
Qed.

Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.diff_spec".
unfold In. intros s s' x; revert x s s'.
induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
rewrite ?mem_node; simpl mem;
try (rewrite IHx; clear IHx); try intuition congruence.
rewrite andb_true_iff. destruct o'; intuition discriminate.
Qed.

Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A),
fold f s i = fold_left (fun a e => f e a) (elements s) i.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.fold_spec".
unfold fold, elements. intros s A i f. revert s i.
set (f' := fun a e => f e a).
assert (H: forall s i j acc,
fold_left f' acc (xfold f s i j) =
fold_left f' (xelements s j acc) i).

induction s as [|l IHl o r IHr]; intros; trivial.
destruct o; simpl xelements; simpl xfold.
rewrite IHr, <- IHl. reflexivity.
rewrite IHr. apply IHl.

intros. exact (H s i 1 nil).
Qed.

Lemma cardinal_spec: forall s, cardinal s = length (elements s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.cardinal_spec".
unfold elements.
assert (H: forall s j acc,
(cardinal s + length acc)%nat = length (xelements s j acc)).

induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
rewrite <- IHl. simpl. rewrite <- IHr.
rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.

intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
Qed.

Lemma xfilter_spec: forall f s x i,
In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.xfilter_spec".
intro f. unfold In.
induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
rewrite mem_Leaf. intuition discriminate.
rewrite mem_node. destruct x; simpl.
rewrite IHr. reflexivity.
rewrite IHl. reflexivity.
rewrite <- andb_lazy_alt. apply andb_true_iff.
Qed.

Lemma filter_spec: forall s x f, @compat_bool elt E.eq f ->
(In x (filter f s) <-> In x s /\ f x = true).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.filter_spec".   intros. apply xfilter_spec. Qed.

Lemma xforall_spec: forall f s i,
xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.xforall_spec".
unfold For_all, In. intro f.
induction s as [|l IHl o r IHr]; intros i; simpl.
intuition discriminate.
rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
rewrite IHl, IHr. clear IHl IHr.
split.
intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
apply Hr, H.
apply Hl, H.
rewrite H in Hi. assumption.
intro H; intuition.
specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
apply H. assumption.
apply H. assumption.
Qed.

Lemma for_all_spec: forall s f, @compat_bool elt E.eq f ->
(for_all f s = true <-> For_all (fun x => f x = true) s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.for_all_spec".   intros. apply xforall_spec. Qed.

Lemma xexists_spec: forall f s i,
xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.xexists_spec".
unfold Exists, In. intro f.
induction s as [|l IHl o r IHr]; intros i; simpl.
firstorder.
rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
rewrite IHl, IHr. clear IHl IHr.
split.
intros [[Hi|[x Hr]]|[x Hl]].
exists 1. exact Hi.
exists x~1. exact Hr.
exists x~0. exact Hl.
intros [[x|x|] H]; eauto.
Qed.

Lemma exists_spec : forall s f, @compat_bool elt E.eq f ->
(exists_ f s = true <-> Exists (fun x => f x = true) s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.exists_spec".   intros. apply xexists_spec. Qed.

Lemma partition_filter : forall s f,
partition f s = (filter f s, filter (fun x => negb (f x)) s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.partition_filter".
unfold partition, filter. intros s f. generalize 1 as j.
induction s as [|l IHl o r IHr]; intro j.
reflexivity.
destruct o; simpl; rewrite IHl, IHr; reflexivity.
Qed.

Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f ->
Equal (fst (partition f s)) (filter f s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.partition_spec1".   intros. rewrite partition_filter. reflexivity. Qed.

Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f ->
Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.partition_spec2".   intros. rewrite partition_filter. reflexivity. Qed.

Notation InL := (InA E.eq).

Lemma xelements_spec: forall s j acc y,
InL y (xelements s j acc)
<->
InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.xelements_spec".
induction s as [|l IHl o r IHr]; simpl.
intros. split; intro H.
left. assumption.
destruct H as [H|[x [Hx Hx']]]. assumption. discriminate.

intros j acc y. case o.
rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
right. exists x~1. auto.
right. exists x~0. auto.
intros [H|[x [-> H]]].
eauto.
destruct x.
left. right. right. exists x; auto.
right. exists x; auto.
left. left. reflexivity.

rewrite IHl, IHr. clear IHl IHr. split.
intros [[H|[x [-> H]]]|[x [-> H]]].
eauto.
right. exists x~1. auto.
right. exists x~0. auto.
intros [H|[x [-> H]]].
eauto.
destruct x.
left. right.  exists x; auto.
right. exists x; auto.
discriminate.
Qed.

Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.elements_spec1".
unfold elements. intros. rewrite xelements_spec.
split; [ intros [A|(y & B & C)] | intros IN ].
inversion A. simpl in *. congruence.
right. exists x. auto.
Qed.

Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.lt_rev_append".   induction j; intros; simpl; auto. Qed.

Lemma elements_spec2: forall s, sort E.lt (elements s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.elements_spec2".
unfold elements.
assert (H: forall s j acc,
sort E.lt acc ->
(forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
sort E.lt (xelements s j acc)).

induction s as [|l IHl o r IHr]; simpl; trivial.
intros j acc Hacc Hsacc. destruct o.
apply IHl. constructor.
apply IHr. apply Hacc.
intros x y Hx Hy. apply Hsacc; assumption.
case_eq (xelements r j~1 acc). constructor.
intros z q H. constructor.
assert (H': InL z (xelements r j~1 acc)).
rewrite H. constructor. reflexivity.
clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
apply (Hsacc 1 z); trivial. reflexivity.
simpl. apply lt_rev_append. exact I.
intros x y Hx Hy. inversion_clear Hy.
rewrite H. simpl. apply lt_rev_append. exact I.
rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
apply Hsacc; assumption.
simpl. apply lt_rev_append. exact I.

apply IHl. apply IHr. apply Hacc.
intros x y Hx Hy. apply Hsacc; assumption.
intros x y Hx Hy. rewrite xelements_spec in Hy.
destruct Hy as [Hy|[z [-> Hy]]].
apply Hsacc; assumption.
simpl. apply lt_rev_append. exact I.

intros. apply H. constructor.
intros x y _ H'. inversion H'.
Qed.

Lemma elements_spec2w: forall s, NoDupA E.eq (elements s).
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.elements_spec2w".
intro. apply SortA_NoDupA with E.lt; auto with *.
apply elements_spec2.
Qed.

Lemma choose_spec1: forall s x, choose s = Some x -> In x s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.choose_spec1".
induction s as [| l IHl o r IHr]; simpl.
intros. discriminate.
destruct o.
intros x H. injection H; intros; subst. reflexivity.
revert IHl. case choose.
intros p Hp x H. injection H as <-. apply Hp.
reflexivity.
intros _ x. revert IHr. case choose.
intros p Hp H. injection H as <-. apply Hp.
reflexivity.
intros. discriminate.
Qed.

Lemma choose_spec2: forall s, choose s = None -> Empty s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.choose_spec2".
unfold Empty, In. intros s H.
induction s as [|l IHl o r IHr].
intro. apply empty_spec.
destruct o.
discriminate.
simpl in H. destruct (choose l).
discriminate.
destruct (choose r).
discriminate.
intros [a|a|].
apply IHr. reflexivity.
apply IHl. reflexivity.
discriminate.
Qed.

Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.choose_empty".
intros s Hs. case_eq (choose s); trivial.
intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs.
elim (Hs _ Hp).
Qed.

Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.choose_spec3'".
setoid_rewrite <- equal_spec.
induction s as [|l IHl o r IHr].
intros. symmetry. apply choose_empty. assumption.

destruct s' as [|l' o' r'].
generalize (Node l o r) as s. simpl. intros. apply choose_empty.
rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H.
assumption.

simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
Qed.

Lemma choose_spec3: forall s s' x y,
choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.choose_spec3".   intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed.

Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.min_elt_spec1".
unfold In.
induction s as [| l IHl o r IHr]; simpl.
intros. discriminate.
intros x. destruct (min_elt l); intros.
injection H as <-. apply IHl. reflexivity.
destruct o; simpl.
injection H as <-. reflexivity.
destruct (min_elt r); simpl in *.
injection H as <-. apply IHr. reflexivity.
discriminate.
Qed.

Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.min_elt_spec3".
unfold Empty, In. intros s H.
induction s as [|l IHl o r IHr].
intro. apply empty_spec.
intros [a|a|].
apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
case min_elt; intros; try discriminate. destruct o; discriminate.
apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
intro; discriminate.
revert H. clear. simpl. case min_elt; intros; try discriminate.
destruct o; discriminate.
Qed.

Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.min_elt_spec2".
unfold In.
induction s as [|l IHl o r IHr]; intros x y H H'.
discriminate.
simpl in H. case_eq (min_elt l).
intros p Hp. rewrite Hp in H. injection H as <-.
destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp.
destruct o.
injection H as <-. intros Hl.
destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

destruct (min_elt r).
injection H as <-.
destruct y as [z|z|].
apply (IHr e z); trivial.
elim (Hp _ H').
discriminate.
discriminate.
Qed.

Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.max_elt_spec1".
unfold In.
induction s as [| l IHl o r IHr]; simpl.
intros. discriminate.
intros x. destruct (max_elt r); intros.
injection H as <-. apply IHr. reflexivity.
destruct o; simpl.
injection H as <-. reflexivity.
destruct (max_elt l); simpl in *.
injection H as <-. apply IHl. reflexivity.
discriminate.
Qed.

Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.max_elt_spec3".
unfold Empty, In. intros s H.
induction s as [|l IHl o r IHr].
intro. apply empty_spec.
intros [a|a|].
apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
intro; discriminate.
apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
case max_elt; intros; try discriminate. destruct o; discriminate.
revert H. clear. simpl. case max_elt; intros; try discriminate.
destruct o; discriminate.
Qed.

Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
Proof. hammer_hook "MSetPositive" "MSetPositive.PositiveSet.max_elt_spec2".
unfold In.
induction s as [|l IHl o r IHr]; intros x y H H'.
discriminate.
simpl in H. case_eq (max_elt r).
intros p Hp. rewrite Hp in H. injection H as <-.
destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp.
destruct o.
injection H as <-. intros Hl.
destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

destruct (max_elt l).
injection H as <-.
destruct y as [z|z|].
elim (Hp _ H').
apply (IHl e z); trivial.
discriminate.
discriminate.
Qed.

End PositiveSet.


Require Import Fin Bool Kami.Lib.EclecticLib String Ascii List Streams.
Import ListNotations.

Fixpoint Fin n :=
  match n with
  | 0 => Empty_set
  | S m => (unit + Fin m)%type
  end.

Section Vector.

Fixpoint Vec X n : Type :=
  match n with
  | 0 => unit
  | S m => (X * Vec X m)%type
  end.

Fixpoint vec_index{n X} : Fin.t n -> Vec X n -> X :=
  match n with
  | 0 => case0 _
  | S m => fun i v => fin_case i _ (fst v) (fun j => vec_index j (snd v))
  end.

Fixpoint mkVec{n X} : (Fin.t n -> X) -> Vec X n :=
  match n with
  | 0 => fun _ => tt
  | S m => fun f => (f Fin.F1, mkVec (fun j => f (Fin.FS j)))
  end.

Fixpoint VecEq{n X} : (X -> X -> bool) -> Vec X n -> Vec X n -> bool :=
  match n with
  | 0 => fun _ _ _ => true
  | S m => fun eq v1 v2 => eq (fst v1) (fst v2) && VecEq eq (snd v1) (snd v2)
  end.

Fixpoint vmap{n X Y}(f : X -> Y) : Vec X n -> Vec Y n :=
  match n with
  | 0 => fun _ => tt
  | S m => fun '(x,xs) => (f x, vmap f xs)
  end.

Fixpoint v_to_list{n X} : Vec X n -> list X :=
  match n with
  | 0 => fun _ => []
  | S m => fun '(x,xs) => x::v_to_list xs
  end.

Fixpoint add_indices_aux{n X} : nat -> Vec X n -> Vec (nat * X) n :=
  match n return nat -> Vec X n -> Vec (nat * X) n with
  | 0 => fun _ _ => tt
  | S m => fun acc '(x,xs) => ((acc,x), add_indices_aux (S acc) xs)
  end.

Definition add_indices{n X} : Vec X n -> Vec (nat * X) n := add_indices_aux 0.

Fixpoint add_strings{n X} : (Fin.t n -> string) -> Vec X n -> Vec (string * X) n :=
  match n return (Fin.t n -> string) -> Vec X n -> Vec (string * X) n with
  | 0 => fun _ _ => tt
  | S m => fun strs '(x,xs) => ((strs Fin.F1,x),add_strings (fun j => strs (Fin.FS j)) xs)
  end.

End Vector.

Section Tuple.

Fixpoint Tuple{n} : (Fin.t n -> Type) -> Type :=
  match n with
  | 0 => fun _ => unit
  | S m => fun ts => ((ts Fin.F1) * (Tuple (fun j => ts (Fin.FS j))))%type
  end.

Fixpoint Tup_map{n} : forall (ts1 ts2 : Fin.t n -> Type)(fs : forall i, ts1 i -> ts2 i)(t : Tuple ts1), Tuple ts2 :=
  match n with
  | 0 => fun _ _ _ _ => tt
  | S m => fun ts1 ts2 fs t => (fs F1 (fst t), Tup_map (fun i => ts1 (FS i)) (fun i => ts2 (FS i)) (fun i => fs (FS i)) (snd t))
  end.

Fixpoint tup_index{n} : forall (i : Fin.t n) ts, Tuple ts -> ts i :=
  match n with
  | 0 => case0 _
  | S m => fun i ts t => fin_case i _ (fst t) (fun j => tup_index j (fun j => ts (Fin.FS j)) (snd t))
  end.

Fixpoint mkTup{n} : forall ts : Fin.t n -> Type, (forall i, ts i) -> Tuple ts :=
  match n with
  | 0 => fun _ _ => tt
  | S m => fun ts es => (es Fin.F1, mkTup (fun j => ts (Fin.FS j)) (fun j => es (Fin.FS j)))
  end.

Fixpoint TupEq{n} : forall ts : Fin.t n -> Type, (forall i, ts i -> ts i -> bool) -> Tuple ts -> Tuple ts -> bool :=
  match n with
  | 0 => fun _ _ _ _ => true
  | S m => fun ts eqs t1 t2 => eqs Fin.F1 (fst t1) (fst t2) && TupEq (fun j => ts (Fin.FS j)) (fun j => eqs (Fin.FS j)) (snd t1) (snd t2)
  end.

Fixpoint tup_to_vec{n X} : forall (ts : Fin.t n -> Type)(to_X : forall i, ts i -> X), Tuple ts -> Vec X n :=
  match n with
  | 0 => fun _ _ _ => tt
  | S m => fun ts to_X '(x,t) => (to_X Fin.F1 x, tup_to_vec (fun j => ts (Fin.FS j)) (fun j => to_X (Fin.FS j)) t)
  end.

End Tuple.

Section Lookup.

Fixpoint Fin_lookup{X}(pred : X -> bool){n} : (Fin.t n -> X) -> option (Fin.t n) :=
  match n return (Fin.t n -> X) -> option (Fin.t n) with
  | 0 => fun _ => None
  | S m => fun f => if pred (f F1) then Some F1 else
      match Fin_lookup pred (fun j => f (FS j)) with
      | None => None
      | Some i => Some (FS i)
      end
  end.

(* Check lookup.

Definition lookup{K X} : (K -> K -> bool) -> K -> list (K * X) -> option X :=
  fun eqbk key pairs => match List.find (fun p => eqbk key (fst p)) pairs with
                        | Some p => Some (snd p)
                        | None => None
                        end. *)

End Lookup.

Section PrintUtil.

Open Scope char_scope.

Fixpoint char_replicate(c : ascii)(n : nat) : string :=
  match n with
  | 0 => EmptyString
  | S m => String c (char_replicate c m)
  end.

Fixpoint string_drop(n : nat)(str : string) : string :=
  match n with
  | 0 => str
  | S m => match str with
           | EmptyString => EmptyString
           | String c str' => string_drop m str'
           end
  end.

Definition pad_with(c : ascii)(n : nat)(str : string) : string :=
  if Nat.ltb (String.length str) n then char_replicate c (n - String.length str) ++ str else string_drop (String.length str - n) str.

(*
Fixpoint intersperse(x : string)(xs : list string) : list string :=
  match xs with
  | [] => []
  | y::ys => match ys with
             | [] => xs
             | z::zs => y::x::intersperse x ys
             end
  end.
 *)
End PrintUtil.

Section Streams.

CoFixpoint unwind_list_aux{X}(xs ys : list X) : ys <> [] -> Stream X :=
  match ys return ys <> [] -> Stream X with
  | [] => fun pf => match pf eq_refl with end
  | y::zs => fun pf => match xs with
                       | x::xs' => Cons x (unwind_list_aux xs' (y::zs) pf)
                       | [] => Cons y (unwind_list_aux zs (y::zs) pf)
                       end
  end.

Definition unwind_list{X}(xs : list X) : xs <> [] -> Stream X :=
  unwind_list_aux xs xs.

Fixpoint take{X}(n : nat)(xs : Stream X) : list X :=
  match n with
  | 0 => []
  | S m => match xs with
           | Cons x xs' => x :: take m xs'
           end
  end.

End Streams.

Section Option.

Definition o_bind{X Y}(o : option X)(cont : X -> option Y) : option Y :=
  match o with
  | Some x => cont x
  | None => None
  end.

Definition o_ret{X}(x : X) : option X := Some x.

End Option.

Notation "'o_do' x <- y ; cont" := (o_bind y (fun x => cont)) (at level 20).


Require Import ABS.Lang.Syntax.
Require Import TLC.LibList.
Local Open Scope list_scope.
Set Implicit Arguments.

Section section_sim.

Context (Xs₁ Xs₂ : list var).

Definition var_sim X₁ X₂ : Prop :=
∃ n, Nth n Xs₁ X₁ ∧ Nth n Xs₂ X₂.

Inductive lid_sim L : lid L → lid L → Prop :=
| lid_f_sim : ∀ X₁ X₂, var_sim X₁ X₂ → lid_sim (lid_f X₁) (lid_f X₂)
| lid_b_sim : ∀ I, lid_sim (lid_b I) (lid_b I)
.

Inductive lbl_sim HV L : lbl HV L → lbl HV L → Prop :=
| lbl_var_sim : ∀ β, lbl_sim (lbl_var β) (lbl_var β)
| lbl_id_sim : ∀ ι₁ ι₂, lid_sim ι₁ ι₂ → lbl_sim (lbl_id ι₁) (lbl_id ι₂)
.

Inductive ef_sim EV HV L : ef EV HV L → ef EV HV L → Prop :=
| ef_var_sim : ∀ α, ef_sim (ef_var α) (ef_var α)
| ef_lbl_sim : ∀ ℓ₁ ℓ₂, lbl_sim ℓ₁ ℓ₂ → ef_sim (ef_lbl ℓ₁) (ef_lbl ℓ₂)
.

Inductive eff_sim EV HV L : eff EV HV L → eff EV HV L → Prop :=
| eff_nil_sim : eff_sim [] []
| eff_cons_sim :
  ∀ ε₁ 𝓔₁ ε₂ 𝓔₂, ef_sim ε₁ ε₂ → eff_sim 𝓔₁ 𝓔₂ →
  eff_sim (ε₁ :: 𝓔₁) (ε₂ :: 𝓔₂)
.

Inductive
ty_sim EV HV L : ty EV HV L → ty EV HV L → Prop :=
| ty_unit_sim : ty_sim 𝟙 𝟙
| ty_fun :
  ∀ S₁ T₁ E₁ S₂ T₂ E₂, ty_sim S₁ S₂ → ty_sim T₁ T₂ → eff_sim E₁ E₂ →
  ty_sim (ty_fun S₁ T₁ E₁) (ty_fun S₂ T₂ E₂)
| ty_efun : ∀ T₁ T₂, @ty_sim _ _ _ T₁ T₂ → ty_sim (ty_efun T₁) (ty_efun T₂)
| ty_hfun : ∀ 𝔽 T₁ T₂, @ty_sim _ _ _ T₁ T₂ → ty_sim (ty_hfun 𝔽 T₁) (ty_hfun 𝔽 T₂)
.

Inductive
hd_sim EV HV V L : hd EV HV V L → hd EV HV V L → Prop :=
| hd_var : ∀ p, hd_sim (hd_var p) (hd_var p)
| hd_def_sim :
  ∀ 𝔽 ι₁ ι₂ t₁ t₂, lid_sim ι₁ ι₂ → @tm_sim _ _ _ _ t₁ t₂ →
  hd_sim (hd_def 𝔽 ι₁ t₁) (hd_def 𝔽 ι₂ t₂)
with
val_sim EV HV V L : val EV HV V L → val EV HV V L → Prop :=
| val_unit_sim : val_sim val_unit val_unit
| val_var_sim : ∀ x, val_sim (val_var x) (val_var x)
| val_fun_sim : ∀ t₁ t₂, @tm_sim _ _ _ _ t₁ t₂ → val_sim (val_fun t₁) (val_fun t₂)
| val_efun_sim : ∀ t₁ t₂, @tm_sim _ _ _ _ t₁ t₂ → val_sim (val_efun t₁) (val_efun t₂)
| val_hfun_sim : ∀ t₁ t₂, @tm_sim _ _ _ _ t₁ t₂ → val_sim (val_hfun t₁) (val_hfun t₂)
| val_up_sim : ∀ h₁ h₂, @hd_sim _ _ _ _ h₁ h₂ → val_sim (val_up h₁) (val_up h₂)
with
tm_sim EV HV V L : tm EV HV V L → tm EV HV V L → Prop :=
| tm_val_sim : ∀ v₁ v₂, val_sim v₁ v₂ → tm_sim (tm_val v₁) (tm_val v₂)
| tm_Down_sim :
  ∀ t₁ t₂, @tm_sim _ _ _ _ t₁ t₂ → tm_sim (⬇ t₁) (⬇ t₂)
| tm_down_sim :
  ∀ X₁ t₁ X₂ t₂, var_sim X₁ X₂ → tm_sim t₁ t₂ → tm_sim (⇩ X₁ t₁) (⇩ X₂ t₂)
| tm_let_sim :
  ∀ t₁ s₁ t₂ s₂,
  tm_sim t₁ t₂ → @tm_sim _ _ _ _ s₁ s₂ →
  tm_sim (tm_let t₁ s₁) (tm_let t₂ s₂)
| tm_eapp_sim :
  ∀ t₁ 𝓔₁ t₂ 𝓔₂,
  tm_sim t₁ t₂ → eff_sim 𝓔₁ 𝓔₂ →
  tm_sim (tm_eapp t₁ 𝓔₁) (tm_eapp t₂ 𝓔₂)
| tm_happ_sim :
  ∀ t₁ h₁ t₂ h₂,
  tm_sim t₁ t₂ → hd_sim h₁ h₂ →
  tm_sim (tm_happ t₁ h₁) (tm_happ t₂ h₂)
| tm_app_sim :
  ∀ t₁ s₁ t₂ s₂,
  tm_sim t₁ t₂ → tm_sim s₁ s₂ →
  tm_sim (tm_app t₁ s₁) (tm_app t₂ s₂)
.

Inductive ktx_sim EV HV V L : ktx EV HV V L → ktx EV HV V L → Prop :=
| ktx_hole_sim : ktx_sim ktx_hole ktx_hole
| ktx_down_sim :
  ∀ K₁ K₂ X₁ X₂, ktx_sim K₁ K₂ → var_sim X₁ X₂ →
  ktx_sim (ktx_down K₁ X₁) (ktx_down K₂ X₂)
| ktx_let_sim :
  ∀ K₁ K₂ t₁ t₂,
  ktx_sim K₁ K₂ → @tm_sim _ _ _ _ t₁ t₂ →
  ktx_sim (ktx_let K₁ t₁) (ktx_let K₂ t₂)
| ktx_eapp_sim :
  ∀ K₁ K₂ 𝓔₁ 𝓔₂,
  ktx_sim K₁ K₂ → eff_sim 𝓔₁ 𝓔₂ →
  ktx_sim (ktx_eapp K₁ 𝓔₁) (ktx_eapp K₂ 𝓔₂)
| ktx_happ_sim :
  ∀ K₁ K₂ h₁ h₂,
  ktx_sim K₁ K₂ → hd_sim h₁ h₂ →
  ktx_sim (ktx_happ K₁ h₁) (ktx_happ K₂ h₂)
| ktx_app1_sim :
  ∀ K₁ K₂ t₁ t₂,
  ktx_sim K₁ K₂ → tm_sim t₁ t₂ →
  ktx_sim (ktx_app1 K₁ t₁) (ktx_app1 K₂ t₂)
| ktx_app2_sim :
  ∀ K₁ K₂ v₁ v₂,
  ktx_sim K₁ K₂ → val_sim v₁ v₂ →
  ktx_sim (ktx_app2 K₁ v₁) (ktx_app2 K₂ v₂)
.

Definition xEnv_sim EV HV V (Γ₁ Γ₂ : V → ty EV HV ∅) : Prop :=
∀ x, ty_sim (Γ₁ x) (Γ₂ x).

End section_sim.

Fixpoint XEnv_sim_aux (Xs₁ Xs₂ : list var) EV HV (Ξ₁ Ξ₂ : XEnv EV HV) : Prop :=
match Ξ₁, Ξ₂ with
| [], [] => True
| (X₁, (T₁, 𝓔₁)) :: Ξ₁, (X₂, (T₂, 𝓔₂)) :: Ξ₂ =>
  ty_sim Xs₁ Xs₂ T₁ T₂ ∧ eff_sim Xs₁ Xs₂ 𝓔₁ 𝓔₂ ∧
  XEnv_sim_aux (X₁ :: Xs₁) (X₂ :: Xs₂) Ξ₁ Ξ₂
| _, _ => False
end.

Definition XEnv_sim EV HV (Ξ₁ Ξ₂ : XEnv EV HV) : Prop :=
XEnv_sim_aux [] [] Ξ₁ Ξ₂.


(** Sequence.v *)

From Babel Require Import TerminalDogma.
From Babel Require Import TerminalDogma.Infinity.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(*
(** The module to deal with finite or countable infinite sequences. *)

Open Scope Nat_scope.

Record finSeq (T : Type) : Type := build_finSeq {
    finSeq_len : nat;
    finSeq_f :> [1, finSeq_len]N -> T;
}.

Definition infSeq (T : Type) : Type := nat -> T.

Inductive seque (T : Type) : Type :=
| finSeq_obj :> finSeq T -> seque T
| infSeq_obj :> infSeq T -> seque T.

Definition index (T : Type) (s : seque T) : Set :=
    match s with
    | finSeq_obj s => [1, finSeq_len s ]N
    | infSeq_obj _ => nat
    end.

Lemma finSeq_index_eq (T : Type) (s1 s2 : finSeq T) (Heq : index s1 = index s2)
    : finSeq_len s1 = finSeq_len s2.
Abort.

Definition seque2fun (T : Type) (s : seque T) : index s -> T :=
    match s with
    | finSeq_obj s' => s'
    | infSeq_obj s' => s'
    end.

Coercion seque2fun : seque >-> Funclass.

(** finite sequence with length as dependent type *)

Record sequeN (T : Type) (n : nat) := build_sequeN {
    sequeN_obj :> finSeq T;
    sequeN_len : finSeq_len sequeN_obj = n;
}.

(** sequence zip*)

Definition finsSeq_fun_zip (X Y Z: Type) (sx : finSeq X) (sy : finSeq Y)
    (HdimEq : finSeq_len sx = finSeq_len sy) (f : X -> Y -> Z) : finSeq Z.
Proof.
    refine (@build_finSeq Z (finSeq_len sx) _).
    move => x. apply f. apply (sx x). apply sy. by rewrite -HdimEq.
Defined.

Definition seq_fun_zip (X Y Z: Type) (sx : seque X) (sy : seque Y)
    (HdimEq : index sx = index sy) (f : X -> Y -> Z) : seque Z.
Proof. rewrite /index in HdimEq. destruct sx, sy.
    { apply finSeq_obj. refine (@build_finSeq Z (finSeq_len f0) _).
    move => x. apply f. apply (f0 x). apply f1. by rewrite -HdimEq. }
    by destruct (fin_inf_neq HdimEq).
    by symmetry in HdimEq; destruct (fin_inf_neq HdimEq).
    { apply infSeq_obj. move => n. apply f. by apply /i /n. by apply /i0 /n. }
Defined.

Definition sequeN_fun_zip (n : nat) (X Y Z: Type) (sx : sequeN X n)
        (sy : sequeN Y n) (f : X -> Y -> Z) : sequeN Z n.
Proof.
    have Heqx : finSeq_len sx = n. by apply sx.
    have HeqxI : ([1, n]N:Type) = [1, finSeq_len sx]N. f_equal. by rewrite Heqx.
    have Heqy : finSeq_len sy = n. by apply sy.
    have HeqyI : ([1, n]N:Type) = [1, finSeq_len sy]N. f_equal. by rewrite Heqy.
    set fs := @build_finSeq _ n
        (fun x =>
            f (sx (transport HeqxI x)) (sy (transport HeqyI x))).
    refine (@build_sequeN _ _ fs _).
    by rewrite /fs => //.
Defined.

Print sequeN_fun_zip.

(** sequence fold *)
Definition sequeN_foldl (n : nat) (X Y : Type) (h : Y) (sx : sequeN X n)
    (f : Y -> X -> Y) : Y.
Proof. elim : n sx. by move => x; exact h.
*)


Require Import Prelims L Programs.

Require Import Ring Arith.

(** * Abstract Substitution Machine *)

Local Notation state := (list Pro*list Pro)%type.

(** ** Reduction Rules *)

Definition tc (c:Pro) C: list Pro :=
  match c with
    [] => C
  |_ => c::C
  end.

Inductive step : state -> state -> Prop :=
  step_pushVal P P' Q T V:
    jumpTarget 0 [] P = Some (Q,P')
    -> step ((lamT::P)::T,V) (tc P' T,Q::V)
| step_beta P Q R T V:
    step ((appT::P)::T,Q::R::V) (substP R 0 (lamT::Q++[retT])::tc P T,V).
Hint Constructors step.

Definition init s : state := ([compile s],[]).

Lemma tc_compile s c C: tc (compile s++c) C = (compile s++c)::C.
Proof.
  induction s in c|-*;cbn. all:cbn;try autorewrite with list in *;try congruence.
Qed.

(** ** Time *)
 (** We can show the right generalisation that connects the big-step characterisation of the L time resource measure with abstract machine steps.
  For technical reasons, we seperate that there *is* a abstract machine reduction from the exact analysis of the step that reduction takes,
 by using evars and a existential quantified variable [l] that collects the steps during the proof and which we show equal to the desired formula (3k+1) afterwards. *)

Lemma correctTime' s t k c0 C V:
  timeBS k s t ->
  exists p l, reprP p t /\ pow step l ((compile s++c0)::C,V) (tc c0 C,p::V) /\ l = 3*k+1.
Proof.
  intros Ev.
  induction Ev in c0, C,V |- *.
  -exists (compile s),1. split. constructor. split. 2:omega. apply (rcomp_1 step). cbn. constructor.
   autorewrite with list. apply jumpTarget_correct.
  -cbn [compile]. autorewrite with list. cbn [List.app].
   edestruct IHEv1 with (c0:=compile t ++ appT :: c0) (C:=C) (V:=V)
     as (p1&l1&rep1&R1&->);inv rep1.
   edestruct IHEv2 with (c0:=appT :: c0) (C:=C) (V:=compile s'::V)
     as (p2&l2&rep2&R2&->);inv rep2.
   edestruct IHEv3 with (c0:=@nil Tok) (C:=tc c0 C) (V:=V)
     as (p3&l3&rep3&R3&->);inv rep3. rename s0 into u.
   eexists (compile u),_. split. now eauto. split.
   + apply pow_add. eexists. split. exact R1.
     rewrite tc_compile.
     apply pow_add. eexists. split. exact R2.
     apply pow_add. eexists. split. eapply (rcomp_1 step). constructor.
     autorewrite with list in R3.
     rewrite <- substP_correct in R3. exact R3.
   +omega.
Qed.

Lemma correctTime s t k:
  timeBS k s t ->
  exists p, reprP p t /\ pow step (3*k+1) (init s) ([],[p]).
Proof.
  intros Ev.
  destruct (correctTime' [] [] [] Ev) as (p&?&rep&R&->).
  autorewrite with list in R.
  eauto.
Qed.

(** ** Space *)

Lemma helperF P T: sum (map sizeT P) + sum (map sizeP T) <= sum (map sizeP (tc P T)).
Proof.
  destruct P as [|[] []];cbn;try omega.
Qed.

Lemma helper2 s m: size s <= m -> 1+ sum (map sizeT (compile s)) <= 2*m.
Proof.
  intros. pose (sizeP_size s). omega.
Qed.

Lemma helperF' P T:  sum (map sizeP (tc P T)) <= sum (map sizeT P) + sum (map sizeP T) + 1.
Proof.
  destruct P as [|[] []];cbn;try omega.
Qed.

Definition redWithMaxSizeS := redWithMaxSize (fun '(T',V') => (sum (map sizeP T') + sum (map sizeP V'))) step.

(** The carefullt balanced generalisation will go through, as for time. We again first collect the precise size [m] of intermediate steps as implied by the machine rules/inductive hypothesis and afterwards show that [m] always is in the claimed bounds. *)
Lemma correctSpace' s t k P T V:
  spaceBS k s t ->
  exists m Q , reprP Q t /\
          redWithMaxSizeS m ((compile s++P)::T,V)
                          (tc P T,Q::V)
          /\ k + sum (map sizeP (tc P T)) + sum (map sizeP V) <= m
            <= 2*k + sum (map sizeP (tc P T)) + sum (map sizeP V).

Proof.
  intros Ev.
  induction Ev in P, T,V |- * .
  -eexists _,(compile s). cbn - [sizeP]. autorewrite with list. split. constructor. split.
   {econstructor. 2:apply redWithMaxSizeR. constructor. now eauto using jumpTarget_correct. reflexivity. reflexivity. }
   repeat (cbn - [ Nat.max sizeP];autorewrite with list).
   replace( sizeP (lamT :: compile s ++ retT :: P)) with (sizeP (compile s)+sizeP P + 1). 2:{unfold sizeP;repeat (cbn;autorewrite with list);try omega. }
   specialize (sizeP_size' s). specialize (sizeP_size s).
   specialize (helperF' P T) as ?. specialize (helperF P T) as ?.
   intros. unfold sizeP in *. eapply Nat.max_case_strong. all:omega.
  -cbn [compile]. autorewrite with list. cbn [List.app].

    edestruct IHEv1 as (m1'&p1&rep1&R1&eq11&eq12).
    inv rep1.
    edestruct IHEv2 as (m2'&p2&rep2&R2&eq21&eq22).
    inv rep2.
    edestruct IHEv3 with (P:=@nil Tok)as (m3'&p3&rep3&R3&eq31&eq32).
    eexists _,p3. split. tauto. split.
    eapply redWithMaxSize_trans.
    eapply R1.
    rewrite tc_compile.
    eapply redWithMaxSize_trans.
    eapply R2.
    eapply redWithMaxSize_trans.
    eapply redWithMaxSizeC. cbn;now eauto.
    autorewrite with list in R3.
    erewrite substP_correct with (t:=lam t').
    eapply R3.
    reflexivity.
    cbn. eapply redWithMaxSizeR. reflexivity. reflexivity. reflexivity. reflexivity.
    (** Now, a very tedious analysis of all the involved state sizes and different results for [max] yields that the claim indeed holds.
    Luckely, we can automat this by using [omega] after providing all the neccessary instances of needed lemmatas and doing all the case splits for the [max]-function. *)
    1:{
      cbn -[max].
      rewrite !tc_compile in *.
      split.
      { clear eq12 eq22 eq32.
      all:specialize (sizeP_size' s').
      all:specialize (sizeP_size' s).
      all:specialize (sizeP_size' t').
      all:specialize (sizeP_size' t).
      all:specialize (sizeP_size' u).
      specialize (helperF' P T) as H'.
      unfold sizeP in *.
      all:repeat (cbn - [max] in *;autorewrite with list in * ).
      all:(repeat apply Nat.max_case_strong;intros;try omega).
      }
      { clear eq11 eq21 eq31.
        all:specialize (sizeP_size s').
        all:specialize (sizeP_size s).
        all:specialize (sizeP_size t').
        all:specialize (sizeP_size t).
        all:specialize (sizeP_size u).
        all:apply spaceBS_ge in Ev1 as [? ?].
        all:apply spaceBS_ge in Ev2 as [? ?].
        all:apply spaceBS_ge in Ev3 as [H'' ?].
        apply redWithMaxSize_ge in R3 as [].

        specialize (helperF P T).
        intros.

        all:repeat (match goal with [ H: size _ <= _  |- _] => (apply helper2 in H;cbn in H;autorewrite with list in H) end ). unfold sizeP in *.
        repeat (cbn -[Nat.max] in *;try autorewrite with list in * ).
        (repeat apply Nat.max_case_strong;intros;try omega).
      }
    }
Qed.

Lemma correctSpace s t m:
  spaceBS m s t ->
  exists m' P, reprP P t /\ redWithMaxSizeS m' (init s) ([],[P]) /\ m <= m' <= 2*m.
Proof.
  intros Ev. specialize (correctSpace' [] [] [] Ev) as (m'&P&?&R&leq).
  eexists m',P. split. tauto.
  autorewrite with list in *.
  split.
  -eapply R.
  -cbn in leq. omega.
Qed.


Set Implicit Arguments.
Require Export syntax std.
Require Import Morphisms Omega FinFun.

(** * Semantics **)
Section Semantics.

  Context {X: Const}.
  Implicit Types (s t: exp X) (delta: fin -> fin) (sigma: fin -> exp X).

  Reserved Notation "s > t" (at level 70).

  Inductive step : exp X -> exp X -> Prop :=
  | stepBeta s s' t: beta s t = s' -> (lambda s) t > s'
  | stepLam s s': s > s' -> lambda s > lambda s'
  | stepAppL s s' t: s > s' -> s t > s' t
  | stepAppR s t t': t > t' -> s t > s t'
  where "s > t" := (step s t).

  Notation "s >* t" := (star step s t) (at level 70).
  Hint Constructors step star.

  Notation "s ▷ t" := (evaluates step s t) (at level 60).
  Notation normal := (Normal step).

  (** ** Compatibility Properties *)
  Section CompatibilityProperties.

    Global Instance lam_proper: Proper (star step ++> star step) lam.
    Proof. induction 1; eauto. Qed.

    Global Instance app_proper: Proper (star step ++> star step ++> star step) app.
    Proof.
      intros x x' H1 y y' H2; induction H1; induction H2; eauto.
    Qed.

    Lemma ren_step s t delta:
      s > t -> ren delta s > ren delta t.
    Proof.
      induction 1 in delta |-*; cbn; eauto.
      econstructor. subst. now asimpl.
    Qed.

    Lemma ren_steps s t delta:
      s >* t -> ren delta s >* ren delta t.
    Proof.
      induction 1; eauto using ren_step.
    Qed.

    Global Instance ren_step_proper:
      Proper (eq ++> step ++> step) (@ren X).
    Proof.
      intros ? zeta -> s t H; now eapply ren_step.
    Qed.

    Global Instance ren_steps_proper:
      Proper (eq ++> star step ++> star step) (@ren X).
    Proof.
      intros ? zeta -> s t H; now eapply ren_steps.
    Qed.

    Lemma subst_step s t sigma:
      s > t -> sigma • s > sigma • t.
    Proof.
      induction 1 in sigma |-*; cbn; eauto.
      - econstructor. subst. now asimpl.
    Qed.

    Lemma subst_steps s t sigma:
      s >* t -> sigma • s >* sigma • t.
    Proof.
      induction 1; eauto using subst_step.
    Qed.

    Global Instance subst_step_proper:
      Proper (eq ++> step ++> step) (@subst_exp X).
    Proof.
      intros ? zeta -> s t H; now eapply subst_step.
    Qed.

    Global Instance subst_steps_proper:
      Proper (eq ++> star step ++> star step) (@subst_exp X).
    Proof.
      intros ? zeta -> s t H; now eapply subst_steps.
    Qed.

  End CompatibilityProperties.

  (** ** Normality Characterisation *)
  Section Normality.

    Lemma normal_var x: normal (var x).
    Proof. intros t H1; inv H1. Qed.

    Lemma normal_const c: normal (const c).
    Proof. intros t H1; inv H1. Qed.

    Lemma normal_lam_intro s: normal s -> normal (lambda s).
    Proof. intros H1 t H2; inv H2; eapply H1; eauto. Qed.

    Lemma normal_lam_elim s: normal (lambda s) -> normal s.
    Proof. intros H1 t H2; eapply H1; eauto. Qed.

    Lemma normal_app_l s t: normal (s t) -> normal s.
    Proof. intros H t' H1; eapply H; eauto. Qed.

    Lemma normal_app_r s t: normal (s t) -> normal t.
    Proof. intros H t' H1; eapply H; eauto. Qed.

    Lemma normal_app_not_lam s t: normal (s t) -> ~ isLam s.
    Proof. destruct s; intuition; eapply H; eauto. Qed.

    Lemma normal_app_intro s t:
      ~ isLam s -> normal s -> normal t -> normal (s t).
    Proof.
      intros; intros t' H2; inv H2; cbn in *; eauto.
      all: firstorder.
    Qed.

    Hint Resolve normal_var normal_const normal_lam_intro
       normal_lam_elim normal_app_l normal_app_r normal_app_intro.

    Lemma normal_ren s delta:
      normal s -> normal (ren delta s).
    Proof.
      induction s in delta |-*; cbn; intuition.
      eapply normal_app_intro; eauto.
      destruct s1; cbn; eauto.
      intros _; eapply H; eauto.
    Qed.

    Lemma normal_subst s sigma:
      (forall x, ~ isLam (sigma x)) ->
      (forall x, normal (sigma x)) ->
      normal s -> normal (sigma • s).
    Proof.
      induction s in sigma |-*; intros H1 H2 N; cbn in *; intuition.
      - eapply normal_lam_intro, IHs; [| | now eapply normal_lam_elim].
        + intros []; cbn; intuition.
          unfold funcomp in *. eapply H1 with (x := n).
          destruct sigma; cbn; intuition.
        + intros []; cbn; intuition.
          now eapply normal_ren.
      - eapply normal_app_intro; eauto.
        destruct s1; eauto.
        intros _; eapply N; eauto.
    Qed.

    Global Instance dec_normal: Dec1 (normal).
    Proof.
      intros s; unfold Dec; induction s; intuition.
      all: try solve [right; contradict b; eauto].
      destruct s1; intuition.
      right; intros H; eapply H; eauto.
    Qed.

    Lemma head_atom s:
      normal s -> ~ isLam s -> isAtom (head s).
    Proof.
      induction s; cbn; eauto.
      intros H _; cbn.
      eapply IHs1; eauto.
      destruct s1; eauto.
      intros _. eapply H; eauto.
    Qed.

  End Normality.

  Hint Resolve normal_var normal_const normal_lam_intro
       normal_lam_elim normal_app_l normal_app_r normal_app_intro.

  Hint Resolve head_atom.

  (** ** Inversion Lemmas *)
  Section InversionLemmas.

    Lemma head_preserved s s':
      s > s' -> isLam (head s') -> isLam (head s).
    Proof.
      induction 1; cbn; eauto.
    Qed.

    Lemma steps_lam s v:
      lambda s >* v -> exists s', v = lambda s' /\ s >* s'.
    Proof.
      remember (lambda s) as t. intros H1. revert s Heqt.
      induction H1.
      - intros ? ->; eexists; eauto.
      - intros; subst. inv H. edestruct IHstar; eauto; intuition; subst.
        exists x. eauto.
    Qed.

    Lemma steps_app s t v:
      app s t >* v -> (exists s', exists t', v = app s' t' /\ s >* s' /\ t >* t')
                    \/ (exists s', s >* lambda s' /\ isLam (head s)).
    Proof.
      remember (s t) as r. intros H1. revert s t Heqr.
      induction H1.
      - intros; subst. left; eexists; eexists; intuition.
      - intros; subst. inv H.
        + right. eexists; split; cbn; eauto.
        + edestruct IHstar; eauto.
          * destruct H as (? & ? & ? & ? & ?); subst.
            left. eexists; eexists; eauto.
          * destruct H as (? & ? & ?). right. eexists; split; eauto.
            eapply head_preserved; eauto.
        + edestruct IHstar; eauto.
          * destruct H as (? & ? & ? & ? & ?); subst.
            left. eexists; eexists; eauto.
    Qed.

    Lemma steps_app_atom  s t v:
      isAtom s -> s t >* v -> exists t', v = s t' /\ t >* t'.
    Proof.
      destruct s;
        intros ? [(? & ? & ? & ?)|(? & ? & ?)] % steps_app; cbn in *; intuition.
      all: inv H2; eauto; inv H1.
    Qed.

    Lemma injective_upRen_exp_exp delta:
      Injective delta -> Injective (upRen_exp_exp delta).
    Proof.
      intros H [| x] [| y]; eauto.
      all: cbn; discriminate.
    Qed.

    Lemma anti_ren delta s t:
      Injective delta -> ren delta s = ren delta t -> s = t.
    Proof.
      intros H; induction s in delta, H, t |-*; destruct t; try discriminate.
      all: cbn; injection 1; intros; subst; eauto.
      - erewrite IHs.
        3: eapply H1. eauto. eapply injective_upRen_exp_exp; eauto.
      - erewrite IHs1, IHs2; eauto.
    Qed.

    Lemma step_anti_ren delta s t: ren delta s > t -> exists t', s > t' /\ t = ren delta t'.
    Proof.
      remember (ren delta s) as s'; intros H;
        revert s Heqs'; induction H in delta |-*.
      all: intros []; try discriminate; injection 1; intros; subst.
      - destruct e; try discriminate; injection H1; intros; subst.
        exists (beta e e0); intuition. now asimpl.
      - edestruct IHstep; eauto.
        intuition; subst. exists (lambda x). intuition.
      - edestruct IHstep; eauto.
        exists (x e0); intuition; now subst.
      - edestruct IHstep; eauto.
        exists (e x); intuition; now subst.
    Qed.

    Lemma steps_anti_ren delta s t:
      ren delta s >* t -> exists t', s >* t' /\ t = ren delta t'.
    Proof.
      remember (ren delta s) as s'. intros H; revert s Heqs'; induction H.
      - intros; subst. exists s; eauto.
      - intros; subst. eapply step_anti_ren in H as []; intuition.
        edestruct (IHstar x); intuition.
        exists x0; eauto.
    Qed.

  End InversionLemmas.
End Semantics.

Notation "s > t" := (step s t) (at level 70).
Notation "s >* t" := (star step s t) (at level 70).
Notation "s ▷ t" := (evaluates step s t) (at level 60).
Notation normal := (Normal step).

Hint Constructors step star.

Hint Resolve normal_var normal_const normal_lam_intro normal_app_intro.
Hint Resolve head_atom.


Goal forall A, A -> Type.
Proof.
  intros; eauto.
Qed.


(* --------------------------------------------------------------------
 * Copyright (c) - 2017--2021 - Xavier Allamigeon <xavier.allamigeon at inria.fr>
 * Copyright (c) - 2017--2021 - Ricardo D. Katz <katz@cifasis-conicet.gov.ar>
 * Copyright (c) - 2019--2021 - Pierre-Yves Strub <pierre-yves@strub.nu>
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import bigop ssralg ssrnum zmodp matrix fingroup perm.
Require Import extra_misc inner_product.

Import Order.Theory.

Definition lte_anti := (=^~ @eq_le, @lt_asym, @lt_le_asym, @le_lt_asym).

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

Local Open Scope ring_scope.
Import GRing.Theory Num.Theory.

Section Order.

Variable R : realFieldType.

Section Core.

Variable n : nat.

Implicit Types x y z : 'cV[R]_n.

Definition lev x y := [forall i, x i 0 <= y i 0].

Notation "<=m" := lev: ring_scope.
Notation ">=m x" := (lev x) (at level 0): ring_scope.
Notation "<=m x" := (lev^~ x) (at level 0): ring_scope.
Notation "x <=m y" := (lev x y) (at level 0): ring_scope.
Notation "x >=m y" := (y <=m x) (only parsing, at level 0) : ring_scope.

Lemma lev_add2l x :
  {mono +%R x : y z / y <=m z}.
Proof.
by move => y z; apply: eq_forallb => i; rewrite !mxE ler_add2l.
Qed.

Lemma lev_add2r x :
  {mono +%R^~ x : y z / y <=m z}.
Proof.
by move => y z; apply: eq_forallb => i; rewrite !mxE ler_add2r.
Qed.

Lemma lev_opp2 :
  {mono -%R: x y /~ x <=m y}.
Proof.
by move => x y; apply: eq_forallb => i; rewrite !mxE ler_opp2.
Qed.

(* Addition of vector inequalities retains order *)
Lemma lev_add x y (l1 l2 : 'cV[R]_n) :
  (l1 <=m x) -> (l2 <=m y) -> ((l1 + l2) <=m (x + y)).
Proof.
  rewrite /lev; move => /forallP Hx /forallP Hy.
  by apply/forallP => ?; rewrite !mxE ler_add //.
Qed.

Lemma lev_pscalar (a : R) :
  0 < a -> {mono *:%R a : x y / x <=m y }.
Proof.
by move => Ha x y; apply: eq_forallb => i; rewrite !mxE ler_pmul2l.
Qed.

Lemma lev_wpscalar a x y :
  0 <= a -> x <=m y -> (a *: x) <=m (a *: y).
Proof.
move => Ha /forallP Hxy.
apply/forallP => i; rewrite !mxE.
by apply: ler_wpmul2l.
Qed.

Lemma gev0P x :
  reflect (forall i, 0 <= x i 0) (x >=m 0).
Proof.
apply: (iffP forallP) => [H i | H i].
- by move/(_ i): H; rewrite mxE.
- by rewrite mxE; apply: H.
Qed.

Lemma lev0P x :
  reflect (forall i, x i 0 <= 0) (x <=m 0).
Proof.
apply: (iffP forallP) => [H i | H i].
- by move/(_ i): H; rewrite mxE.
- by rewrite mxE; apply: H.
Qed.

Lemma paddv_eq0 x y :
  (0 <=m x) -> (0 <=m y) -> (x + y == 0) = (x == 0) && (y == 0).
Proof.
move => /forallP Hx /forallP Hy.
apply/idP/idP.
- move/eqP/colP => Hxy; apply/andP; split;
  apply/eqP; apply/colP => i; move/(_ i)/eqP: Hxy; rewrite !mxE paddr_eq0;
  by [move/andP => [/eqP H /eqP H'] | move/(_ i): Hx; rewrite mxE | move/(_ i): Hy; rewrite mxE].
- by move/andP => [/eqP -> /eqP ->]; rewrite addr0.
Qed.

Lemma subv_ge0 x y :
  (0 <=m (y - x)) = (x <=m y).
Proof.
by apply: eq_forallb => i; rewrite !mxE subr_ge0.
Qed.

Lemma subv_le0 x y :
  (0 >=m (y - x)) = (x >=m y).
Proof.
by apply: eq_forallb => i; rewrite !mxE subr_le0.
Qed.

Lemma lev_refl x :
  (x <=m x).
Proof.
by apply/forallP => i.
Qed.

Lemma oppv_ge0 x :
  (0 <=m -x) = (x <=m 0).
Proof.
by apply: eq_forallb => i; rewrite !mxE oppr_ge0.
Qed.

Lemma lev_antisym:
  antisymmetric (<=m).
Proof.
move => x y /andP [/forallP Hx /forallP Hy].
apply/colP => i; apply: le_anti; apply/andP; split; by [move/(_ i): Hx; move/(_ i): Hy].
Qed.

Lemma lev_trans:
  transitive (<=m).
Proof.
move => x y z /forallP Hx /forallP Hy.
apply/forallP => i; move/(_ i): Hy; move/(_ i): Hx.
by apply: le_trans.
Qed.

Lemma eqv_le x y :
  (x == y) = (x <=m y) && (y <=m x).
Proof.
apply/idP/idP.
- by move/eqP ->; rewrite lev_refl.
- by move/lev_antisym/eqP.
Qed.

Lemma vdot_lev x y z :
  x >=m 0 -> y <=m z -> '[x,y] <= '[x,z].
Proof.
move => /forallP Hx /forallP Hyz.
rewrite -subr_ge0 -vdotBr /vdot.
apply: sumr_ge0 => i _; apply: mulr_ge0.
- by move/(_ i): Hx; rewrite mxE.
- by rewrite !mxE subr_ge0.
Qed.

Lemma vdot_lev_eq0 x y :
  [forall i, x i 0 > 0] -> y >=m 0 -> '[x,y] = 0 -> y = 0.
Proof.
move => Hx Hy Hxy.
suff: forall i, x i 0 * y i 0 = 0.
- move => H; apply/colP => i; rewrite mxE; move/(_ i)/eqP: H.
  rewrite mulf_eq0; move/forallP/(_ i)/lt0r_neq0/negbTE: Hx ->.
  by rewrite /=; move/eqP.
- move => i; move: Hxy i is_true_true; apply: psumr_eq0P => i _.
  rewrite (pmulr_rge0 _ ((forallP Hx) i)).
  by move/forallP/(_ i): Hy; rewrite mxE.
Qed.

Lemma vdot_lev_eq x y z : [forall i, x i 0 > 0] -> y >=m z -> '[x,y] = '[x,z] -> y = z.
Proof.
move => Hx.
rewrite -subv_ge0 => Hyz.
move/eqP; rewrite -subr_eq0 -vdotBr => /eqP Hdot.
apply/eqP; rewrite -subr_eq0.
apply/eqP; exact: (vdot_lev_eq0 Hx).
Qed.

Definition lev_max x y := \col_i (Num.max (x i 0) (y i 0)).
Definition lev_min x y := \col_i (Num.min (x i 0) (y i 0)).

Lemma lev_maxC x y :
  lev_max x y = lev_max y x.
Proof.
apply/colP => i; rewrite !mxE; apply: maxC.
Qed.

Lemma lev_minC x y :
  lev_min x y = lev_min y x.
Proof.
apply/colP => i; rewrite !mxE; apply: minC.
Qed.

Lemma lev_maxl x y :
  (lev_max x y) >=m x.
Proof.
by apply/forallP => i; rewrite !mxE le_maxr lexx.
Qed.

Lemma lev_maxr x y :
  (lev_max x y) >=m y.
Proof.
by rewrite lev_maxC; apply: lev_maxl.
Qed.

Lemma lev_minl x y :
  (lev_min x y) <=m x.
Proof.
by apply/forallP => i; rewrite !mxE le_minl lexx.
Qed.

Lemma lev_minr x y :
  (lev_min x y) <=m y.
Proof.
by rewrite lev_minC; apply: lev_minl.
Qed.

Lemma add_lev_min_max x y :
  lev_min x y + lev_max x y = x + y.
Proof.
by apply/colP => i; rewrite !mxE /= addr_min_max.
Qed.

Definition pos_part x := lev_max x 0.
Definition neg_part x := -(lev_min x 0).

Lemma pos_part_gev0 x :
  (pos_part x) >=m 0.
Proof.
by apply: lev_maxr.
Qed.

Lemma neg_part_gev0 x :
  (neg_part x) >=m 0.
Proof.
by rewrite oppv_ge0; apply: lev_minr.
Qed.

Lemma add_pos_neg_part x :
  (pos_part x) - (neg_part x) = x.
Proof.
by rewrite opprK addrC add_lev_min_max addr0.
Qed.

Lemma row_perm_lev (s : {perm 'I_n}) x y :
  (x <=m y) = ((row_perm s x) <=m (row_perm s y)).
Proof.
apply/idP/idP => /forallP H; apply/forallP => i.
- by move/(_ (s i)): H; rewrite !mxE.
- by move/(_ ((s^-1)%g i)): H; rewrite !mxE permKV.
Qed.

Lemma row_perm_gev0 (s : {perm 'I_n}) x :
  (x >=m 0) = ((row_perm s x) >=m 0).
Proof.
by rewrite (row_perm_lev s) row_perm_const.
Qed.

End Core.

Notation "<=m" := lev: ring_scope.
Notation ">=m x" := (lev x) (at level 0): ring_scope.
Notation "<=m x" := (lev^~ x) (at level 0): ring_scope.
Notation "x <=m y" := (lev x y) (at level 0): ring_scope.
Notation "x >=m y" := (y <=m x) (only parsing, at level 0) : ring_scope.

Section ExtraOrder.

Variable n p : nat.

Lemma lev_castmx (eq_np : n = p) :
  {mono (@castmx R n 1 p 1 (eq_np, erefl _)) : x y / x <=m y }.
Proof.
move => x y.
apply/idP/idP.
- move/forallP => H; apply/forallP => i.
  by move/(_ (cast_ord eq_np i)): H; rewrite !castmxE //= cast_ord_id cast_ordK.
- move/forallP => H; apply/forallP => ?.
  by rewrite !castmxE /= cast_ord_id; apply: H.
Qed.

Lemma castmx_gev0 (eq_np : n = p) x :
  ((castmx (eq_np, erefl _) x) >=m 0) = (x >=m 0).
Proof.
have {1}<-: (castmx (eq_np, erefl 1%N) 0 = (0:'cV[R]_p)) by rewrite castmx_const.
apply: lev_castmx.
Qed.

Lemma col_mx_lev (x y : 'cV[R]_n) (v w : 'cV[R]_p) :
  ((col_mx x v) <=m (col_mx y w)) = ((x <=m y) && (v <=m w)).
Proof.
apply/idP/idP.
- move/forallP => H.
  apply/andP; split.
    + by apply/forallP => i; move: (H (lshift p i)); rewrite !col_mxEu.
    + by apply/forallP => i; move: (H (rshift n i)); rewrite !col_mxEd.
- move/andP => [/forallP H1  /forallP H2].
  apply/forallP =>i.
  rewrite !mxE.
  by case: splitP => [ k _ | k _ ]; [move: (H1 k) | move: (H2 k)].
Qed.

Lemma col_mx_lev0 (x : 'cV[R]_n) (v : 'cV[R]_p) :
  ((col_mx x v) <=m 0) = ((x <=m 0) && (v <=m 0)).
Proof.
by rewrite -{1}[0]vsubmxK col_mx_lev !linear0.
Qed.

Lemma col_mx_gev0 (y : 'cV[R]_n) (w : 'cV[R]_p) :
  (0 <=m (col_mx y w)) = ((0 <=m y) && (0 <=m w)).
Proof.
by rewrite -{1}[0]vsubmxK col_mx_lev !linear0.
Qed.

Lemma gev0_vsubmx (x : 'cV[R]_(n+p)) :
  (0 <=m x) = (0 <=m (usubmx x)) && (0 <=m (dsubmx x)).
Proof.
by rewrite -{1}[x]vsubmxK col_mx_gev0.
Qed.

Lemma lev0_vsubmx (x : 'cV[R]_(n+p)) :
  (0 >=m x) = (0 >=m (usubmx x)) && (0 >=m (dsubmx x)).
Proof.
by rewrite -{1}[x]vsubmxK col_mx_lev0.
Qed.

Lemma lev_sum I (r : seq I) (P : pred I) (F G : I -> 'cV[R]_n) :
    (forall i, P i -> (F i) <=m (G i)) ->
    (\sum_(i <- r | P i) F i) <=m (\sum_(i <- r | P i) G i).
Proof.
move => H.
apply/forallP => i.
- rewrite !summxE.
  apply: ler_sum => j Hj.
  + by move/(_ _ Hj)/forallP/(_ i): H.
Qed.

Lemma lev_scalar_mx (a b : R) : (a <= b) = ((a%:M) <=m (b%:M)).
Proof.
apply/idP/forallP => [? i| /(_ ord0)];
  by rewrite !mxE ?[i]ord1_eq0 /= !mulr1n.
Qed.

End ExtraOrder.

End Order.

Section LexOrder.

Variable R : realFieldType.

Section Core.

Variable n : nat.
Implicit Types x y u v : 'rV[R]_n.

Fixpoint leqlex_seq x y l :=
  match l with
  | [::] => true
  | i :: l' =>
    if x 0 i < y 0 i then true
    else if x 0 i == y 0 i then leqlex_seq x y l'
         else false
  end.

Definition leqlex x y := leqlex_seq x y (enum 'I_n).
Definition ltrlex x y := (x != y) && (leqlex x y).
Definition geqlex x y := leqlex y x.

Notation "<=lex" := leqlex: ring_scope.
Notation ">=lex" := geqlex: ring_scope.

Notation "<=lex x" := (geqlex x) (at level 0): ring_scope.
Notation ">=lex x" := (leqlex x) (at level 0): ring_scope.

Notation "x <=lex y" := (leqlex x y) (at level 0): ring_scope.
Notation "x >=lex y" := (y <=lex x) (only parsing, at level 0) : ring_scope.

Notation "x <lex y" := (ltrlex x y) (at level 0): ring_scope.
Notation "x >lex y" := (y <lex x) (only parsing, at level 0) : ring_scope.

Lemma order_preserving_equiv x y u v :
  (forall i, ((x 0 i < y 0 i) = (u 0 i < v 0 i)) /\ (x 0 i == y 0 i) = (u 0 i == v 0 i)) -> (x <=lex y) = (u <=lex v).
Proof.
move => H.
suff /(_ (enum 'I_n)): forall s, (leqlex_seq x y s = leqlex_seq u v s) by done.
move => s.
elim: s => [| i s' IH]; first by done.
- rewrite /= IH.
  by move/(_ i): H => [-> ->].
Qed.

Lemma lex_add2l x :
  {mono +%R x : y z / y <=lex z}.
Proof.
move => y z; symmetry.
apply: order_preserving_equiv => i.
move/(_ (y 0 i) (z 0 i)): (leW_mono (ler_add2l (x 0 i))) <-.
rewrite !mxE; split; first done.
symmetry; apply/inj_eq; exact: GRing.addrI.
Qed.

Lemma lex_add2r x :
  {mono +%R^~ x : y z / y <=lex z}.
Proof.
move => y z; symmetry.
apply: order_preserving_equiv => i.
move/(_ (y 0 i) (z 0 i)): (leW_mono (ler_add2r (x 0 i))) <-.
rewrite !mxE; split; first done.
symmetry; apply/(inj_eq (GRing.addIr _)).
Qed.

Lemma lex_pscalar (a : R) :
  0 < a -> {mono *:%R a : x y / x <=lex y }.
Proof.
move => Ha y z; symmetry.
apply: order_preserving_equiv => i.
rewrite !mxE.
move/(_ (y 0 i) (z 0 i)): (leW_mono (ler_pmul2l Ha)) <-.
split; first done.
symmetry; apply/inj_eq; apply/mulfI; exact: lt0r_neq0.
Qed.

Lemma subv_gelex0 x y :
  (0 <=lex (y - x)) = (x <=lex y).
Proof.
by move/(_ x y): (lex_add2r (-x)); rewrite addrN.
Qed.

Lemma lex_refl x :
  (x <=lex x).
Proof.
suff /(_ (enum 'I_n)): forall s, (leqlex_seq x x s) by done.
move => s.
elim: s => [| i s' IH]; first by done.
by rewrite /= IH ltxx eq_refl.
Qed.

Lemma oppv_gelex0 x :
  (0 <=lex -x) = (x <=lex 0).
Proof.
by move/(_ x 0): (lex_add2l (-x)); rewrite addNr addr0.
Qed.

Lemma scalar_neg_mul_lex_pos  a x :
  a < 0 -> (0 <=lex x) = ((a *: x) <=lex 0).
Proof.
move => Ha.
rewrite -oppr_gt0 in Ha.
by rewrite -(lex_pscalar Ha 0 x) scaler0 scaleNr oppv_gelex0.
Qed.

Lemma lex_antisym :
  antisymmetric (<=lex).
Proof.
move => x y H.
suff: forall s, (leqlex_seq x y s && leqlex_seq y x s)
                -> (forall i, i \in s -> x 0 i = y 0 i).
- move/(_ (enum 'I_n) H) => H'.
  apply/rowP => i.
  apply: (H' i); last by apply: mem_enum.
- move => s.
  elim: s => [ _ ? | i s' IH]; first by rewrite in_nil.
  rewrite /=.
  case: (ltrgtP (x 0 i) (y 0 i)); try by [rewrite andbF | rewrite andFb].
  + move => Hxyi; move/IH => IH' j.
    rewrite in_cons; move/orP; case.
    * by move/eqP ->.
    * apply: IH'.
Qed.

Lemma lex_trans :
  transitive (<=lex).
Proof.
move => y x z Hxy Hyz.
suff: forall s, leqlex_seq x y s -> leqlex_seq y z s
                -> leqlex_seq x z s
  by move/(_ (enum 'I_n))/(_ Hxy Hyz).
move => s.
elim: s => [ | i s' IH]; first by done.
rewrite /=.
case: (ltrgtP (x 0 i) (y 0 i)) (ltrgtP (y 0 i) (z 0 i))
  => [H [H' | H' | H'] | H [H' | H' | H'] | H [H' | H' | H']]; try by done.
- by move: (lt_trans H H') ->.
- by rewrite -H' ifT //.
- by rewrite H ifT //.
- by rewrite -H' H eq_refl ltxx; apply: IH.
Qed.

Lemma lex0_total :
  forall x, (0 <=lex x) || (x <=lex 0).
Proof.
move => x.
suff: forall s, (leqlex_seq 0 x s) || (leqlex_seq x 0 s)
  by move/(_ (enum 'I_n)).
move => s.
elim: s => [ | i s' IH /=]; first by done.
by rewrite mxE; case: (sgrP (x 0 i)).
Qed.

Lemma lex_total :
  total (<=lex).
Proof.
move => x y.
suff: (0 <=lex (y - x)) || ((y - x) <=lex 0)
  by rewrite subv_gelex0 -[X in _ || X](lex_add2r x) -addrA addNr add0r addr0.
by apply: lex0_total.
Qed.

Lemma lex_ltrW x y :
  (x <lex y) -> (x <=lex y).
Proof.
by move/andP => [_].
Qed.

Lemma lex_nnscalar a x y :
  0 <= a -> x <=lex y -> (a *: x) <=lex (a *: y).
Proof.
move => Ha Hxy.
case: (ltrgt0P a).
- by move/lex_pscalar ->.
- by move/(le_lt_trans Ha); rewrite ltxx.
- by move ->; rewrite !scale0r; apply: lex_refl.
Qed.

Lemma lex0_nnscalar a x :
  0 <= a -> 0 <=lex x -> 0 <=lex (a *: x).
Proof.
move => a_nn x_nn.
suff: (a *: 0) <=lex (a *: x).
- by rewrite linear0.
- exact: lex_nnscalar.
Qed.

Lemma lex_scalar_le0 a x :
  a <= 0 -> x <=lex 0 -> 0 <=lex (a *: x).
Proof.
move => a_np x_np.
suff: 0 <=lex ((-a) *: (-x)).
- by rewrite scaleNr linearN /= opprK.
- apply: lex0_nnscalar.
  + by rewrite oppr_ge0.
  + by rewrite oppv_gelex0.
Qed.

Lemma lex_negscalar a x y :
  a < 0 -> (x <=lex y) = ((a *: y) <=lex (a *: x)).
Proof.
move => Ha.
by rewrite -subv_gelex0 (scalar_neg_mul_lex_pos (y-x) Ha) scalerBr -oppv_gelex0 opprB subv_gelex0.
Qed.

Lemma lex_add x y z t :
  x <=lex y -> z <=lex t -> (x + z) <=lex (y + t).
Proof.
move => Hxy Hzt.
apply: (@lex_trans (x + t)).
- by rewrite lex_add2l.
- by rewrite lex_add2r.
Qed.

Lemma lex_subr_addr x y z :
  (x <=lex (y + z)) = ((x - y) <=lex z).
Proof.
apply/idP/idP.
- move => H.
  move: (lex_refl (-y)) => H'.
  move: (lex_add H H').
  by rewrite -addrA [z - y]addrC addrA addrN add0r.
- move => H.
  move: (lex_refl y) => H'.
  move: (lex_add H H').
  by rewrite -addrA addNr addr0 addrC.
Qed.

Lemma lex_subr_le0 x y :
  ((y - x) <=lex 0) = (y <=lex x).
Proof.
rewrite -lex_subr_addr.
by rewrite addr0.
Qed.

Lemma lex_ltrNge x y :
  (x <lex y) = ~~(y <=lex x).
Proof.
rewrite /ltrlex -[X in X = _]negbK negb_and.
apply/(congr1 negb); rewrite negbK.
case: (boolP (x <=lex y)).
- rewrite /= orbF => H.
  apply/idP/idP; first by move/eqP ->; apply: lex_refl.
  move => H'; move/andP/lex_antisym: (conj H H') ->; by apply: eq_refl.
- rewrite /= orbT.
  by move/orP: (lex_total x y); case; try by move ->.
Qed.

Lemma lex_nmulr_rlt0 a x :
  a < 0 -> ((a *: x) <lex (0) ) = ((0) <lex x).
Proof.
move => a_is_neg.
rewrite 2!lex_ltrNge.
by apply/idP/idP; apply: contra; rewrite (lex_negscalar x 0 a_is_neg) scaler0.
Qed.

Lemma lex_gtr_addl x y :
  ((x + y) <lex x) = (y <lex 0).
Proof.
rewrite 2!lex_ltrNge; apply: congr1.
by rewrite lex_subr_addr addrN.
Qed.

Lemma lex_ltr_addl x y :
  x <lex (x + y) = 0 <lex y.
Proof.
rewrite lex_ltrNge -[y]opprK -lex_subr_addr -lex_ltrNge addrC lex_gtr_addl.
by rewrite !lex_ltrNge oppv_gelex0 opprK.
Qed.

Lemma lex_le_ltr_trans x y z :
  (x <=lex y) -> (y <lex z) -> (x <lex z).
Proof.
move => Hxy Hyz.
apply/andP; split; last by exact: (lex_trans Hxy (lex_ltrW Hyz)).
apply: contraT; rewrite negbK; move/eqP => Hxz.
by move: Hyz; rewrite -Hxz lex_ltrNge Hxy.
Qed.

Lemma lex_ltr_le_trans x y z :
  (x <lex y) -> (y <=lex z) -> (x <lex z).
Proof.
move => Hxy Hyz.
apply/andP; split; last by exact: (lex_trans (lex_ltrW Hxy) Hyz).
apply: contraT; rewrite negbK; move/eqP => Hxz.
by move: Hxy; rewrite Hxz lex_ltrNge Hyz.
Qed.

Definition lex_min x y := if x <=lex y then x else y.

Lemma lex_minC x y :
  (lex_min x y) = (lex_min y x).
Proof.
rewrite /lex_min.
case: (boolP (x <=lex y)).
- case: ifP; last by done.
  by move => H H'; move/andP/lex_antisym: (conj H H') ->.
- by rewrite -lex_ltrNge; move/lex_ltrW => ?; rewrite ifT //.
Qed.

Lemma lex_ler_minl x y z :
  ((lex_min y z) <=lex x) = ((y <=lex x) || (z <=lex x)).
Proof.
rewrite /lex_min.
apply/idP/idP.
- case: ifP => [_ | _].
  + by move => ?; apply/orP; left.
  + by move => ?; apply/orP; right.
- move => H; case: ifP => [H' | H'].
  + move/orP: H; case; first by done.
    * by move/(lex_trans H').
  + move/negbT: H'; rewrite -lex_ltrNge; move/lex_ltrW.
    move/orP: H; case; last by done.
    * by move => H H'; apply: (lex_trans H' H).
Qed.

Lemma lex_min_l x y :
  x <=lex y -> lex_min x y = x.
Proof.
by apply: ifT.
Qed.

Lemma lex_min_r x y :
  y <=lex x -> lex_min x y = y.
Proof.
rewrite lex_minC; apply: lex_min_l.
Qed.

Fixpoint lex_min_seq S :=
  match S with
  | [::] => 0
  | [:: x] => x
  | x :: S' => lex_min x (lex_min_seq S')
  end.

Lemma lex_min_seq_ler S :
  forall i, i \in S -> (lex_min_seq S) <=lex i.
Proof.
elim: S => [ | x S' IH].
- by move => i; rewrite in_nil.
- move => i. rewrite in_cons. move/orP => [/eqP -> | H].
  + rewrite /=.
    case H': S'; first by apply: lex_refl.
    * rewrite lex_ler_minl; apply/orP; left; by apply: lex_refl.
  + rewrite /=; move: H.
    case H': S'; first by rewrite in_nil.
    * by rewrite -H'; move => Hi; rewrite lex_ler_minl; apply/orP; right; apply: IH.
Qed.

Lemma lex_min_seq_eq S :
  S != [::] -> has [pred i | lex_min_seq S == i] S.
Proof.
elim: S => [ | x S']; first by done.
- case: (altP (S' =P [::])) => [-> /= | HS /(_ is_true_true) IH _]; first by rewrite eq_refl.
  + apply/hasP.
    case: (boolP (x <=lex (lex_min_seq S'))) => [ H'' | ]. (* TODO: error if the space | ] is removed *)
    * exists x; first by rewrite mem_head.
      by rewrite /= lex_min_l //; case H: S'.
    * rewrite -lex_ltrNge => H''.
      move/hasP: IH => [i Hi /= /eqP Hi'].
      exists i; first by rewrite mem_behead.
      case H: S'; first by move: Hi; rewrite H in_nil.
      rewrite lex_min_r -H Hi' //.
      by rewrite -Hi'; apply: lex_ltrW.
Qed.

End Core.

Notation "<=m" := lev: ring_scope.
Notation ">=m x" := (lev x) (at level 0): ring_scope.
Notation "<=m x" := (lev^~ x) (at level 0): ring_scope.
Notation "x <=m y" := (lev x y) (at level 0): ring_scope.
Notation "x >=m y" := (y <=m x) (only parsing, at level 0) : ring_scope.

Notation "<=lex" := leqlex: ring_scope.
Notation ">=lex" := geqlex: ring_scope.

Notation "<=lex x" := (geqlex x) (at level 0): ring_scope.
Notation ">=lex x" := (leqlex x) (at level 0): ring_scope.

Notation "x <=lex y" := (leqlex x y) (at level 0): ring_scope.
Notation "x >=lex y" := (y <=lex x) (only parsing, at level 0) : ring_scope.

Notation "x <lex y" := (ltrlex x y) (at level 0): ring_scope.
Notation "x >lex y" := (y <lex x) (only parsing, at level 0) : ring_scope.

Section ExtraLexOrder.

Variable n : nat.
Implicit Types u v : 'rV[R]_n.

Lemma lex_ord0 (u v : 'rV[R]_(1+n)) :
  (u <=lex v) -> u 0 0 <= v 0 0.
Proof.
rewrite /leqlex.
case: {2}(enum _) (erefl (enum 'I_(1+n))) => [| x0 ? Henum];
  first by move/(congr1 size); rewrite size_enum_ord {1}add1n.
have <-: x0 = 0.
- apply/ord_inj.
  move/(congr1 (head 0))/(congr1 (@nat_of_ord _)): Henum.
  by rewrite -2!nth0 nth_enum_ord //.
rewrite Henum /=; case: ifP => [|_]; first by move/ltW.
- case: ifP => [|_]; last by done.
  + by move/eqP ->; rewrite lexx.
Qed.

Lemma leqlex_seq_cons S1 S2 u v :
  (leqlex_seq u v S1) && (leqlex_seq u v S2) -> leqlex_seq u v (S1 ++ S2).
Proof.
elim: S1 => [| i S1' IH]; first by rewrite /=.
rewrite /=.
case: ifP => [| Hi]; first by done.
case: ifP; done.
Qed.

Lemma leqlex_seq_lev S u v :
  [forall i in S, u 0 i <= v 0 i] -> leqlex_seq u v S.
Proof.
elim: S => [| i S' IH H]; first by done.
rewrite /=; case: ifP => [| /negbT Hi]; first by done.
rewrite -leNgt in Hi.
move/forallP/(_ i)/implyP/(_ (mem_head _ _)): (H) => Hi'.
move/andP: (conj Hi' Hi); rewrite lte_anti; move ->.
apply: IH.
apply/forallP => j; apply/implyP => Hj.
by move/forallP/(_ j): H; rewrite in_cons Hj orbT.
Qed.

Lemma leqlex_seq_head i S u v :
  (u 0 i < v 0 i) -> leqlex_seq u v (i :: S).
Proof.
by move => Hi; rewrite /=; rewrite ifT //.
Qed.

Lemma leqlex_seq_cons_head i S1 S2 u v :
  [forall j in S1, u 0 j <= v 0 j] && (u 0 i < v 0 i) ->
    leqlex_seq u v (S1 ++ (i :: S2)).
Proof.
move/andP => [/leqlex_seq_lev H /(leqlex_seq_head S2) H'].
by apply: leqlex_seq_cons; apply/andP; split.
Qed.

Lemma enum_ord_split i0 :
  enum 'I_n = (filter (fun j => (nat_of_ord j < nat_of_ord i0)%N) (enum 'I_n)) ++ (i0:: filter (fun j => (nat_of_ord i0 < nat_of_ord j < n)%N) (enum 'I_n)).
Proof.
apply: (inj_map (@ord_inj _)).
rewrite !val_enum_ord map_cat map_cons.
have ->: filter (fun j => (nat_of_ord i0 < nat_of_ord j < n)%N) (enum 'I_n) =
filter (preim (@nat_of_ord n) (fun j => (nat_of_ord i0 < j < n)%N)) (enum 'I_n)
  by apply: eq_filter => j; rewrite /=.
have ->: filter (fun j => (nat_of_ord j < nat_of_ord i0)%N) (enum 'I_n) =
filter (preim (@nat_of_ord n) (fun j => (j < nat_of_ord i0)%N)) (enum 'I_n)
  by apply: eq_filter => j; rewrite /=.
rewrite -2!filter_map !val_enum_ord.
have Hi0 : (nat_of_ord i0 < n)%N by apply: ltn_ord.
have ->: [seq j <- iota 0 n | (j < i0)%N] = iota 0 i0.
- have /eq_filter -> : (fun j => (j < i0)%N) =1 (fun j => j \in iota 0 i0).
  + by move => j; rewrite mem_iota leq0n /= add0n.
  symmetry; apply/(subseq_uniqP (iota_uniq _ _)).
  rewrite -{2}[n](subnKC (ltnW Hi0)).
  by rewrite iotaD add0n; apply: prefix_subseq.
have ->: [seq j <- iota 0 n | (i0 < j < n )%N] = iota (i0.+1) (n - (i0.+1)).
- have /eq_filter -> : (fun j => (i0 < j < n)%N) =1 (fun j => j \in iota (i0.+1) (n - (i0.+1))).
  + by move => j; rewrite mem_iota subnKC //.
  symmetry; apply/(subseq_uniqP (iota_uniq _ _)).
  rewrite -{4}[n](subnKC Hi0).
  by rewrite iotaD add0n; apply: suffix_subseq.
rewrite -{1}[n](subnKC (ltnW Hi0)) iotaD add0n.
apply/(congr1 (fun s => _ ++ s)).
suff ->: (n - i0 = 1 + (n - i0.+1))%N
  by rewrite iotaD addn1 /=.
- by rewrite -subn_gt0 in Hi0; rewrite add1n subnS prednK.
Qed.

Lemma lex_lev_strict u v i :
  [forall (j | (nat_of_ord j < nat_of_ord i)%N), u 0 j <= v 0 j] && (u 0 i < v 0 i) -> (u <lex v).
Proof.
move/andP => [H H'].
rewrite /ltrlex; apply/andP; split.
- move: H'. apply: contraL.
  by move/eqP/rowP/(_ i) ->; rewrite ltxx.
- rewrite /leqlex (enum_ord_split i).
  apply: leqlex_seq_cons_head; apply/andP; split; last by done.
  apply/forallP => j; apply/implyP; rewrite mem_filter => /andP [Hj _].
  by move/forallP/(_ j)/implyP/(_ Hj): H.
Qed.

Lemma lex_lev u v :
  (forall j, u 0 j <= v 0 j) -> (u <=lex v).
Proof.
move => u_lev_v.
by apply: leqlex_seq_lev; apply/forall_inP.
Qed.

Lemma sum_lex {p : nat} (v w : 'I_p -> 'rV[R]_n) (P : pred 'I_p):
  (forall i, P i -> (v i) <=lex (w i)) -> (\sum_(i | P i) v i) <=lex \sum_(i | P i) w i.
Proof.
move=> ?; rewrite (@big_ind2 _ _ (leqlex (n:=n))) ?lex_refl //.
exact/lex_add.
Qed.

Lemma lev_mul_lex {p: nat} (v : 'rV[R]_p) (M N : 'M[R]_(p,n)):
  0 <=m (v^T) -> (forall i, (row i M) <=lex (row i N)) -> (v *m M) <=lex (v *m N).
Proof.
move/gev0P=> v_ge0 le_MN.
rewrite !mulmx_sum_row; apply/sum_lex=> i _.
apply/lex_nnscalar; rewrite ?le_MN //.
by move: (v_ge0 i); rewrite mxE.
Qed.

Lemma ltlex_seqP (x y : 'rV_n) l i: i \in l -> x 0 i != y 0 i -> leqlex_seq x y l ->
  (exists i l1 l2, [/\ l = l1 ++ i :: l2, (forall j, j \in l1 -> x 0 j = y 0 j) & x 0 i < y 0 i]).
Proof.
elim: l=> //= h t ih i_ht xy_n_i; case: ltrgtP=> //; first by (move=> ? _; exists h; exists [::]; exists t).
move=> xy_h_eq leqlex_xy.
have i_t: (i \in t).
- move: i_ht; rewrite in_cons; case/orP=> // /eqP contr.
  by move: xy_h_eq xy_n_i; rewrite contr=> ->; rewrite eqxx.
case: (ih i_t xy_n_i leqlex_xy)=> i' [l1] [l2] [-> j_lt_i' xy_lt_i'].
exists i'; exists (h :: l1); exists l2; split=> //.
by move=> j; rewrite in_cons; case/orP=> [/eqP ->|/j_lt_i' ->].
Qed.

Lemma lex_lev_strictP (u v : 'rV_n): reflect
  (exists i, (forall j, (nat_of_ord j < nat_of_ord i)%N -> u 0 j = v 0 j) /\ u 0 i < v 0 i)
  (u <lex v).
Proof.
apply/(iffP idP).
- rewrite /ltrlex /leqlex; case/andP=> xy_n leqlex_xy.
  have [i [i_In uv_n_i]]: exists i, (i \in enum 'I_n) /\ (u 0 i != v 0 i).
  + move: xy_n; rewrite -subr_eq0; case/rV0Pn=> i.
    rewrite !mxE subr_eq0=> ?; exists i; split=> //.
    by rewrite mem_enum.
  case: (ltlex_seqP i_In uv_n_i leqlex_xy)=> j [l1] [l2] [In_eq j_lt_eq uv_lt_j].
  exists j; split=> //.
  move=> k kj_lt; apply/j_lt_eq.
  move/eqP: In_eq; rewrite (enum_ord_split j) eqseq_pivotl ?mem_filter ?ltnn //.
  by case/andP=> /eqP <- _; rewrite mem_filter kj_lt mem_enum.
- case=> i [eq_le_i lt_i]; apply/(lex_lev_strict (i:=i)); rewrite lt_i andbT.
  by apply/forallP=> j; apply/implyP=> j_lt_i; rewrite (eq_le_i j j_lt_i) lexx.
Qed.

Lemma lex_eqOlt (u v : 'rV[R]_n) : (u <=lex v) = (u == v) || (u <lex v).
Proof. by rewrite /ltrlex; case/boolP: (u == v)=> //= /eqP ->; rewrite lex_refl. Qed.

Lemma lex_ltr_addlt (a b c d : 'rV[R]_n): a <=lex b -> c <lex d ->
  (a + c) <lex (b + d).
Proof.
rewrite lex_eqOlt; case/orP.
- move/eqP=> -> /andP [+ cd_lex]; rewrite /ltrlex (lex_add2l b) cd_lex andbT.
  apply/contra_neq=> ?; exact/(addrI b).
- case/lex_lev_strictP=> i_ab [j_ab_eq i_ab_lt] /lex_lev_strictP [i_cd] [j_cd_eq i_cd_lt].
  have min_abcd: (minn i_ab i_cd < n)%N by apply/(leq_ltn_trans (n:=i_ab))=> //; exact/geq_minl.
  apply/lex_lev_strictP; exists (Ordinal min_abcd); split.
  + by move=> /= j; rewrite ltn_min=> /andP [??]; rewrite !mxE j_ab_eq ?j_cd_eq.
  + rewrite !mxE.
    have [h_eq | min_ab | min_cd]: [\/ i_ab = i_cd, (i_ab < i_cd)%N | (i_ab > i_cd)%N] by
      case: ltngtP=> ?; [exact/Or32 | exact/Or33 | exact/Or31/val_inj].
    * have ->: (Ordinal min_abcd = i_ab) by apply/val_inj; rewrite /= h_eq minnn.
      by apply/ltr_add=> //; rewrite h_eq.
    * have ->: (Ordinal min_abcd = i_ab) by exact/val_inj/minn_idPl/ltnW.
      by rewrite j_cd_eq //; apply/ltr_le_add.
    * have ->: (Ordinal min_abcd = i_cd) by exact/val_inj/minn_idPr/ltnW.
      by rewrite j_ab_eq //; apply/ler_lt_add.
Qed.

Lemma ltrlex_sum {p : nat} (A B : 'I_p -> 'rV[R]_n):
  (forall i, (A i) <=lex (B i)) -> (exists j, (A j) <lex (B j)) ->
  (\sum_i A i) <lex (\sum_i B i).
Proof.
move=> AB_lex [j ABj_ltr].
rewrite !(bigD1_seq j) ?index_enum_uniq ?mem_index_enum //=.
rewrite addrC [X in _ <lex X]addrC; apply/lex_ltr_addlt=> //.
apply/sum_lex=> i _; exact/AB_lex.
Qed.

Section IndLexOrder.

Fixpoint ind_lexleq (a b : seq R) :=
  match a, b with
  |[::], [::]=> true
  |ha::ta, hb::tb=> if ha < hb then true else
                    if ha == hb then ind_lexleq ta tb else false
  |_, _=> false
  end.

Lemma lex_foo (v w : 'rV[R]_n):
  v <=lex w =
  ind_lexleq [seq (v 0 i) | i <- (enum 'I_n)] [seq (w 0 i) | i <- (enum 'I_n)].
Proof.
rewrite /leqlex.
elim: (enum 'I_n)=> //= h t ->.
by case: ifP=> //.
Qed.

End IndLexOrder.

End ExtraLexOrder.

End LexOrder.

Notation "<=m" := lev: ring_scope.
Notation ">=m x" := (lev x) (at level 0): ring_scope.
Notation "<=m x" := (lev^~ x) (at level 0): ring_scope.
Notation "x <=m y" := (lev x y) (at level 0): ring_scope.
Notation "x >=m y" := (y <=m x) (only parsing, at level 0) : ring_scope.

Notation "<=lex" := leqlex: ring_scope.
Notation ">=lex" := geqlex: ring_scope.

Notation "<=lex x" := (geqlex x) (at level 0): ring_scope.
Notation ">=lex x" := (leqlex x) (at level 0): ring_scope.

Notation "x <=lex y" := (leqlex x y) (at level 0): ring_scope.
Notation "x >=lex y" := (y <=lex x) (only parsing, at level 0) : ring_scope.

Notation "x <lex y" := (ltrlex x y) (at level 0): ring_scope.
Notation "x >lex y" := (y <lex x) (only parsing, at level 0) : ring_scope.