Require Import VST.floyd.proofauto.
Require Import Coq.Classes.Equivalence.
Require Import CertiGraph.lib.List_ext.

Section FindLemmas.

Context {size : Z}.
Context {inf: Z}.
Context {Z_EqDec : EquivDec.EqDec Z eq}.

(* Find and lemmas about it *)

Fixpoint find {A: Type} {EA: EquivDec.EqDec A eq} (l : list A) (n : A) (ans : Z) :=
  match l with
  | [] => ans
  | h :: t => if EA h n
              then ans
              else (find t n (1 + ans))
  end.

Lemma find_index_gen: forall (l: list Z) i ans,
    0 <= i < Zlength l ->
    ~ In (Znth i l) (sublist 0 i l) ->
    find l (Znth i l) ans = i + ans.
Proof.
  intros. generalize dependent i.
  generalize dependent ans. induction l.
  1: intros; rewrite Zlength_nil in H; exfalso; lia.
  unfold find.
  intros.
  destruct (Z_EqDec a (Znth i (a :: l))).
  - rewrite <- e in H0. clear - H H0.
    destruct (Z.eq_dec 0 i). 1: lia.
    destruct H. assert (0 < i) by lia.
    exfalso. apply H0.
    unfold sublist. replace (i-0) with i by lia. simpl.
    replace (Z.to_nat i) with (Z.to_nat (Z.succ (i-1))) by rep_lia.
    rewrite Z2Nat.inj_succ by lia.
    rewrite firstn_cons. simpl; left; trivial.
  - destruct (Z.eq_dec 0 i).
    1: rewrite <- e in c; rewrite Znth_0_cons in c;
      exfalso.
    apply c. reflexivity.
    assert (0 <= i - 1 < Zlength l) by
        (rewrite Zlength_cons in H; rep_lia).
    assert (~ In (Znth (i - 1) l) (sublist 0 (i - 1) l)). {
      rewrite <- (Znth_pos_cons i l a) by lia.
      rewrite <- (sublist_1_cons l a i).
      intro. apply H0.
      apply (sublist_In 1 i).
      rewrite sublist_sublist0 by lia. assumption.
    }
    pose proof (IHl (1 + ans) (i - 1) H1 H2).
    replace (i - 1 + (1 + ans)) with (i + ans) in H3 by lia.
    replace (Znth i (a :: l)) with (Znth (i - 1) l).
    2: { symmetry. apply Znth_pos_cons; lia. }
    rewrite <- H3.
    unfold find. trivial.
Qed.

Lemma find_index: forall (l: list Z) i,
    0 <= i < Zlength l ->
    ~ In (Znth i l) (sublist 0 i l) ->
    find l (Znth i l) 0 = i.
Proof.
  intros. replace i with (i + 0) at 2 by lia.
  apply find_index_gen; trivial.
Qed.

Lemma find_range_gen: forall (l: list Z) target ans,
    In target l ->
    0 <= ans ->
    ans <= find l target ans < Zlength l + ans.
Proof.
  intros. generalize dependent target.
  generalize dependent ans.
  induction l.
  1: intros; simpl; now rewrite Zlength_nil.
  intros. apply in_inv in H. destruct H.
  - subst a. unfold find.
    destruct (Z_EqDec target target).
    rewrite Zlength_cons. split; rep_lia.
    exfalso. apply c. reflexivity.
  - unfold find. destruct (Z_EqDec a target).
    1: rewrite Zlength_cons; split; rep_lia.
    assert (0 <= 1 + ans) by lia.
    pose proof (IHl (1+ans) H1 target H).
    clear -H2. unfold find in H2.
    rewrite Zlength_cons. rep_lia.
Qed.

Lemma find_range: forall l target,
    In target l ->
    0 <= find l target 0 < Zlength l.
Proof.
  intros. replace (Zlength l) with (Zlength l + 0) by lia.
  apply find_range_gen; trivial; lia.
Qed.

Lemma Znth_find_gen:
  forall (l: list Z) target ans,
    0 <= ans ->
    In target l ->
    Znth ((find l target ans)-ans) l = target.
Proof.
  intros. generalize dependent ans.
  induction l. 1: inversion H0.
  intros.
  destruct H0.
  - subst target. simpl.
    destruct (Z_EqDec a a).
    + replace (ans-ans) with 0 by lia.
      rewrite Znth_0_cons; auto.
    + exfalso; apply c; reflexivity.
  - specialize (IHl H0).
    simpl.
    destruct (Z_EqDec a target).
    + replace (ans-ans) with 0 by lia.
      rewrite Znth_0_cons; auto.
    + assert (0 <= 1 + ans) by lia.
      specialize (IHl (1+ans) H1).
      rewrite Znth_pos_cons.
      replace (1+ans) with (ans+1) in IHl at 2 by lia.
      rewrite Z.sub_add_distr in IHl.
      assumption.
      destruct (find_range_gen l target (1+ans) H0 H1) as [? _].
      lia.
Qed.

Lemma Znth_find:
  forall (l: list Z) target,
    In target l ->
    Znth (find l target 0) l = target.
Proof.
  intros.
  replace (find l target 0) with (find l target 0 - 0) by lia.
  apply Znth_find_gen; [lia | assumption].
Qed.

Lemma Forall_fold_min:
  forall (f: Z -> Prop) (x: Z) (al: list Z),
    f x -> Forall f al -> f (fold_right Z.min x al).
Proof.
  intros. induction H0.
  simpl. auto. simpl. unfold Z.min at 1.
  destruct (Z.compare x0 (fold_right Z.min x l)) eqn:?; auto.
Qed.

Lemma fold_min_another:
  forall x al y,
    fold_right Z.min x (al ++ [y]) = Z.min (fold_right Z.min x al) y.
Proof.
  intros. revert x; induction al; simpl; intros.
  apply Z.min_comm. rewrite <- Z.min_assoc. f_equal. apply IHal.
Qed.

Theorem fold_min_general:
  forall (al: list Z)(i: Z),
    In i (al) ->
    forall x, List.fold_right Z.min x al <= i.
Proof.
  induction al; intros. 1: inversion H.
  destruct H.
  1: subst a; simpl; apply Z.le_min_l.
  simpl. rewrite Z.le_min_r. apply IHal, H.
  Qed.

Theorem fold_min:
  forall (al: list Z)(i: Z),
    In i (al) ->
    List.fold_right Z.min (hd 0 al) al <= i.
Proof. intros. apply fold_min_general, H. Qed.

Lemma min_not_in_prev i l :
  Znth i l < fold_right Z.min (Znth 0 l) (sublist 0 i l) ->
  ~ In (Znth i l) (sublist 0 i l).
Proof.
  intros. intro.
  pose proof (fold_min_general (sublist 0 i l) (Znth i l) H0(Znth 0 l)). lia.
Qed.

Lemma min_in_list : forall l1 l2 starter,
    incl l1 l2 ->
    In starter l2 ->
    In (fold_right Z.min starter l1) l2.
Proof.
  intros. induction l1; trivial. simpl.
  destruct (Z.min_dec a (fold_right Z.min starter l1));
    rewrite e; clear e.
  apply H, in_eq.
  apply IHl1, (incl_cons_inv H).
Qed.

Lemma Znth_0_hd:
  forall list, Zlength list > 0 -> Znth 0 list = hd 0 list.
Proof.
  intros. induction list; inversion H.
  rewrite Znth_0_cons. trivial.
Qed.

Lemma min_picks_first:
  forall num mono start,
    start <= mono ->
    fold_right Z.min start (list_repeat num mono) = start.
Proof.
  intros. induction num; trivial.
  simpl. rewrite IHnum. rewrite Z.min_r; lia.
Qed.

Lemma find_src: forall src,
    0 < inf ->
    0 <= src < size ->
    find (upd_Znth src (list_repeat (Z.to_nat size) inf) 0)
         (fold_right Z.min (hd 0 (upd_Znth src (list_repeat (Z.to_nat size) inf) 0))
                     (upd_Znth src (list_repeat (Z.to_nat size) inf) 0)) 0 = src.
Proof.
  intros.
  assert (Ha: 0 <= src < Zlength (list_repeat (Z.to_nat size) inf)). {
    rewrite Zlength_list_repeat; lia.
  }

  remember (upd_Znth src (list_repeat (Z.to_nat size) inf) 0) as l.
  replace (fold_right Z.min (hd 0 l) l) with (Znth src l).
  - apply find_index.
    1: rewrite Heql, upd_Znth_Zlength;
      rewrite Zlength_list_repeat; lia.
    rewrite Heql.
    rewrite upd_Znth_same; trivial.
    rewrite sublist_upd_Znth_l.
    2: lia.
    2: rewrite Zlength_list_repeat; lia.
    rewrite sublist_list_repeat by lia.
    replace (src - 0) with (src) by lia.
    intro. apply in_list_repeat in H1. lia.
  - subst l.
    rewrite upd_Znth_same; trivial.
    rewrite upd_Znth_unfold at 2; auto.
    repeat rewrite fold_right_app.
    repeat rewrite sublist_list_repeat; try lia.
    2: rewrite Zlength_list_repeat; lia.
    repeat rewrite Zlength_list_repeat by lia.
    replace (src - 0) with (src) by lia.
    rewrite <- Znth_0_hd.
    2: { rewrite upd_Znth_Zlength by assumption.
         rewrite Zlength_list_repeat; lia. }
    destruct (Z.eq_dec src 0).
    + rewrite e. rewrite upd_Znth_same.
      2: rewrite Zlength_list_repeat; lia.
      simpl. rewrite Z.min_l; trivial.
      rewrite min_picks_first; lia.
    + rewrite upd_Znth_diff;
        try rewrite Zlength_list_repeat; try lia.
      rewrite Znth_list_repeat_inrange by lia.
      simpl. rewrite Z.min_l.
      1,2: rewrite min_picks_first.
      all: try lia; compute; inversion 1.
Qed.

Lemma fold_min_in_list: forall l, Zlength l > 0 -> In (fold_right Z.min (hd 0 l) l) l.
Proof.
  intros. apply min_in_list.
  - apply incl_refl.
  - rewrite <- Znth_0_hd by trivial. apply Znth_In; lia.
Qed.

Lemma find_app_In1:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l1 l2: list A) v ans, In v l1 -> find (l1++l2) v ans = find l1 v ans.
Proof.
induction l1; intros. contradiction.
destruct (EA v a). hnf in e. subst a.
simpl.
destruct (EA v v). auto. unfold RelationClasses.complement, Equivalence.equiv in c; contradiction.
destruct H. symmetry in H; contradiction.
simpl. destruct (EA a v). symmetry in e; contradiction.
rewrite IHl1; auto.
Qed.

Lemma find_accum_add1:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v ans1 ans2, find l v (ans1+ans2) = ans1 + find l v ans2.
Proof.
induction l; intros.
simpl. auto.
simpl. destruct (EA a v). auto.
replace (1+(ans1+ans2)) with (ans1 + (1+ans2)) by lia. apply IHl.
Qed.

Lemma find_app_notIn1:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l1: list A) l2 v ans, ~ In v l1 -> find (l1++l2) v ans = Zlength l1 + find l2 v ans.
Proof.
induction l1; intros. rewrite app_nil_l, Zlength_nil. lia.
assert (~ In v l1). unfold not; intros; apply H. right; auto.
simpl. destruct (EA a v). hnf in e; subst a. exfalso. apply H. left; auto.
rewrite Zlength_cons. rewrite IHl1; auto.
rewrite <- Z.add_1_r, <- Z.add_assoc. rewrite find_accum_add1. auto.
Qed.

Corollary find_notIn:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v ans, ~ In v l -> find l v ans = Zlength l + ans.
Proof.
intros. replace l with (l++nil). rewrite find_app_notIn1. simpl.
rewrite app_nil_r; auto.
auto. apply app_nil_r.
Qed.

Corollary find_notIn_0:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v, ~ In v l -> find l v 0 = Zlength l.
Proof. intros. rewrite find_notIn by auto. rewrite Z.add_0_r; auto. Qed.

Lemma find_In_ubound:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v ans, In v l -> find l v ans < Zlength l + ans.
Proof.
induction l; intros. contradiction.
rewrite Zlength_cons.
simpl. destruct (EA a v).
pose proof (Zlength_nonneg l); lia.
rewrite Z.add_succ_l. rewrite find_accum_add1, Z.add_1_l.
assert (find l v ans < Zlength l + ans). apply IHl. destruct H. contradiction. auto.
lia.
Qed.

Lemma find_ubound:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v ans, find l v ans <= Zlength l + ans.
Proof.
induction l; intros. rewrite Zlength_nil; simpl; lia.
rewrite Zlength_cons.
simpl. destruct (EA a v).
pose proof (Zlength_nonneg l); lia.
rewrite Z.add_succ_l. rewrite find_accum_add1, Z.add_1_l.
specialize IHl with v ans.
lia.
Qed.

Lemma find_cons:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v ans, find (v::l) v ans = ans.
Proof.
intros. simpl. destruct (EA v v). auto. unfold RelationClasses.complement, Equivalence.equiv in c; contradiction.
Qed.

Lemma find_lbound:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) v ans, ans <= find l v ans.
Proof.
induction l; intros. simpl. lia.
simpl. destruct (EA a v). lia.
rewrite find_accum_add1. specialize IHl with v ans; lia.
Qed.

Lemma find_app_le:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l1: list A) l2 v ans, find l1 v ans <= find (l1++l2) v ans.
Proof.
induction l1; intros.
rewrite app_nil_l. simpl. apply find_lbound.
simpl. destruct (EA a v). lia.
do 2 rewrite find_accum_add1. specialize IHl1 with l2 v ans. lia.
Qed.

Lemma find_eq:
forall {A:Type} {EA: EquivDec.EqDec A eq} (l: list A) x y acc, NoDup l -> In x l -> In y l -> find l x acc = find l y acc -> x = y.
Proof.
induction l; intros. contradiction.
destruct H0; destruct H1.
++
subst x; subst y. auto.
++
subst x. rewrite find_cons in H2.
simpl in H2. destruct (EA a y). hnf in e; subst y. trivial.
rewrite find_accum_add1 in H2. pose proof (find_lbound l y acc). lia.
++
subst y. rewrite find_cons in H2.
simpl in H2. destruct (EA a x). hnf in e; subst x. trivial.
rewrite find_accum_add1 in H2. pose proof (find_lbound l x acc). lia.
++
simpl in H2. destruct (EA a x). hnf in e; subst x. apply NoDup_cons_2 in H; contradiction.
destruct (EA a y). hnf in e; subst y. apply NoDup_cons_2 in H; contradiction.
do 2 rewrite find_accum_add1 in H2. apply (IHl x y acc).
apply NoDup_cons_1 in H; auto. auto. auto. lia.
Qed.

(***************FIND LEMMAS*******)

Context {E: Type}.
Context {E_EqDec: EquivDec.EqDec E eq}.

Lemma NoDup_incl_ordered_powerlist:
  forall (l: list E), NoDup l -> exists L,
  (forall l', (NoDup l' /\ incl l' l /\ (forall x y, In x l' -> In y l' -> (find l' x 0 <= find l' y 0 <-> find l x 0 <= find l y 0)))
  <-> In l' L).
Proof.
induction l; intros.
exists (nil::nil). intros; split; intros. destruct H0 as [? [? ?]]. destruct l'. left; auto.
assert (In e (e::l')). left; auto. apply H1 in H3; contradiction.
destruct H0. subst l'. split. apply NoDup_nil. split. unfold incl; intros; auto.
intros. simpl. lia.
contradiction.
(*inductive step*)
assert (~ In a l). apply NoDup_cons_2 in H; auto. apply NoDup_cons_1 in H.
destruct (IHl H) as [L ?]. clear IHl.
assert (forall l', In l' L -> ~ In a l').
intros. apply H1 in H2. destruct H2 as [? [? ?]]. unfold not; intros. apply H3 in H5. contradiction.
exists (L ++ map (fun l' => (a::l')) L).
intros; split; intros.
**
destruct H3 as [? [? ?]]. apply in_or_app.
destruct (in_dec E_EqDec a l').
****
right.
(*then l' must be of form (a::l'')*)
destruct l'. contradiction.
destruct (E_EqDec e a).
******
hnf in e0. subst e.
apply in_map. apply H1.
split. apply NoDup_cons_1 in H3; auto.
split. unfold incl; intros. assert (In a0 (a::l)). apply H4. right; auto.
destruct H7. subst a0. apply NoDup_cons_2 in H3. contradiction. auto.
intros.
assert (find (a :: l') x 0 <= find (a :: l') y 0 <-> find (a :: l) x 0 <= find (a :: l) y 0). apply H5.
right; auto. right; auto.
apply NoDup_cons_2 in H3.
simpl in H8.
destruct (E_EqDec a x). hnf in e. subst x. contradiction.
destruct (E_EqDec a y). hnf in e. subst y. contradiction.
replace 1 with (1+0) in H8 by lia. repeat rewrite find_accum_add1 in H8.
split; intros. lia. lia.
******
unfold complement, equiv in c.
assert (find (e :: l') e 0 <= find (e :: l') a 0 <-> find (a :: l) e 0 <= find (a :: l) a 0). apply H5.
left; auto. auto. simpl in H6.
destruct (E_EqDec e e). 2: { unfold complement, equiv in c0; contradiction. }
destruct (E_EqDec a a). 2: { unfold complement, equiv in c0; contradiction. }
clear e0 e1.
destruct (E_EqDec e a). hnf in e0; contradiction.
destruct (E_EqDec a e). hnf in e0; symmetry in e0; contradiction.
clear c0 c1.
assert (0 <= find l' a 1). { apply (Z.le_trans 0 1). lia. apply find_lbound. }
apply H6 in H7. assert (1 <= 0). { apply (Z.le_trans 1 (find l e 1)). apply find_lbound. auto. }
lia.
****
left. apply H1. split. auto. split. unfold incl; intros. assert (In a0 (a::l)). apply H4; auto.
destruct H7. subst a0. contradiction. auto.
intros. assert (find l' x 0 <= find l' y 0 <-> find (a :: l) x 0 <= find (a :: l) y 0). apply H5; auto.
simpl in H8. destruct (E_EqDec a x). hnf in e. subst x. contradiction.
destruct (E_EqDec a y). hnf in e. subst y. contradiction.
replace 1 with (1+0) in H8 by lia. do 2 rewrite find_accum_add1 in H8.
split; intros. apply H8 in H9. lia.
apply H8. lia.
**
apply in_app_or in H3. destruct H3.
****
apply H1 in H3. destruct H3 as [? [? ?]].
split. auto. split. unfold incl; intros. right. apply H4. auto.
intros.
assert (find l' x 0 <= find l' y 0 <-> find l x 0 <= find l y 0). apply H5; auto.
simpl.
destruct (E_EqDec a x). hnf in e; subst x. apply H4 in H6; contradiction.
destruct (E_EqDec a y). hnf in e; subst y. apply H4 in H7; contradiction.
replace 1 with (1+0) by lia. do 2 rewrite (find_accum_add1).
split; intros. apply H8 in H9. lia. lia.
****
apply list_in_map_inv in H3. destruct H3 as [lx [? ?]]. subst l'. rename lx into l'.
assert (~ In a l'). apply H2; auto. apply H1 in H4. destruct H4 as [? [? ?]].
split. apply NoDup_cons; auto.
split. unfold incl; intros. destruct H7. subst a0. left; auto.
right. apply H5. auto.
intros. destruct H7.
subst x. simpl. destruct (E_EqDec a a). 2: { unfold complement, equiv in c; contradiction. }
destruct (E_EqDec a y). lia. split; intros. apply (Z.le_trans 0 1). lia. apply find_lbound. apply (Z.le_trans 0 1). lia. apply find_lbound.
destruct H8. subst y. simpl.
destruct (E_EqDec a a). 2: { unfold complement, equiv in c; contradiction. }
destruct (E_EqDec a x). lia. split; intros.
assert (1 <= 0). apply (Z.le_trans 1 (find l' x 1)). apply find_lbound. lia. lia.
assert (1 <= 0). apply (Z.le_trans 1 (find l x 1)). apply find_lbound. lia. lia.
assert (find l' x 0 <= find l' y 0 <-> find l x 0 <= find l y 0). apply H6; auto. simpl.
destruct (E_EqDec a x). hnf in e; subst x; contradiction.
destruct (E_EqDec a y). hnf in e; subst y; contradiction.
replace 1 with (1+0) by lia. repeat rewrite find_accum_add1.
split; intros; lia.
Qed.

Lemma test2:
forall (l' l: list E), NoDup l -> NoDup l' -> incl l' l -> exists lsorted, Permutation lsorted l' /\
(forall a b, In a lsorted -> In b lsorted -> (find lsorted a 0 <= find lsorted b 0 <-> find l a 0 <= find l b 0)).
Proof.
induction l'; intros l Hl; intros.
exists nil. split. apply perm_nil. intros. contradiction.
assert (exists lsorted : list E,
         Permutation lsorted l' /\
         (forall a b : E, In a lsorted -> In b lsorted -> find lsorted a 0 <= find lsorted b 0 <-> find l a 0 <= find l b 0)).
apply IHl'. auto. apply NoDup_cons_1 in H; auto. unfold incl; intros. apply H0. right; auto. clear IHl'.
destruct H1 as [lsorted [? ?]].
assert (Ha: ~ In a lsorted). unfold not; intros. apply (Permutation_in (l':=l')) in H3. 2: auto.
apply NoDup_cons_2 in H; contradiction.
assert (Hsorted_NoDup: NoDup lsorted). apply (Permutation_NoDup (l:=l')). apply Permutation_sym; auto. apply NoDup_cons_1 in H; auto.
(*split the list*)
set (k:= find l a 0) in *.
assert (exists l1 l2, lsorted = l1++l2 /\ (forall x, In x l1 -> find l x 0 < find l a 0) /\ (forall x, In x l2 -> find l a 0 <= find l x 0)). {
clear H1.
induction lsorted. exists nil; exists nil. split. rewrite app_nil_r; auto.
split; intros; contradiction.
destruct (Z.lt_ge_cases (find l a0 0) (find l a 0)); rename H1 into Ha0.
++
assert (exists l1 l2 : list E,
              lsorted = l1 ++ l2 /\
              (forall x : E, In x l1 -> find l x 0 < find l a 0) /\ (forall x : E, In x l2 -> find l a 0 <= find l x 0)). {
apply IHlsorted. 2: { unfold not; intros. apply Ha. right; auto. }
2: { apply NoDup_cons_1 in Hsorted_NoDup; auto. }
intros. split; intros.
apply H2. right; auto. right; auto.
apply NoDup_cons_2 in Hsorted_NoDup.
simpl. destruct (E_EqDec a0 a1). hnf in e; subst a0; contradiction.
destruct (E_EqDec a0 b). hnf in e; subst a0; contradiction.
replace 1 with (1+0) by lia. do 2 rewrite find_accum_add1. lia.
apply H2 in H4. 2: right; auto. 2: right; auto.
simpl in H4. apply NoDup_cons_2 in Hsorted_NoDup.
destruct (E_EqDec a0 a1). hnf in e; subst a0; contradiction.
destruct (E_EqDec a0 b). hnf in e; subst a0; contradiction.
replace 1 with (1+0) in H4 by lia. do 2 rewrite find_accum_add1 in H4. lia.
} clear IHlsorted.
destruct H1 as [l1 [l2 [? [? ?]]]].
exists (a0::l1). exists l2. split. simpl. rewrite H1; auto.
split; intros. destruct H5. subst x; auto. apply H3; auto.
apply H4; auto.
++
exists nil. exists (a0::lsorted). split. auto.
split; intros. contradiction.
destruct H1. subst x. auto.
apply (Z.le_trans _ (find l a0 0)). auto.
apply H2. left; auto. right; auto.
rewrite find_cons. apply find_lbound.
}
destruct H3 as [l1 [l2 [? [? ?]]]]. subst lsorted.
exists (l1++a::l2).
split. { apply NoDup_Permutation. apply NoDup_app_inv. apply NoDup_app_l in Hsorted_NoDup; auto.
apply NoDup_cons. unfold not; intros; apply Ha. apply in_or_app; right; auto.
apply NoDup_app_r in Hsorted_NoDup; auto.
unfold not; intros. destruct H6. subst x. apply Ha. apply in_or_app; left; auto.
assert (~ In x l2). apply (NoDup_app_not_in E l1 l2); auto. contradiction.
auto.
split; intros. apply in_app_or in H3; destruct H3. right. apply (Permutation_in (l:=l1++l2)); auto. apply in_or_app; left; auto.
destruct H3. subst x. left; auto. right. apply (Permutation_in (l:=l1++l2)); auto. apply in_or_app; right; auto.
apply in_or_app. destruct H3. subst x. right; left; auto.
apply (Permutation_in (l':=l1++l2)) in H3. 2: apply Permutation_sym; auto.
apply in_app_or in H3; destruct H3. left; auto. right; right; auto.
}
intros. apply in_app_or in H3. apply in_app_or in H6. specialize H2 with a0 b.
destruct H3; destruct H6.
**
rewrite (find_app_In1 l1 (a::l2)) by auto. rewrite find_app_In1 by auto.
rewrite find_app_In1 in H2 by auto. rewrite find_app_In1 in H2 by auto.
apply H2. apply in_or_app. left; auto. apply in_or_app; left; auto.
**
rewrite find_app_In1 by auto.
assert (~ In b l1). unfold not; intros. destruct H6. subst b. apply Ha. apply in_or_app; left; auto.
assert (~ In b l2). apply (NoDup_app_not_in E l1 l2); auto. contradiction.
rewrite find_app_notIn1 by auto.
destruct H6. subst b. split; intros. apply Z.le_lteq. left; apply H4; auto.
apply (Z.le_trans _ (Zlength l1 + 0)). apply find_ubound. pose proof (find_lbound (a::l2) a 0); lia.
split; intros. apply (Z.le_trans _ (find l a 0)). apply Z.le_lteq. left; apply H4; auto. apply H5; auto.
apply (Z.le_trans _ (Zlength l1 + 0)). apply find_ubound. pose proof (find_lbound (a::l2) b 0); lia.
**
assert (~ In a0 l1). unfold not; intros. destruct H3. subst a0. apply Ha. apply in_or_app; left; auto.
assert (~ In a0 l2). apply (NoDup_app_not_in E l1 l2); auto. contradiction.
(*this is false*)
rewrite find_app_notIn1 by auto. rewrite find_app_In1 by auto.
split; intros. assert (find l1 b 0 < Zlength l1 + 0). apply find_In_ubound; auto. rewrite Z.add_0_r in H9.
assert (0 <= find (a::l2) a0 0). apply find_lbound. lia.
destruct H3. subst a0.
****
assert (find l b 0 < find l a 0). apply H4; auto. lia.
****
assert (find l b 0 < find l a0 0). apply (Z.lt_le_trans _ (find l a 0)). apply H4; auto. apply H5; auto. lia.
**
assert (~ In a0 l1). unfold not; intros. destruct H3. subst a0. apply Ha. apply in_or_app; left; auto.
assert (~ In a0 l2). apply (NoDup_app_not_in E l1 l2); auto. contradiction.
assert (~ In b l1). unfold not; intros. destruct H6. subst b. apply Ha. apply in_or_app; left; auto.
assert (~ In b l2). apply (NoDup_app_not_in E l1 l2); auto. contradiction.
rewrite find_app_notIn1 by auto. rewrite find_app_notIn1 by auto.
rewrite find_app_notIn1 in H2 by auto. rewrite find_app_notIn1 in H2 by auto.
destruct H3; destruct H6.
****
subst a0. subst b. split; intros; lia.
****
subst a0. rewrite find_cons. split; intros. apply H5; auto. pose proof (find_lbound (a::l2) b 0); lia.
****
subst b. rewrite find_cons. (*falseness*)
split; intros.
assert (0 < find (a::l2) a0 0). simpl. destruct (E_EqDec a a0).
hnf in e. subst a0. exfalso; apply Ha. apply in_or_app; right; auto.
pose proof (find_lbound l2 a0 1). lia.
lia.
apply Z.le_lteq in H6. destruct H6.
assert (find l a 0 <= find l a0 0). apply H5; auto. lia.
assert (incl l' l). unfold incl; intros. apply H0. right; auto.
apply (find_eq l a0 a 0) in H6. subst a0. rewrite find_cons; lia.
auto. apply H9. apply (Permutation_in (l:= (l1++l2))); auto. apply in_or_app; right; auto.
apply H0. left; auto.
**** rewrite <- H2.
2: apply in_or_app; right; auto. 2: apply in_or_app; right; auto.
simpl.
destruct (E_EqDec a a0). hnf in e; subst a0. exfalso; apply Ha. apply in_or_app; right; auto.
destruct (E_EqDec a b). hnf in e; subst b. exfalso; apply Ha. apply in_or_app; right; auto.
replace 1 with (1+0) by lia. do 2 rewrite find_accum_add1. split; intros; lia.
Qed.

End FindLemmas.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL B FREE SOFTWARE LICENSE AGREEMENT           *)
(**************************************************************)

From Coq
 Require Import Arith Lia.

From KruskalTrees
  Require Import notations tactics idx vec.

From KruskalTrees
  Require list_choice.

Import idx_notations vec_notations
       list_choice (list_choice_t).

Set Implicit Arguments.

#[local] Reserved Notation "'⟨' x '|' v '⟩'" (at level 0, v at level 200, format "⟨ x | v ⟩").

(* ∈ ⟨|⟩ ≤ₑ ≤ₚ ≤ₕ ≤ₖ *)

Section dtree.

  (* The most general trees we have, ie dependent trees
     with a different type at each arity ... *)

  Variable (X : nat -> Type).

  Unset Elimination Schemes.

  Inductive dtree : Type :=
    | dtree_cons k : X k -> vec dtree k -> dtree.

  Set Elimination Schemes.

  Notation "⟨ x | v ⟩" := (dtree_cons x v).

  Section dtree_cons_inj.

    Local Definition dtree_arity t := match t with @dtree_cons k _ _ => k end.
    Local Definition dtree_root t : X (dtree_arity t) := match t with ⟨x|_⟩ => x end.
    Local Definition dtree_sons t : vec dtree (dtree_arity t) := match t with ⟨_|v⟩ => v end.

    Local Fact dtree_cons_injective n x (v : vec _ n) t :
          ⟨x|v⟩ = t -> exists e : n = dtree_arity t, x↺e = dtree_root t /\ v↺e = dtree_sons t.
    Proof. intros []; now exists eq_refl. Qed.

    Fact dtree_cons_inj n x (v : vec _ n) m y (w : vec _ m) :
          ⟨x|v⟩ = ⟨y|w⟩ <-> exists (e : n = m), x↺e = y /\ v↺e = w.
    Proof.
      split.
      + apply dtree_cons_injective.
      + intros (? & ? & ?); eq refl; subst; auto.
    Qed.

  End dtree_cons_inj.

  Section dtree_rect.

    Variable (P : dtree -> Type)
             (P_cons : forall k x (v : vec _ k), (forall p, P v⦃p⦄) -> P ⟨x|v⟩).

    Fixpoint dtree_rect t : P t :=
      match t with
        | dtree_cons x v => P_cons x v (fun p => dtree_rect v⦃p⦄)
      end.

    Fact dtree_rect_fix k x (v : vec _ k) : dtree_rect ⟨x|v⟩ = P_cons x v (fun p => dtree_rect v⦃p⦄).
    Proof. reflexivity. Qed.

  End dtree_rect.

  Definition dtree_rec (P : _ -> Set) := dtree_rect P.
  Definition dtree_ind (P : _ -> Prop) := dtree_rect P.

  Definition dtree_fall (P : forall k, X k -> vec dtree k -> Prop) : dtree -> Prop.
  Proof.
    induction 1 as [ k x v IH ].
    exact (P _ x v /\ forall p, IH p).
  Defined.

  Fact dtree_fall_fix P k x (v : vec _ k) : dtree_fall P ⟨x|v⟩ = (P _ x v /\ forall p, dtree_fall P v⦃p⦄).
  Proof. reflexivity. Qed.

  Definition dtree_exst (P : forall k, X k -> vec dtree k -> Prop) : dtree -> Prop.
  Proof.
    induction 1 as [ k x v IH ].
    exact (P _ x v \/ exists p, IH p).
  Defined.

  Fact dtree_exst_fix P k x (v : vec _ k) : dtree_exst P ⟨x|v⟩ = (P _ x v \/ exists p, dtree_exst P v⦃p⦄).
  Proof. reflexivity. Qed.

  Section dtree_fall_rect.

    Variables (P : forall k, X k -> vec dtree k -> Prop)
              (Q : dtree -> Type)
              (HQ : forall k x v, @P k x v -> (forall p : idx k, dtree_fall P v⦃p⦄) -> (forall p, Q v⦃p⦄) -> Q ⟨x|v⟩).

    Theorem dtree_fall_rect t : dtree_fall P t -> Q t.
    Proof.
      induction t as [ n x v IH ]; intros H.
      rewrite dtree_fall_fix in H; destruct H; auto.
    Qed.

  End dtree_fall_rect.

  Fact dtree_fall_mono (P Q : forall k, X k -> vec dtree k -> Prop) :
           (forall k, @P k ⊆₂ @Q k)
        -> dtree_fall P ⊆₁ dtree_fall Q.
  Proof. induction 2 using dtree_fall_rect; simpl; auto. Qed.

  Section dtree_fall_exst.

    Variables (P Q : forall k, X k -> vec dtree k -> Prop)
              (HPQ : forall k x v, { @P k x v } + { Q x v })
              (HPQnot : forall k x v, @P k x v -> Q x v -> False).

    Fact dtree_fall_exst t : { dtree_fall P t } + { dtree_exst Q t }.
    Proof.
      induction t as [ n x v IH ].
      destruct idx_finite_t with n as (l & Hl).
      destruct list_choice_t
        with (l := l)
             (P := fun p => dtree_fall P v⦃p⦄)
             (Q := fun p => dtree_exst Q v⦃p⦄)
        as [ H1 | (p & Hp1 & Hp2) ]; auto;
        [ destruct (HPQ x v) as [ H2 | H2 ] | ].
      1: left; simpl; auto.
      all: right; simpl; eauto.
    Qed.

    Fact dtree_fall_exst_absurd t : dtree_fall P t -> dtree_exst Q t -> False.
    Proof.
      induction 1 as [ k x v H1 H2 IH2 ] using dtree_fall_rect.
      intros [ | [] ]; eauto.
    Qed.

  End dtree_fall_exst.

  Fact dtree_fall_dec P :
           (forall n (x : X n) v, { P n x v } + { ~ P n x v })
         -> forall t, { dtree_fall P t } + { ~ dtree_fall P t }.
  Proof.
    intros H t.
    destruct dtree_fall_exst with (1 := H) (t := t) as [ H1 | H1 ]; auto.
    right.
    intros H2; revert H2 H1.
    apply dtree_fall_exst_absurd; auto.
  Qed.

End dtree.

Module dtree_notations.

  Notation "⟨ x | v ⟩" := (dtree_cons x v).

End dtree_notations.

Import dtree_notations.

Section dtree_map.

  Variables (X Y : nat -> Type) (f : forall n, X n -> Y n).

  Definition dtree_map : dtree X -> dtree Y.
  Proof.
    induction 1 as [ n x _ w ].
    exact ⟨f x|vec_set w⟩.
  Defined.

  Fact dtree_map_fix n x (v : vec (dtree X) n) : dtree_map ⟨x|v⟩ = ⟨f x|vec_map dtree_map v⟩.
  Proof. rewrite <- vec_set_map; auto. Qed.

End dtree_map.

Tactic Notation "dtree" "discr" hyp(H) :=
  (  (apply dtree_cons_inj in H as (? & _); lia)
  || (apply dtree_cons_inj in H as (? & ? & _); eq refl; easy) ).

Tactic Notation "dtree" "discr" :=
  try (repeat
    match goal with
      | H: _ = _ :> dtree _ |- _ => (dtree discr H || clear H)
    end; fail).

Tactic Notation "dtree" "inj" hyp(H) :=
  let e := fresh
  in  apply dtree_cons_inj in H as (e & H); eq refl;
      destruct H as [ H <- ]; try clear e.

Section dtree_eq_dec.

  Variable (X : nat -> Type) (eqX_dec : forall n (x y : X n), { x = y } + { x <> y }).

  Theorem dtree_eq_dec (r t : dtree X) : { r = t } + { r <> t }.
  Proof.
    revert t; induction r as [ n x v IHv ]; intros [ m y w ].
    destruct (eq_nat_dec n m) as [ <- | C ].
    2: now right; contradict C; dtree inj C.
    destruct (eqX_dec x y) as [ <- | C ].
    2: now right; contradict C; dtree inj C.
    destruct (vec_eq_dec_ext v w) as [ <- | C ]; auto.
    now right; contradict C; dtree inj C.
  Qed.

End dtree_eq_dec.


Set Implicit Arguments.

Require Import Arith.Arith_base List Omega.
Require Import Wellfounded.Lexicographic_Product.
Require Import Relation_Operators.

(* begin hide *)

Require Import LibTactics.

(* end hide *)

(** * Type Definitions *)

(** ** Identifier definition *)

(** Identifiers are just natural numbers. This eases the task of equality test *)

Definition id := nat.

(** Decidable equality of identifiers *)

Definition eq_id_dec : forall (v v' : id), {v = v'} + {v <> v'} := eq_nat_dec.

(** ** Type definition *)

(** Type definition is direct *)

Inductive ty : Set :=
  | var : id -> ty
  | arr : ty -> ty -> ty
  | con : ty.

(** Decidable equality test for types *)

Definition eq_ty_dec : forall (t t' : ty), {t = t'} + {t <> t'}.
  pose eq_id_dec.
  decide equality.
Defined.

(* begin hide *)

(** General simplification tactic. In html, we will omit such Ltac defs. *)

Ltac s :=
  match goal with
    | [ H : _ /\ _ |- _] => destruct H
    | [ H : _ \/ _ |- _] => destruct H
    | [ |- context[eq_id_dec ?a ?b] ] => destruct (eq_id_dec a b) ; subst ; try congruence
    | [H : context[eq_id_dec ?a ?b] |- _] =>
      destruct (eq_id_dec a b) ; subst ; try congruence
    | [ |- context[eq_nat_dec ?a ?b] ] => destruct (eq_nat_dec a b) ; subst ; try congruence
    | [ x : (id * ty)%type |- _ ] => let t := fresh "t" in destruct x as [x t]
    | [ H : (_,_) = (_,_) |- _] => inverts* H
    | [ H : Some _ = Some _ |- _] => inverts* H
    | [ H : Some _ = None |- _] => congruence
    | [ H : None = Some _ |- _] => congruence
    | [ |- _ /\ _] => split
    | [ H : ex _ |- _] => destruct H
  end.

Ltac mysimp := (repeat (simpl; s)) ; simpl; auto with arith.

(* end hide *)

(** The size of a type. This is used in by the termination argument of
    the unification algorithm.  **)

Fixpoint size (t : ty) : nat :=
  match t with
    | arr l r => 1 + size l + size r
    | _ => 1
  end.

(** * Definition of Constraints **)

(** A constraint is just a pair of types *)

Definition constr := (ty * ty)%type.

(** A constraint list is just a list of pairs *)

Definition list_constr := list constr.

(** Measures of constraints follows direct from the type size definition *)

Definition constr_size (c : constr) : nat :=
  match c with
    (t,t') => size t + size t'
  end.

Fixpoint list_measure (l : list_constr) : nat :=
  match l with
    | nil => 0
    | p :: l => constr_size p + list_measure l
  end.

(** * Context of Type Variables **)

(** Type variables context is the key element to the formalization of the termination
    argument of the unification algorithm. This context is used to store the variables
    that aren't yet solved by the unification. At each step, the unification algorithm
    will solve some variables (thus, the size of the context decreases), or the measure
    of constraints being unified deacreses. *)

Definition varctxt := list id.

(** Definition of when a variable (id) is member of a variable context *)

Fixpoint member (C : varctxt) (i : id) : Prop :=
  match C with
    | nil => False
    | v :: vs => if eq_id_dec v i then True else member vs i
  end.

(** Decidability of the previous membership relation *)

Definition member_dec : forall C i, {member C i} + {~ member C i}.
  refine (fix member_dec (C : varctxt) (i : id) : {member C i} + {~ member C i} :=
                match C with
                  | nil => right _ _
                  | v :: vs =>
                      match eq_id_dec v i with
                        | left _ => left _ _
                        | right _ =>
                            match member_dec vs i with
                              | left _ => left _ _
                              | right _ => right _ _
                            end
                      end
                end) ; mysimp.
Defined.

(** * Well Formedness Definitions *)

(** Here we define the concepts of well formed types and constraints. We
    say that a type is well formed if all of its variables are in a variable context.
    Similarly, a constraint is well formed if all of its types are well formed.*)

Fixpoint wf_ty (C : varctxt) (t : ty) : Prop :=
  match t with
    | var v => member C v
    | con => True
    | arr l r => wf_ty C l /\ wf_ty C r
  end.

Fixpoint wf_constr_list (C : varctxt) (l : list_constr)  : Prop :=
  match l with
    | nil => True
    | (t,t') :: C' => wf_ty C t /\ wf_ty C t' /\ wf_constr_list C C'
  end.

Lemma wf_ty_end t a C : wf_ty C t -> wf_ty (C ++ a :: nil) t.
Proof.
  induction t ; mysimp ; intros ; mysimp ; generalize H ;
    induction C ; simpl ; [tauto | mysimp].
Qed.

Hint Resolve wf_ty_end.

Lemma appcons (A:Type) : forall (s1 s2:list A) x, s1 ++ x::s2 = (s1 ++ x::nil) ++ s2.
  intros ; rewrite app_ass ; auto.
Qed.

Lemma wf_ty_weaken C2 t : forall C1, wf_ty C1 t -> wf_ty (C1 ++ C2) t.
Proof.
  induction C2 ; intros ; [rewrite <- app_nil_end | rewrite appcons] ; auto.
Qed.

Hint Resolve wf_ty_weaken.

(** * The "Real" Constraint definition *)

 (** We define a constraint as a dependent product of
    a variable context and a list of constraints.
    This is needed for a simple termination argument
    for the unification algorithm. **)

Definition constraints := sigT (fun _ : varctxt => list_constr).

Definition get_ctxt(c : constraints) : varctxt := let (v,_) := c in v.
Definition get_list_constr(c : constraints) : list_constr := let (_,l) := c in l.
Definition mk_constraints(C : varctxt)(l : list_constr) : constraints := existT _ C l.

(** ** Constraint ordering *)

(** A strict order on constraints. Here we use the library definition of lexicographic orderings. *)

Definition constraints_lt : constraints -> constraints -> Prop :=
  lexprod varctxt (fun _ => list_constr)
          (fun (x y : varctxt) => length x < length y)
          (fun (x : varctxt) (l l' : list_constr) => list_measure l < list_measure l').

(** A proof that the order is well-founded *)

Definition well_founded_constraints_lt : well_founded constraints_lt :=
  @wf_lexprod varctxt (fun _ : varctxt => list_constr)
              (fun (x y : varctxt) => length x < length y)
              (fun (x : varctxt) (l l' : list_constr) => list_measure l < list_measure l')
              (well_founded_ltof varctxt (@length id))
              (fun _ => well_founded_ltof list_constr list_measure).

(** * Occurs-check test *)

(** A predicate that specifies when a variable v occurs free in a type t *)

Fixpoint occurs (v : id) (t : ty) : Prop :=
  match t with
    | var n => if eq_id_dec n v then True else False
    | con  => False
    | arr l r => occurs v l \/ occurs v r
  end.

(** Decidability of occurs check test *)

Definition occurs_dec : forall v t, {occurs v t} +  {~ occurs v t}.
  refine (fix occurs_dec v t : {occurs v t} +  {~ occurs v t} :=
            match t with
              | var n =>
                  if eq_id_dec n v then left _ _ else right _ _
              | con => right _ _
              | arr l r =>
                  match occurs_dec v l, occurs_dec v r with
                    | left _, left _ => left _ _
                    | left _, right _ => left _ _
                    | right _, left  _ => left _ _
                    | right _, right _ => right _ _
                  end
            end) ; mysimp ; intuition.
Defined.

(** * Substitutions *)

(** A operation for substitute all the ocurrences of variable x in t2 by t1. *)

Fixpoint sub (t1 : ty) (x : id) (t2 : ty) : ty :=
  match t2 with
    | var n => if eq_id_dec x n then t1 else var n
    | con => con
    | arr l r => arr (sub t1 x l) (sub t1 x r)
  end.

(** Removing a variable from a variable context *)

Fixpoint remove (v : id) (ctx : varctxt) : varctxt :=
  match ctx with
    | nil => nil
    | y :: ys => if eq_id_dec y v then remove v ys else y :: (remove v ys)
  end.

Lemma wf_ty_remove_weak t x C : wf_ty (remove x C) t  -> wf_ty C t.
Proof.
  induction t ; auto ; simpl ; [induction C ; simpl ; mysimp | intros ; mysimp ; firstorder].
Qed.

Hint Resolve wf_ty_remove_weak.

Lemma remove_dist x ctx ctx' : remove x (ctx ++ ctx') = (remove x ctx) ++ (remove x ctx').
Proof.
  induction ctx ; mysimp ; intros ; rewrite IHctx ; auto.
Qed.

(** Suppose that a type t is well formed with respect to a variable context ctx and
    the variable x is free in t,
    if we substitute x for u and u is well formed with respecto to ctx - {x},
    we get a type that is well formed with respect to ctx - {x}.
    This is formalized by the lemma subst_remove. *)

Lemma subst_remove' : forall x t ctx, member ctx t -> x <> t -> member (remove x ctx) t.
Proof.
  induction ctx ; mysimp.
Qed.

(* begin hide *)

Hint Resolve subst_remove'.

(* end hide *)

Lemma subst_remove : forall t x ctx, wf_ty ctx t -> member ctx x ->
                                     forall u, wf_ty (remove x ctx) u ->
                                               wf_ty (remove x ctx) (sub u x t).
Proof.
  induction t ; simpl ; intros ; mysimp.
Qed.

(* begin hide *)

Hint Resolve subst_remove.

(* end hide *)

(** ** Substitution Definitions and Its Well Formedness Predicate *)

(** Substitution and its domain *)

Definition substitution := list (id * ty).

Definition dom (s : substitution) : list id := List.map (@fst id ty) s.

(** Definition of a  well formed substitution. A substitution is well formed,
    if form each pair (v,t), where v is a variable and t a type, we have that
    v is in a variable context C and t is well formed in the variable context
    C - {v}. *)

Fixpoint wf_subst (C : varctxt) (s : substitution) : Prop :=
  match s with
    | nil => True
    | (v,t) :: s' => member C v /\ wf_ty (remove v C) t /\ wf_subst (remove v C) s'
  end.

(** Substitution application functions *)

Fixpoint apply_subst (s : substitution) (t : ty) : ty :=
  match s with
    | nil => t
    | (v,t') :: s' => apply_subst s' (sub t' v t)
  end.

Fixpoint apply_subst_constraint (s : substitution) (l : list_constr) : list_constr :=
  match l with
    | nil => nil
    | (t,t1) :: l' => (apply_subst s t , apply_subst s t1) :: apply_subst_constraint s l'
  end.

(** Removing a list of names from a given variable context. *)

Fixpoint minus (C : varctxt) (xs : list id) : varctxt :=
  match xs with
    | nil => C
    | x :: xs => remove x (minus C xs)
  end.

Lemma remove_comm : forall x y C, remove x (remove y C) = remove y (remove x C).
Proof.
  induction C ; mysimp.
Qed.

Hint Resolve remove_comm.

Lemma minus_remove : forall C2 C1 x, minus (remove x C1) C2 = remove x (minus C1 C2).
Proof.
  induction C2 ; mysimp ; intros ; rewrite IHC2 ; auto.
Qed.

Lemma wf_ty_minus_weaken t C2 C1 : wf_ty (minus C1 C2) t -> wf_ty C1 t.
Proof.
  induction C2 ; eauto.
Qed.

Hint Resolve wf_ty_minus_weaken.

(** If s is a well-formed substitution with respect to C,
   and t is a well-formed type with respect to C, s t is
   a well-formed type with respect to C - (dom s) *)

Lemma substs_remove : forall s C t , wf_subst C s ->
                                     wf_ty C t ->
                                     wf_ty (minus C (dom s)) (apply_subst s t).
Proof.
  induction s ; mysimp ; intros ; mysimp.
  generalize (IHs (remove a C)) ; rewrite minus_remove ; intros ; auto.
Qed.

Hint Resolve substs_remove.

Lemma minus_app : forall (C : varctxt) s v t, minus C (dom (s ++ (v,t) :: nil)) = remove v (minus C (dom s)).
Proof.
  induction s ; mysimp ; intros ; mysimp ; rewrite IHs ; auto.
Qed.

(** ** Some Obvious Facts About Substitutions **)

Lemma apply_subst_id : forall t, apply_subst nil t = t.
Proof.
  induction t ; mysimp.
Qed.

Lemma apply_subst_con : forall s, apply_subst s con = con.
Proof.
  induction s ; mysimp.
Qed.

Lemma apply_subst_app : forall s l r, apply_subst s (arr l r) = arr (apply_subst s l) (apply_subst s r).
Proof.
  induction s ; mysimp.
Qed.

Lemma apply_subst_end : forall s v t t', apply_subst (s ++ (v,t) :: nil) t' = sub t v (apply_subst s t').
Proof.
  induction s ; mysimp.
Qed.

Lemma apply_subst_append : forall s2 s1 t, apply_subst (s1 ++ s2) t = apply_subst s2 (apply_subst s1 t).
Proof.
  induction s2 ; intros ; simpl. rewrite <- app_nil_end ; auto.
  assert (s1 ++ a :: s2 = (s1 ++ (a::nil)) ++ s2).
  rewrite app_ass ; auto. rewrite H. destruct a. rewrite (IHs2 (s1 ++ (i,t0)::nil)).
  rewrite <- apply_subst_end. auto.
Qed.

Lemma wf_subst_last (s : substitution) : forall x t C, wf_subst C s ->
  member (minus C (dom s)) x -> wf_ty (remove x (minus C (dom s))) t ->
    wf_subst C (s ++ (x,t)::nil).
Proof.
  induction s ; simpl ; intros ; mysimp.
  apply (IHs _ _ (remove a C)) ; auto ; rewrite minus_remove ; auto.
Qed.

Hint Resolve wf_subst_last.

Lemma wf_subst_append : forall C s2 s1,  wf_subst C s1 ->
                                         wf_subst (minus C (dom s1)) s2 ->
                                         wf_subst C (s1 ++ s2).
Proof.
  induction s2 ; simpl ; intros. rewrite <- app_nil_end ; auto.
  mysimp. rewrite appcons. apply IHs2. auto. rewrite minus_app ; auto.
Qed.

Hint Resolve wf_subst_append.

(** * Lemmas *)

(** ** Termination Proof Lemmas *)

Lemma lt_list_constr_lt_measure : forall t t' l, list_measure l < list_measure ((t,t') :: l).
Proof.
  induction t ; destruct t' ; intros ; simpl in * ; mysimp.
Qed.

Hint Resolve lt_list_constr_lt_measure.

Lemma lt_list_constr_lt_constraints : forall t t' C l, constraints_lt (mk_constraints C l) (mk_constraints C ((t,t') :: l)).
Proof.
  intros ; apply right_lex ; auto.
Qed.

Lemma app_lt_measure : forall l l' r r' lc, list_measure ((l,l') :: (r, r') :: lc) < list_measure ((arr l r, arr l' r') :: lc).
Proof.
  intros ; induction lc ; mysimp ; try omega.
Qed.

Lemma app_lt_constraints : forall l l' r r' lc C, constraints_lt (mk_constraints C ((l,l') :: (r,r') :: lc))
                                                                 (mk_constraints C ((arr l r, arr l' r') :: lc)).
Proof.
  intros ; apply right_lex ; mysimp ; try omega.
Qed.

Lemma non_member_remove_length : forall C v, ~ member C v -> length (remove v C) = length C.
Proof.
  induction C ; auto ; mysimp ; intros ; mysimp ; try tauto.
Qed.

Lemma remove_varctxt_length : forall C v, member C v -> length (remove v C) < length C.
Proof.
  intros ; induction C ; simpl in * ; try contradiction ; mysimp ;
  destruct (member_dec C v) ; auto with arith ;
   match goal with
     | [H : ~ member _ _ |- _] => rewrite (non_member_remove_length _ _ H) ; auto with arith
   end.
Qed.

Hint Resolve remove_varctxt_length.

Lemma varctxt_lt_constraints_varl :
  forall C v t l, member C v ->
                  constraints_lt (mk_constraints (remove v C) (apply_subst_constraint ((v,t) :: nil) l))
                                 (mk_constraints C ((var v, t) :: l)).
Proof.
  intros ; apply left_lex ; auto.
Qed.

Lemma varctxt_lt_constraints_varr :
  forall C v t l, member C v ->
                  constraints_lt (mk_constraints (remove v C) (apply_subst_constraint ((v,t) :: nil) l))
                                 (mk_constraints C ((t, var v) :: l)).
Proof.
  intros ; apply left_lex ; auto.
Qed.

Hint Resolve lt_list_constr_lt_constraints app_lt_constraints
             varctxt_lt_constraints_varl varctxt_lt_constraints_varr.

(** ** Relating occurs check and well formedness of types *)

Lemma occurs_wf_ty v C t : wf_ty C t -> ~ occurs v t -> wf_ty (remove v C) t.
Proof.
  induction t ; mysimp ; try tauto.
Qed.

Hint Resolve occurs_wf_ty.

(** ** Some Obvious Facts About Applications *)

Lemma app_subst_eq : forall l l' r r' s,  apply_subst s l = apply_subst s l' ->
                                          apply_subst s r = apply_subst s r' ->
                                          apply_subst s (arr l r) = apply_subst s (arr l' r').
Proof.
  intros ; do 2 rewrite apply_subst_app ; fequals*.
Qed.

Hint Resolve app_subst_eq.

(** ** Extensionality Lemmas For Substitutions *)

Lemma ext_subst_var_ty : forall s s', (forall v, apply_subst s (var v) = apply_subst s' (var v)) ->
                                       forall t, apply_subst s t = apply_subst s' t.
Proof.
  intros ; induction t ; mysimp ; try (do 2 rewrite apply_subst_app) ;
     simpl in * ; auto ; try (do 2 rewrite apply_subst_con) ; auto.
    try (rewrite IHt1 ; auto). try (rewrite IHt2 ; auto).
Qed.

Lemma ext_subst_ty_var : forall s s', (forall t, apply_subst s t = apply_subst s' t) ->
                                      forall v, apply_subst s (var v) = apply_subst s' (var v).
Proof.
  mysimp.
Qed.

Hint Resolve ext_subst_var_ty ext_subst_ty_var.

Lemma sub_occurs : forall t v u, ~ occurs v u -> u = sub t v u.
Proof.
  induction u ; mysimp ; intros ; try firstorder ; try congruence.
Qed.

Hint Resolve sub_occurs.

(** * Specification of the Unification Algorithm *)

Inductive UnifyFailure : list_constr -> Prop :=
  | occ_fail  : forall v t lc, occurs v t -> UnifyFailure (((var v), t) :: lc)
  | occ_fail'  : forall v t lc, occurs v t -> UnifyFailure ((t, (var v)) :: lc)
  | con_app   : forall l r lc, UnifyFailure ((con,(arr l r)) :: lc)
  | app_con   : forall l r lc, UnifyFailure (((arr l r), con) :: lc)
  | app_left  : forall l l' r r' lc, UnifyFailure ((l,l') :: lc) -> UnifyFailure (((arr l r), (arr l' r')) :: lc)
  | app_right  : forall l l' r r' lc, UnifyFailure ((l,l') :: (r, r') :: lc) -> UnifyFailure (((arr l r), (arr l' r')) :: lc)
  | constr_rec : forall t t' l, UnifyFailure l -> UnifyFailure ((t,t') :: l)
  | subs_rec : forall t t' s l, UnifyFailure (apply_subst_constraint s l) -> UnifyFailure ((t,t') :: l).

Hint Constructors UnifyFailure.

(** ** Definition of a unifier for a list of constraints *)

Fixpoint unifier (cs : list_constr) (s : substitution) : Prop :=
  match cs with
    | nil => True
    | (t,t') :: cs' => apply_subst s t = apply_subst s t' /\ unifier  cs' s
  end.

(** a simple lemma about unifiers and variable substitutions *)

Lemma unifier_append : forall l v t s,
                         unifier (apply_subst_constraint ((v, t) :: nil) l) s ->
                         unifier l ((v,t) :: s).
Proof.
  induction l ; intros ; mysimp ;
    try (match goal with
          | [a : constr |- _] => destruct a
         end) ; simpl in * ; try splits*.
Qed.

Lemma unify_ty : forall t v t' s, apply_subst s (var v) = apply_subst s t' ->
                                  apply_subst s t = apply_subst s (sub t' v t).
Proof.
  induction t ; intros ; mysimp.
Qed.

Hint Resolve unify_ty.

Lemma unifier_subst : forall l v t s, apply_subst s (var v) = apply_subst s t ->
                                        unifier l s ->
                                        unifier (apply_subst_constraint ((v,t) :: nil) l) s.
Proof.
  induction l ; intros ; mysimp ;
    try (match goal with
          | [a : constr |- _] => destruct a
         end) ; simpl in * ; mysimp.
  assert (apply_subst s (var v) = apply_subst s t) ; auto.
  apply unify_ty with (t := t0) in H.
  apply unify_ty with (t := t1) in H2.
  rewrite <- H. rewrite <- H2. auto.
Qed.

Hint Resolve unifier_append unifier_subst.

Definition wf_constraints (c : constraints) :=
  wf_constr_list (get_ctxt c) (get_list_constr c).

Lemma wf_constr_list_remove : forall l C v t, wf_constr_list C l ->
                                                member C v ->
                                                ~ occurs v t ->
                                                wf_ty C t ->
                                                wf_constr_list (remove v C) (apply_subst_constraint ((v,t) :: nil) l).
Proof.
  induction l ; intros ; mysimp ; destruct a ; simpl in * ; mysimp.
Qed.

Hint Resolve wf_constr_list_remove.

(** * Type of the unification algorithm *)

(*
The type of unification algorithm specifies that from a list of well-formed constraints
we can either:

1 - Produce a well-formed substitution s such that it unifies the constraints and s is the
    least of such unifiers.
2 - It returns a proof that no such unifier exists.

*)

Definition unify_type (c : constraints) := wf_constraints c ->
           ({ s | unifier (get_list_constr c) s /\ wf_subst (get_ctxt c) s /\
             forall s', unifier (get_list_constr c) s' ->
               exists s'', forall v, apply_subst s' (var v) = apply_subst (s ++ s'') (var v)})
           + { UnifyFailure (get_list_constr c) }.

(** * Main definition of the unification function *)

(* The unification algorithm is defined by a combinator that performs well-founded recursion
   over a well-founded relation. The constraints_lt is a well founded relation over constraints,
   so, we can use the library combinator for well-founded recursion in order to compute the
   unifier over such constraints.

   The algorithm below uses a lot of type annotations, needed to pattern-match over dependent
   types.

   Also, the algorithm definition is polluted by tactics. This is necessary in order to
   generate the proof terms to the obligations to ensure the well-foundness of the recursive
   calls and to finish the proofs for soundness and completness of the algorithm.*)

Definition unify_body (l : constraints)
                      (unify : forall (l'  : constraints),
                                 constraints_lt l' l -> unify_type l') : unify_type l.
   unfold unify_type ; intros prf ;
   destruct l as [C l] ; simpl ;
   refine (
       match l as l' return l = l' ->
          ({ s | unifier l s /\ wf_subst C s /\
              forall s', unifier l s' ->
              exists s'', forall v, apply_subst s' (var v) = apply_subst (s ++ s'') (var v)} +
                        { UnifyFailure l }) with
          | nil => fun H1 => inleft _ (@exist substitution _ nil _)
          | (t,t') :: l' => fun H1 =>
              match eq_ty_dec t t' return
                 ({ s | unifier l s /\ wf_subst C s /\
                forall s', unifier l s' ->
                 exists s'', forall v, apply_subst s' (var v) = apply_subst (s ++ s'') (var v)})
                    + {UnifyFailure l} with
                | left _ =>
                       match unify (mk_constraints C l') _ _ with
                        | inleft (exist _ s _) =>  inleft _ (@exist substitution _ s _)
                        | inright _ => inright _ _
                      end
                | right _ =>
                    match t as t1, t' as t1'
                       return t = t1 -> t' = t1' ->
                         ({ s | unifier l s /\ wf_subst C s /\
                           forall s', unifier l s' ->
                exists s'', forall v, apply_subst s' (var v) = apply_subst (s ++ s'') (var v)})
                                    + { UnifyFailure l } with
                        | var v, t =>
                            fun H1 H2 =>
                              match occurs_dec v t with
                                | left _ => inright _ _
                                | right _ =>
                                    match unify (mk_constraints (minus C (v :: nil))
                                                (apply_subst_constraint ((v,t) :: nil) l')) _ _ with
                                      | inleft (exist _ s _) => inleft _ (@exist substitution _ ((v,t) :: s) _ )
                                      | inright _ => inright _ _
                                    end
                              end
                        | t, var v =>
                            fun H1 H2 =>
                              match occurs_dec v t with
                                | left _ => inright _ _
                                | right _ =>
                                    match unify (mk_constraints (minus C (v :: nil))
                                                (apply_subst_constraint ((v,t) :: nil) l')) _ _ with
                                      | inleft (exist _ s _) => inleft _ (@exist substitution _ ((v,t) :: s) _ )
                                      | inright _ => inright _ _
                                    end
                              end
                        | con, con =>
                            fun H1 H2 => inright _ _
                        | con , arr _ _ =>
                            fun H1 H2 => inright _ _
                        | arr _ _, con =>
                            fun H1 H2 => inright _ _
                        | arr l1 r, arr l1' r' =>
                            fun H1 H2 =>
                              match unify (mk_constraints C ((l1,l1') :: (r,r') :: l')) _ _ with
                                | inleft (exist _ s _)  => inleft _ (@exist substitution _ s _)
                                | inright _ => inright _ _
                              end
                    end (refl_equal t) (refl_equal t')
              end
       end (refl_equal l)
     ) ; clear unify ;  unfolds in prf ; simpl in * ; substs ; mysimp ;
         eauto ; simpl in * ; intros ; try (unfold t in *) ;
           try (do 2 fequals* ; symmetry ; auto ; fail) ; mysimp ;
             unfold wf_constraints in * ; simpl in * ; mysimp ;
               try (match goal with
             | [H : apply_subst ?s (arr _ _) = apply_subst ?s (arr _ _),
                Hu : unifier _ ?s,
                H1 :  forall s',
                        apply_subst s' _ = apply_subst s' _ /\
                        apply_subst s' _ = apply_subst s' _ /\ unifier _ s' ->
                        exists s'',
                          forall v : id, _ |- _ ] =>
                   do 2 rewrite apply_subst_app in H ; injection H ; clear H ;
                   intros Ha Hb ; destruct (H1 _ (conj Hb (conj Ha Hu))) as [sc Hc] ;
                   exists* sc
               | [H : apply_subst ?s (var _) = apply_subst ?s ?t,
                  Hu : unifier _ ?s,
                  H1 : forall s', unifier _ s' -> _ |- _] =>
                      apply (unifier_subst _ _ _ _ H) in Hu ; destruct (H1 _ Hu) as [sa Ha] ;
                      eexists ; intros ; case_if* ; substs ; try rewrite H ;
                      eapply ext_subst_var_ty in Ha ; eauto
               | [H : apply_subst ?s ?t = apply_subst ?s (var _),
                  Hu : unifier _ ?s,
                  H1 : forall s', unifier _ s' -> _ |- _] =>
                       symmetry in H ; apply (unifier_subst _ _ _ _ H) in Hu ;
                       destruct (H1 _ Hu) as [sa Ha] ; eexists ; intros ; case_if* ; substs ;
                       try rewrite H ; eapply ext_subst_var_ty in Ha ; eauto
                    end) ; try (apply wf_constr_list_remove ; simpl in * ; auto).
Defined.

Definition unify : forall l : constraints, unify_type l :=
  well_founded_induction well_founded_constraints_lt unify_type unify_body.

Extraction Language Haskell.
Recursive Extraction unify.


(* Converting Integers to Positive, and Vice-Versa *)
(* This is needed because identifiers from the language (function names, continuations) *)
(* must be communicated accross languages *)

Require Import Integers.
Require Import Coqlib.
Require Import monad.
Require Import Errors.
Require Import Int.
Require Import common.
(* Require Import monad_impl. *)

Definition pos_of_int (i:int) : positive :=
  Z.to_pos (Int.intval i).

(* This fails if the positive is too big *)
(* This will prevent the backend optimization from happening *)
Definition int_of_pos (p:positive) : res int :=
  do z <- OK(Zpos p);
    match (Z.ltb z Int.modulus) with
    | true => OK (Int.repr z)
    | false => Error ((MSG "Overflowed Int/Pos conversion")::nil)
    end.

Definition nat_of_int (i:int) : nat :=
  Z.to_nat (Int.intval i).

Definition int_of_nat (n:nat) : res int :=
  let z := Z.of_nat n in
  match (Z.ltb z Int.modulus) with
  | true => OK (Int.repr z)
  | false => Error ((MSG "Overflowed Nat/Pos conversion")::nil)
  end.

Transparent Int.repr.
Lemma repr_lt:
  forall z:Z,
    Z.lt z Int.modulus ->
    Z.lt (-1 ) z ->
    Int.intval (Int.repr z) = z.
Proof.
  intros z LT POS. unfold Int.repr. simpl. rewrite Int.Z_mod_modulus_eq.
  apply Z.mod_small. split; omega.
Qed.

Theorem int_pos_correct:
  forall p i,
    int_of_pos p = OK i ->
    pos_of_int i = p.
Proof.
  unfold int_of_pos, pos_of_int. intros p i H. repeat do_ok. inv HDO.
  destruct (Z.ltb (Zpos p) Int.modulus) eqn:MOD; inv H1.
  rewrite repr_lt. auto.
  - rewrite Z.ltb_lt in MOD. auto.
  - assert (N: 0 <= Z.pos p) by apply Pos2Z.is_nonneg.
    rewrite <- Z.lt_pred_le in N. simpl in N. apply N.
Qed.

Theorem int_nat_correct:
  forall n i,
    int_of_nat n = OK i ->
    nat_of_int i = n.
Proof.
  unfold int_of_nat, nat_of_int. intros n i H.
  destruct (Z.ltb (Z.of_nat n) Int.modulus) eqn:MOD; inv H.
  rewrite repr_lt.
  - apply Nat2Z.id.
  - rewrite Z.ltb_lt in MOD. auto.
  - assert (N: 0 <= Z.of_nat n) by apply Nat2Z.is_nonneg.
    rewrite <- Z.lt_pred_le in N. simpl in N. apply N.
Qed.

Lemma z_mod_same:
  forall p,
    Z.pos p <? Int.modulus = true <->
    Int.Z_mod_modulus (Z.pos p) = Z.pos p.
Proof.
  intros p. split; intros H.
  - rewrite Int.Z_mod_modulus_eq. apply Zmod_small. split. apply Pos2Z.is_nonneg. apply Z.ltb_lt. auto.
  - rewrite Int.Z_mod_modulus_eq in H. apply Z.ltb_lt.
    assert (0 <= Z.pos p mod Int.modulus < Int.modulus).
    { apply Z_mod_lt. apply Int.modulus_pos. } destruct H0.
    rewrite H in H1. auto.
Qed.

Lemma ok_same:
  forall A a1 a2,
    @OK A a1 = @OK A a2 -> a1 = a2.
Proof.
  intros A a1 a2 H. inv H. auto.
Qed.

Lemma repr_same:
  forall i1 i2,
    Int.repr i1 = Int.repr i2 ->
    Int.Z_mod_modulus i1 = Int.Z_mod_modulus i2.
Proof.
  intros i1 i2 H. inv H. auto.
Qed.

Lemma pos_ok:
  forall p i,
    int_of_pos p = OK i ->
    Z.pos p <? Int.modulus = true.
Proof.
  unfold int_of_pos. intros. repeat do_ok. inv HDO.
  destruct (Z.ltb (Zpos p) Int.modulus) eqn:MOD; inv H1. auto.
Qed.
(* in this lemma, if I intro before the unfold, Qed doesnt finish... *)

Lemma same_pos:
  forall p1 p2 i,
    int_of_pos p1 = OK i ->
    int_of_pos p2 = OK i ->
    Int.repr (Zpos p1) = Int.repr (Zpos p2).
Proof.
  unfold int_of_pos. intros. repeat do_ok. inv HDO0. inv HDO.
  destruct (Z.pos p1 <? Int.modulus). 2: inv H1.
  destruct (Z.pos p2 <? Int.modulus). 2: inv H2.
  apply ok_same in H2. apply ok_same in H1. subst. auto.
Qed.

Theorem int_of_pos_injective:
  forall (p1 p2:positive) (i:int),
    int_of_pos p1 = OK i ->
    int_of_pos p2 = OK i ->
    p1 = p2.
Proof.
  intros p1 p2 i H H0.
  specialize (same_pos p1 p2 i H H0). intros.
  apply repr_same in H1. apply pos_ok in H. apply pos_ok in H0.
  apply z_mod_same in H. apply z_mod_same in H0.
  rewrite H in H1. rewrite H0 in H1. inv H1. auto.
Qed.
(* I had to do this proof in such a convoluted way because Qed would not terminate... *)
(* I have to investigate what's happening *)


Set Universe Polymorphism.
Set Primitive Projections.

Axiom Ω : Type.

Inductive list A :=
| nil : list A
| cons : A -> list A -> list A.

Fixpoint app {A} (l1 l2 : list A) : list A :=
match l1 with
| nil _ => l2
| cons _ x l1 => cons _ x (app l1 l2)
end.

Record sig A (P : A -> Type) := exist {
  wit : A;
  prf : P wit;
}.

Arguments wit {_ _} _.
Arguments prf {_ _} _.

Definition prod A B := sig A (fun _ => B).
Definition pair {A B} (x : A) (y : B) : prod A B := exist _ _ x y.

Definition M A := prod A (list Ω).

Definition ret {A} (x : A) : M A := pair x (nil Ω).

Definition pointwise {A} (f : A -> Type) (T : M A) : Type := f T.(wit).

Definition TYPE := M (sig Type (fun A => M A -> A)).

Definition mkTYPE (A : Type) (alg : M A -> A) : TYPE := pair (exist _ _ A alg) (nil Ω).

Definition El (A : TYPE) : Type := pointwise wit A.

Definition bind {A B} (x : M A) (f : A -> M B) : M B :=
  let r := f x.(wit) in
  pair r.(wit) (app x.(prf) r.(prf)).

Definition hbind {A B} (x : M A) (f : A -> El B) : El B :=
match x.(prf) with
| nil _ => f x.(wit)
| _ => B.(wit).(prf) (pair (f x.(wit)) x.(prf))
end.

Definition Typeᶫ : TYPE.
Proof.
refine (ret (exist _ _ TYPE _)).
refine (fun T => bind T (fun X => X)).
Defined.

Check Typeᶫ : El Typeᶫ.

Definition free A := mkTYPE (M A) (fun b => bind b (fun X => X)).

Definition pbind {A} {B : A -> El Typeᶫ} (x : M A) (f : forall x : A, El (B x)) : El (hbind x B) :=
match x.(prf) as p return El (hbind (pair x.(wit) p) B) with
| nil _ => f x.(wit)
| _ => (B _).(wit).(prf) (pair (f x.(wit)) x.(prf))
end.

Definition Prodᶫ (A : TYPE) (B : El A -> TYPE) : TYPE.
Proof.
refine (ret (exist _ _ (forall x : El A, El (B x)) _)).
refine (fun f x => hbind f (fun f => f x)).
Defined.

Notation "A →ᶫ B" := (Prodᶫ A (fun _ => B)) (at level 99, right associativity, B at level 200).
Notation "'Πᶫ'  x .. y , P" := (Prodᶫ _ (fun x => .. (Prodᶫ _ (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity).

Definition Lamᶫ {A B} (f : forall x : El A, El (B x)) : El (Prodᶫ A B) := f.
Definition Appᶫ {A B} (f : El (Prodᶫ A B)) (x : El A) := f x.

Definition pbind' {A R}
  {B : A -> El (R  →ᶫ Typeᶫ)}
  (x : M A) (r : El R) (f : forall x : A, El (B x r)) : El (hbind x B r) :=
match x.(prf) as p return El (hbind (pair x.(wit) p) B r) with
| nil _ => f x.(wit)
| _ => (B _ _).(wit).(prf) (pair (f x.(wit)) x.(prf))
end.

Definition boolᶫ : TYPE.
Proof.
refine (ret (exist _ _ (M bool) _)).
refine (fun b => bind b (fun b => b)).
Defined.

Definition trueᶫ : El boolᶫ := ret true.
Definition falseᶫ : El boolᶫ := ret false.

Definition bool_caseᶫ (P : TYPE) (Pt : El P) (Pf : El P) (b : El boolᶫ) : El P :=
  hbind b (fun b => if b then Pt else Pf).

Check (eq_refl : (fun P Pt Pf => bool_caseᶫ P Pt Pf trueᶫ) = (fun P Pt Pf => Pt)).
Check (eq_refl : (fun P Pt Pf => bool_caseᶫ P Pt Pf falseᶫ) = (fun P Pt Pf => Pf)).

Definition θ_bool (n : El boolᶫ) : (El boolᶫ -> El Typeᶫ) -> El Typeᶫ :=
  bool_caseᶫ ((boolᶫ →ᶫ Typeᶫ) →ᶫ Typeᶫ) (fun k => k trueᶫ) (fun k => k falseᶫ) n.

Definition bool_recᶫ (P : El boolᶫ -> TYPE)
  (Pt : El (P trueᶫ)) (Pf : El (P falseᶫ)) (b : El boolᶫ) : El (bool_caseᶫ Typeᶫ (P trueᶫ) (P falseᶫ) b) :=
  pbind b (bool_rec _ Pt Pf).

Check (eq_refl : (fun P Pt Pf => bool_recᶫ P Pt Pf trueᶫ) = (fun P Pt Pf => Pt)).
Check (eq_refl : (fun P Pt Pf => bool_recᶫ P Pt Pf falseᶫ) = (fun P Pt Pf => Pf)).

Inductive nat_ :=
| O_ : nat_
| S_ : M nat_ -> nat_.

Definition natᶫ : TYPE := mkTYPE (M nat_) (fun l => bind l (fun n => n)).

Definition Oᶫ : El natᶫ := ret O_.
Definition Sᶫ : El (natᶫ →ᶫ natᶫ) := fun n => ret (S_ n).

Definition nat_caseᶫ (P : TYPE) (P0 : El P) (PS : El natᶫ -> El P -> El P) (n : El natᶫ) : El P.
Proof.
refine (hbind n (fun n => _)).
refine ((fix F n := match n return El P with O_ => P0 | S_ n => PS n (hbind n F) end) n).
Defined.

Check (eq_refl : (fun P P0 PS n => nat_caseᶫ P P0 PS Oᶫ) = (fun P P0 PS n => P0)).
Check (eq_refl : (fun P P0 PS n => nat_caseᶫ P P0 PS (Sᶫ n)) = (fun P P0 PS n => PS n (nat_caseᶫ P P0 PS n))).

Definition θ_nat (n : El natᶫ) : (El natᶫ -> El Typeᶫ) -> El Typeᶫ :=
  nat_caseᶫ ((natᶫ →ᶫ Typeᶫ) →ᶫ Typeᶫ) (fun k => k Oᶫ) (fun _ r k => r (fun n => k (Sᶫ n))) n.

Definition nat_rectᶫ (P : El natᶫ -> TYPE) (P0 : El (P Oᶫ)) (PS : forall n : El natᶫ, El (θ_nat n P) -> El (θ_nat (Sᶫ n) P)) (n : El natᶫ) :
  El (θ_nat n P).
Proof.
refine (pbind' n _ (fun n => _)).
match goal with [ |- El (?X n P) ] => set (K := X) end.
refine ((fix F n := match n return El (K n P) with O_ => P0 | S_ n => PS n _ end) n).
refine (@pbind' nat_ (Πᶫ _ : El natᶫ, Typeᶫ) _ n P F).
Defined.

Check (eq_refl : (fun P P0 PS n => nat_rectᶫ P P0 PS Oᶫ) = (fun P P0 PS n => P0)).
Check (eq_refl : (fun P P0 PS n => nat_rectᶫ P P0 PS (Sᶫ n)) = (fun P P0 PS n => PS n (nat_rectᶫ P P0 PS n))).

(** Proving that linear terms commute with storage operators *)

Inductive box (A : TYPE) := Box : El A -> box A.

Definition boxᶫ (A : TYPE) : TYPE :=
  mkTYPE (M (box A)) (fun b => bind b (fun b => b)).

Definition Boxᶫ (A : TYPE) (x : El A) : El (boxᶫ A) := ret (Box _ x).

Definition box_rectᶫ (A : TYPE) (P : TYPE) (pb : El A -> El P) (b : El (boxᶫ A)) : El P :=
  hbind b (fun b => box_rect A (fun _ => El P) pb b).

(** Linear definition taken from Paul Blain Levy last POPL article. *)
Definition linear {A B} (f : El (A →ᶫ B)) : Prop :=
  forall b : El (boxᶫ A), f (box_rectᶫ _ _ (fun x => x) b) = box_rectᶫ _ _ f b.


Require Import String.
Require Import Ascii.
Require Import BinaryString.
Require Import Decimal.
Require Import Dec.

Require Import DecimalZ.
Require Import BinInt.

Fixpoint uint_to_string (x: uint) : string :=
	match x with
	| D0 y => String "0" (uint_to_string y)
	| D1 y => String "1" (uint_to_string y)
	| D2 y => String "2" (uint_to_string y)
	| D3 y => String "3" (uint_to_string y)
	| D4 y => String "4" (uint_to_string y)
	| D5 y => String "5" (uint_to_string y)
	| D6 y => String "6" (uint_to_string y)
	| D7 y => String "7" (uint_to_string y)
	| D8 y => String "8" (uint_to_string y)
	| D9 y => String "9" (uint_to_string y)
	| _ => ""
	end.

Definition int_to_string (x: int) : string :=
	match x with
	| Pos y => uint_to_string y
	| Neg y => String "-" (uint_to_string y)
	end.

Definition Z_to_string (x: Z) : string :=
	int_to_string (Z.to_int x).

Fixpoint uint_of_string (s: string) : uint :=
	match s with
	| String "0" t => D0 (uint_of_string t)
	| String "1" t => D1 (uint_of_string t)
	| String "2" t => D2 (uint_of_string t)
	| String "3" t => D3 (uint_of_string t)
	| String "4" t => D4 (uint_of_string t)
	| String "5" t => D5 (uint_of_string t)
	| String "6" t => D6 (uint_of_string t)
	| String "7" t => D7 (uint_of_string t)
	| String "8" t => D8 (uint_of_string t)
	| String "9" t => D9 (uint_of_string t)
	| _ => Nil
	end.

Definition int_of_string (s: string) : int :=
	match s with
	| String "-" t => Neg (uint_of_string t)
	| _ => Pos (uint_of_string s)
	end.

Definition Z_of_string (s: string) : Z :=
	Z.of_int (int_of_string s).

Lemma uint_string (x: uint) : uint_of_string (uint_to_string x) = x.
Proof.
induction x; simpl; try easy; now rewrite IHx.
Qed.

Lemma int_string (x: int) : int_of_string (int_to_string x) = x.
Proof.
case x; intro d.
+ simpl.
	case_eq (uint_to_string d); intros.
	- simpl; f_equal.
		case_eq d; intros; try trivial; rewrite H0 in H; simpl in H; inversion H.
	- destruct a; subst; unfold int_of_string.
		destruct b; [ | now rewrite <- H, uint_string ].
		destruct b0; [ now rewrite <- H, uint_string | ].
		destruct b1; [ | now rewrite <- H, uint_string ].
		destruct b2; [ | now rewrite <- H, uint_string ].
		destruct b3; [ now rewrite <- H, uint_string | ].
		destruct b4; [ | now rewrite <- H, uint_string ].
		destruct b5; [ now rewrite <- H, uint_string | ].
		destruct b6; [ now rewrite <- H, uint_string | ].
		now destruct d.
+ now simpl; rewrite uint_string.
Qed.

Theorem Z_string (x : Z) : Z_of_string (Z_to_string x) = x.
Proof.
unfold Z_to_string.
unfold Z_of_string.
rewrite int_string.
apply of_to.
Qed.

Definition is_int (s : string) := int_to_string (int_of_string s) = s.
Definition is_uint (s : string) := uint_to_string (uint_of_string s) = s.
Definition is_Z (s : string) := Z_to_string (Z_of_string s) = s.

Lemma DecidableIsUint (s : string) : Decidable (is_uint s).
Proof.
induction s.
+ now left.
+ destruct a.
	destruct b; destruct b0; destruct b1; destruct b2; destruct b3;
	destruct b4; destruct b5; destruct b6; try (now right);
	destruct IHs;
		try (now left; unfold is_uint; cbn; rewrite H);
		try (now right; intro Hf; apply H; inversion Hf).
Qed.

Lemma DecidableIsInt (s : string) : (Decidable (is_int s)).
Proof.
destruct s.
+ now left.
+ destruct a.
	destruct b; destruct b0; destruct b1; destruct b2; destruct b3;
	destruct b4; destruct b5; destruct b6; try (now right); destruct (DecidableIsUint s);
		try (now left; unfold is_int; cbn; f_equal);
		try (now right; intro Hf; apply H; inversion Hf).
Qed.


Require Import SyntaxProp.
Require Export Dynamic.
Require Import Shared.

(*
=====
step
=====
*)

(*
Lemma step_done :
  forall P cfg,
    cfg_done cfg ->
    ~ exists cfg', P / cfg ==> cfg'.
Proof with auto.
  intros P [[[H V] n] T] cfgDone.
  simpls.
  destruct T...
  simpls.
  destruct e...
  intros contra. destruct contra as [cfg' Hstep].
  inv Hstep;
    match goal with
        Hctx : is_econtext _ |- _ =>
        inv Hctx
    end; congruence.
Qed.

Lemma step_irreflexive :
  forall P cfg,
    ~ P / cfg ==> cfg.
Proof with auto.
  intros P [[[H V] n] T].
  induction T; try(contra)...
  induction e; intros contra;
  inversion contra; try(omega); subst;
  match goal with
    | [Hctx : is_econtext _ |- _ ] => inv Hctx
  end; congruence.
Qed.
*)

Lemma step_n_monotonic :
  forall P H H' V V' n n' T T',
    P / (H, V, n, T) ==> (H', V', n', T') ->
    n <= n'.
Proof with eauto.
  introv Hstep.
  gen T'.
  induction T as [| |]; intros; inv Hstep...
  gen e'.
  induction e0; introv Hstep;
  inv Hstep; try(malformed_context);
  try(inv_eq)...
Qed.


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

From Coq Require Import Lexicographic_Exponentiation Relation_Definitions.
From Coq Require Import Inverse_Image Inclusion List Relation_Operators.
From Buchberger Require Import Relation_Operators_compat Monomials.
From Buchberger Require Import Term CoefStructure OrderStructure.

Set Default Proof Using "Type".

Section Porder.
Load hCoefStructure.
Load hOrderStructure.
Load hTerm.

Set Implicit Arguments.
Unset Strict Implicit.

Definition ltT (a b : Term A n) : Prop := ltM (T2M a) (T2M b).

Local Hint Unfold ltT : core.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem ltT_trans : transitive (Term A n) ltT.
Proof using os.
unfold transitive, ltT in |- *; auto.
intros x y z H' H'0; apply (ltM_trans _ _ _ _ os) with (y := T2M y); auto.
Qed.

Lemma eqT_compat_ltTr :
 forall a b c : Term A n, eqT b c -> ltT a b -> ltT a c.
Proof.
unfold eqT in |- *; unfold ltT in |- *; intros a b c H; rewrite H; auto.
Qed.

Lemma eqT_compat_ltTl :
 forall a b c : Term A n, eqT b c -> ltT b a -> ltT c a.
Proof.
unfold eqT in |- *; unfold ltT in |- *; intros a b c H; rewrite H; auto.
Qed.

Definition eqT_dec : forall x y : Term A n, {eqT x y} + {~ eqT x y}.
intros x y; unfold eqT in |- *; simpl in |- *; auto.
apply eqmon_dec.
Defined.

Definition ltT_dec : forall x y : Term A n, {ltT x y} + {ltT y x} + {eqT x y}.
intros x y; exact (ltM_dec (T2M x) (T2M y)).
Defined.

Lemma ltT_not_eqT : forall x y : Term A n, eqT x y -> ~ ltT x y.
Proof using os.
unfold eqT, ltT in |- *; simpl in |- *; intros x y H; rewrite H; auto.
apply ltM_nonrefl with (1 := os).
Qed.

Lemma eqT_not_ltT : forall x y : Term A n, ltT x y -> ~ eqT x y.
Proof using os.
unfold eqT, ltT, not in |- *; simpl in |- *; intros x y H Q;
 absurd (ltM (T2M x) (T2M y)); auto; rewrite Q; auto.
apply ltM_nonrefl with (1 := os).
Qed.

Theorem ltT_not_refl : forall x : Term A n, ~ ltT x x.
Proof using os.
intros x; unfold ltT in |- *; apply ltM_nonrefl with (1 := os).
Qed.

Local Hint Resolve ltT_not_eqT eqT_not_ltT ltT_not_refl : core.

Lemma ltT_not_ltT : forall x y : Term A n, ltT x y -> ~ ltT y x.
Proof using os.
intros x y H'; red in |- *; intros H'0; absurd (ltT x x); auto.
apply ltT_trans with (y := y); auto.
Qed.

Local Hint Resolve ltT_not_ltT : core.

Lemma ltT_eqT :
 forall a b c d : Term A n, eqT a b -> eqT c d -> ltT a c -> ltT b d.
Proof.
unfold eqT, ltT in |- *; intros a b c d R1 R2; rewrite R1; rewrite R2; auto.
Qed.

Let eqT_refl := eqT_refl A n.

Lemma ltT_eqTr : forall a b c : Term A n, eqT a b -> ltT a c -> ltT b c.
Proof.
intros a b c H' H'0; apply ltT_eqT with (a := a) (c := c); auto.
Qed.

Lemma ltT_eqTl : forall a b c : Term A n, eqT a b -> ltT c a -> ltT c b.
Proof.
intros a b c H' H'0; apply ltT_eqT with (a := c) (c := a); auto.
Qed.

Theorem multTerm_ltT_l :
 forall m1 m2 m3,
 ltT m1 m2 -> ltT (multTerm multA m3 m1) (multTerm multA m3 m2).
Proof using os.
intros a b c; case a; case b; case c; unfold ltT in |- *; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 H.
apply ltM_plusl with (1 := os); auto.
Qed.

Theorem multTerm_ltT_r :
 forall m1 m2 m3,
 ltT m1 m2 -> ltT (multTerm multA m1 m3) (multTerm multA m2 m3).
Proof using os.
intros a b c; case a; case b; case c; unfold ltT in |- *; simpl in |- *; auto.
intros; apply ltM_plusr with (1 := os); auto.
Qed.

Theorem T1_is_min_ltT : forall a, ~ ltT a (T1 A1 n).
Proof using os.
intros a; case a; unfold ltT in |- *; simpl in |- *; auto.
intros a0 m; unfold M1 in |- *; apply (M1_min _ _ _ _ os); auto.
Qed.

Theorem minusTerm_ltT_l :
 forall a b c, eqT a b -> ltT a c -> ltT (minusTerm minusA a b) c.
Proof.
intros a b c; case a; case b; case c; unfold ltT in |- *; simpl in |- *; auto.
Qed.

Theorem invTerm_ltT_l : forall a c, ltT a c -> ltT (invTerm invA a) c.
Proof.
intros a b; case a; case b; unfold ltT in |- *; simpl in |- *; auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition pX := cons (A:=Term A n).

Set Strict Implicit.
Unset Implicit Arguments.

Definition pO := nil (A:=Term A n).

Let consA := cons (A:=mon n).

Let nilA := nil (A:=mon n).

Let listA := list (mon n).

Local Hint Unfold consA nilA listA : core.

Fixpoint fP (a : list (Term A n)) : listA :=
  match a with
  | nil => nilA
  | b :: p => consA (T2M b) (fP p)
  end.

Theorem fP_app : forall p q : list (Term A n), fP (p ++ q) = fP p ++ fP q.
intros p; elim p; simpl in |- *; auto.
intros a l H' q.
rewrite (H' q); auto.
Qed.

Let DescA := Desc (mon n) ltM.

Set Implicit Arguments.
Unset Strict Implicit.

Definition olist (p : list (Term A n)) := DescA (fP p).

Local Hint Resolve d_nil d_one : core.
Local Hint Unfold olist DescA : core.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem olistOne : forall a b : Term A n, ltT b a -> olist (pX a (pX b pO)).
Proof.
unfold olist, ltT in |- *; simpl in |- *; auto.
intros a b H'.
generalize (d_conc _ ltM (T2M b) (T2M a) nilA); simpl in |- *; auto.
Qed.

Local Hint Resolve olistOne : core.

Theorem olistO : olist pO.
Proof.
unfold olist, ltT in |- *; simpl in |- *; auto.
red in |- *; unfold nilA in |- *; apply d_nil.
Qed.

Lemma app2_inv :
 forall (x y z t : mon n) (p : listA),
 (p ++ consA x nilA) ++ consA y nilA = consA z (consA t nilA) ->
 x = z /\ y = t.
Proof.
intros x y z t p; case p; simpl in |- *; auto.
intros H'; injection H'; simpl in |- *; auto.
intros a l; case l; simpl in |- *; auto.
intros H'; discriminate H'.
intros a0 l0; case l0; simpl in |- *; auto.
intros H'; discriminate H'.
intros a1 l1 H'; discriminate H'.
Qed.

Theorem olist_ltT :
 forall (l : list (Term A n)) (a b : Term A n),
 olist (l ++ pX a (pX b pO)) -> ltT b a.
Proof.
unfold ltT, olist in |- *; simpl in |- *; auto.
intros l a b.
rewrite (fP_app l (pX a (pX b pO))); simpl in |- *; auto.
intros H'.
elim (dist_Desc_concat _ ltM (fP l) (consA (T2M a) (consA (T2M b) nilA)));
 [ intros H'5 H'6; try exact H'6 | idtac ]; auto.
simple inversion H'6.
discriminate H.
discriminate H.
elim (app2_inv y x (T2M a) (T2M b) l0); [ intros H'8 H'9 | idtac ]; auto.
rewrite H'9; rewrite H'8; auto.
Qed.

Theorem olist_cons :
 forall (l : list _) a b, ltT b a -> olist (pX b l) -> olist (pX a (pX b l)).
Proof.
intros l; pattern l in |- *; apply (rev_ind (A:=Term A n)); auto.
intros x l0; case l0.
simpl in |- *.
unfold olist in |- *; simpl in |- *.
intros H' a b H'0 H'1; try assumption.
apply (d_conc _ ltM (T2M x) (T2M b) (consA (T2M a) nilA)).
generalize (olist_ltT pO); unfold ltT, olist in |- *; simpl in |- *; auto.
apply (olistOne a b); auto.
intros b l1 H' a b0 H'0; generalize H'; pattern l1 in |- *;
 apply (rev_ind (A:=Term A n)); unfold ltT, olist in |- *;
 simpl in |- *; auto.
intros H'2 H'3.
apply (d_conc _ ltM (T2M x) (T2M b) (consA (T2M a) (consA (T2M b0) nilA)));
 auto.
generalize (olist_ltT (b0 :: nil)); unfold ltT, olist in |- *; simpl in |- *;
 auto.
simpl in |- *; apply H'2; auto.
apply (desc_prefix _ ltM (consA (T2M b0) (consA (T2M b) nilA)) (T2M x)); auto.
intros x1 l2; rewrite (fP_app (l2 ++ x1 :: nil) (x :: nil));
 rewrite (fP_app l2 (x1 :: nil)); rewrite (fP_app l2 (x :: nil)).
intros H'2 H'3 H'4;
 apply
  (d_conc _ ltM (T2M x) (T2M x1)
     (consA (T2M a) (consA (T2M b0) (consA (T2M b) (fP l2))))).
generalize (olist_ltT (pX b0 (pX b l2))); unfold olist, ltT in |- *;
 intros H'5; apply H'5.
rewrite (fP_app (pX b0 (pX b l2)) (pX x1 (pX x pO))); simpl in |- *; auto.
generalize (app_ass (fP l2) (consA (T2M x1) nilA) (consA (T2M x) nilA));
 simpl in |- *; auto; unfold consA in |- *.
intros H'6; rewrite <- H'6; simpl in |- *; auto.
simpl in |- *; apply H'3; auto; apply (desc_prefix _ ltM) with (a := T2M x);
 auto.
Qed.

Lemma fp_tail : forall x p, fP (p ++ x :: nil) = fP p ++ T2M x :: nil.
Proof.
intros x p; elim p; simpl in |- *; auto.
intros a l H'; rewrite H'; auto.
Qed.

Lemma descA_subst : forall a b : listA, b = a -> DescA a -> DescA b.
Proof.
intros a b H'; rewrite H'; auto.
Qed.

Theorem olist_pX_eqT :
 forall a b p, olist (pX a p) -> eqT a b -> olist (pX b p).
Proof.
unfold olist, eqT in |- *.
simpl in |- *; auto.
intros a b p H' H'0; rewrite <- H'0; auto.
Qed.

Theorem olist_pX_order : forall l a b, olist (pX a (pX b l)) -> ltT b a.
Proof.
intros l a b H'.
elim (dist_Desc_concat _ ltM (consA (T2M a) (consA (T2M b) nilA)) (fP l));
 [ intros H'5 H'6 | idtac ]; auto.
apply olist_ltT with (l := pO); auto.
Qed.

Theorem olist_X : forall (l : list _) a, olist (pX a l) -> olist l.
Proof.
intros l a H'.
elim (dist_Desc_concat _ ltM (consA (T2M a) nilA) (fP l));
 [ intros H'5 H'6 | idtac ]; auto.
Qed.

Theorem olist_imp_olist :
 forall l a b, olist (pX a (pX b l)) -> olist (pX a l).
Proof using os.
intros l; case l.
intros a b H'.
elim (dist_Desc_concat _ ltM (consA (T2M a) nilA) (consA (T2M b) nilA));
 [ intros H'5 H'6 | idtac ]; auto.
intros b l0 a b0 H'.
apply olist_cons; auto.
apply ltT_trans with (y := b0).
apply olist_pX_order with (l := l0); auto.
apply olist_X with (a := a); auto.
apply olist_pX_order with (l := b :: l0); auto.
apply olist_X with (a := b0); auto.
apply olist_X with (a := a); auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Inductive ltP : list (Term A n) -> list (Term A n) -> Prop :=
  | ltPO : forall x p, ltP pO (pX x p)
  | ltP_hd : forall x y p q, ltT x y -> ltP (pX x p) (pX y q)
  | ltP_tl : forall x y p q, eqT x y -> ltP p q -> ltP (pX x p) (pX y q).

Set Strict Implicit.
Unset Implicit Arguments.

Lemma fltP : forall p q, ltP p q -> Ltl _ ltM (fP p) (fP q).
Proof.
intros p q H'; elim H'; auto.
simpl in |- *; intros; apply (Lt_nil (mon n)); auto.
simpl in |- *; intros; apply (Lt_hd (mon n)); auto.
simpl in |- *; unfold eqT in |- *; (intros x y p1 q1 H; rewrite H).
simpl in |- *; intros; apply (Lt_tl (mon n)); auto.
Qed.

Local Hint Resolve fltP : core.

Theorem ltp_not_refl : forall x, ~ ltP x x.
Proof using os.
intros x; elim x.
red in |- *; intros H'; inversion H'.
intros a l H'; red in |- *; intros H'0; simple inversion H'0.
discriminate H.
injection H1.
injection H0.
intros H'1 H'2 H'3 H'4; rewrite H'2; rewrite H'4; intros H'5.
apply (ltT_not_refl a); auto.
injection H1; injection H2.
intros H'1 H'2 H'3 H'4; rewrite H'1; rewrite H'3; auto.
Qed.

Local Hint Resolve ltPO : core.

Theorem ltP_trans : forall x y z, ltP x y -> ltP y z -> ltP x z.
Proof using os.
intros x y z H'; generalize z; clear z; elim H'.
intros x0 p z; case z; auto.
intros H'0; inversion H'0.
intros x0 y0 p q H'0 z H'1; simple inversion H'1.
discriminate H.
rewrite <- H1.
intros H'2; try assumption.
apply ltP_hd; auto.
apply ltT_trans with (y := y0); auto.
injection H0.
intros H'3 H'4; rewrite <- H'4; auto.
rewrite <- H2.
intros H'2 H'3; apply ltP_hd; auto.
apply ltT_eqTl with (a := x1); auto.
injection H1.
intros H'4 H'5; rewrite H'5; auto.
intros x0 y0 p q H'0 H'1 H'2 z H'3; simple inversion H'3.
discriminate H.
rewrite <- H1; auto.
intros H'4; apply ltP_hd; auto.
apply ltT_eqTr with (a := y0).
apply (eqT_sym A n); auto.
injection H0.
intros H'5 H'6; rewrite <- H'6; auto.
rewrite <- H2.
intros H'4 H'5; apply ltP_tl; auto.
apply (eqT_trans A n) with (y := x1); auto.
injection H1.
intros H'6 H'7; rewrite H'7; auto.
apply H'2; auto.
injection H1.
intros H'6; rewrite <- H'6; auto.
Qed.

Theorem olist_pX_ltP : forall a p, olist (pX a p) -> ltP p (pX a pO).
Proof.
intros a p; case p; auto.
intros b l H'.
apply ltP_hd; auto.
apply olist_pX_order with (l := l); auto.
Qed.

Theorem ltP_pX_olist :
 forall a p, olist p -> ltP p (pX a pO) -> olist (pX a p).
Proof.
intros a p; case p; auto.
intros H' H'1; unfold olist, DescA, consA in |- *; simpl in |- *;
 unfold consA, nilA in |- *.
apply d_one; auto.
intros b l H' H'0.
apply olist_cons; auto.
simple inversion H'0.
discriminate H.
injection H1; injection H0; intros H'1 H'2 H'3 H'4;
 (rewrite H'2; rewrite H'4); auto.
injection H2; intros H'1 H'2; rewrite H'1; auto.
unfold pO in |- *; intros H'3 H'4; inversion H'4.
Qed.

Theorem ltP_order_comp :
 forall (a b c : Term A n) (p q : list (Term A n)),
 ltP (pX b p) (pX a q) -> ltT a c -> ltT b c.
Proof using os.
intros a b c p q H1; inversion_clear H1.
intros; apply ltT_trans with (y := a); auto.
apply eqT_compat_ltTl.
apply eqT_sym; trivial.
Qed.

Local Hint Resolve ltP_order_comp : core.

Set Implicit Arguments.
Unset Strict Implicit.

Definition nZterm : list (Term A n) -> Prop.
intros H'; elim H'.
exact True.
intros a P1 Rec.
exact (Rec /\ ~ zeroP (A:=A) A0 eqA (n:=n) a).
Defined.

Definition canonical (a : list (Term A n)) : Prop := olist a /\ nZterm a.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem canonical_imp_olist : forall a, canonical a -> olist a.
Proof.
intros a H'; elim H'; auto.
Qed.

Local Hint Resolve canonical_imp_olist : core.

Theorem canonical0 :
 forall a b,
 ltT b a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> canonical (pX a (pX b pO)).
Proof.
intros a b H' H'0 H'1; simpl in |- *; auto.
split; simpl in |- *; auto.
Qed.

Theorem canonical_ltT :
 forall l a b, canonical (l ++ pX a (pX b pO)) -> ltT b a.
Proof.
intros l a b H'; auto.
apply olist_ltT with (l := l); auto.
Qed.

Theorem canonical_nzeroP :
 forall a p, canonical (pX a p) -> ~ zeroP (A:=A) A0 eqA (n:=n) a.
Proof.
intros a p H'; red in |- *; intros H'0; inversion H'.
generalize H0; simpl in |- *; intuition; auto.
Qed.

Theorem canonical_cons :
 forall l a b,
 ltT b a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 canonical (pX b l) -> canonical (pX a (pX b l)).
Proof.
intros l a b H' H'0 H'1; split; simpl in |- *; auto.
apply olist_cons; auto.
repeat split; auto.
inversion H'1; simpl in H0; intuition.
apply canonical_nzeroP with (p := l); auto.
Qed.

Theorem canonical_pX_eqT :
 forall a b p,
 canonical (pX a p) ->
 eqT a b -> ~ zeroP (A:=A) A0 eqA (n:=n) b -> canonical (pX b p).
Proof.
intros a b p H' H'0 H'1.
split; auto.
apply olist_pX_eqT with (a := a); auto.
simpl in |- *; split; auto.
case H'; simpl in |- *; intuition.
Qed.

Theorem canonical_pX_order :
 forall l a b, canonical (pX a (pX b l)) -> ltT b a.
Proof.
intros l a b H'; auto.
apply olist_pX_order with (l := l); auto.
Qed.

Theorem canonical_imp_canonical :
 forall l a, canonical (pX a l) -> canonical l.
Proof.
intros l a H'.
split; auto.
apply olist_X with (a := a); auto.
elim H'; simpl in |- *; intuition.
Qed.

Theorem canonical_skip_fst :
 forall l a b, canonical (pX a (pX b l)) -> canonical (pX a l).
Proof using os.
intros l a b H'; split; auto.
apply olist_imp_olist with (b := b); auto.
inversion H'.
generalize H0; simpl in |- *; intuition.
Qed.

Theorem canonical_pX_ltP : forall a p, canonical (pX a p) -> ltP p (pX a pO).
Proof.
intros a p H'; auto.
apply olist_pX_ltP; auto.
Qed.

Theorem ltP_pX_canonical :
 forall a p,
 canonical p ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> ltP p (pX a pO) -> canonical (pX a p).
Proof using eqA_dec.
intros a p H' H'0 H'1; split; auto.
apply ltP_pX_olist; auto.
inversion H'.
generalize H0 H'0; simpl in |- *; case (zeroP_dec A A0 eqA eqA_dec n a); auto.
Qed.

Theorem not_double_canonical :
 forall (a : Term A n) (p : list (Term A n)), ~ canonical (pX a (pX a p)).
Proof using os.
intros a p; red in |- *; intros H'; try exact H'.
absurd (ltT a a); auto.
apply canonical_pX_order with (l := p); auto.
Qed.

Theorem canonical_imp_in_nzero :
 forall p : list (Term A n),
 canonical p -> forall a : Term A n, In a p -> ~ zeroP (A:=A) A0 eqA (n:=n) a.
Proof.
intros p; elim p; auto.
intros a l H' H'0 a0 H'1; elim H'1; auto.
intros H'2; rewrite <- H'2.
apply canonical_nzeroP with (p := l); auto.
intros H'2; auto.
apply H'; auto.
apply canonical_imp_canonical with (a := a); auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition poly := {a : list _ | canonical a}.

Definition sltP (sa sb : poly) : Prop :=
 let (p, H1) return Prop := sa in let (q, H2) return Prop := sb in ltP p q.

Definition fspoly (sa : poly) : Pow _ ltM :=
 let (p, H) return (Pow _ ltM) := sa in
 exist DescA (fP p) (canonical_imp_olist p H).

Set Strict Implicit.
Unset Implicit Arguments.

Theorem fsltP :
 forall p q : poly, sltP p q -> lex_exp _ ltM (fspoly p) (fspoly q).
Proof.
intros p q; case p; case q; unfold lex_exp in |- *; simpl in |- *; auto.
Qed.

Local Hint Resolve fsltP : core.

Theorem sltp_wf : well_founded sltP.
Proof using os.
lapply (wf_inverse_image poly (Pow _ ltM) (lex_exp _ ltM) fspoly);
 [ intros H'3 | idtac ].
apply
 wf_incl with (R2 := fun x y : poly => lex_exp _ ltM (fspoly x) (fspoly y));
 auto.
red in |- *; auto.
apply (wf_lex_exp _ ltM); auto; apply ltM_wf with (1 := os).
Qed.

End Porder.


(**********************************************************************************
 * PredomSum.v                                                                    *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * July 2010                                                                      *
 * Build with Coq 8.2pl1 plus SSREFLECT                                           *
 **********************************************************************************)

(*==========================================================================
  Definition of co-products and associated lemmas
  ==========================================================================*)
Set Automatic Coercions Import.
Require Import PredomCore.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Unset Automatic Introduction.

(*==========================================================================
  Order-theoretic definitions
  ==========================================================================*)

Section OrdSum.

Variable O1 O2 : ordType.

Lemma sum_ordAxiom : PreOrd.axiom (fun (x y:O1+O2) => match x, y with | inl x, inl y => x <= y | inr x, inr y => x <= y | _,_ =>  False end).
case => x0. split ; first by []. by case => x1 ; case => x2 ; try apply Ole_trans.
split ; first by []. by case => x1 ; case => x2 ; try apply Ole_trans.
Qed.

Canonical Structure sum_ordMixin := OrdMixin sum_ordAxiom.
Canonical Structure sum_ordType := Eval hnf in OrdType sum_ordMixin.

Lemma inl_mono : monotonic (@inl O1 O2).
by move => x y l.
Qed.

Definition Inl : O1 =-> sum_ordType := Eval hnf in mk_fmono inl_mono.

Lemma inr_mono : monotonic (@inr O1 O2).
by move => x y l.
Qed.

Definition Inr : O2 =-> sum_ordType := Eval hnf in mk_fmono inr_mono.

Lemma sum_fun_mono (O3:ordType) (f:O1 =-> O3) (g:O2 =-> O3) : monotonic (fun x => match x with inl x => f x | inr y => g y end).
move => O3 f g. by case => x ; case => y ; try done ; move => X ; apply fmonotonic.
Qed.

Definition Osum_fun (O3:ordType) (f:O1 =-> O3) (g:O2 =-> O3) := Eval hnf in mk_fmono (sum_fun_mono f g).

End OrdSum.

Lemma sumOrdAxiom : @CatSum.axiom _ (sum_ordType) (@Inl) (@Inr) (@Osum_fun).
move => O0 O1 O2 f g. split ; first by split ; apply: fmon_eq_intro.
move => m [A B]. apply: fmon_eq_intro. case => x.
- by apply (fmon_eq_elim A x).
- by apply (fmon_eq_elim B x).
Qed.

Canonical Structure sum_ordCatMixin := sumCatMixin sumOrdAxiom.
Canonical Structure sum_ordCatType := Eval hnf in sumCatType sum_ordCatMixin.

Add Parametric Morphism (D E F:ordType) : (@Osum_fun D E F)
with signature (@Ole _ : (D =-> F) -> (D =-> F) -> Prop) ++> (@Ole _ : (E =-> F) -> (E =-> F) -> Prop) ++>
   (@Ole (sum_ordType _ _ -=> _) : ((D + E) =-> F) -> (_ =-> _) -> Prop)
as Osum_fun_le_compat.
intros f f' lf g g' lg.
simpl. intros x ; case x ; clear x ; auto.
Qed.

Add Parametric Morphism (D E F:ordType) : (@Osum_fun D E F)
with signature (@tset_eq _ : (D =-> F) -> (D =-> F) -> Prop ) ==>
      (@tset_eq _ : (E =-> F) -> (E =-> F) -> Prop) ==> (@tset_eq ((sum_ordType D E) -=> F))
as Osum_fun_eq_compat.
intros f f' lf g g' lg.
simpl. apply fmon_eq_intro.
destruct lg. destruct lf.
intros x ; split ; case x ; clear x ; auto.
Qed.

Section CPOSum.

Variable D1 D2 : cpoType.

Lemma sum_left_mono (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inl D2 d}) :
   monotonic (fun x => match c x with | inl y => y | inr _ => projT1 ex end).
move => c. case => x X. simpl.
move => z z' l. simpl.
have H:= fmonotonic c (leq0n z). have HH:=fmonotonic c (leq0n z').
rewrite -> X in H,HH.
have A:=fmonotonic c l. case: (c z) H A ; last by [].
move => x0 _. by case: (c z') HH.
Qed.

Definition sum_left (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inl D2 d}) : natO =-> D1 :=
   Eval hnf in mk_fmono (sum_left_mono ex).

Lemma sum_right_mono (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inr D1 d}) :
   monotonic (fun x => match c x with | inr y => y | inl _ => projT1 ex end).
move => c. case => x X. simpl.
move => z z' l. simpl.
have H:= fmonotonic c (leq0n z). have HH:=fmonotonic c (leq0n z').
rewrite -> X in H,HH.
have A:=fmonotonic c l. case: (c z) H A ; first by [].
move => x0 _. by case: (c z') HH.
Qed.

Definition sum_right (c:natO =-> sum_ordType D1 D2) (ex:{d| c O = inr D1 d}) : natO =-> D2 :=
   Eval hnf in mk_fmono (sum_right_mono ex).

Definition SuminjProof (c:natO =-> sum_ordType D1 D2) (n:nat) :
      {d | c n = inl D2 d} + {d | c n = inr D1 d}.
move => c n.
case: (c n) => cn.
- left. by exists cn.
- right. by exists cn.
Defined.

Definition sum_lub (c: natO =-> sum_ordType D1 D2) : sum_ordType D1 D2 :=
match (SuminjProof c 0) with
| inl X => (inl D2 (lub (sum_left X)))
| inr X => (inr D1 (lub (sum_right X)))
end.

(*==========================================================================
  Domain-theoretic definitions
  ==========================================================================*)

Lemma Dsum_ub (c : natO =-> sum_ordType D1 D2) (n : nat) : c n <= sum_lub c.
move => c n. have L:=fmonotonic c (leq0n n).
unfold sum_lub. case: (SuminjProof c 0) ; case => c0 e ; rewrite e in L.
-  move: L. case_eq (c n) ; last by []. move => cn e' L. apply: (Ole_trans _ (le_lub _ n)).
  simpl. by rewrite e'.
-  move: L. case_eq (c n) ; first by []. move => cn e' L. apply: (Ole_trans _ (le_lub _ n)).
  simpl. by rewrite e'.
Qed.

Lemma Dsum_lub (c : natO =-> sum_ordType D1 D2) (x : sum_ordType D1 D2) :
   (forall n : natO, c n <= x) -> sum_lub c <= x.
intros c x. case x ; clear x ; intros x cn. unfold sum_lub.
case (SuminjProof c 0).
- intros s. assert (lub (sum_left s) <= x).
  apply (lub_le). intros n. specialize (cn n). destruct s as [d c0].
  simpl. case_eq (c n).
  + intros dn dnl. rewrite dnl in cn. by auto.
  + intros dn cnr. rewrite cnr in cn. by inversion cn.
  by auto.
- intros s. destruct s. simpl. specialize (cn 0). rewrite e in cn. by inversion cn.
- unfold sum_lub. case (SuminjProof c 0) ; first case.
  + move => y e. simpl. specialize (cn 0). rewrite e in cn. by inversion cn.
  + intros s. assert (lub (sum_right s) <= x).
    * apply lub_le. intros n. specialize (cn n). destruct s as [d c0].
      simpl. case_eq (c n).
      - intros dl cnl. rewrite cnl in cn. by inversion cn.
      - intros dl dll. rewrite dll in cn. by auto.
    by auto.
Qed.

Lemma sum_cpoAxiom : CPO.axiom sum_lub.
move => c s n.
split ; first by apply Dsum_ub.
by apply Dsum_lub.
Qed.

Canonical Structure sum_cpoMixin := CpoMixin sum_cpoAxiom.
Canonical Structure sum_cpoType := Eval hnf in CpoType sum_cpoMixin.

(*
(** Printing +c+ %\ensuremath{+}% *)
Infix "+c+" := Dsum (at level 28, left associativity).*)

Variable D3:cpoType.

Lemma SUM_fun_cont (f:D1 =-> D3) (g:D2 =-> D3) : @continuous sum_cpoType _ (Osum_fun f g).
intros f g c. simpl.
case_eq (lub c).
- move => ll sl. unfold lub in sl. simpl in sl. unfold sum_lub in sl. destruct (SuminjProof c 0) ; last by [].
  case: sl => e. rewrite <- e. clear ll e. rewrite -> (fcontinuous f (sum_left s)).
  apply lub_le_compat => n. simpl. case: s => d s. simpl. move: (fmonotonic c (leq0n n)).
  case: (c 0) s ; last by []. move => s e. rewrite -> e ; clear s e. by case: (c n).
- move => ll sl. unfold lub in sl. simpl in sl. unfold sum_lub in sl. destruct (SuminjProof c 0) ; first by [].
  case: sl => e. rewrite <- e. clear ll e. rewrite -> (fcontinuous g (sum_right s)).
  apply lub_le_compat => n. simpl. case: s => d s. simpl. move: (fmonotonic c (leq0n n)).
  case: (c 0) s ; first by []. move => s e. rewrite -> e ; clear s e. by case: (c n).
Qed.

Definition SUM_funX (f:D1 =-> D3) (g:D2 =-> D3) : sum_cpoType =-> D3 := Eval hnf in mk_fcont (SUM_fun_cont f g).
Definition SUM_fun f g := locked (SUM_funX f g).

Lemma SUM_fun_simpl f g x : SUM_fun f g x =-= match x with inl x => f x | inr x => g x end.
move => f g x. unlock SUM_fun. simpl. by case: x.
Qed.

(** printing [| %\ensuremath{[} *)
(** printing |] %\ensuremath{]} *)
(* Notation "'[|' f , g '|]'" := (SUM_fun f g) (at level 30).*)

Lemma Inl_cont : continuous (Inl D1 D2).
move => c. simpl. by apply: lub_le_compat => n.
Qed.

Definition INL : D1 =-> sum_cpoType := Eval hnf in mk_fcont Inl_cont.

Lemma Inr_cont : continuous (Inr D1 D2).
move => c. simpl. by apply: lub_le_compat => n.
Qed.

Definition INR : D2 =-> sum_cpoType := Eval hnf in mk_fcont Inr_cont.

End CPOSum.

Lemma sumCpoAxiom : @CatSum.axiom _ sum_cpoType (@INL) (@INR) (@SUM_fun).
move => D0 D1 D2 f g. split. unlock SUM_fun. apply: (proj1 (@sumOrdAxiom D0 D1 D2 f g)).
move => m. unlock SUM_fun. apply: (proj2 (@sumOrdAxiom D0 D1 D2 f g)).
Qed.

Canonical Structure cpoSumCatMixin := sumCatMixin sumCpoAxiom.
Canonical Structure cpoSumCatType := Eval hnf in sumCatType cpoSumCatMixin.

Lemma SUM_fun_simplx (X Y Z : cpoType) (f:X =-> Z) (g : Y =-> Z) x : [|f,g|] x =-= match x with inl x => f x | inr x => g x end.
move => X Y Z f g. case=> x ; unfold sum_fun ; simpl ; by rewrite SUM_fun_simpl.
Qed.

Definition getmorph (D E : cpoType) (f:D -=> E) : D =-> E := ev << <| const _ f, Id |>.

Lemma SUM_Fun_mon (D E F:cpoType) : monotonic (fun (P:(D -=> F) * (E -=> F)) => [|getmorph (fst P), getmorph (snd P)|]).
move => D E F. case => f g. case => f' g'. case ; simpl => l l' x.
unfold sum_fun. simpl. do 2 rewrite SUM_fun_simpl.
by case x ; [apply l | apply l'].
Qed.

Definition SUM_Funm (D E F:cpoType) : fmono_ordType ((D -=> F) * (E -=> F)) (D + E -=> F) :=
  Eval hnf in mk_fmono (@SUM_Fun_mon D E F).

Lemma SUM_Fon_cont (D E F:cpoType) : continuous (@SUM_Funm D E F).
move => D E F c. simpl. unfold getmorph. unfold sum_fun. simpl.
by case => x ; simpl ; rewrite SUM_fun_simpl ; apply: lub_le_compat => n ; simpl ; rewrite SUM_fun_simpl.
Qed.

Definition SUM_Fun (D E F:cpoType) : ((D -=> F) * (E -=> F)) =-> (D + E -=> F) := Eval hnf in  mk_fcont (@SUM_Fon_cont D E F).
Implicit Arguments SUM_Fun [D E F].

Lemma SUM_Fun_simpl (D E F:cpoType) (f:D =-> F) (g:E =-> F) : SUM_Fun (f,g) =-= SUM_fun f g.
move => D E F f g. apply: fmon_eq_intro => x. simpl. unfold sum_fun. simpl. by do 2 rewrite SUM_fun_simpl.
Qed.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Import Helix.MSigmaHCOL.CType.

Require Import MathClasses.orders.minmax.
Require Import MathClasses.interfaces.canonical_names.

Require Import Helix.HCOL.CarrierType.

(* =CarrierA= as =CarrierType= *)
Module CarrierAasCT <: CType.
  Context `{CAPROPS: CarrierProperties}.

  Definition t := CarrierA.

  Definition CTypeEquiv := CarrierAe.
  Definition CTypeSetoid := CarrierAsetoid.
  Definition CTypeEquivDec := CarrierAequivdec.

  Definition CTypeZero  := CarrierAz.
  Definition CTypeOne   := CarrierA1.
  Definition CTypeZeroOneApart := CarrierA_Z_neq_One.
  Definition CTypePlus := CarrierAplus.

  Definition CTypeNeg   := CarrierAneg.
  Definition CTypeMult  := CarrierAmult.

  Definition CTypeAbs   := abs.
  Definition CTypeZLess := Zless.
  Definition CTypeMin   := @min CarrierA CarrierAle CarrierAledec.
  Definition CTypeMax   := @max CarrierA CarrierAle CarrierAledec.
  Definition CTypeSub   := sub.

  Definition Zless_proper := CarrierType.Zless_proper.
  Definition abs_proper := CarrierAabs_proper.
  Definition plus_proper := CarrierAPlus_proper.
  Definition sub_proper := CarrierA_sub_proper.
  Definition mult_proper := CarrierAmult_proper.
  Definition min_proper := CarrierA_min_proper.
  Definition max_proper := CarrierA_max_proper.

End CarrierAasCT.