From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype prime tuple finfun finset bigop.
Require Import Program JMeq Compare_dec ExtrOcamlNatInt.
Require Import tree_traversal rank_select insert_delete set_clear dynamic.

Set Implicit Arguments.

Tactic Notation "remember_eq" constr(expr) ident(vname) ident(eqname) :=
  case (exist (fun x => x = expr) expr erefl) => vname eqname.

Section dynamic_dependent.
Variable w : nat.
Hypothesis wordsize_gt1: w > 1.

Section insert.

Definition balanceL {nl ml d cl cr nr mr} (p : color) (l : near_tree w nl ml d cl) (r : tree w nr mr d cr) :
  color_ok p (fix_color l) (* important claim! *) ->
  color_ok p cr ->
  {tr : near_tree w (nl + nr) (ml + mr) (incr_black d p) p | dflatteni tr = dflatteni l ++ dflatten r}.

  destruct l as [s1 o1 s2 o2 s3 o3 d' x y z | s o d' c' cc l'].
  (* l is bad *)
  + case: p => //= cpl cpr.
    rewrite -(addnA (s1 + s2)) -(addnA (o1 + o2)).
    exists (Good Black (rnode (bnode x y) (bnode z r))).
    by rewrite /= !catA.
  (* l is good *)
  + case: p => /= cpl cpr; last by exists (Good Black (bnode l' r)).
    case Hc': c' in cpl.
    (* bad pattern (c' and p are red) *)
    - destruct l' as [|s1 o1 s2 o2 d cl' cr' c' w1 w2 l'1 l'2] => //.
      subst c'; destruct cl', cr', cr => //.
      exists (Bad l'1 l'2 r).
      by rewrite /= !catA.
    (* otherwise *)
    - subst c'; destruct cr => //.
      by exists (Good Red (rnode l' r)).
Defined.

Definition balanceR {nl ml d cl cr nr mr} (p : color) (l : tree w nl ml d cl) (r : near_tree w nr mr d cr):
  color_ok p cl ->
  color_ok p (fix_color r) ->  (* important claim! *)
  {tr : near_tree w (nl + nr) (ml + mr) (incr_black d p) p | dflatteni tr = dflatten l ++ dflatteni r}.

  destruct r as [s1 o1 s2 o2 s3 o3 d' x y z | s o d' c' cc r'].
  (* r is bad *)
  + case: p => //= cpl cpr.
    rewrite -!addnA [nl + (s1 + (s2 + s3))]addnA [ml + (o1 + (o2 + o3))]addnA.
    exists (Good Black (rnode (bnode l x) (bnode y z))).
    by rewrite /= !catA.
  (* r is good *)
  + case: p => /= cpl cpr; last by exists (Good Black (bnode l r')).
    case Hc': c' in cpr.
    (* bad pattern (c' and p are red) *)
    - destruct r' as [|s1 o1 s2 o2 d cl' cr' c' w1 w2 r'1 r'2] => //=.
      subst c'; destruct cl', cr', cl => //.
      rewrite !addnA.
      by exists (Bad l r'1 r'2).
    (* otherwise *)
    - subst c'; destruct cl => //.
      by exists (Good Red (rnode l r')).
Defined.

Program Fixpoint dinsert' {n m d c} (B : tree w n m d c) (b : bool) i
        {measure (size_of_tree B)} : { B' : near_tree w n.+1 (m + b) d c
                            | dflatteni B' = insert1 (dflatten B) b i } :=
  match B with
  | Leaf s _ _ =>
    let s' := insert1 s b i in
    match size s' == 2 * (w ^ 2) with
    | true => let n  := (size s') %/ 2 in
              let sl := take n s' in
              let sr := drop n s' in
              Good c (rnode (Leaf _ sl _ _) (Leaf _ sr _ _))
    | false => Good c (Leaf _ s' _ _)
    end
  | Node s1 o1 s2 o2 d cl cr _ okl okr l r =>
    if i < s1
    then proj1_sig (balanceL c (dinsert' l b i) r _ okr)
    else proj1_sig (balanceR c l (dinsert' r b (i - s1)) okl _)
  end.

  Next Obligation.
    move/eqP/eqnP : Heq_anonymous => /=.
    rewrite size_take size_insert1.
    move => H.
    rewrite H.
    case: ifP => H2. by rewrite mulKn // leq_div //.
    have H3 : w ^ 2 %/ 2 <= w ^ 2. by rewrite leq_div.
    have H4 : w ^ 2 <= 2 * w ^ 2. by rewrite leq_pmull.
    by move:(leq_trans H3 H4).
  Qed.

  Next Obligation.
    move/eqP/eqnP : Heq_anonymous => /=.
    rewrite size_take size_insert1.
    move => H.
    rewrite H mulnC.
    case: ifP => //.
    rewrite mulnK //.
    have H2 : w ^ 2 > 0. by rewrite expn_gt0 wordsize_gt0.
    have H3 : w ^ 2 < w ^ 2 * 2. by rewrite -{1}[w ^ 2]muln1 ltn_mul2l H2 /=.
    by rewrite H3.
  Qed.

  Next Obligation.
    move/eqP/eqnP : Heq_anonymous => /=.
    rewrite size_drop size_insert1.
    move => H.
    by rewrite H mulKn // mulSn mul1n -addnBA // subnKC // leq_div.
  Qed.

  Next Obligation.
    move/eqP/eqnP : Heq_anonymous => /=.
    rewrite size_drop size_insert1.
    move => H.
    by rewrite H mulKn // mulSn mul1n -addnBA // subnKC // -{1}[w ^ 2]addn0 ltn_add2l expn_gt0 wordsize_gt0.
  Qed.

  Next Obligation. by rewrite -size_cat cat_take_drop size_insert1. Qed.

  Next Obligation.
    rewrite -count_cat cat_take_drop /count_one count_insert1.
    by destruct b.
  Qed.

  Next Obligation.
    rewrite /dflatteni /insert1.
    destruct dinsert'_func_obligation_5, dinsert'_func_obligation_6 => /=.
    by rewrite cat_take_drop.
  Qed.

  Next Obligation.
    rewrite size_insert1.
    by apply: leq_trans.
  Qed.

  Next Obligation.
    move/eqP/eqnP/eqP: Heq_anonymous => /=.
    rewrite size_insert1 neq_ltn.
    case/orP => //.
    by rewrite ltnNge wildcard'0.
  Qed.

  Next Obligation. by rewrite size_insert1. Qed.

  Next Obligation. rewrite /count_one count_insert1. by destruct b. Qed.

  Next Obligation.
    rewrite /dflatteni /insert1.
    by destruct dinsert'_func_obligation_11, dinsert'_func_obligation_12, dinsert'_func_obligation_13 => /=.
  Qed.

  Next Obligation.
    apply /ltP; by rewrite -Heq_B /= -[X in X < _]addn0 ltn_add2l size_of_tree_pos.
  Qed.

  Next Obligation. by destruct dinsert',x,c. Qed.

  Next Obligation.
    apply /ltP; by rewrite -Heq_B /= -[X in X < _]add0n ltn_add2r size_of_tree_pos.
  Qed.

  Next Obligation. by destruct dinsert',x,c. Qed.

  Next Obligation. by rewrite -addn1 -[RHS]addn1 addnA. Qed.

  Next Obligation. by rewrite [o2 + b]addnC addnA. Qed.

  Next Obligation. by rewrite -[RHS]addnA [o2 + b]addnC addnA. Qed.

  Next Obligation.
    case: ifP => /= H.
    - set B' := balanceL _ _ _ _ _.
      destruct dinsert'_func_obligation_23.
      rewrite (proj2_sig B') {B'}.
      destruct dinsert' => /=.
      by rewrite e /insert1 /insert take_cat drop_cat size_dflatten H -!catA.
    - set B' := balanceR _ _ _ _ _.
      rewrite /dflatteni /eq_rect => /=.
      destruct dinsert'_func_obligation_23, dinsert'_func_obligation_22, dinsert'_func_obligation_21.
      rewrite -/(dflatteni (proj1_sig B')) (proj2_sig B') {B'}.
      destruct dinsert' => /=.
      by rewrite e /insert1 /insert take_cat drop_cat size_dflatten H -!catA.
  Qed.

Definition dinsert n m d c (B : tree w n m d c) (b : bool) (i : nat) :=
  fix_near_tree (proj1_sig (dinsert' B b i)).

Lemma dinsertK n m d c (B : tree w n m d c) b i :
  dflatten (dinsert B b i) = insert1 (dflatten B) b i.
Proof. by rewrite /dinsert fix_near_treeK (proj2_sig (dinsert' B b i)). Qed.

End insert.

Section query.

Fixpoint daccess {n m d c} (tr : tree w n m d c) i :=
  match tr with
  | Leaf s _ _ => nth false s i
  | Node lnum _ _ _ _ _ _ _ _ _ l r =>
    if i < lnum
    then daccess l i
    else daccess r (i - lnum)
  end.

Fixpoint drank {n m d c} (tr : tree w n m d c) i :=
  match tr with
  | Leaf s _ _ => rank true i s
  | Node lnum lones rnum rones _ _ _ _ _ _ l r =>
    if i < lnum
    then drank l i
    else lones + drank r (i - lnum)
  end.

Fixpoint dselect_0 {n m d c} (tr : tree w n m d c) i :=
  match tr with
  | Leaf s _ _ => select false i s
  | Node s1 o1 s2 o2 _ _ _ _ _ _ l r =>
    let zeroes := s1 - o1
    in if i <= zeroes
    then dselect_0 l i
    else s1 + dselect_0 r (i - zeroes)
  end.

Fixpoint dselect_1 {n m d c} (tr : tree w n m d c) i :=
  match tr with
  | Leaf s _ _ => select true i s
  | Node s1 o1 s2 o2 _ _ _ _ _ _ l r =>
    if i <= o1
    then dselect_1 l i
    else s1 + dselect_1 r (i - o1)
  end.

Definition access (s : seq bool) i := nth false s i.

Lemma daccessK nums ones d c (B : tree w nums ones d c) :
  daccess B =1 access (dflatten B).
Proof.
  rewrite /access.
  elim: B => //= lnum o1 s2 o2 d0 cl cr c0 i i0 l IHl r IHr x.
  by rewrite nth_cat size_dflatten -IHl -IHr.
Qed.

Lemma drankK nums ones d c (B : tree w nums ones d c) i :
  drank B i = rank true i (dflatten B).
Proof.
  elim: B i => //= lnum o1 s2 o2 d0 cl cr c0 i i0 l IHl r IHr x.
  by rewrite rank_cat size_dflatten IHl -IHr -dflatten_rank.
Qed.

Lemma drank_ones num ones d c (B : tree w num ones d c) :
  drank B num = ones.
Proof.
  by rewrite [in RHS](dflatten_rank B) drankK.
Qed.

Lemma dselect1K nums ones d c (B : tree w nums ones d c) i :
  dselect_1 B i = select true i (dflatten B).
Proof.
  elim: B i => //= lnum o1 s2 o2 d0 cl cr c0 i i0 l IHl r IHr x.
  by rewrite select_cat -dflatten_ones IHl IHr size_dflatten.
Qed.

Lemma dselect0K nums ones d c (B : tree w nums ones d c) i :
  dselect_0 B i = select false i (dflatten B).
Proof.
  elim: B i => //= lnum o1 s2 o2 d0 cl cr c0 i i0 l IHl r IHr x.
  by rewrite select_cat -dflatten_zeroes IHl IHr size_dflatten.
Qed.

End query.

(* Section added by Xuanrui
 * because I wanted to experiment with this version as well...
 *
 * Feel free to comment this out or remove this...
 *)

Section set_clear.

Obligation Tactic := idtac.

Program Fixpoint bset {num ones d c} (B : tree w num ones d c) i
  {measure (size_of_tree B)} :
  { B'b : tree w num (ones + (~~ (daccess B i)) && (i < num)) d c * bool
  | dflatten (fst B'b) = bit_set (dflatten B) i/\snd B'b = ~~ daccess B i } :=
  match B with
  | Leaf s _ _ => (Leaf _ (bit_set s i) _ _, ~~ (access s i))
  | Node lnum lones rnum rones _ _ _ _ col cor l r =>
    match lt_dec i lnum with
    | left H =>
      let x := bset l i
      in (Node col cor x.1 r, x.2)
    | right H =>
      let x := bset r (i - lnum)
      in (Node col cor l x.1, x.2)
    end
  end.

  Next Obligation. intros. by rewrite size_bit_set. Qed.

  Next Obligation. intros. by rewrite size_bit_set. Qed.

  Next Obligation. intros; apply: size_bit_set. Qed.

  Next Obligation.
    intros; case Hi: (i < size s).
    rewrite /count_one /daccess (count_bit_set false). by rewrite andbT addnC.
    by rewrite Hi.
    rewrite andbF addn0. by rewrite /count_one /daccess bit_set_over //= leqNgt Hi.
  Qed.

  Next Obligation.
    intros; subst; split => //.
    by destruct bset_func_obligation_4 , bset_func_obligation_3 => /=.
  Qed.

  Next Obligation.
    intros; subst. apply /ltP.
    by rewrite -addn1 leq_add2l size_of_tree_pos.
  Qed.

  Next Obligation.
    intros; move/ltP: (H) => Hi /=.
    by rewrite Hi (ltn_addr _ Hi) addnAC.
  Qed.

  Next Obligation.
    split; last first.
      destruct bset as [[l' flip][Hl' Hf]] => /=.
      move/ltP: (H) => ->.
      by rewrite -Hf.
    move=> /=.
    move: (lones + rones + _) (bset_func_obligation_7 _ _ _ _ _ _) => ones' Ho.
    destruct Ho => /=.
    destruct bset as [[l' flip][Hl' Hf]] => /=.
    rewrite /= in Hl'.
    move/ltP: (H).
    rewrite Hl' /bit_set update_cat {1}(size_dflatten l) => Hi.
    by rewrite ifT.
  Qed.

  Next Obligation.
    intros; subst. apply /ltP.
    by rewrite -add1n leq_add2r size_of_tree_pos.
  Qed.

  Next Obligation.
    intros; move/ltP: (H) => Hi /=.
    rewrite -if_neg Hi !addnA.
    by rewrite -(ltn_add2l lnum) subnKC // leqNgt.
  Qed.

  Next Obligation.
    split; last first.
      destruct bset as [[r' flip][Hr' Hf]] => /=.
      move/ltP: (H) => Hi.
      by rewrite -if_neg Hi -Hf.
    move=> /=.
    move: (lones + rones + _) (bset_func_obligation_10 _ _ _ _ _ _) => ones' Ho.
    destruct Ho => /=.
    destruct bset as [[r' flip][Hr' Hf]] => /=.
    rewrite /= in Hr'.
    move/ltP: (H).
    rewrite Hr' /bit_set update_cat (size_dflatten l) => Hi.
    by rewrite -if_neg Hi.
  Qed.

  Next Obligation. intuition. Qed.

End set_clear.

Section delete.

  Lemma count_delete {arr i} : count_one arr - nth false arr i = count_one (delete arr i).
  Proof.
    case_eq (i < (size arr)) => H.
     rewrite -(cat_take_drop i arr) /delete /count_one !count_cat cat_take_drop (drop_nth false) // -/(cat [:: nth false arr i] _) count_cat /= addn0.
     case: (nth false arr i) => /=.
      by rewrite [1 + _]addnC addnA addn1 subn1 -[_.+1]subn0 subSKn subn0.
     by rewrite add0n subn0.
    rewrite ltnNge in H.
    move/negPn : H => H.
    rewrite nth_default /count_one /delete // take_oversize // drop_oversize.
     by rewrite count_cat /= addn0 subn0.
    by apply: leqW.
  Qed.

  Lemma delete_oversize {arr : seq bool} {i} : size arr <= i -> arr = delete arr i.
  Proof.
    move => H.
    rewrite /= /delete take_oversize // drop_oversize.
     by rewrite cats0.
     by apply: leqW.
  Qed.

  Lemma daccess_default {n m d c} (tr : tree w n m d c) : forall(i : nat), n <= i -> (daccess tr i) = false.
  Proof.
    elim: tr => /=. intros; by rewrite nth_default //.
    intros.
    case: ifP => H2.
     move: (ltn_addr s2 H2) => H3.
     move: (leq_ltn_trans H1 H3).
     by rewrite ltnn.
    move: (leq_sub2r s1 H1).
    rewrite addKn => H3.
    by apply: (H0 (i1 - s1) H3).
  Qed.

  (* NB: move? *)
  Lemma sizeW (arr : seq bool) : w ^ 2 %/ 2 <= size arr -> 0 < size arr.
  Proof.
    move/eqP: (wordsize_sqrn_div2_neq0 _ wordsize_gt1).
    rewrite -lt0n => ltn1.
    rewrite leq_eqVlt.
    case/orP => eq2. move/eqP: eq2 => eq2. by rewrite eq2 in ltn1.
    exact: (ltn_trans ltn1 eq2).
  Qed.

  Lemma delete_cat {arr arr' : seq bool} {i} : delete (arr ++ arr') i = (if i < size arr then delete arr i ++ arr' else arr ++ delete arr' (i - (size arr))).
  Proof.
    rewrite /delete take_cat -catA.
    case: ifP => H.
     rewrite drop_cat.
     case: ifP => // H2.
     move: (negbT H2).
     rewrite -leqNgt => H3.
     have H4 : i.+1 = size arr. apply/eqP. rewrite eqn_leq. by apply/andP.
     by rewrite H4 subnn drop0 drop_oversize //.
    rewrite drop_cat.
    case: ifP => H2. move: (ltnW H2). by rewrite H.
    move: (negbT H) (negbT H2).
    rewrite -!leqNgt => H3 H4.
    by rewrite catA subSn //.
  Qed.

  Lemma addnBAC a b c : a >= c -> (a + b) - c = (a - c) + b.
  Proof. by move => ?; rewrite addnC -addnBA // addnC. Qed.

  Lemma cons_head_behead (arr: seq bool) : (size arr) > 0 -> (access arr 0) :: (behead arr) = arr.
  Proof. case: arr => /= //. Qed.

  Lemma cat_head_behead (arr arr' : seq bool) : 0 < size arr' -> (rcons arr (access arr' 0)) ++ (delete arr' 0) = arr ++ arr'.
  Proof. move => H. rewrite !cat_rcons -!cat_cons take0 drop1 /= cons_head_behead //. Qed.

  Lemma cat_last_belast (arr arr' : seq bool) : 0 < size arr -> (delete arr (size arr).-1) ++ ((access arr (size arr).-1) :: arr') = arr ++ arr'.
  Proof.
    move => H.
    rewrite /delete /access drop_oversize;last by rewrite prednK.
    rewrite cats0.
    move: H.
    elim arr => // /= b arr'' IH.
    case H : (0 < size arr'').
     by rewrite -(IH H); destruct arr''.
    move/negP/negP in H.
    rewrite leqNgt in H.
    move/negPn in H.
    move: H.
    case arr'' => //.
  Qed.

  Lemma cons_delete {i} (arr arr' : seq bool) : 0 < size arr' ->
                                                (rcons (delete arr i) (access arr' 0)) ++ (delete arr' 0) = (delete arr i) ++ arr'.
  Proof. move => H. rewrite !cat_rcons -!catA -cat_cons take0 drop1 /= cons_head_behead //. Qed.

  Lemma size_rcons_delete {arr : seq bool} (i : nat) (b : bool) : i < size arr -> size (rcons (delete arr i) b) = size arr.
  Proof.
    move => G.
    rewrite size_rcons size_delete // -addn1 -subn1 subnK //.
    case_eq i => [H|i' H]. by rewrite H in G.
    rewrite H in G.
    exact: (ltn_trans (ltn0Sn i') G).
  Qed.

  Lemma size_delete1 {arr : seq bool} (i : nat) : size arr = (size (delete arr i)) + (i < size arr).
  Proof.
    case_eq (i < size arr).
     move/idP => G.
     rewrite size_delete // -subn1 /= subnK //.
     case_eq i => [H|i' H]. by rewrite H in G.
     rewrite H in G.
     exact: (ltn_trans (ltn0Sn i') G).
    move/negP/negP => G.
    rewrite -leqNgt in G.
    rewrite /delete take_oversize // drop_oversize // /=;last first. exact: (leqW G).
    by rewrite cats0 addn0.
  Qed.

  Lemma leq_nth_count {i arr} : nth false arr i <= count_one arr.
  Proof.
    rewrite -(cat_take_drop i arr) /count_one count_cat nth_cat size_take.
    case: ifP. case: ifP => H. by rewrite ltnn. by rewrite H.
    case: ifP.
     rewrite subnn nth0 /head /(count_mem _).
     case (drop i arr) => // b.
     destruct b => //.
     case (take i arr) => // b.
     destruct b => // /= l r.
     rewrite add0n addnA ltn_addr // ltn_addl //.
    move/negP/negP => H ?.
    rewrite -leqNgt in H.
    rewrite nth_default;last first. rewrite size_drop. move/eqP: H => H. by rewrite H leq0n.
    by rewrite /= leq0n.
  Qed.

Lemma leq_divn2n_mul2 (a : nat) : a > 0 -> a %/ 2 + a %/ 2 < 2 * a.
Proof.
by move=> ?; rewrite mul2n divn2 addnn ltn_double -{1}(add0n a) avg_ltn_l.
Qed.

  Lemma ltn_subln a b c : c > 0 -> a < b + c = (a - b < c).
  Proof.
    case H1 : (b <= a) => H2. by rewrite -[RHS](ltn_add2r b) subnK // addnC.
    move: H1; rewrite leqNgt; move/negP/negP => H1.
    rewrite ltn_addr //. move: H1.
    case: b => // n H1.
    move/eqP: (ltnW H1) => W.
    by rewrite W H2.
  Qed.

  Lemma ltn_subrn a b c : b > 0 -> a < b + c = (a - c < b).
  Proof. rewrite addnC. exact: (ltn_subln a c b). Qed.

  Lemma sizeW' {s o d c} (tr : tree w s o d c) : s > 0.
  Proof. elim tr; intros; first apply sizeW => //; rewrite ltn_addr //. Qed.

  Inductive near_tree' : nat -> nat -> nat -> color -> Type :=
  | Stay : forall {s o d c} p,
      color_ok c (inv p) ->
      tree w s o d c -> near_tree' s o d p
  | Down : forall {s o d},
      tree w s o d Black -> near_tree' s o d.+1 Black.

  Definition dflatteni' {s o d c} (tr : near_tree' s o d c) :=
    match tr with
    | Stay _ _ _ _ _ _ t => dflatten t
    | Down _ _ _ t =>  dflatten t
   end.

  Definition black_of_red {s o d} (B : tree w s o d Red) : { B' : tree w s o (incr_black d Black) Black | dflatten B' = dflatten B }.

    move: B; move ceq : (Red) => c' B.
    move: B ceq => [//|? ? ? ? ? cl cr c ? ? l r] /= <-.
    by exists (bnode l r).
  Defined.

  Lemma leq_access_count {s o d c} : forall(B : tree w s o d c), forall(i : nat) , i < s -> daccess B i <= o.
  Proof.
    move => B.
    elim B => /=. intros. exact: leq_nth_count.
    move => s1 o1 s2 o2 d' cl cr c' ? ? l IHl r IHr.
    move => i H.
    case: ifP => H'.
    by rewrite (leq_trans (IHl _ H')) // leq_addr.
    rewrite (leq_trans _ (leq_addl _ _)) //.
    move: (IHr (i - s1)).
    rewrite -(ltn_add2r s1) subnK ;last by rewrite leqNgt H' /=.
    rewrite addnC => H''.
    exact: (H'' H).
  Qed.

  Definition merge_arrays (a b : seq bool) (i : nat) (w1 : w ^ 2 %/ 2 == size a) (w2 : w ^ 2 %/ 2 == size b) (val : i < size a + size b) :
             {tr : tree w (size a + size b - (i < size a + size b)) (count_one a + count_one b - (access (a ++ b) i)) 0 Black | dflatten tr = delete (a ++ b) i}.

    move/eqP : (wordsize_sqrn_div2_neq0 _ wordsize_gt1); rewrite -lt0n => pos.
    move/eqP: w1 => w1. move/eqP: w2 => w2. move: (pos); rewrite w1 => w1p. move: (pos); rewrite w2 => w2p.
    case Hl : (i < size a).
     have ueq : size ((rcons (delete a i) (access b 0)) ++ (delete b 0)) < 2 * w ^ 2.
      rewrite size_cat size_rcons !size_delete // prednK // -subn1 addnBA // subn1 -w1 -w2 ltnW // prednK //;last rewrite ltn_addl //.
      rewrite leq_divn2n_mul2 // wordsize_sqrn_gt0 //.
     have leq : size (rcons (delete a i) (access b 0) ++ delete b 0) >= w ^ 2 %/ 2.
       by rewrite size_cat size_rcons !size_delete // prednK // w1 leq_addr.
     rewrite ltn_addr // addnC -addnBA // subn1 -(size_delete Hl) /= addnC -size_cat delete_cat addnBAC /access nth_cat Hl; last rewrite leq_nth_count //.
     rewrite count_delete -count_cat -cat_head_behead //.
     by exists (Leaf _ ((rcons (delete a i) (access b 0)) ++ (delete b 0)) leq ueq).
    move: val; rewrite ltn_subln // => Hr.
    have ueq : size (a ++ (delete b (i - (size a)))) < 2 * w ^ 2.
     rewrite size_cat size_delete // -w1 -w2 -subn1 addnBA // subn1 ltnW // prednK //;last rewrite ltn_addl //.
     rewrite leq_divn2n_mul2 // wordsize_sqrn_gt0 //.
    have leq : size (a ++ (delete b (i - (size a)))) >= w ^ 2 %/ 2.
    rewrite size_cat size_delete //;last rewrite -{1}w1 w2 //.
      by rewrite leq_addr.
    rewrite Hr -addnBA // subn1 -(size_delete Hr) -size_cat -addnBA /access nth_cat Hl ;last rewrite leq_nth_count //.
      rewrite count_delete -count_cat.
    exists (Leaf _ (a ++ (delete b (i - (size a)))) leq ueq).
    by rewrite /= delete_cat Hl.
  Qed.

  Lemma xir_ok {c} : color_ok c (inv Red).
  Proof. move: c => [] //. Qed.

  Definition delete_from_leaves {s1 o1 s2 o2} p (l : tree w s1 o1 0 Black) (r : tree w s2 o2 0 Black) (i : nat) :
    {B' : near_tree' (s1 + s2 - (i < s1 + s2))
                    (o1 + o2 - access (dflatten l ++ dflatten r) i) (incr_black 0 p) p | dflatteni' B' = delete (dflatten l ++ dflatten r) i}.

    move/eqP : (wordsize_sqrn_div2_neq0 _ wordsize_gt1) (sizeW' l) (sizeW' r); rewrite -lt0n => pos posl posr.
    remember_eq 0 d' deq; remember_eq Black c' ceq; move: l r; rewrite -ceq -deq => l; destruct l as [al leql ueql|]; last rewrite ceq /= // in deq.
    move => {deq ceq}; remember_eq 0 d' deq; remember_eq Black c' ceq; rewrite /= -ceq -deq => r; destruct r as [ar leqr ueqr|]; last rewrite ceq /= // in deq.

    rewrite /access nth_cat.
    case: ifP => Hl.
     case bcl : (w ^ 2 %/ 2 == size al).
      case bcr : (w ^ 2 %/ 2 == size ar).
       case (merge_arrays al ar i bcl bcr (ltn_addr _ Hl)).
       rewrite /access nth_cat Hl => res resK.
       case: p;[ by exists (Stay Red xir_ok res) | by exists (Down res)].
      rewrite /=.
      rewrite leq_eqVlt bcr (size_delete1 0) posr /= addn1 in leqr,ueqr.
      rewrite -(size_rcons_delete i (access ar 0)) // in leql,ueql.
      rewrite addnC -addnBA // ltn_addl // subn1 -(size_delete Hl) addnC -size_cat addnBAC;last exact: leq_nth_count.
      rewrite count_delete -count_cat -cat_head_behead // count_cat size_cat.
      case: p;
        [ exists (Stay Red xir_ok (rnode (Leaf _ (rcons (delete al i) (access ar 0)) leql ueql) (Leaf _ (delete ar 0) leqr (ltnW ueqr))))
        | exists (Stay Black (black_any_ok Red) (bnode (Leaf _ (rcons (delete al i) (access ar 0)) leql ueql) (Leaf _ (delete ar 0) leqr (ltnW ueqr)))) ];
      by rewrite delete_cat Hl /= cat_head_behead.
     rewrite leq_eqVlt bcl (size_delete1 i) Hl /= addn1 in leql,ueql.
     rewrite addnC -addnBA // ltn_addl // subn1 -(size_delete Hl) /= addnC addnBAC;last exact: leq_nth_count.
     rewrite count_delete.
      case: p;
        [ exists (Stay Red xir_ok (rnode (Leaf _ (delete al i) leql (ltnW ueql)) (Leaf _ ar leqr ueqr)))
        | exists (Stay Black (black_any_ok Red) (bnode (Leaf _ (delete al i) leql (ltnW ueql)) (Leaf _ ar leqr ueqr))) ];
     by rewrite delete_cat Hl.
    case Hrl : (i < size al + size ar).
     case bcr : (w ^ 2 %/ 2 == size ar).
      case bcl : (w ^ 2 %/ 2 == size al).
       rewrite -Hrl.
       case (merge_arrays al ar i bcl bcr Hrl).
       rewrite /access nth_cat Hl => res resK.
       case: p;[ by exists (Stay Red xir_ok res) | by exists (Down res)].
      rewrite leq_eqVlt bcl (size_delete1 (size al).-1) prednK //= leqnn addn1 in leql,ueql.
      move/eqP/eqP in bcl. move/eqP in bcr.
      have leqr' : w ^ 2 %/ 2 <= size ((access al (size al).-1) :: (delete ar (i - size al))).
       rewrite /= size_delete //;last rewrite -ltn_subln //. rewrite prednK //.
      have ueqr' : size ((access al (size al).-1) :: (delete ar (i - size al))) < 2 * w ^ 2.
       rewrite /= size_delete //;last rewrite -ltn_subln //. rewrite prednK //.
     rewrite -!addnBA //;last by apply leq_nth_count.
     rewrite count_delete -count_cat /= subn1 [size ar](size_delete1 (i - size al)) -ltn_subln // Hrl -subn1 -addnBA // subnn addn0 -size_cat -cat_last_belast // size_cat count_cat.
      case: p;
        [ exists (Stay Red xir_ok (rnode (Leaf _ (delete al (size al).-1) leql (ltnW ueql)) (Leaf _ ((access al (size al).-1) :: (delete ar (i - size al))) leqr' ueqr')))
        | exists (Stay Black (black_any_ok Red) (bnode (Leaf _ (delete al (size al).-1) leql (ltnW ueql)) (Leaf _ ((access al (size al).-1) :: (delete ar (i - size al))) leqr' ueqr'))) ];
     by rewrite delete_cat Hl /= cat_last_belast.
    rewrite /=.
    rewrite leq_eqVlt bcr (size_delete1 (i - size al)) -ltn_subln // Hrl addn1 /= in leqr,ueqr.
    rewrite -!addnBA //;last exact: leq_nth_count.
    rewrite count_delete subn1 [size ar](size_delete1 (i - size al)).
    rewrite -ltn_subln // Hrl -subn1 -addnBA // subnn addn0.
    case: p;
      [ exists (Stay Red xir_ok (rnode (Leaf _ al leql ueql) (Leaf _ (delete ar (i - size al)) leqr (ltnW ueqr))))
      | exists (Stay Black (black_any_ok Red) (bnode (Leaf _ al leql ueql) (Leaf _ (delete ar (i - size al)) leqr (ltnW ueqr)))) ];
    by rewrite delete_cat Hl.
   rewrite /= nth_default;last rewrite ltn_subln // in Hrl;last by rewrite leqNgt Hrl.
   rewrite !subn0.
   case: p;
     [ exists (Stay Red xir_ok (rnode (Leaf _ al leql ueql) (Leaf _ ar leqr ueqr)))
     | exists (Stay Black (black_any_ok Red) (bnode (Leaf _ al leql ueql) (Leaf _ ar leqr ueqr))) ];
   by rewrite -delete_oversize // size_cat leqNgt Hrl.
  Defined.

  Definition balright {s1 s2 o1 o2 d cl cr} (p : color)
             (l : tree w s1 o1 d cl)
             (dr : near_tree' s2 o2 d cr) :
    color_ok p cl ->
    color_ok p cr ->
  {B' : near_tree' (s1 + s2) (o1 + o2) (incr_black d p) p |
  dflatteni' B' = dflatten l ++ dflatteni' dr}.

    move: p => [].
     move: cl cr l dr => [] [] // l dr ? ?.
     move: l dr; move ceq : (Black) => c' l dr.
     move: dr ceq l => /= [? ? d' c p ok dr|? ? d' dr] ceq l.
      move: ceq c ok l dr => <- [] // ? l dr.
      by exists (Stay Red xir_ok (rnode l dr)).
     move: l dr => {ceq c'} /=; move ceq : (Black) => c'; move deq : (d'.+1) => d'' l dr.
     move: l deq ceq dr => [//| ? ? ? ? ? ? clr c cllok clrok ll lr] deq ceq dr.
     move: ceq deq ll lr dr cllok clrok => <- /= [] <- ll lr dr clrok ?.
     move: clr lr clrok => [] lr ? {c'}.
      move: ll lr dr; move ceq : (Red) => c' ll lr dr.
      move: lr ll dr ceq => [//| ? ? ? ? ? cl' cr' cll okl okr lrl lrr] ll dr ceq.
      move: ceq cl' cr' okl okr ll lrl lrr dr => /= <- [] [] //= ? ? ll lrl lrr dr.
      rewrite !addnA -![_ + _ + _ + _]addnA.
      exists (Stay Red xir_ok (rnode (bnode ll lrl) (bnode lrr dr))).
      by rewrite /= !catA.
     rewrite -!addnA -catA.
     by exists (Stay Red xir_ok (bnode ll (rnode lr dr))).
    move => /= ? ?.
    move: dr l => [? ? d' c ? ? dr|? ? d' dr] l; first by exists (Stay Black (black_any_ok Red) (bnode l dr)).
    move: dr l => /=; move deq : (d'.+1) => d'' dr l.
    move: l deq dr => [//| ? oo ? ? ? cll clr c cllok clrok ll lr] /=.
    move: clr clrok lr => [] clrok lr.
     move: c cllok clrok => [] //= ? ? [] -> dr.
     move: lr; move ceq : (Red) => c' lr.
     move: lr ceq dr ll => /= [//|? ? ? ? ? cl' cr' ? okl okr lrl lrr] ceq dr ll.
     move: ceq cl' cr' ll lrl lrr okl okr dr => <- [] [] //= ll lrl lrr ? ? dr.
     rewrite !addnA -![_ + _ + _ + _]addnA.
     exists (Stay Black (black_any_ok Red) (bnode (bnode ll lrl) (bnode lrr dr))).
     by rewrite /= -!catA.
    move: c cllok clrok => [] /= cllok clrok.
     move: cll cllok ll => [] // ? ll deq.
     move: lr ll ; move ceq : (Black) => c' lr ll dr.
     move: lr ceq deq ll dr => [//| ? ? ? ? ? cl' cr' crl okl okr lrl lrr] ceq deq ll dr.
     move: ceq deq lrl lrr ll dr okl okr => /= <- [] <- lrl lrr ll dr /= ? ?.
     move: cr' lrr  => [] lrr;last first.
      rewrite -!addnA.
      exists (Stay Black (black_any_ok Red) (bnode ll (bnode lrl (rnode lrr dr)))).
      by rewrite /= -!catA.
     move: lrr => /=; move ceq : (Red) => c lrr {c'}.
     move: lrr ceq lrl ll dr => [//| ? ? ? ? ? clrrl clrr c' okl okr lrrl lrrr] ceq lrl ll dr.
     move: ceq clrrl clrr lrrl lrrr lrl ll dr okl okr => <- [] [] // lrrl lrrr lrl ll dr ? ?.
     rewrite -!addnA [X in (_ + X)]addnA [X in (oo + X)]addnA.
     exists (Stay Black (black_any_ok Red) (bnode ll (rnode (bnode lrl lrrl) (bnode lrrr dr)))).
     by rewrite /= -!catA.
    move => [] -> dr.
    rewrite -!addnA -!catA.
    by exists (Down (bnode ll (rnode lr dr))).
  Defined.

  Definition balleft {s1 s2 o1 o2 d cl cr} (p : color)
             (dl : near_tree' s1 o1 d cl)
             (r : tree w s2 o2 d cr) :
    color_ok p cl ->
    color_ok p cr ->
  {B' : near_tree' (s1 + s2) (o1 + o2) (incr_black d p) p |
  dflatteni' B' = dflatteni' dl ++ dflatten r}.

    move: p => [].
     move: cl cr dl r => [] [] // dl r ? ?.
     move: dl r; move ceq : (Black) => c' dl r.
     move: dl ceq r => /= [? ? d' c p ok dl|? ? d' dl] ceq r.
      move: ceq c ok r dl => <- [] // ? r dl.
      by exists (Stay Red xir_ok (rnode dl r)).
     move: dl r => {ceq c'} /=; move ceq : (Black) => c'; move deq : (d'.+1) => d'' dl r.
     move: r deq ceq dl => [//| ? ? ? ? ? crl ? c crlok crrok rl rr] deq ceq dl.
     move: ceq deq rl rr dl crlok crrok => <- /= [] <- rl rr dl crlok ?.
     move: crl rl crlok => [] rl ? {c'}.
      move: rl rr dl; move ceq : (Red) => c' rl rr dl.
      move: rl rr dl ceq => [//| ? ? ? ? ? cl' cr' crl okl okr rll rlr] rr dl ceq.
      move: ceq cl' cr' okl okr rr rll rlr dl => /= <- [] [] //= ? ? rr rll rlr dl.
      rewrite !addnA -![_ + _ + _ + _]addnA.
      exists (Stay Red xir_ok (rnode (bnode dl rll) (bnode rlr rr))).
      by rewrite /= !catA.
     rewrite !addnA /= !catA.
     by exists (Stay Red xir_ok (bnode (rnode dl rl) rr)).
    move => /= ? ?.
    move: dl r => [? ? d' c ? ? dl|? ? d' dl] r; first by exists (Stay Black (black_any_ok Red) (bnode dl r)).
    move: dl r => /=; move deq : (d'.+1) => d'' dl r.
    move: r deq dl => [//| ? ? ? ? ? crl crr c crlok crrok rl rr] /=.
    move: crl crlok rl => [] crlok rl.
     move: c crlok crrok => [] //= ? ? [] -> dl.
     move: rl; move ceq : (Red) => c' rl.
     move: rl ceq dl rr => /= [//|? ? ? ? ? cl' cr' crl okl okr rll rlr] ceq dl rr.
     move: ceq cl' cr' rr rll rlr okl okr dl => <- [] [] //= rr rll rlr ? ? dl.
     rewrite !addnA -![_ + _ + _ + _]addnA.
     exists (Stay Black (black_any_ok Red) (bnode (bnode dl rll) (bnode rlr rr))).
     by rewrite /= -!catA.
    move: c crrok crlok => [] /= crrok crlok.
     move: crr crrok rr => [] // ? rr deq.
     move: rl rr; move ceq : (Black) => c' rl rr dl.
     move: rl ceq deq rr dl => [//| ? ? ? ? ? cl' cr' crl okl okr rll rlr] ceq deq rr dl.
     move: ceq deq rll rlr rr dl okl okr => /= <- [] <- rll rlr rr dl /= ? ?.
     move: cl' rll  => [] rll;last first.
      rewrite !addnA.
      exists (Stay Black (black_any_ok Red) (bnode (bnode (rnode dl rll) rlr) rr)).
      by rewrite /= -!catA.
     move: rll; move ceq : (Red) => c rll {c'}.
     move: rll ceq rlr rr dl=> [//| ? ? ? o3 ? crll crlr c' okl okr rlll rllr] ceq rlr rr dl.
     move: ceq crll crlr rlll rllr rlr rr dl okl okr => <- [] [] // rlll rllr rlr rr dl ? ?.
     rewrite -!addnA ![_ + ( _ + (_ + (_ + _)))]addnA [X in _ + _ + X]addnA [o3 + (_ + _)]addnA.
     exists (Stay Black (black_any_ok Red) (bnode (bnode dl rlll) (rnode (bnode rllr rlr) rr))).
     by rewrite /= -!catA.
    move => [] -> dl.
    rewrite !addnA !catA.
    by exists (Down (bnode (rnode dl rl) rr)).
  Defined.

  Lemma access_cat s t i : access (s ++ t) i = (if i < size s then access s i else access t (i - size s)).
  Proof. by rewrite /access nth_cat. Qed.

  Lemma cic_ok {c} : color_ok c (inv c).
  Proof. by destruct c. Qed.

  Lemma ltn_subLN a b c : 0 < c -> (a < b + c) -> (a - b < c).
  Proof. move => H H'. rewrite -ltn_subln //. Qed.

  Lemma ltn_subLN2 a b c i : 0 < c ->
                             i < a + b + c ->
                             (i < a + b) = false ->
                             i - a - b < c.
  Proof.
    move => H H'; rewrite ltnNge.
    move/negPn => H''.
    rewrite -!ltn_subln //;
     first by rewrite addnA.
    by apply: ltn_addl.
  Qed.

Lemma leq_addln a b c : a <= b -> a <= b + c.
Proof. by move/leq_trans; apply; rewrite leq_addr. Qed.

Lemma leq_addrn a b c : a <= c -> a <= b + c.
Proof. by move/leq_trans; apply; rewrite leq_addl. Qed.

Hint Resolve ltn_subLN ltn_subLN2 addnA leq_addr leq_addrn ltn_addl ltn_addr cic_ok leq_access_count sizeW' : core.

Lemma ordinal_caseL {s1 o1 s2 o2 d i cl cr} c
      (lok : color_ok c cl)
      (rok : color_ok c cr)
      (l : tree w s1 o1 d cl)
      (r : tree w s2 o2 d cr) :
      i < s1 ->
      {B' : near_tree' (s1 - 1) (o1 - daccess l i) d cl | dflatteni' B' = delete (dflatten l) i} ->
      {B' : near_tree' (s1 + s2 - 1) (o1 + o2 - daccess l i) (incr_black d c) c | dflatteni' B' = delete (dflatten l) i ++ dflatten r }.
Proof.
  move=> H dl.
  rewrite !addnBAC; eauto.
  apply: exist; apply: etrans;
  first by (apply (proj2_sig (balleft c (proj1_sig dl) r lok rok))).
  congr (_ ++ _); by apply: (proj2_sig dl).
Qed.

Lemma ordinal_caseR {s1 o1 s2 o2 d i cl cr} c
      (lok : color_ok c cl)
      (rok : color_ok c cr)
      (l : tree w s1 o1 d cl)
      (r : tree w s2 o2 d cr) :
      i < s1 + s2 ->
      {B' : near_tree' (s2 - 1) (o2 - daccess r (i - s1)) d cr | dflatteni' B' = delete (dflatten r) (i - s1)} ->
      {B' : near_tree' (s1 + s2 - 1) (o1 + o2 - daccess r (i - s1)) (incr_black d c) c | dflatteni' B' = dflatten l ++ delete (dflatten r) (i - s1)}.
Proof.
  move=> H dr.
  rewrite -!addnBA; eauto.
  apply: exist; apply: etrans;
  first (apply: (proj2_sig (balright c l (proj1_sig dr) lok rok));
         apply: ltn_subLN; by eauto);
  congr (_ ++ _); by apply: (proj2_sig dr).
Qed.

Definition ddelete (d: nat) (c: color) (num ones : nat) (i : nat) (B : tree w num ones (incr_black d c) c) :
    { B' : near_tree' (num - (i < num)) (ones - (daccess B i)) (incr_black d c) c | dflatteni' B' = delete (dflatten B) i }.
  case val : (i < num);last first.
   move/negP/negP : val;
   rewrite ltnNge; move/negPn => val;
   rewrite daccess_default // !subn0 -delete_oversize;
   last by rewrite size_dflatten.
   apply: (exist _ (Stay _ _ B)) => //.

  move: B; move dceq: (incr_black d c) => d' B;
  elim: B d dceq i val => {c} // [s1 o1 ? ? d'' [] [] c // g1 g2 l IHl r IHr] d dceq i val;
  (have dceq' : d = d'' by case: c dceq g1 g2 => //=; case => //);
  move: dceq' l r IHl IHr => /= <- l r IHl IHr {dceq};
  rewrite delete_cat size_dflatten;
  case: ifP => H;
  (* most general cases *)
  try (apply: (ordinal_caseL c _ _ l r H (IHl d erefl i H)); by eauto);
  try (apply: (ordinal_caseR c _ _ l r val (IHr d erefl (i - s1) _));
       eauto; apply: ltn_subLN; by eauto).

  case: d r l IHl IHr val H => {d' d''} [| d r l _ IHr val H] /=.
   move creq: Red => cr;
   move cbeq: Black => cb; move deq: 0 => d r l.
   case: l creq cbeq deq r => // ? ? ? ? ? [] [] [] // ? ? ll lr ? <- /= deq r _ _ val H.
   move: deq ll lr r val H => <- ll lr r val H.
   move: (delete_from_leaves Red lr r (i - (size (dflatten ll)))).
   rewrite delete_cat access_cat -!daccessK !size_dflatten -!ltn_subln ; eauto.
   rewrite H !addnA val subnDA /= -!addnA -!addnBA; eauto => dr.
   apply: exist; apply: etrans.
   apply: (proj2_sig (balright c ll (proj1_sig dr) _ _)); eauto.
   rewrite -!catA; congr (_ ++ _).
   apply: (proj2_sig dr).
  apply: (ordinal_caseR c _ _ l r val (IHr d erefl (i - s1) _));
   eauto; apply: ltn_subLN; by eauto.
  case: d r l IHl IHr val H => {d' d''} [| d r l IHl _ val H] /=.
   move creq: Red => cr;
   move cbeq: Black => cb'; move deq: 0 => d r l.
   case: r creq cbeq deq l => // ? ? ? ? ? [] [] [] // ? ? rl rr ? <- /= deq l _ _ val H.
   move: deq rl rr l val H => <- rl rr l val H.
   move: (delete_from_leaves Red l rl i).
   rewrite delete_cat access_cat -!daccessK !size_dflatten; eauto.
   rewrite ltn_addr H /=; auto => dl.
   rewrite !addnA.
   rewrite [s1 + _ + _ - _]addnBAC; eauto.
   rewrite [o1 + _ + _ - _]addnBAC; eauto.
   apply: exist; apply: etrans.
   apply: (proj2_sig (balleft c (proj1_sig dl) rr _ _ )); eauto.
   rewrite !catA; congr (_ ++ _).
   exact: (proj2_sig dl).
   by rewrite (leq_trans _ (leq_addr _ _)) // leq_access_count.
  apply: (ordinal_caseL c _ _ l r H (IHl d erefl i H)); by eauto.

  case: d l r IHl IHr => [l r _ _| d l r IHl _].
   move: (delete_from_leaves c l r i).
   by rewrite access_cat delete_cat size_dflatten H val /= daccessK.
  apply: (ordinal_caseL c _ _ l r H (IHl d erefl i H)); by eauto.

  case: d l r IHl IHr => [l r _ _| d l r _ IHr].
   move: (delete_from_leaves c l r i).
   by rewrite access_cat delete_cat size_dflatten H val /= daccessK.
  apply: (ordinal_caseR c _ _ l r val (IHr d erefl (i - s1) _));
   eauto; apply: ltn_subLN; by eauto.
Qed.
End delete.

End dynamic_dependent.
Extract Inductive tree => tree_ml [ "LeafML" "(function (s1,o1,s2,o2,d,c,cl,cr,l,r) -> NodeML (s1, o1, s2, o2, c, l, r))" ]
"(fun fl fn ->
  function
  | LeafML arr -> fl arr
  | NodeML (s1,o1,s2,o2,c,(NodeML (_,_,_,_,cl,_,_) as l),(NodeML (_,_,_,_,cr,_,_) as r)) -> fn s1 o1 s2 o2 1 cl cr c l r
  | NodeML (s1,o1,s2,o2,c,(LeafML _ as l),(NodeML (_,_,_,_,cr,_,_) as r)) -> fn s1 o1 s2 o2 1 Black cr c l r
  | NodeML (s1,o1,s2,o2,c,(LeafML _ as l),(LeafML _ as r)) -> fn s1 o1 s2 o2 1 Black Black c l r
  | NodeML (s1,o1,s2,o2,c,(NodeML (_,_,_,_,cl,_,_) as l),(LeafML _ as r)) -> fn s1 o1 s2 o2 1 cl Black c l r)".
Extraction TestCompile dinsert ddelete tree_ml.
Extraction "dydep.ml" dinsert ddelete tree_ml.


Set Implicit Arguments.
Require Import Arith Metatheory Lambda_Ex Lambda.
Require Import Rewriting LambdaES_Infra.
Require Import LambdaES_Defs.

Require NormalizationTheory. Module NT := NormalizationTheory.

(* LambdaES_Def *)

Inductive SN_ind (n : nat) (R : pterm -> pterm -> Prop) (t : pterm) : Prop :=
 | SN_intro : (forall t', R t t' -> exists k, k < n /\ SN_ind k R t') -> SN_ind n R t.

Lemma SN_ind_Succ : forall R t n, SN_ind n R t -> SN_ind (S n) R t.
Proof.
 intros. constructor. intros t' Ht. inversion H.
 specialize H0 with t'. apply H0 in Ht. inversion Ht.
 destruct H1 as [H1 H2]. exists x. split.
 - omega.
 - assumption.
Qed.

Definition SN (R : pterm -> pterm -> Prop) (t : pterm) :=
                                             exists n, SN_ind n R t.

Lemma SN_Red : forall R t u, SN R t -> R t u -> SN R u.
Proof.
 intros R t u Ht Hr. inversion Ht. inversion H. apply H0 in Hr.
 inversion Hr. destruct H1 as [H1 H2]. exists x0. assumption.
Qed.

(* =================================================================

   Relacoes entre SN e NT.SN: falta provar se SN e patriarcal:
   necessidade de garantir um numero finito de redutos a partir
   de um termo t em lex, para do MAX entre os n' de cada t'
   obtermos um n para t.

====================================================================
Lemma SNisPat : NT.patriarchal lex (SN lex).
Proof.
 unfold NT.patriarchal. intros.

Theorem SNindP {R: pterm -> pterm -> Prop} {P: pterm -> Prop}
: (forall t, (forall t', R t t' -> P t') -> SN R t -> P t)
  -> (forall t, SN R t -> P t).
Proof.
 intros HI t Ht. apply HI.

Lemma SNequivNTSN : forall t, SN lex t <-> NT.SN lex t.
Proof.
 split; intros H.
 - apply NT.toSN. inversion H as [x H1]. intros y Ht. induction Ht.
   + inversion H0. apply H0 in Ht. inversion Ht.
     inversion H2. inversion H3.
   + apply IHx.
===================================================================*)

Definition NF (R : pterm -> pterm -> Prop) (t : pterm) :=
                                                 forall t', ~ R t t'.

Inductive SNalt (R : pterm -> pterm -> Prop) (t : pterm) : Prop :=
| SN_nf : NF R t -> SNalt R t
| SN_acc : (forall t', R t t' -> SNalt R t') -> SNalt R t.

Lemma SNaltPat {R : pterm -> pterm -> Prop} : NT.patriarchal R (SNalt R).
Proof.
  unfold NT.patriarchal. intros x H. apply SN_acc. assumption.
Qed.

Lemma SNaltStab : forall R t u, SNalt R t -> R t u -> SNalt R u.
Proof.
 intros R t u Ht Hr. inversion Ht.
 - apply H in Hr. inversion Hr.
 - specialize H with u. apply H in Hr. assumption.
Qed.

Theorem SNindP {R: pterm -> pterm -> Prop} {P: pterm -> Prop}
: (forall t, (forall t', R t t' -> P t') -> SNalt R t -> P t)
  -> (forall t, SNalt R t -> P t).
Proof.
  intros IH t Ht.
  (*
  assert (Hpat: NT.patriarchal R (fun x => SNalt R x -> P x)).
  { unfold NT.patriarchal.
    intros.
    apply IH.
    - intros.
      apply H.
      + assumption.
      + apply SNaltStab with x; assumption.
    - assumption.
  } *)
  induction Ht.
  - apply IH.
   + intros. apply H in H0. inversion H0.
   + constructor; assumption.
  - apply IH.
   + assumption.
   + apply SN_acc. assumption.
Qed.

Theorem SNaltEquivNTSN {R: pterm -> pterm -> Prop}: forall t, SNalt R t <-> NT.SN R t.
Proof.
 split; intro H.
 - inversion H.
  + apply NT.toSN. intros. apply H0 in H1. inversion H1.
  + eapply SNindP.
   * intros. apply NT.SNpatriarchal. apply H1.
   * assumption.
 - eapply NT.SNind.
   + intros. apply SNaltPat. apply H0.
  + assumption.
Qed.

Lemma SNalt_app : forall t t', SNalt lex (pterm_app t t') -> SNalt lex t /\ SNalt lex t'. Admitted.

(* Inductive headApp : pterm -> Prop :=  *)

(*   | hvar : forall x, headApp (pterm_fvar x) *)

(*   | happ : forall t u,  *)

(*                          headApp t -> Lterm u -> *)
(* (*-------------------------------------------------------------------------*) *)
(*                          headApp (pterm_app t u) *)

(* . *)

(* Inductive HNF_Beta : pterm -> Prop := *)

(*   | hnfB_headApp : forall t, headApp t -> HNF_Beta t *)

(*   | hnfB_abs : forall L t, *)

(*                       (forall x, x \notin L -> HNF_Beta (t ^ x))->  *)
(* (*-------------------------------------------------------------------------*) *)
(*                                HNF_Beta (pterm_abs t) *)
(* . *)

(* Inductive nfbApp : pterm -> Prop :=  *)

(*   | nfb_var : forall x, nfbApp (pterm_fvar x) *)

(*   | nfb_app : forall t u,  *)

(*                        nfbApp t -> Lterm u -> NF Beta u -> *)
(* (*-------------------------------------------------------------------------*) *)
(*                            nfbApp (pterm_app t u) *)

(* . *)

(* Inductive NF_Beta : pterm -> Prop := *)

(*   | nfB_nfbApp : forall t, nfbApp t -> NF_Beta t *)

(*   | nfB_abs : forall L t, *)

(*                       (forall x, x \notin L -> NF_Beta (t ^ x))->  *)
(* (*-------------------------------------------------------------------------*) *)
(*                                NF_Beta (pterm_abs t) *)
(* . *)

Lemma NFB_app : forall u v, NF Beta (pterm_app u v) -> NF Beta u /\ NF Beta v.
Proof.
 intros. split; unfold NF; unfold not; intros.
 - assert ( pterm_app u v -->Beta pterm_app t' v).
   { apply L_app_left. assumption. }
   apply H in H1. assumption.
 - assert ( pterm_app u v -->Beta pterm_app u t').
   { apply L_app_right. assumption. }
   apply H in H1. assumption.
Qed.

(* Lemma NF_Beta_NF : forall t, Lterm t -> (NF Beta t <-> NF_Beta t). *)
(* Proof. *)
(*  split; intro H'.  *)
(*  - induction H. *)
(*   + do 2 constructor. *)
(*   + constructor. apply NFB_app in H'; destruct H' as [H1 H2]. apply nfb_app. *)

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

(* (* Lambda *) *)

(* (* Lemma L_SN_app : forall n R t u, L_red_regular R ->  Lterm t -> Lterm u ->  *) *)
(* (*                SN_ind n (L_contextual_closure R) (pterm_app t u) -> *) *)
(* (*                SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) u. *) *)
(* (*  Proof. *) *)
(* (*  intros n R t u Reg.  *) *)
(* (*  generalize t u; clear t u.   *) *)
(* (*  induction n.  intros. split; rewrite <- NF_eq_SN0 in *|-*; unfold NF in *|-*.  *) *)
(* (*  intros t' H'. apply (H1 (pterm_app t' u)). apply L_app_left; trivial. *) *)
(* (*  intros u' H'. apply (H1 (pterm_app t u')). apply L_app_right; trivial. *) *)
(* (*  intros t u Tt Tu H. destruct H. split.  *) *)
(* (*  apply SN_intro. intros t' H'. exists n. split; try omega.  *) *)
(* (*  apply IHn with (t := t') (u := u); trivial. apply red_regular_Lctx in Reg. *) *)
(* (*  apply Reg in H'. apply H'. case (H (pterm_app t' u)). apply L_app_left; trivial.  *) *)
(* (*  intros k H''. apply WSN with (k := k). omega. apply H''. *) *)
(* (*  apply SN_intro. intros u' H'. exists n. split; try omega.  *) *)
(* (*  apply IHn with (t := t) (u := u'); trivial. apply red_regular_Lctx in Reg. *) *)
(* (*  apply Reg in H'. apply H'. case (H (pterm_app t u')). apply L_app_right; trivial.  *) *)
(* (*  intros k H''. apply WSN with (k := k). omega. apply H''. *) *)
(* (* Qed.  *) *)

(* (* Lemma L_SN_abs : forall x n R t, L_red_regular R -> L_red_out R ->  *) *)
(* (*                SN_ind n (L_contextual_closure R) (pterm_abs t) -> *) *)
(* (*                x \notin (fv t) -> SN_ind n (L_contextual_closure R) (t ^ x). *) *)
(* (* Proof. *) *)
(* (*  intros x n R t Reg Out. *) *)
(* (*  generalize t; clear t. *) *)
(* (*  apply red_regular_Lctx in Reg.  *) *)
(* (*  apply red_out_Lctx in Out.  *) *)
(* (*  apply L_red_out_to_rename in Out. *) *)
(* (*  induction n. intros.  *) *)
(* (*  apply SN0_to_NF in H.  *) *)
(* (*  apply NF_to_SN0; unfold NF in *|-*. *) *)
(* (*  intros t' H'. gen_eq t0 : (close t' x). intro H1. *) *)
(* (*  replace t' with (t0 ^ x) in H'. *) *)
(* (*  assert (Q: L_contextual_closure R (pterm_abs t) (pterm_abs t0)). *) *)
(* (*     apply L_abs_in with (L := {{x}}). intros z H2.  *) *)
(* (*     apply notin_singleton in H2. apply Out with (x := x); trivial. *) *)
(* (*     rewrite H1. apply fv_close'. *) *)
(* (*  assert (Q': ~ L_contextual_closure R (pterm_abs t) (pterm_abs t0)). *) *)
(* (*     apply H. *) *)
(* (*  contradiction. rewrite H1. rewrite open_close_var with (x := x). *) *)
(* (*  reflexivity. apply Reg in H'. apply Lterm_is_term. apply H'. *) *)
(* (*  intros. destruct H. apply SN_intro. *) *)
(* (*  intros. exists n. split; try omega. *) *)
(* (*  gen_eq t0 : (close t' x). intro H2. *) *)
(* (*  replace t' with (t0 ^ x). replace t' with (t0 ^ x) in H1. *) *)
(* (*  apply IHn; trivial. case (H (pterm_abs t0)); trivial. *) *)
(* (*  apply L_abs_in with (L := {{x}}). *) *)
(* (*  intros z H3. apply notin_singleton in H3.  *) *)
(* (*  apply Out with (x := x); trivial. *) *)
(* (*  rewrite H2. apply fv_close'. *) *)
(* (*  intros k H3. apply WSN with (k := k); try omega. *) *)
(* (*  apply H3. rewrite H2. apply fv_close'. *) *)
(* (*  rewrite H2. rewrite open_close_var with (x := x). *) *)
(* (*  reflexivity. apply Lterm_is_term. apply Reg in H1. apply H1. *) *)
(* (*  rewrite H2. rewrite open_close_var with (x := x). *) *)
(* (*  reflexivity. apply Lterm_is_term. apply Reg in H1. apply H1.  *) *)
(* (* Qed. *) *)

(* (* Lemma L_SN_mult_app : forall n R t l, L_red_regular R ->  Lterm t -> Lterm %% l ->  *) *)
(* (*                SN_ind n (L_contextual_closure R) (t // l) -> *) *)
(* (*                SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) %% l. *) *)
(* (* Proof. *) *)
(* (*  intros n R t l Reg. generalize n t; clear n t. *) *)
(* (*  induction l; simpl. intros n t T H0 H. split; trivial. *) *)
(* (*  intros n t T H0 H. destruct H0. apply L_SN_app in H; trivial. destruct H. *) *)
(* (*  assert (Q : SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) %% l).  *) *)
(* (*   apply IHl; trivial. *) *)
(* (*  clear IHl. destruct Q. split; trivial. split; trivial. *) *)
(* (*  rewrite Lterm_mult_app. split; trivial.  *) *)
(* (* Qed.  *) *)

(* Lemma Lctx_red_h_mult_app : forall R t t' lu, Lterm %% lu -> (L_contextual_closure R) t t' -> (L_contextual_closure R) (t // lu) (t' // lu). *)
(* Proof. *)
(*  intros R t t' lu Tlu H. induction lu; simpl in *|-*; trivial. *)
(*  destruct Tlu. apply L_app_left; trivial. *)
(*  apply IHlu; trivial. *)
(* Qed.  *)

(* (* Lemma Lctx_red_t_mult_app : forall R t lu lu', Lterm t -> Lterm %% lu -> R_list (L_contextual_closure R) lu lu' -> (L_contextual_closure R) (t // lu) (t // lu'). *) *)
(* (* Proof. *) *)
(* (*  intros R t lu lu' Tt Tlu H. unfold R_list in H. *) *)
(* (*  case H; clear H; intros t0 H. *) *)
(* (*  case H; clear H; intros t1 H. *) *)
(* (*  case H; clear H; intros l0 H. *) *)
(* (*  case H; clear H; intros l1 H. *) *)
(* (*  destruct H. destruct H0.  *) *)
(* (*  rewrite H. rewrite H0. rewrite H in Tlu.  *) *)
(* (*  clear H H0. induction l0; simpl. destruct l1; simpl.  *) *)
(* (*  apply L_app_right; trivial. *) *)
(* (*  apply L_app_right; trivial.  *) *)
(* (*  simpl in Tlu. apply Lterm_app. rewrite Lterm_mult_app.  *) *)
(* (*  destruct Tlu. destruct H0. *) *)
(* (*  split; trivial. apply Tlu. *) *)
(* (*  simpl in Tlu. destruct Tlu.  *) *)
(* (*  apply L_app_left; trivial. *) *)
(* (*  apply IHl0; trivial.  *) *)
(* (* Qed. *) *)

(* (** Inductive Characterisation of NF Beta **) *)

(* (* Lemma NF_ind_eq_Beta : forall t, Lterm t -> (NF_ind Beta t <-> NF Beta t). *) *)
(* (* Proof. *) *)
(* (*  intros. split.  *) *)
(* (*  intro H'. induction H'. *) *)
(* (*  induction l; simpl in *|-*. *) *)
(* (*  intros t H2. inversion H2. inversion H3. *) *)
(* (*  intros t H2. inversion H2. inversion H3. *) *)
(* (*  case eqdec_nil with (l := l). intro. rewrite H11 in H6. simpl in H6. *) *)
(* (*  generalize H6. discriminate. *) *)
(* (*  intro H11. case  m_app_eq_app with (t := (pterm_fvar x)) (lu := l); trivial. *) *)
(* (*  intros t2 H12. case H12; clear H12; intros t3 H12.  *) *)
(* (*  generalize H6. rewrite H12. discriminate. *) *)
(* (*  unfold NF in IHl. apply IHl with (t' := t'). inversion H. trivial. *) *)
(* (*  intros u' H'. apply H0. right; trivial. *) *)
(* (*  intros u' H8 Tu' t1.  apply H1; trivial. right; trivial. trivial. *) *)
(* (*  unfold NF in H1. apply H1 with (u := a) (t' := u'). *) *)
(* (*  left; trivial. inversion H; trivial. trivial. *) *)
(* (*  intros t' H2. inversion H2. inversion H3. inversion H. *) *)
(* (*  unfold NF in H1. case var_fresh with (L := L \u L0 \u L1). *) *)
(* (*  intros x Fr. apply notin_union in Fr. destruct Fr. apply notin_union in H8; destruct H8. *) *)
(* (*  apply H1 with (x := x) (t' := t'0 ^x); trivial.  *) *)
(* (*  apply H7; trivial. apply H4; trivial.  *) *)
(* (*  assert (Reg : L_red_regular rule_beta). apply L_beta_regular. *) *)
(* (*  assert (Out : L_red_out rule_beta). apply L_beta_red_out. *) *)
(* (*  apply Lterm_size_induction3 with (t := t); trivial; intros. *) *)
(* (*  apply NF_ind_app; intros. *) *)
(* (*  apply H0; trivial. rewrite NF_eq_SN0 in H1|-*. apply L_SN_mult_app in H1; trivial. *) *)
(* (*  destruct H1. rewrite <- P_list_eq with (P := SN_ind 0 (L_contextual_closure rule_beta)) in H3. *) *)
(* (*  apply H3; trivial.  rewrite <- P_list_eq with (P := Lterm). intros.  *) *)
(* (*  apply H0; trivial. case eqdec_nil with (l := l); intro. *) *)
(* (*  rewrite H4 in *|-*. simpl in *|-*. unfold Lbody in H1. *) *)
(* (*  case H1; clear H1; intros L H1. apply NF_ind_abs with (L := fv t1 \u L). *) *)
(* (*  intros x Fr. apply notin_union in Fr. destruct Fr. apply H2; trivial. *) *)
(* (*  apply H1; trivial. rewrite NF_eq_SN0 in H3. apply L_SN_abs with (x := x) in H3; trivial. *) *)
(* (*  rewrite <- NF_eq_SN0 in H3. trivial.  *) *)
(* (*  apply False_ind. case not_nil_append with (l := l); trivial. *) *)
(* (*  intros t0 H5. case H5; clear H5; intros l' H5.  rewrite H5 in H3. *) *)
(* (*  rewrite <- mult_app_append in H3. unfold NF in H3. apply (H3 ((t1 ^^ t0) // l')). *) *)
(* (*  apply Lctx_red_h_mult_app. rewrite <- P_list_eq with (P := Lterm). intros. *) *)
(* (*  apply H0. rewrite H5. apply in_or_app. left; trivial. *) *)
(* (*  apply L_redex. apply reg_rule_beta; trivial. unfold body. unfold Lbody in H1. *) *)
(* (*  case H1; clear H1; intros L H1. apply H0. rewrite H5. *) *)
(* (*  apply in_or_app. right. simpl. left; trivial. *) *)
(* (* Qed. *) *)

(* (** Inductive Characterisation of NF Beta **) *)

(* (* Lemma NF_ind_eq_Beta : forall t, Lterm t -> (NF_ind Beta t <-> NF Beta t). *) *)
(* (* Proof. *) *)
(* (*  intros. split.  *) *)
(* (*  intro H'. induction H'. *) *)
(* (*  induction l; simpl in *|-*. *) *)
(* (*  intros t H2. inversion H2. inversion H3. *) *)
(* (*  intros t H2. inversion H2. inversion H3. *) *)
(* (*  case eqdec_nil with (l := l). intro. rewrite H11 in H6. simpl in H6. *) *)
(* (*  generalize H6. discriminate. *) *)
(* (*  intro H11. case  m_app_eq_app with (t := (pterm_fvar x)) (lu := l); trivial. *) *)
(* (*  intros t2 H12. case H12; clear H12; intros t3 H12.  *) *)
(* (*  generalize H6. rewrite H12. discriminate. *) *)
(* (*  unfold NF in IHl. apply IHl with (t' := t'). inversion H. trivial. *) *)
(* (*  intros u' H'. apply H0. right; trivial. *) *)
(* (*  intros u' H8 Tu' t1.  apply H1; trivial. right; trivial. trivial. *) *)
(* (*  unfold NF in H1. apply H1 with (u := a) (t' := u'). *) *)
(* (*  left; trivial. inversion H; trivial. trivial. *) *)
(* (*  intros t' H2. inversion H2. inversion H3. inversion H. *) *)
(* (*  unfold NF in H1. case var_fresh with (L := L \u L0 \u L1). *) *)
(* (*  intros x Fr. apply notin_union in Fr. destruct Fr. apply notin_union in H8; destruct H8. *) *)
(* (*  apply H1 with (x := x) (t' := t'0 ^x); trivial.  *) *)
(* (*  apply H7; trivial. apply H4; trivial.  *) *)
(* (*  assert (Reg : L_red_regular rule_beta). apply L_beta_regular. *) *)
(* (*  assert (Out : L_red_out rule_beta). apply L_beta_red_out. *) *)
(* (*  apply Lterm_size_induction3 with (t := t); trivial; intros. *) *)
(* (*  apply NF_ind_app; intros. *) *)
(* (*  apply H0; trivial. rewrite NF_eq_SN0 in H1|-*. apply L_SN_mult_app in H1; trivial. *) *)
(* (*  destruct H1. rewrite <- P_list_eq with (P := SN_ind 0 (L_contextual_closure rule_beta)) in H3. *) *)
(* (*  apply H3; trivial.  rewrite <- P_list_eq with (P := Lterm). intros.  *) *)
(* (*  apply H0; trivial. case eqdec_nil with (l := l); intro. *) *)
(* (*  rewrite H4 in *|-*. simpl in *|-*. unfold Lbody in H1. *) *)
(* (*  case H1; clear H1; intros L H1. apply NF_ind_abs with (L := fv t1 \u L). *) *)
(* (*  intros x Fr. apply notin_union in Fr. destruct Fr. apply H2; trivial. *) *)
(* (*  apply H1; trivial. rewrite NF_eq_SN0 in H3. apply L_SN_abs with (x := x) in H3; trivial. *) *)
(* (*  rewrite <- NF_eq_SN0 in H3. trivial.  *) *)
(* (*  apply False_ind. case not_nil_append with (l := l); trivial. *) *)
(* (*  intros t0 H5. case H5; clear H5; intros l' H5.  rewrite H5 in H3. *) *)
(* (*  rewrite <- mult_app_append in H3. unfold NF in H3. apply (H3 ((t1 ^^ t0) // l')). *) *)
(* (*  apply Lctx_red_h_mult_app. rewrite <- P_list_eq with (P := Lterm). intros. *) *)
(* (*  apply H0. rewrite H5. apply in_or_app. left; trivial. *) *)
(* (*  apply L_redex. apply reg_rule_beta; trivial. unfold body. unfold Lbody in H1. *) *)
(* (*  case H1; clear H1; intros L H1. apply H0. rewrite H5. *) *)
(* (*  apply in_or_app. right. simpl. left; trivial. *) *)
(* (* Qed. *) *)

(* (** Inductive Characterisation of SN Beta **) *)

(*  Inductive SN_Beta : pterm -> Prop := *)

(*   | sn_beta_var : forall (x : var) (lu : list pterm), *)

(*                       (forall u, (In u lu) -> SN_Beta u) -> *)
(* (*-------------------------------------------------------------------------*) *)
(*                          SN_Beta ((pterm_fvar x) // lu) *)

(*   | sn_beta_abs : forall L (u : pterm), *)

(*                       (forall x, x \notin L -> SN_Beta (u ^ x))->  *)
(* (*-------------------------------------------------------------------------*) *)
(*                              SN_Beta (pterm_abs u) *)

(*   | sn_beta_meta_sub : forall  (t u : pterm) (lv : list pterm), *)

(*                           SN_Beta u -> SN_Beta ((t ^^ u) // lv) -> *)
(* (*-------------------------------------------------------------------------*) *)
(*                     SN_Beta ((pterm_app (pterm_abs t)  u) // lv) *)
(* .   *)

(* Theorem SN_Beta_prop : forall t, Lterm t -> SN Beta t -> SN_Beta t. *)
(* Proof. *)
(*  intros t T.  *)

(*  intro H. case H; clear H; intros n H.  *)
(*  generalize t T H; clear T t H. induction n; intros. *)
(* (*  rewrite <- NF_eq_SN0 in H. rewrite <- NF_ind_eq_Beta in H; trivial. *) *)
(* (*  induction H. apply sn_beta_var; intros. *) *)
(* (*  apply H0; trivial. rewrite Lterm_mult_app in T. destruct T. *) *)
(* (*  rewrite <- P_list_eq in H3. apply H3; trivial. *) *)
(* (*  inversion T; clear T. apply sn_beta_abs with (L := L \u L0); intros. *) *)
(* (*  apply notin_union in H3. destruct H3. apply H0; trivial. apply H2; trivial. *) *)
(* (*  assert (Reg : L_red_regular rule_beta); try apply L_beta_regular. *) *)
(* (*  assert (Out : L_red_out rule_beta); try apply  L_beta_red_out. *) *)
(* (*  generalize H; clear H. apply Lterm_size_induction3 with (t := t); intros; trivial.  *) *)
(* (*  apply sn_beta_var; intros. *) *)
(* (*  assert (Q : SN_ind (S n) Beta  %% l).  *) *)
(* (*     apply L_SN_mult_app in H0; trivial. apply H0.  *) *)
(* (*     rewrite <- P_list_eq with (P := Lterm).       *) *)
(* (*     intros u' H2. apply H; trivial.   *) *)
(* (*  apply H; trivial. rewrite <- P_list_eq with (P := SN_ind (S n) Beta) in Q. *) *)
(* (*  apply Q; trivial.  *) *)
(* (*  case eqdec_nil with (l := l).  *) *)
(* (*  intro H3. rewrite H3 in *|-*. simpl in *|-*. clear H H3. *) *)
(* (*  inversion H0; clear H0. *) *)
(* (*  apply sn_beta_abs  with (L := fv t1 \u x). intros y Fr. *) *)
(* (*  apply notin_union in Fr. destruct Fr. *) *)
(* (*  apply H1; trivial. apply H; trivial. apply L_SN_abs; trivial. *) *)
(* (*  intro H3. case not_nil_append with (l := l); trivial. *) *)
(* (*  intros a Hl. case Hl; clear Hl. intros l' Hl. *) *)
(* (*  rewrite Hl in *|-*. rewrite <- mult_app_append in *|-*. *) *)
(* (*  clear H3 Hl.  *) *)
(* (*  assert (Tl : Lterm a /\ Lterm %% l'). *) *)
(* (*    split. apply H. apply in_or_app. right.  *) *)
(* (*    simpl; left; trivial. *) *)
(* (*    apply P_list_eq with (P := Lterm). *) *)
(* (*    intros u Hu. apply H. apply in_or_app. left. *) *)
(* (*    trivial.   *) *)
(* (*  destruct Tl. apply sn_beta_meta_sub. apply H. *) *)
(* (*  apply in_or_app. simpl. right. left; trivial. *) *)
(* (*  apply L_SN_mult_app in H2; trivial. destruct H2. apply L_SN_app in H2; trivial. *) *)
(* (*  destruct H2; trivial. *) *)
(* (*  inversion H0. apply Lterm_abs with (L := x); intros.  *) *)
(* (*  apply H6; trivial.  apply Lterm_app. inversion H0. apply Lterm_abs with (L := x); intros.  *) *)
(* (*  apply H5; trivial. trivial. apply IHn. rewrite  Lterm_mult_app. split; trivial. *) *)
(* (*  apply Lbody_open_term; trivial. *) *)
(* (*  apply SN_one_step with (t := pterm_app (pterm_abs t1) a // l'); trivial. *) *)
(* (*  apply Lctx_red_h_mult_app; trivial. apply L_redex. apply reg_rule_beta. *) *)
(* (*  unfold Lbody in H0. case H0; clear H0; intros L H0. exists L. intros. *) *)
(* (*  apply H0; trivial. trivial. *) *)
(* (* Qed. *) *)
(* Admitted. *)

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

(* (* Lambda_Ex *) *)

(* (** The two definitions of SN are equivalent for lex. *)
 *)
(* Lemma SN_equivSN_alt: forall t, SN lex t <-> SN_alt lex t.
 *)
(* Proof. Admitted. *)

(* (* *)

(* (** NF lex Properties **)
 *)
(*
 *)
(* Lemma NF_eqC : forall t t', t =e t' -> NF lex t -> NF lex t'.
 *)
(* Proof.
 *)
(*  intros t t'. intros. unfold NF in *|-*.
 *)
(*  intros t1 H1. rewrite <- H in H1.
 *)
(*  apply (H0 t1); trivial.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma NF_fvar : forall x, NF lex (pterm_fvar x).
 *)
(* Proof.
 *)
(*  intros x t H'.
 *)
(*  case H'; clear H'.
 *)
(*  intros t0 H0. case H0; clear H0.
 *)
(*  intros t1 H1. destruct H1. destruct H0.
 *)
(*  assert (Q : pterm_fvar x = t0).
 *)
(*   clear H0 H1 t1. gen_eq t1 : (pterm_fvar x).
 *)
(*   intro H1. induction H. rewrite H1. rewrite H1 in H.
 *)
(*   inversion H; trivial. clear H H1 H2 H3 s t0. inversion H0; trivial.
 *)
(*   rewrite IHtrans_closure in H. rewrite H1. rewrite H1 in H. inversion H.
 *)
(*   inversion H2; trivial. rewrite H1 in H. symmetry. inversion H. inversion H2; trivial.
 *)
(*  rewrite <- Q in H0. inversion H0. inversion H2. inversion H5. inversion H5.
 *)
(* Qed.
 *)
(*
 *)
(*
 *)
(* Lemma NF_app_lex : forall t u v, NF lex u -> NF lex v -> (pterm_app u v -->lex t) ->
 *)
(*                exists t', u =e pterm_abs t' /\ t =e (t'[v]).
 *)
(* Proof.
 *)
(*  intros t u v NFu NFv H. apply lex_app in H. case H; clear H; intro H.
 *)
(*  case H; clear H; intros t' H. exists t'; trivial.
 *)
(*  case H; clear H; intro H; case H; clear H; intros t' H; destruct H.
 *)
(*  assert (Q : ~ u -->lex t'). apply (NFu t'). contradiction.
 *)
(*  assert (Q : ~ v -->lex t'). apply (NFv t'). contradiction.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma NF_app_lex_eq : forall t u v, NF lex u -> NF lex v -> (pterm_app u v -->lex t) ->
 *)
(*                exists t' t'' v', u = pterm_abs t' /\ t = (t''[v']).
 *)
(* Proof.
 *)
(*  intros t u v NFu NFv H. apply NF_app_lex in H; trivial.
 *)
(*  case H; clear H. intros t' H. destruct H.
 *)
(*  apply eqC_sym in H. apply eqC_abs_term in H.
 *)
(*  apply eqC_sym in H0. apply eqC_sub_term in H0.
 *)
(*  case H; clear H. intros t1 H. case H; clear H. intros L H. destruct H.
 *)
(*  case H0; clear H0. intros t1' H0. case H0; clear H0. intros u' H0.
 *)
(*  exists t1 t1' u'. split. rewrite H. reflexivity. rewrite H0. reflexivity.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma NF_mult_app_var : forall x lt, NF lex %% lt -> NF lex ((pterm_fvar x) // lt).
 *)
(* Proof.
 *)
(*  intros x lt H.
 *)
(*  induction lt; simpl in *|-*. apply NF_fvar.
 *)
(*  destruct H. assert (Q : NF lex (pterm_fvar x // lt)). apply IHlt; trivial.
 *)
(*  clear IHlt. unfold NF. intros t' H'. case eqdec_nil with (l := lt). intro H''.
 *)
(*  rewrite H'' in H'. simpl in H'.
 *)
(*  apply NF_app_lex_eq in H'; trivial. case H'; clear H'. intros t0 H'.
 *)
(*  case H'; clear H'. intros t0' H'. case H'; clear H'. intros v' H'.
 *)
(*  destruct H'. inversion H1.
 *)
(*  apply NF_fvar. intro H''.
 *)
(*  assert (Q' : exists t' u', (pterm_fvar x) // lt = pterm_app t' u').
 *)
(*   apply m_app_eq_app; trivial.
 *)
(*  case Q'; clear Q'. intros u H1. case H1; clear H1. intros v H1.
 *)
(*  rewrite H1 in H'. apply NF_app_lex_eq in H'; trivial.
 *)
(*  case H'; clear H'. intros t0 H'. case H'; clear H'. intros t0' H'.
 *)
(*  case H'; clear H'. intros v' H'.
 *)
(*  destruct H'. inversion H2; trivial.
 *)
(*  rewrite <- H1; trivial.
 *)
(* Qed.
 *)
(*
 *)
(*
 *)
(*
 *)
(* Lemma lex_abs_not_NF : forall l t, l <> nil -> term (pterm_abs t // l) -> ~ NF lex (pterm_abs t // l).
 *)
(* Proof.
 *)
(*  intros. induction l. intro H'. apply H; trivial.
 *)
(*  simpl in *|-*. case eqdec_nil with (l := l). intro H'.
 *)
(*  rewrite H' in *|-*. simpl in *|-*. intro H1.
 *)
(*  apply (H1 (t[a])). apply ctx_to_mod_eqC. apply redex.
 *)
(*  apply B_lx. apply term_distribute_over_application in H0.
 *)
(*  destruct H0. apply term_abs_to_body in H0. apply reg_rule_b; trivial.
 *)
(*  intro H'. apply term_distribute_over_application in H0. destruct H0.
 *)
(*  assert (Q : ~ NF lex (pterm_abs t // l)).
 *)
(*    apply IHl; trivial.
 *)
(*  clear IHl H'. intro H'. apply Q. intros t' H2.
 *)
(*  apply (H' (pterm_app t' a)). apply left_app_lex; trivial.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma lex_sub_not_NF : forall x t u, body t -> term u -> x \notin (fv t) ->
 *)
(*       ~ NF lex (t ^ x) -> ~ NF lex (t[u]).
 *)
(* Proof.
 *)
(*  intros. intro H3. apply H2. clear H2.
 *)
(*  intros t0 H2. gen_eq t1 : (close t0 x). intro H4.
 *)
(*  replace t0 with (t1 ^ x) in H2. apply (H3 (t1 [u])).
 *)
(*  apply left_subst_lex with (L:= (fv t) \u (fv t1)); trivial.
 *)
(*  intros z Fr. apply notin_union in Fr. destruct Fr.
 *)
(*  apply ctx_sys_lex_red_rename with (x := x); trivial.
 *)
(*  rewrite H4. apply fv_close'. rewrite H4.
 *)
(*  rewrite open_close_var with (x := x); trivial.
 *)
(*  apply ctx_sys_Bex_regular in H2. apply H2.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma lex_sub_not_NF' : forall t u, body t -> term u -> ~ NF lex (t[u]).
 *)
(* Proof.
 *)
(*   intros. apply body_size_induction with (t := t); trivial; intros; intro H'.
 *)
(*   apply (H' u). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_var; trivial.
 *)
(*   apply (H' (pterm_fvar x)). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_gc; trivial.
 *)
(*   apply (H' (pterm_abs ((& t1)[u]))). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_lamb; trivial.
 *)
(*   rewrite body_eq_body'; unfold body'. simpl; trivial.
 *)
(*   apply (H' (pterm_app (t1[u]) (t2[u]))). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_app; trivial;
 *)
(*   rewrite body_eq_body' in *|-*; unfold body' in *|-*; simpl in *|-*; apply H2.
 *)
(*   case var_fresh with (L := fv t3).
 *)
(*   intros x Hx. case fv_in_or_notin with (t := t3 ^ x) (x := x); intros.
 *)
(*   apply (H' ((& t1)[u][ t3[ u ] ])). apply ctx_to_mod_eqC. apply redex. apply sys_x_lx. apply reg_rule_comp; trivial.
 *)
(*   rewrite body_eq_body' in *|-*; unfold body' in *|-*; simpl in *|-*; split; trivial.
 *)
(*   rewrite term_eq_term'. unfold term'. apply not_body_term_fvar with (x := x); trivial.
 *)
(*   rewrite body_eq_body' in H2. unfold body' in H2. trivial.
 *)
(*   assert (T : term t3).
 *)
(*     rewrite term_eq_term'; simpl. unfold term'.
 *)
(*     rewrite body_eq_body' in *|-; unfold body' in *|-.
 *)
(*     apply body_term_fvar with (x := x); trivial.
 *)
(*   clear x Hx H2 H5. rewrite eqC_redex in H'; trivial.
 *)
(*   generalize H'. case var_fresh with (L := fv ((& t1)[u])).
 *)
(*   intros x Fr. apply lex_sub_not_NF with (x := x); trivial.
 *)
(*   rewrite body_eq_body'. unfold body'. simpl.
 *)
(*   split. apply lc_at_bswap; try omega; trivial.
 *)
(*   rewrite <- body_eq_body'. apply term_is_a_body; trivial.
 *)
(*   unfold open. unfold bswap. simpl.
 *)
(*   replace (open_rec 0 (pterm_fvar x) u) with u.
 *)
(*   apply H4.
 *)
(*   simpl in Fr. apply notin_union in Fr. apply Fr.
 *)
(*   rewrite size_bswap_rec; trivial.
 *)
(*   rewrite body_eq_body'. unfold body'.
 *)
(*   rewrite <- lc_at_open with (u := pterm_fvar x); trivial.
 *)
(*   apply lc_at_bswap; try omega; trivial.
 *)
(*   rewrite open_lc_at; trivial.
 *)
(*   rewrite <- term_eq_term'; trivial.
 *)
(* Qed.   *)

(* (** SN lex Properties **)
 *)
(*
 *)
(*
 *)
(* Lemma SN_app_var : forall x t, SN lex t -> SN lex (pterm_app (pterm_fvar x) t).
 *)
(* Proof.
 *)
(*  intros x t H. case H; clear H. intros n H. exists n. generalize t H; clear t H.
 *)
(*  induction n. intros t H. rewrite <- NF_eq_SN0 in *|-*.
 *)
(*  replace (pterm_app (pterm_fvar x) t) with ((pterm_fvar x) // (t :: nil)).
 *)
(*  apply NF_mult_app_var. simpl; split; trivial. simpl; trivial.
 *)
(*  intros t H. inversion H. apply SN_intro. intros u H'.
 *)
(*  apply lex_app_var in H'. case H'; clear H'; intros t' H'.
 *)
(*  destruct H'. case (H0 t'); clear H0; trivial. intros k H0.
 *)
(*  destruct H0. exists n; split; try omega. rewrite H1. apply IHn.
 *)
(*  apply WSN with (k := k); try omega; trivial.
 *)
(* Qed.
 *)
(*
 *)
(*
 *)
(*
 *)
(* Lemma SN_mult_app_var : forall x lt, term %% lt -> SN lex %% lt -> SN lex ((pterm_fvar x) // lt).
 *)
(* Proof.
 *)
(*  intros x lt T H. induction lt; simpl. exists 0. rewrite <- NF_eq_SN0. apply NF_fvar.
 *)
(*  simpl in *|-*. destruct T. destruct H. assert (H': SN lex (pterm_fvar x // lt)). apply IHlt; trivial. clear H2 IHlt.
 *)
(*  case H; clear H. intros n H. case H'; clear H'. intros n' H'.
 *)
(*  gen_eq k : (n + n'). intro Hk. exists k. generalize a lt n n'  H0 H1 H H' Hk. clear a lt n n' H0 H1 H H' Hk.
 *)
(*  induction k. intros.
 *)
(*  assert (Qn : n = 0). symmetry in Hk. omega.
 *)
(*  assert (Qn': n' = 0). symmetry in Hk. omega. clear Hk.
 *)
(*  rewrite Qn in H. rewrite Qn' in H'. clear Qn Qn'.
 *)
(*  rewrite <- NF_eq_SN0 in *|-*.
 *)
(*  replace (pterm_app (pterm_fvar x // lt) a) with ((pterm_fvar x) // (a :: lt)).
 *)
(*  apply NF_mult_app_var. simpl. split; trivial. clear a n n' H0 H.
 *)
(*  induction lt; simpl in *|-*; trivial. split. intros a' Ha'.
 *)
(*  apply (H' (pterm_app (pterm_fvar x // lt) a')).
 *)
(*  apply right_app_lex; trivial. rewrite term_mult_app. destruct H1. split; trivial.
 *)
(*  apply IHlt. apply H1. intros t' Ht'. apply (H' (pterm_app t' a)).
 *)
(*  apply left_app_lex; trivial. apply H1. simpl; trivial.
 *)
(*  intros. apply SN_intro. intros t' Ht'. inversion H. inversion H'.
 *)
(*  apply lex_app in Ht'. case Ht'; clear Ht'. intro Ht'. case Ht'; clear Ht'. intros u Ht'. destruct Ht'.
 *)
(*  case eqdec_nil with (l := lt). intro H6. rewrite H6 in H4. simpl in H4. apply eqC_fvar_term in H4. apply False_ind.
 *)
(*  generalize H4. discriminate. intro H6. case m_app_eq_app with (t := (pterm_fvar x)) (lu := lt); trivial.
 *)
(*  intros u0 H7. case H7; clear H7. intros v0 H7. rewrite H7 in H4. apply eqC_app_term in H4.
 *)
(*  case H4; clear H4. intros u' H4. case H4; clear H4. intros v' H4. destruct H4. apply False_ind.
 *)
(*  generalize H4. discriminate.
 *)
(*  intro H4. case H4; clear H4. intro H4. case H4; clear H4; intros u H4. destruct H4.
 *)
(*  case (H3 u); trivial; clear H3. intros k' H3. destruct H3. exists k. split; try omega.
 *)
(*  rewrite H4. apply lex_mult_app_var in H5. case H5; clear H5. intros lt' H5. destruct H5. rewrite H5.
 *)
(*  apply IHk with (n := n) (n' := n' - 1); trivial. apply lex_R_list_regular in H7. apply H7; trivial.
 *)
(*  apply WSN with (k := k'); try omega. rewrite <- H5; trivial. omega.
 *)
(*  intro H4. case H4; clear H4. intros a' H4. destruct H4. exists k; split; try omega.
 *)
(*  case (H2 a'); clear H2; trivial. intros k' H2. destruct H2. rewrite H4.
 *)
(*  apply IHk with (n := n - 1) (n' := n'); trivial. apply ctx_sys_Bex_regular in H5. apply H5.
 *)
(*  apply WSN with (k := k'); try omega; trivial. omega.
 *)
(* Qed.
 *)
(*
 *)
(*
 *)
(* Lemma lex_SN_abs : forall n L t, (forall x, x \notin L -> SN_ind n lex (t ^ x)) ->
 *)
(*                                  (SN_ind n lex (pterm_abs t)).
 *)
(* Proof.
 *)
(*  intros n L t. generalize t; clear t. induction n.
 *)
(*  intros. rewrite <- NF_eq_SN0. setoid_rewrite <- NF_eq_SN0 in H.
 *)
(*  intros t' H'. apply lex_abs in H'. case H'; clear H'; intros L0 H'. case H'; clear H'; intros t0 H'.
 *)
(*  destruct H'. pick_fresh x. apply notin_union in Fr. destruct Fr. apply notin_union in H2. destruct H2.
 *)
(*  apply notin_union in H2. destruct H2. apply notin_union in H2. destruct H2.
 *)
(*  case H with (x := x) (t' := (t0 ^ x)); trivial. apply H1; trivial.
 *)
(*  intros t H. apply SN_intro. intros t' H'. exists n; split; try omega.
 *)
(*  apply lex_abs in H'. case H'; clear H'; intros L0 H'. case H'; clear H'; intros t0 H'.
 *)
(*  destruct H'. pick_fresh x. apply notin_union in Fr. destruct Fr. apply notin_union in H2. destruct H2.
 *)
(*  apply notin_union in H2. destruct H2. apply notin_union in H2. destruct H2.  apply notin_union in H2. destruct H2.
 *)
(*  rewrite H0. apply IHn. intros x' H8. destruct (H x'); trivial. case (H9 (t0 ^ x')).
 *)
(*  apply ctx_sys_lex_red_rename with (x := x); trivial. apply H1; trivial.
 *)
(*  intros k H10. destruct H10. apply WSN with (k := k); try omega; trivial.
 *)
(* Qed.
 *)
(*
 *)
(*
 *)
(* Lemma lex_SN_ind_rename : forall n x x' t, body t -> x' \notin ({{x}} \u (fv t)) -> SN_ind n lex (t ^ x) -> SN_ind n lex (t ^ x').
 *)
(* Proof.
 *)
(*  intros n x x' t B Fr H. apply notin_union in Fr; destruct Fr. apply notin_singleton in H0.
 *)
(*  generalize t B H0 H1 H. clear t B H0 H1 H. induction n.
 *)
(*  intros t B H0 H1 H. rewrite <- NF_eq_SN0 in *|-*.
 *)
(*  intros t' H'. gen_eq t0 : (close t' x'). intro H2.
 *)
(*  replace t' with (t0 ^ x') in H'. apply (H (t0 ^x)). apply ctx_sys_lex_red_rename with (x := x'); trivial.
 *)
(*  rewrite H2. apply fv_close'. rewrite H2. rewrite open_close_var with (x := x'). reflexivity.
 *)
(*  apply ctx_sys_Bex_regular in H'. apply H'. intros t B H0 H1 H. destruct H.
 *)
(*  apply SN_intro. intros t' H'. exists n; split; try omega. gen_eq t0 : (close t' x'). intro H2.
 *)
(*  generalize H'. intro T. apply ctx_sys_Bex_regular in T. destruct T.
 *)
(*  replace t' with (t0 ^ x') in H'. case (H (t0 ^ x)); clear H. apply ctx_sys_lex_red_rename with (x := x'); trivial.
 *)
(*  rewrite H2. apply fv_close'. intros k H. destruct H.  replace t' with (t0 ^ x'). apply (IHn t0); trivial.
 *)
(*  apply ctx_sys_Bex_regular in H'. destruct H'. rewrite term_eq_term' in H7. unfold term' in H7. unfold open in H7.
 *)
(*  rewrite body_eq_body'. unfold body'. rewrite lc_at_open with (u := pterm_fvar x'); trivial.
 *)
(*  rewrite H2. apply fv_close'. apply WSN with (k := k); try omega; trivial.
 *)
(*  rewrite H2; rewrite open_close_var with (x := x'); try reflexivity; trivial.
 *)
(*  rewrite H2; rewrite open_close_var with (x := x'); try reflexivity; trivial.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma lex_SN_rename :  forall x x' t, body t -> x' \notin ({{x}} \u (fv t)) -> SN lex (t ^ x) -> SN lex (t ^ x').
 *)
(* Proof.
 *)
(*  intros. case H1; clear H1; intros n H1; exists n; apply lex_SN_ind_rename with (x := x); trivial.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma lex_SN_ind_swap : forall n x y t, SN_ind n lex t -> SN_ind n lex ([(x,y)]t).
 *)
(* Proof.
 *)
(*  intros. generalize t H. clear t H. induction n.
 *)
(*  intros. rewrite <- NF_eq_SN0 in *|-*. intros t' H'.
 *)
(*  apply (H ([(x,y)]t')). rewrite <- swap_inv with (t := t) (x := x) (y := y).
 *)
(*  apply ctx_sys_lex_red_swap; trivial.
 *)
(*  intros. inversion H. clear H. apply SN_intro. intros t' H'.
 *)
(*  rewrite <- swap_inv with (t := t') (x := x) (y := y).
 *)
(*  case (H0 ([(x, y)]t')). rewrite <- swap_inv with (t := t) (x := x) (y := y).
 *)
(*  apply ctx_sys_lex_red_swap; trivial.
 *)
(*  intros k H. destruct H. exists n; split; try omega.  apply IHn; trivial.
 *)
(*  apply WSN with (k := k); try omega; trivial.
 *)
(* Qed.
 *)
(*
 *)
(* Lemma lex_SN_swap : forall x y t, SN lex t -> SN lex ([(x,y)]t).
 *)
(* Proof. intros; case H; clear H; intros n H; exists n; apply lex_SN_ind_swap; trivial. Qed.
 *)
(*
 *)
(* *) *)

(* (* LexSN *) *)

(* (** Inductive Characterisation of SN lex **)
 *)
(*
 *)
(*  Inductive ISN : pterm -> Prop :=
 *)
(*
 *)
(*
 *)
(*   | isn_var : forall (x : var) (lu : list pterm),
 *)
(*
 *)
(*                      (forall u, (In u lu) -> ISN u) ->
 *)
(* (*-------------------------------------------------------------------------*)
 *)
(*                          ISN ((pterm_fvar x) // lu)
 *)
(*
 *)
(*
 *)
(*   | isn_NF : forall (u : pterm),
 *)
(*
 *)
(*                                 NF lex u ->
 *)
(* (*-------------------------------------------------------------------------*)
 *)
(*                                   ISN u
 *)
(*
 *)
(*
 *)
(*   | isn_app : forall  (u v : pterm) (lu : list pterm),
 *)
(*
 *)
(*                       ISN (u[v] // lu) ->
 *)
(* (*-------------------------------------------------------------------------*)
 *)
(*                       ISN ((pterm_app (pterm_abs u)  v) // lu)
 *)
(*
 *)
(*
 *)
(*   | isn_subs : forall  (u v : pterm) (lu : list pterm),
 *)
(*
 *)
(*                   ISN ((u ^^ v) // lu) -> ISN v ->
 *)
(* (*-------------------------------------------------------------------------*)
 *)
(*                        ISN (u[v] // lu)
 *)
(*
 *)
(*
 *)
(*   | isn_abs : forall L (u : pterm),
 *)
(*
 *)
(*                        (forall x, x \notin L -> ISN (u ^ x)) ->
 *)
(* (*-------------------------------------------------------------------------*)
 *)
(*                            ISN (pterm_abs u) .
 *)
(*
 *)
(*
 *)
(*
 *)
(*
 *)
(* Lemma ISN_prop : forall t, term t -> (ISN t <-> SN lex t).
 *)
(* Proof.
 *)
(* (*  intros t T. split. intro H. induction H. *)
 *)
(* (* (* -> *) *)
 *)
(* (*  (* isn_var *) *)
 *)
(* (*  rewrite term_mult_app in T. destruct T. clear H1. *)
 *)
(* (*  assert (Q : SN lex %% lu). *)
 *)
(* (*   clear H. induction lu; simpl in *|-*; trivial. *)
 *)
(* (*   destruct H2. split. apply H0; trivial. left. trivial. *)
 *)
(* (*   apply IHlu; trivial. intros u Hu Tu. *)
 *)
(* (*   apply H0; trivial. right; trivial. *)
 *)
(* (*  apply SN_mult_app_var; trivial. *)
 *)
(* (*  (* isn_NF *) *)
 *)
(* (*  exists 0. rewrite <- NF_eq_SN0; trivial. *)
 *)
(* (*  (* isn_app *) *)
 *)
(* (*  apply perpetuality with (t' := ((u [v]) // lu)); trivial. *)
 *)
(* (*  apply p_B. apply IHISN. rewrite term_mult_app in *|-*. *)
 *)
(* (*  destruct T. split; trivial. rewrite term_eq_term' in *|-*. *)
 *)
(* (*  unfold term' in *|-*. simpl in *|-*. trivial. *)
 *)
(* (*  (* isn_subs *) *)
 *)
(* (*  generalize T. intro T'. rewrite term_mult_app in T. destruct T. *)
 *)
(* (*  apply subs_to_body in H1. destruct H1. *)
 *)
(* (*  apply perpetuality with (t' := ((u ^^ v) // lu)); trivial. *)
 *)
(* (*  apply p_subst1; trivial. apply IHISN2; trivial. apply IHISN1; trivial. *)
 *)
(* (*  rewrite term_mult_app. split; trivial. *)
 *)
(* (*  apply body_open_term; trivial. *)
 *)
(* (*  (* isn_abs *) *)
 *)
(* (*  apply term_abs_to_body in T. *)
 *)
(* (*  case var_fresh with (L := L \u fv u). intros x Fr. *)
 *)
(* (*  apply notin_union in Fr. destruct Fr. *)
 *)
(* (*  case (H0 x); trivial. apply body_to_term; trivial. *)
 *)
(* (*  intros n H3. exists n. apply lex_SN_abs with (L := {{x}} \u (fv u)). *)
 *)
(* (*  intros x' Fr. apply lex_SN_ind_rename with (x := x); trivial. *)
 *)
(* (* (* <- *) *)
 *)
(* (*  intro H. unfold SN in H. case H; clear H; intros n H. *)
 *)
(* (*  generalize t T H; clear T t H. induction n; intros. *)
 *)
(* (*  apply isn_NF. apply SN0_to_NF. trivial. *)
 *)
(* (*  generalize H; clear H. *)
 *)
(* (*  assert (Reg : red_regular sys_Bx). *)
 *)
(* (*   apply  sys_Bx_regular. *)
 *)
(* (*  assert (Out : red_out sys_Bx). *)
 *)
(* (*   apply  sys_Bx_red_out. *)
 *)
(* (*  apply term_size_induction3 with (t := t); intros; trivial. *)
 *)
(* (*  (* var *) *)
 *)
(* (*  apply isn_var; intros. *)
 *)
(* (*  assert (Q : SN_ind (S n) lex  %% l). *)
 *)
(* (*     apply eqC_SN_app_list in H0; trivial. apply H0. *)
 *)
(* (*     rewrite <- P_list_eq with (P := term). *)
 *)
(* (*     intros u' H2. apply H; trivial. *)
 *)
(* (*  apply H; trivial. rewrite <- P_list_eq with (P := SN_ind (S n) lex) in Q. *)
 *)
(* (*  apply Q; trivial. *)
 *)
(* (*  (* abs *) *)
 *)
(* (*  case eqdec_nil with (l := l). *)
 *)
(* (*  intro H3. rewrite H3 in *|-*. simpl in *|-*. clear H H3. *)
 *)
(* (*  apply isn_abs with (L := fv t1). intros x Fr. *)
 *)
(* (*  apply H1; trivial. apply body_to_term; trivial. *)
 *)
(* (*  apply eqC_SN_abs; trivial. *)
 *)
(* (*  intro H3. case not_nil_append with (l := l); trivial. *)
 *)
(* (*  intros a Hl. case Hl; clear Hl. intros l' Hl. *)
 *)
(* (*  rewrite Hl in *|-*. rewrite <- mult_app_append in *|-*. *)
 *)
(* (*  clear H3 Hl. *)
 *)
(* (*  assert (Tl : term a /\ term %% l'). *)
 *)
(* (*    split. apply H. apply in_or_app. right. *)
 *)
(* (*    simpl; left; trivial. *)
 *)
(* (*    apply P_list_eq with (P := term). *)
 *)
(* (*    intros u Hu. apply H. apply in_or_app. left. *)
 *)
(* (*    trivial. *)
 *)
(* (*  clear H H1. destruct Tl. *)
 *)
(* (*  apply isn_app. apply IHn. *)
 *)
(* (*  rewrite term_mult_app. split; trivial. *)
 *)
(* (*  apply body_to_subs; trivial. *)
 *)
(* (*  apply SN_one_step with (t := pterm_app (pterm_abs t1) a // l'); trivial. *)
 *)
(* (*  apply left_m_app_lex; trivial. apply ctx_to_mod_eqC. apply redex. *)
 *)
(* (*  apply B_lx. apply reg_rule_b; trivial. *)
 *)
(* (*  (* subs *) *)
 *)
(* (*  assert (Tl : term %% l). *)
 *)
(* (*    apply P_list_eq with (P := term). *)
 *)
(* (*    intros u Hu. apply H; trivial. *)
 *)
(* (*  apply isn_subs. *)
 *)
(* (*  apply IHn. apply term_mult_app. split; trivial. *)
 *)
(* (*  apply body_open_term; trivial. *)
 *)
(* (*  case SN_trs with (n := S n) (R := lex) (t := (t1 [t3]) // l) (u := (t1 ^^ t3) // l); trivial. *)
 *)
(* (*  apply left_trans_m_app_lex; trivial. *)
 *)
(* (*  apply trs_ex_to_lex. apply full_comp; trivial. *)
 *)
(* (*  intros k Hk. destruct Hk. apply WSN with (k := k); try omega; trivial. *)
 *)
(* (*  apply eqC_SN_app_list in H4; trivial. destruct H4. *)
 *)
(* (*  case var_fresh with (L := (fv t1)). intros x Fr. *)
 *)
(* (*  apply eqC_SN_sub with (x := x) in H4; trivial. *)
 *)
(* (*  destruct H4.  apply H1; trivial. *)
 *)
(* (*  apply body_to_subs; trivial. *)
 *)
(* (* Qed. *) Admitted. *)


Require Import List.
Require Import Arith.

(** * Compiling CCP to D *)

Require Import Common.
Require Import D.

Definition compile (e : CCP.expr) : D.expr := e.

Hint Constructors D.Sem CCP.Sem.

Lemma completeness_lemma :
forall Config Val0
  (CCPS : CCP.Sem Config Val0)
  Val1 K
  (DS : D.Sem (A Val0, K) Val1),
  D.Sem (E Config, K) Val1.
Proof with intros; eauto.
intros ? ? ?.
induction CCPS...
eapply D.App_Eval; try rewrite <- ARGSNIL...
Qed.

Lemma completeness :
forall Config Value
  (CCPS : CCP.Sem Config Value),
  D.Sem (E Config, nil) Value.
Proof with eauto.
intros; eapply completeness_lemma...
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(**** Tests of Field with real numbers ****)

Require Import Reals LegacyRfield.

(* Example 1 *)
Goal
forall eps : R,
(eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)))%R = (eps * (1 / 2))%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 2 *)
Goal
forall (f g : R -> R) (x0 x1 : R),
((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R =
((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 3 *)
Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 4 *)
Goal
forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 5 *)
Goal forall a : R, 1%R = (1 * (1 / a) * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 6 *)
Goal forall a b : R, b = (b * / a * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 7 *)
Goal forall a b : R, b = (b * (1 / a) * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 8 *)
Goal
forall x y : R,
(x * (1 / x + x / (x + y)))%R =
(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R.
Proof.
  intros.
   legacy field.
Abort.


From Hammer Require Import Hammer.

From Fermat4 Require Export Tactics.

Definition nnl_triple (a b c : Z) := ~(a = 0) /\ ~(b = 0) /\ ~(c = 0).

Definition pos_triple (a b c : Z) := (a >= 0) /\ (b >= 0) /\ (c >= 0).

Definition is_pytha (a b c : Z) := (pos_triple a b c) /\ a * a + b * b = c * c.

Definition in_ucirc (x y : R) := (x * x + y * y = 1)%R.
Definition D_r (r x y : R) := (y = r * (x + 1))%R.

Lemma pytha_ucirc1 : forall a b c : Z,
(c > 0) -> (is_pytha a b c) -> (in_ucirc (frac a c) (frac b c)).
Proof. hammer_hook "Pythagorean" "Pythagorean.pytha_ucirc1".
intros; unfold in_ucirc; unfold frac; field_simplify_eq.
unfold is_pytha in H0; elim H0; intros.
repeat rewrite pow_IZR. rewrite <- plus_IZR. simpl Z_of_nat.
ring_simplify [(sym_eq H2)] (c^2);trivial.
discrR; auto with zarith.
Qed.

Lemma pytha_ucirc2 : forall a b c : Z, (a >= 0) /\ (b >= 0) /\ (c > 0) ->
(in_ucirc (frac a c) (frac b c)) -> (is_pytha a b c).
Proof. hammer_hook "Pythagorean" "Pythagorean.pytha_ucirc2".
unfold in_ucirc; unfold frac; unfold is_pytha; intros; split.
unfold pos_triple; auto with zarith.
apply eq_IZR; apply (Rmult_eq_reg_l (/ (IZR c * IZR c))).
pattern (IZR c * IZR c)%R at 2; rewrite <- mult_IZR;rewrite Rinv_l.
rewrite Rinv_mult_distr.
rewrite <- H0; rewrite plus_IZR; repeat rewrite mult_IZR; field.
discrR; auto with zarith.
discrR; auto with zarith.
discrR; auto with zarith.
rewrite mult_IZR; split_Rmult; discrR; auto with zarith.
apply Rinv_neq_0_compat; split_Rmult; discrR; auto with zarith.
Qed.

Definition interCDr (r x y : R) := (in_ucirc x y) /\ (D_r r x y).

Definition p1 := (-1,0)%R.
Definition p2 (r : R) :=
let den := (1 + r * r)%R in
((1 - r * r) / den, 2 * r / den)%R.

Definition eqp (p1 p2 : R * R) := (fst p1) = (fst p2) /\ (snd p1)= (snd p2).

Lemma ordp : forall p1 p2 : R * R, (eqp p1 p2) \/ ~(eqp p1 p2).
Proof. hammer_hook "Pythagorean" "Pythagorean.ordp".
intros p3 p4. unfold eqp; elim p3; elim p4; intros; simpl.
elim (Req_dec a a0); elim (Req_dec b b0); intuition.
Qed.

Lemma interCDr_sol : forall r x y : R,
(interCDr r x y) -> (eqp (x,y) p1) \/ (eqp (x,y) (p2 r)).
Proof. hammer_hook "Pythagorean" "Pythagorean.interCDr_sol".
unfold interCDr;unfold in_ucirc;unfold D_r;unfold eqp, p1, p2;simpl.
intros;elim H;intros;rewrite H1 in H0.
cut (((1 + r * r) * Rsqr x + 2 * r * r * x + (r * r - 1)) = 0)%R.
intro;cut ((1 + r * r) <> 0)%R.
intro;cut (Delta_is_pos (mknonzeroreal (1 + r * r) H3) (2 * r * r)
(r * r - 1))%R.
intro;generalize (Rsqr_sol_eq_0_0 (mknonzeroreal (1 + r * r) H3) (2 * r * r)
(r * r - 1) x H4 H2)%R.
unfold sol_x1, sol_x2;unfold Delta;unfold Rsqr;simpl.
cut ((2 * r * r * (2 * r * r) - 4 * (1 + r * r) * (r * r - 1))%R = 4%R).
intro;rewrite H5. replace (4)%R with (2*2)%R by auto.
rewrite sqrt_square.
induction 1;[right|left].
split;[rewrite H6;field;assumption
|rewrite H1;rewrite H6;field;assumption].
split;[rewrite H6;field;assumption
|rewrite H1;rewrite H6;field;assumption].
unfold Rle;left;prove_sup.
ring.
unfold Delta_is_pos;unfold Delta;unfold Rsqr;simpl;
ring_simplify (2 * r * r * (2 * r * r) - 4 * (1 + r * r) * (r * r - 1))%R;
unfold Rle;left;prove_sup.
apply Rgt_not_eq;unfold Rgt;rewrite Rplus_comm;apply Rle_lt_0_plus_1;
fold (Rsqr r);elim (Req_dec r 0);intro;
[rewrite H3;rewrite Rsqr_0;unfold Rle;right;auto
|unfold Rle;left;apply Rsqr_pos_lt;assumption].
pattern 1%R at 2;rewrite <- H0;unfold Rsqr;ring.
Qed.

Lemma rat_coo1 : forall x y : R, (in_ucirc x y) /\
(exists r : R, (is_rat r) /\ (interCDr r x y)) -> (is_ratp (x,y)).
Proof. hammer_hook "Pythagorean" "Pythagorean.rat_coo1".
unfold in_ucirc, is_ratp, is_rat.
unfold frac; intros; elim H; intros; elim H1; intros; elim H2; intros;
elim H3; intro; elim x1;intros; elim H5; intros;
elim (interCDr_sol x0 x y H4); unfold eqp, p1, p2; simpl; intro; elim H8;
intros; rewrite H9; rewrite H10.
split.
exists (-1,1); split; [ auto with zarith | simpl; field; discrR ].
exists (0,1); split; [ auto with zarith | simpl; field; discrR ].
split.
exists (b * b - a * a, a * a + b * b); split.
auto with zarith.
rewrite H7; rewrite <- Z_R_minus; rewrite plus_IZR; repeat rewrite mult_IZR;
field; split;discrR; auto with zarith reals.
exists (2 * a * b * b, (a * a + b * b) * b); split.
apply not_IZR_0; rewrite mult_IZR; split_Rmult; discrR; auto with zarith.
rewrite H7; repeat rewrite mult_IZR; rewrite plus_IZR;
repeat rewrite mult_IZR; simpl; field; split; discrR;
auto with zarith reals.
Qed.

Lemma rat_coo2 : forall x y : R, (in_ucirc x y) /\ (is_ratp (x,y)) ->
exists r : R, (is_rat r) /\ (interCDr r x y).
Proof. hammer_hook "Pythagorean" "Pythagorean.rat_coo2".
unfold in_ucirc, is_ratp, is_rat, interCDr.
unfold frac, in_ucirc, D_r; intros.
elim (Req_dec x (-1)%R); intro.
exists 1%R; split.
exists (1,1); split; [ auto with zarith | field; discrR ].
elim H; intros; split.
assumption.
rewrite H0; rewrite H0 in H1; ring_simplify (1 * (-1 + 1))%R;
cut ((1 + y * y) = 1)%R;
[ intro; apply Rsqr_0_uniq; unfold Rsqr;
apply (Rplus_0_r_uniq 1 (y * y) H3)%R
| pattern 1%R at 2; rewrite <- H1; ring ].
exists (y / (x + 1))%R; cut ((x + 1) <> 0)%R;
[ intro; split
| rewrite <- (Ropp_involutive 1); fold (x - -1)%R; apply Rminus_eq_contra;
assumption ].
elim H; intros; elim H3; intros; elim H4; intro; elim x0; intros; elim H6;
intros; elim H5; intro; elim x1; intros; elim H9; intros; rewrite H8;
rewrite H11.
cut (a + b <> 0);
[ intro
| apply not_IZR_0;
cut (((IZR a / IZR b + 1) * IZR b)%R = (IZR a + IZR b)%R);
[ intro; rewrite plus_IZR; rewrite <- H12; split_Rmult;
[ rewrite <- H8; assumption
| discrR; assumption ]
| field; discrR; assumption ] ].
exists (a0 * b, b0 * (a + b)); split.
apply not_IZR_0; rewrite mult_IZR; rewrite plus_IZR; split_Rmult; discrR;
assumption.
repeat rewrite mult_IZR; rewrite plus_IZR; field; discrR; try assumption.
repeat split; discrR; try assumption; fold (IZR a / IZR b)%R;
rewrite <- H8; assumption.
split; [ elim H; intros; assumption | field; assumption ].
Qed.

Definition is_posp (c : R * R) := (fst c >= 0)%R /\ (snd c >= 0)%R.

Definition is_ucp (c : R * R) :=
(in_ucirc (fst c) (snd c)) /\ (is_ratp c) /\ (is_posp c).

Definition ucp (p q : Z) :=
let pr := (IZR p) in
let qr := (IZR q) in
let den := (pr * pr + qr * qr)%R in
((qr * qr - pr * pr) / den, (2 * pr * qr) / den)%R.

Definition cond_pqb (p q : Z) := p >= 0 /\ q > 0 /\ p <= q /\ (rel_prime p q).

Definition in_ucp_setb (x y : R) :=
exists p : Z, exists q : Z,
x = (fst (ucp p q)) /\ y = (snd (ucp p q)) /\ (cond_pqb p q).

Lemma rat_pos_coo1 : forall x y : R, (is_ucp (x,y)) ->
exists r : R, (is_rat r) /\ (r >= 0)%R /\ (r <= 1)%R /\ x = (fst (p2 r)) /\
y = (snd (p2 r)).
Proof. hammer_hook "Pythagorean" "Pythagorean.rat_pos_coo1".
intros; unfold is_ucp in H; elim H; intros; elim H1; intros;
elim (rat_coo2 x y (conj H0 H2)); intros; elim H4; intros.
elim (interCDr_sol x0 x y).
unfold eqp; simpl; intro; elim H7; intros; elim H3; simpl; intros;
rewrite H8 in H10; elimtype False; generalize (Rge_le (-1) 0 H10)%R;
fold (~ (0 <= -1)%R); apply Rlt_not_le; prove_sup.
cut (0 < / (1 + x0 * x0))%R;
[ intro
| apply Rinv_0_lt_compat; rewrite <- (Rplus_0_r 0)%R;
apply Rplus_lt_le_compat;
[ prove_sup
| fold (Rsqr x0); elim (Req_dec x0 0); intro;
[ rewrite H7; rewrite Rsqr_0; unfold Rle; right; auto
| unfold Rle; left; apply Rsqr_pos_lt; assumption ] ] ].
unfold eqp; simpl; intro; elim H8; intros; elim H3; simpl; rewrite H9;
rewrite H10; intros; exists x0; split.
assumption.
split.
generalize (Rge_le (2 * x0 / (1 + x0 * x0)) 0 H12); intro;
rewrite Rmult_comm in H13;
rewrite <- (Rmult_0_l (2 / (1 + x0 * x0))) in H13;
cut (0 < 2 / (1 + x0 * x0))%R;
[ intro; rewrite Rmult_comm in H13; unfold Rdiv in H13;
rewrite (Rmult_assoc x0 2) in H13;
rewrite (Rmult_comm x0 (2 * / (1 + x0 * x0)))%R in H13;
generalize (Rmult_le_reg_l (2 / (1 + x0 * x0)) 0 x0 H14 H13); intro;
apply Rle_ge; assumption
| unfold Rdiv; prove_sup; assumption ].
split.
generalize (Rge_le ((1 - x0 * x0) / (1 + x0 * x0)) 0 H11); intro;
unfold Rdiv in H13; rewrite Rmult_comm in H13;
rewrite <- (Rmult_0_r (/ (1 + x0 * x0)))%R in H13;
generalize (Rmult_le_reg_l (/ (1 + x0 * x0)) 0 (1 - x0 * x0) H7 H13)%R;
intro; generalize (Rplus_le_compat_r (x0 * x0) 0 (1 - x0 * x0) H14)%R;
intro; rewrite Rplus_0_l in H15; unfold Rminus in H15;
rewrite Rplus_assoc in H15; rewrite Rplus_opp_l in H15;
rewrite Rplus_0_r in H15; rewrite <- (Rmult_1_r 1) in H15;
fold (Rsqr x0) in H15; fold (Rsqr 1) in H15;
apply (Rsqr_incr_0_var x0 1 H15); unfold Rle; left; prove_sup.
auto.
assumption.
Qed.

Lemma rat_pos_coo2 : forall x y : R, (is_ucp (x,y)) -> (in_ucp_setb x y).
Proof. hammer_hook "Pythagorean" "Pythagorean.rat_pos_coo2".
intros; elim (rat_pos_coo1 x y H); simpl; intros; elim H0; intros; elim H2;
intros; elim H4; intros; elim H6; intros; elim (relp_rat x0 H1 H3 H5);
intro; elim x1; unfold frac; intros; elim H9; intros; elim H11; intros;
elim H13; intros; elim H15; intros; unfold in_ucp_setb; simpl;
unfold cond_pqb; exists a; exists b; rewrite H7; rewrite H8; rewrite H17.
cut (b <> 0); auto with zarith; intro.
split.
field; split; discrR; auto with zarith reals.
split.
field; split; discrR; auto with zarith reals.
tauto.
Qed.

Definition cond_pq (p q : Z) := cond_pqb p q /\ (distinct_parity p q).

Definition in_ucp_set (x y : R) :=
exists p : Z, exists q : Z,
(x = (fst (ucp p q)) /\ y = (snd (ucp p q)) \/
x = (snd (ucp p q)) /\ y = (fst (ucp p q))) /\ (cond_pq p q).

Lemma nrat_pos_coo1 : forall x y : R, (in_ucp_set x y) -> (in_ucp_setb x y).
Proof. hammer_hook "Pythagorean" "Pythagorean.nrat_pos_coo1".
unfold in_ucp_set, in_ucp_setb, cond_pq, cond_pqb; simpl; intros; elim_hyps.
exists x0; exists x1; intuition.
exists (x1 - x0); exists (x0 + x1); rewrite plus_IZR; rewrite <- Z_R_minus;
rewrite H; rewrite H5.
replace
((IZR x1 - IZR x0) * (IZR x1 - IZR x0) +
(IZR x0 + IZR x1) * (IZR x0 + IZR x1))%R with
(2 * (IZR x0 * IZR x0 + IZR x1 * IZR x1))%R by  ring.
split;[idtac|split]; try (field; neq_0;apply sqr_sum; auto with zarith).
do 3 try split; auto with zarith.
generalize (prop1 _ _ H4 H1); auto with zarith.
Qed.

Lemma nrat_pos_coo2 : forall x y : R, (in_ucp_setb x y) -> (in_ucp_set x y).
Proof. hammer_hook "Pythagorean" "Pythagorean.nrat_pos_coo2".
unfold in_ucp_setb, in_ucp_set, cond_pq, cond_pqb, distinct_parity; simpl;
intros; elim_hyps.
elim (relp_parity x0 x1 H4); intro.
exists x0; exists x1; intuition.
unfold both_odd in H5; elim_hyps; generalize (Zodd_def1 _ H5); clear H5;
intro; generalize (Zodd_def1 _ H6); clear H6; intro; elim_hyps.
exists (x2 - x3); exists (x2 + x3 + 1); split;
[ right; rewrite H; rewrite H0; rewrite H5; rewrite H6; atomic_IZR; simpl;
split; field; split; neq_0; apply sqr_sum; auto with zarith
| rewrite H5 in H1; rewrite H6 in H2; rewrite H5 in H3; rewrite H6 in H3;
do 4 try split; auto with zarith ].
apply rel_prime_sym; apply relp_sum; ring_simplify (x2 + x3 + 1 + (x2 - x3));
ring_simplify (x2 + x3 + 1 - (x2 - x3)); generalize H5; clear H5;
ring_simplify (2 * x3 + 1);
intro; generalize H6; clear H6; ring_simplify (2 * x2 + 1); intro;
rewrite <- H5; rewrite <- H6; auto with zarith.
elim (Zeven_odd_dec x2); intro; elim (Zeven_odd_dec x3); intro; Zparity_hyps;
rewrite H7; rewrite H8;
[ left; split; [ apply Zeven_def2; exists (x4 - x5)
| apply Zodd_def2; exists (x4 + x5) ]
| right; split; [ apply Zodd_def2; exists (x5 - x4 - 1)
| apply Zeven_def2; exists (x5 + x4 + 1) ]
| right; split; [ apply Zodd_def2; exists (x4 - x5)
| apply Zeven_def2; exists (x4 + x5 + 1) ]
| left; split; [ apply Zeven_def2; exists (x4 - x5)
| apply Zodd_def2; exists (x4 + x5 + 1) ] ]; ring.
Qed.

Definition pytha_set (a b c : Z) :=
exists p : Z, exists q : Z, exists m : Z,
(a = m * (q * q - p * p) /\ b = 2 * m * (p * q) \/
a = 2 * m * (p * q) /\ b = m * (q * q - p * p)) /\
c = m * (p * p + q * q) /\ m >= 0 /\ (cond_pq p q).

Lemma relp_frac : forall a b c d : Z,
(b <> 0) -> (d <> 0) -> (frac a b) = (frac c d) -> (rel_prime c d) ->
exists m : Z, m <> 0 /\ b = m * d.
Proof. hammer_hook "Pythagorean" "Pythagorean.relp_frac".
unfold frac; intros.
cut (c * b = a * d).
intro; cut (d | c * b);
[ intro; cut (rel_prime d c);
try (intro; generalize (Gauss d c b H4 H5); intro; destruct H6 as (q,H6);
exists q; intuition; rewrite H7 in H6); auto with zarith
| apply (Zdivide_intro _ _ a H3) ].
generalize (Rmult_eq_compat_l (IZR b * IZR d) _ _ H1); clear H1; intro;
replace (IZR b * IZR d * (IZR a / IZR b))%R
with ((IZR a) * (IZR d))%R in H1;
[ replace (IZR b * IZR d * (IZR c / IZR d))%R
with ((IZR c) * (IZR b))%R in H1;
[ repeat rewrite <- mult_IZR in H1; generalize (eq_IZR _ _ H1); auto
| field; discrR; assumption ]
| field; discrR; assumption ].
Qed.

Lemma pytha_thm1 : forall a b c : Z, (is_pytha a b c) -> (pytha_set a b c).
Proof. hammer_hook "Pythagorean" "Pythagorean.pytha_thm1".
do 3 intro; elim (Z_gt_dec c 0); [ idtac
| unfold is_pytha, pytha_set, pos_triple, cond_pq, cond_pqb ]; intros.
generalize (pytha_ucirc1 _ _ _ a0 H); intro;
cut (is_ucp (frac a c, frac b c));
[ clear H0; intro; generalize (rat_pos_coo2 _ _ H0); clear H0; intro;
generalize (nrat_pos_coo2 _ _ H0); clear H0; intro;
unfold in_ucp_set, cond_pq, cond_pqb in H0;
unfold pytha_set, cond_pq, cond_pqb; simpl in H0; elim_hyps;
generalize (relp_pq1 _ _ H1 H4 H5 H2); intro;
generalize (Z.gt_lt _ _ a0); intro; generalize (Zlt_not_eq _ _ H8);
clear H8; intro; generalize (sym_not_eq H8); clear H8; intro;
generalize (Z.gt_lt _ _ H3); intro; generalize (Zlt_not_eq _ _ H9);
clear H9; intro; generalize (sym_not_eq H9); clear H9; intro;
(cut (x * x + x0 * x0 <> 0); [ intro | auto with zarith ];
(cut ((IZR x0 * IZR x0 - IZR x * IZR x) /
(IZR x * IZR x + IZR x0 * IZR x0) =
frac (x0 * x0 - x * x) (x * x + x0 * x0))%R;
[ intro | head_IZR; auto ];
(cut (2 * IZR x * IZR x0 / (IZR x * IZR x + IZR x0 * IZR x0) =
frac (2 * x * x0) (x * x + x0 * x0))%R;
[ intro | head_IZR; auto ])))
| idtac ].
rewrite H11 in H0; clear H11; rewrite H12 in H6; clear H12;
generalize (relp_frac _ _ _ _ H8 H10 H0 H7); intro; elim_hyps;
rewrite H12 in H0; rewrite H12 in H6; exists x; exists x0; exists x1;
generalize (frac_eq _ _ _ _ H11 H10 H0); clear H0; intro;
generalize (frac_eq _ _ _ _ H11 H10 H6); clear H6; intro;
rewrite H0; rewrite H6; rewrite H12; intuition; (left; split; ring) ||
(cut (x1 * (x * x + x0 * x0) > 0);
[ intro; rewrite Zmult_comm in H13; cut (x * x + x0 * x0 > 0);
try (intro; generalize (Zmult_gt_0_reg_l _ _ H14 H13));
auto with zarith
| rewrite <- H12; assumption ]).
rewrite H11 in H6; clear H11; rewrite H12 in H0; clear H12;
generalize (relp_frac _ _ _ _ H8 H10 H6 H7); intro; elim_hyps;
rewrite H12 in H0; rewrite H12 in H6; exists x; exists x0; exists x1;
generalize (frac_eq _ _ _ _ H11 H10 H0); clear H0; intro;
generalize (frac_eq _ _ _ _ H11 H10 H6); clear H6; intro;
rewrite H0; rewrite H6; rewrite H12; intuition; (right; split; ring) ||
(cut (x1 * (x * x + x0 * x0) > 0);
[ intro; rewrite Zmult_comm in H13; cut (x * x + x0 * x0 > 0);
try (intro; generalize (Zmult_gt_0_reg_l _ _ H14 H13));
auto with zarith
| rewrite <- H12; assumption ]).
unfold is_ucp, is_ratp, is_posp; simpl; intuition; unfold is_rat;
unfold is_pytha, pos_triple in H; elim_hyps; generalize (Z.gt_lt _ _ a0);
intro; generalize (IZR_lt _ _ H4); intro; simpl in H5;
fold (IZR c > 0)%R in H5;
[ exists (a, c); intuition | exists (b, c); intuition
| unfold frac; generalize (IZR_ge _ _ H); clear H; intro; simpl in H
| unfold frac; generalize (IZR_ge _ _ H2); clear H2; intro; simpl in H2 ];
auto with reals.
elim_hyps; cut (c = 0);
[ intro; exists 0; exists 1; exists 0; rewrite H3; simpl; intuition;
(left; rewrite H3 in H0; simpl in H0; progress auto with zarith)
|| (compute; auto with zarith)
| auto with zarith ].
Qed.

Lemma pytha_thm2 : forall a b c : Z, (pytha_set a b c) -> (is_pytha a b c).
Proof. hammer_hook "Pythagorean" "Pythagorean.pytha_thm2".
unfold pytha_set, is_pytha, cond_pq, cond_pqb, pos_triple; intros; elim_hyps;
rewrite H; rewrite H7; rewrite H0; split; ring || (intuition; apply Z.le_ge;
generalize (Z.ge_le _ _ H2); clear H2; intro; generalize (Z.gt_lt _ _ H4);
clear H4; intro; generalize (Zlt_le_weak _ _ H4); intro;
repeat apply Zmult_le_0_compat; auto with zarith).
Qed.

Definition pytha_set_even (a b c : Z) :=
exists p : Z, exists q : Z, exists m : Z,
a = m * (q * q - p * p) /\ b = 2 * m * (p * q) /\
c = m * (p * p + q * q) /\ m >= 0 /\ (cond_pq p q).

Lemma pytha_thm3 : forall a b c : Z,
is_pytha a b c -> Zodd a -> pytha_set_even a b c.
Proof. hammer_hook "Pythagorean" "Pythagorean.pytha_thm3".
intros; elim (pytha_thm1 _ _ _ H); clear H; intros;
unfold cond_pq, cond_pqb in H; elim_hyps;
unfold pytha_set_even, cond_pq, cond_pqb; exists x; exists x0; exists x1;
try solve [ intuition ].
elimtype False; rewrite <- Zmult_assoc in H;
generalize (Zeven_def2 _ (ex_intro (fun x => a = 2 * x) (x1 * (x * x0)) H));
intro; generalize (Zeven_not_Zodd _ H9); auto.
Qed.