(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation from Mach to ARM. *)

Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Locations.
Require Import Mach.
Require Import Asm.
Require Import Compopts.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

(** Extracting integer or float registers. *)

Definition ireg_of (r: mreg) : res ireg :=
  match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.

Definition freg_of (r: mreg) : res freg :=
  match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.

(** Recognition of integer immediate arguments for arithmetic operations.
- ARM: immediates are 8-bit quantities zero-extended and rotated right
  by 0, 2, 4, ... 30 bits.  In other words, [n] is an immediate iff
  [rotate-left(n, p)] is between 0 and 255 for some [p = 0, 2, 4, ..., 30].
- Thumb: immediates are 8-bit quantities zero-extended and shifted left
  by 0, 1, ..., 31 bits.  In other words, [n] is an immediate if
  all bits are 0 except a run of 8 adjacent bits.  In addition,
  [00XY00XY] and [XY00XY00] and [XYXYXYXY] are immediates for
  a given [XY] 8-bit constant.
*)

Fixpoint is_immed_arith_arm (n: nat) (x: int) {struct n}: bool :=
  match n with
  | Datatypes.O => false
  | Datatypes.S n =>
      Int.eq x (Int.and x (Int.repr 255)) ||
      is_immed_arith_arm n (Int.rol x (Int.repr 2))
  end.

Fixpoint is_immed_arith_thumb (n: nat) (x: int) {struct n}: bool :=
  match n with
  | Datatypes.O => true
  | Datatypes.S n =>
      Int.eq x (Int.and x (Int.repr 255)) ||
      (Int.eq (Int.and x Int.one) Int.zero
       && is_immed_arith_thumb n (Int.shru x Int.one))
  end.

Definition is_immed_arith_thumb_special (x: int): bool :=
  let l1 := Int.and x (Int.repr 255) in
  let l2 := Int.shl l1 (Int.repr 8) in
  let l3 := Int.shl l2 (Int.repr 8) in
  let l4 := Int.shl l3 (Int.repr 8) in
  let l13 := Int.or l1 l3 in
  let l24 := Int.or l2 l4 in
  Int.eq x l13 || Int.eq x l24 || Int.eq x (Int.or l13 l24).

Definition is_immed_arith (x: int): bool :=
  if thumb tt
  then is_immed_arith_thumb 24%nat x || is_immed_arith_thumb_special x
  else is_immed_arith_arm 16%nat x.

(** Recognition of integer immediate arguments for indexed memory accesses.
- For 32-bit integers, immediate offsets are [(-2^12,2^12)] for ARM classic
  and [(-2^8,2^12)] for Thumb2.
- For 8- and 16-bit integers, immediate offsets are [(-2^8,2^8)].
- For 32- and 64-bit integers, immediate offsets are multiples of 4
  in [(-2^10,2^10)].

For all 3 kinds of accesses, we provide not a recognizer but a synthesizer:
a function taking an arbitrary offset [n] and returning a valid offset [n']
that contains as many useful bits of [n] as possible, so that the
computation of the remainder [n - n'] is as simple as possible.
In particular, if [n] is a representable immediate argument, we should have
[n' = n].
*)

Definition mk_immed_mem_word (x: int): int :=
  if Int.ltu x Int.zero then
    Int.neg (Int.zero_ext (if thumb tt then 8 else 12) (Int.neg x))
  else
    Int.zero_ext 12 x.

Definition mk_immed_mem_small (x: int): int :=
  if Int.ltu x Int.zero then
    Int.neg (Int.zero_ext 8 (Int.neg x))
  else
    Int.zero_ext 8 x.

Definition mk_immed_mem_float (x: int): int :=
  let x := Int.and x (Int.repr (-4)) in   (**r mask low 2 bits off *)
  if Int.ltu x Int.zero then
    Int.neg (Int.zero_ext 10 (Int.neg x))
  else
    Int.zero_ext 10 x.

(** Decomposition of a 32-bit integer into a list of immediate arguments,
    whose sum or "or" or "xor" equals the integer. *)

Fixpoint decompose_int_arm (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl (Int.repr 3) p)) Int.zero then
        decompose_int_arm M n (Int.add p (Int.repr 2))
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_arm M (Int.and n (Int.not m)) (Int.add p (Int.repr 2))
  end.

Fixpoint decompose_int_thumb (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl Int.one p)) Int.zero then
        decompose_int_thumb M n (Int.add p Int.one)
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_thumb M (Int.and n (Int.not m)) (Int.add p Int.one)
  end.

Definition decompose_int_base (n: int): list int :=
  if thumb tt
  then if is_immed_arith_thumb_special n
       then n :: nil
       else decompose_int_thumb 24%nat n Int.zero
  else decompose_int_arm 12%nat n Int.zero.

Definition decompose_int (n: int) : list int :=
  match decompose_int_base n with
  | nil => Int.zero :: nil
  | l   => l
  end.

Definition iterate_op (op1 op2: shift_op -> instruction) (l: list int) (k: code) :=
  match l with
  | nil =>
      op1 (SOimm Int.zero) :: k                 (**r should never happen *)
  | i :: l' =>
      op1 (SOimm i) :: map (fun i => op2 (SOimm i)) l' ++ k
  end.

(** Smart constructors for integer immediate arguments. *)

Definition loadimm_thumb (r: ireg) (n: int) (k: code) :=
  let hi := Int.shru n (Int.repr 16) in
  if Int.eq hi Int.zero
  then Pmovw r n :: k
  else Pmovw r (Int.zero_ext 16 n) :: Pmovt r hi :: k.

Definition loadimm (r: ireg) (n: int) (k: code) :=
  let d1 := decompose_int n in
  let d2 := decompose_int (Int.not n) in
  let l1 := List.length d1 in
  let l2 := List.length d2 in
  if NPeano.leb l1 1%nat then
    Pmov r (SOimm n) :: k
  else if NPeano.leb l2 1%nat then
    Pmvn r (SOimm (Int.not n)) :: k
  else if thumb tt then
    loadimm_thumb r n k
  else if NPeano.leb l1 l2 then
    iterate_op (Pmov r) (Porr r r) d1 k
  else
    iterate_op (Pmvn r) (Pbic r r) d2 k.

Definition addimm (r1 r2: ireg) (n: int) (k: code) :=
  if Int.ltu (Int.repr (-256)) n then
    Psub r1 r2 (SOimm (Int.neg n)) :: k
  else
   (let d1 := decompose_int n in
    let d2 := decompose_int (Int.neg n) in
    if NPeano.leb (List.length d1) (List.length d2)
    then iterate_op (Padd r1 r2) (Padd r1 r1) d1 k
    else iterate_op (Psub r1 r2) (Psub r1 r1) d2 k).

Definition rsubimm (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Prsb r1 r2) (Padd r1 r1) (decompose_int n) k.

Definition andimm (r1 r2: ireg) (n: int) (k: code) :=
  if is_immed_arith n
  then Pand r1 r2 (SOimm n) :: k
  else iterate_op (Pbic r1 r2) (Pbic r1 r1) (decompose_int (Int.not n)) k.

Definition orimm  (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Porr r1 r2) (Porr r1 r1) (decompose_int n) k.

Definition xorimm  (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Peor r1 r2) (Peor r1 r1) (decompose_int n) k.

(** Translation of a shift immediate operation (type [Op.shift]) *)

Definition transl_shift (s: shift) (r: ireg) : shift_op :=
  match s with
  | Slsl n => SOlsl r (s_amount n)
  | Slsr n => SOlsr r (s_amount n)
  | Sasr n => SOasr r (s_amount n)
  | Sror n => SOror r (s_amount n)
  end.

(** Translation of a condition.  Prepends to [k] the instructions
  that evaluate the condition and leave its boolean result in one of
  the bits of the condition register.  The bit in question is
  determined by the [crbit_for_cond] function. *)

Definition transl_cond
              (cond: condition) (args: list mreg) (k: code) :=
  match cond, args with
  | Ccomp c, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1(SOreg r2) :: k)
  | Ccompu c, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (SOreg r2) :: k)
  | Ccompshift c s, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (transl_shift s r2) :: k)
  | Ccompushift c s, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (transl_shift s r2) :: k)
  | Ccompimm c n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_immed_arith n then
            Pcmp r1 (SOimm n) :: k
          else
            loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
  | Ccompuimm c n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_immed_arith n then
            Pcmp r1 (SOimm n) :: k
          else
            loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
  | Ccompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmpd r1 r2 :: k)
  | Cnotcompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmpd r1 r2 :: k)
  | Ccompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzd r1 :: k)
  | Cnotcompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzd r1 :: k)
  | Ccompfs cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmps r1 r2 :: k)
  | Cnotcompfs cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmps r1 r2 :: k)
  | Ccompfszero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzs r1 :: k)
  | Cnotcompfszero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzs r1 :: k)
  | _, _ =>
      Error(msg "Asmgen.transl_cond")
  end.

Definition cond_for_signed_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TClt
  | Cle => TCle
  | Cgt => TCgt
  | Cge => TCge
  end.

Definition cond_for_unsigned_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TClo
  | Cle => TCls
  | Cgt => TChi
  | Cge => TChs
  end.

Definition cond_for_float_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TCmi
  | Cle => TCls
  | Cgt => TCgt
  | Cge => TCge
  end.

Definition cond_for_float_not_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCne
  | Cne => TCeq
  | Clt => TCpl
  | Cle => TChi
  | Cgt => TCle
  | Cge => TClt
  end.

Definition cond_for_cond (cond: condition) :=
  match cond with
  | Ccomp cmp => cond_for_signed_cmp cmp
  | Ccompu cmp => cond_for_unsigned_cmp cmp
  | Ccompshift cmp s => cond_for_signed_cmp cmp
  | Ccompushift cmp s => cond_for_unsigned_cmp cmp
  | Ccompimm cmp n => cond_for_signed_cmp cmp
  | Ccompuimm cmp n => cond_for_unsigned_cmp cmp
  | Ccompf cmp => cond_for_float_cmp cmp
  | Cnotcompf cmp => cond_for_float_not_cmp cmp
  | Ccompfzero cmp => cond_for_float_cmp cmp
  | Cnotcompfzero cmp => cond_for_float_not_cmp cmp
  | Ccompfs cmp => cond_for_float_cmp cmp
  | Cnotcompfs cmp => cond_for_float_not_cmp cmp
  | Ccompfszero cmp => cond_for_float_cmp cmp
  | Cnotcompfszero cmp => cond_for_float_not_cmp cmp
  end.

(** Translation of the arithmetic operation [r <- op(args)].
  The corresponding instructions are prepended to [k]. *)

Definition transl_op
              (op: operation) (args: list mreg) (res: mreg) (k: code) :=
  match op, args with
  | Omove, a1 :: nil =>
      match preg_of res, preg_of a1 with
      | IR r, IR a => OK (Pmov r (SOreg a) :: k)
      | FR r, FR a => OK (Pfcpyd r a :: k)
      |  _  ,  _   => Error(msg "Asmgen.Omove")
      end
  | Ointconst n, nil =>
      do r <- ireg_of res;
      OK (loadimm r n k)
  | Ofloatconst f, nil =>
      do r <- freg_of res;
      OK (Pflid r f :: k)
  | Osingleconst f, nil =>
      do r <- freg_of res;
      OK (Pflis r f :: k)
  | Oaddrsymbol s ofs, nil =>
      do r <- ireg_of res;
      OK (Ploadsymbol r s ofs :: k)
  | Oaddrstack n, nil =>
      do r <- ireg_of res;
      OK (addimm r IR13 n k)
  | Ocast8signed, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (if thumb tt then
            Psbfx r r1 Int.zero (Int.repr 8) :: k
          else
            Pmov r (SOlsl r1 (Int.repr 24)) ::
            Pmov r (SOasr r (Int.repr 24)) :: k)
  | Ocast16signed, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (if thumb tt then
            Psbfx r r1 Int.zero (Int.repr 16) :: k
          else
            Pmov r (SOlsl r1 (Int.repr 16)) ::
            Pmov r (SOasr r (Int.repr 16)) :: k)
  | Oadd, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd r r1 (SOreg r2) :: k)
  | Oaddshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd r r1 (transl_shift s r2) :: k)
  | Oaddimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (addimm r r1 n k)
  | Osub, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub r r1 (SOreg r2) :: k)
  | Osubshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub r r1 (transl_shift s r2) :: k)
  | Orsubshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Prsb r r1 (transl_shift s r2) :: k)
  | Orsubimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (rsubimm r r1 n k)
  | Omul, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmul r r1 r2 :: k)
  | Omla, a1 :: a2 :: a3 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (Pmla r r1 r2 r3 :: k)
  | Omulhs, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psmull IR14 r r1 r2 :: k)
  | Omulhu, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pumull IR14 r r1 r2 :: k)
  | Odiv, a1 :: a2 :: nil =>
      assertion (mreg_eq res R0);
      assertion (mreg_eq a1 R0);
      assertion (mreg_eq a2 R1);
      OK (Psdiv :: k)
  | Odivu, a1 :: a2 :: nil =>
      assertion (mreg_eq res R0);
      assertion (mreg_eq a1 R0);
      assertion (mreg_eq a2 R1);
      OK (Pudiv :: k)
  | Oand, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand r r1 (SOreg r2) :: k)
  | Oandshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand r r1 (transl_shift s r2) :: k)
  | Oandimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (andimm r r1 n k)
  | Oor, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr r r1 (SOreg r2) :: k)
  | Oorshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr r r1 (transl_shift s r2) :: k)
  | Oorimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (orimm r r1 n k)
  | Oxor, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor r r1 (SOreg r2) :: k)
  | Oxorshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor r r1 (transl_shift s r2) :: k)
  | Oxorimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (xorimm r r1 n k)
  | Obic, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic r r1 (SOreg r2) :: k)
  | Obicshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic r r1 (transl_shift s r2) :: k)
  | Onot, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmvn r (SOreg r1) :: k)
  | Onotshift s, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmvn r (transl_shift s r1) :: k)
  | Oshl, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plsl r r1 r2 :: k)
  | Oshr, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pasr r r1 r2 :: k)
  | Oshru, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plsr r r1 r2 :: k)
  | Oshift s, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmov r (transl_shift s r1) :: k)
  | Oshrximm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      if Int.eq n Int.zero then
        OK (Pmov r (SOreg r1) :: k)
      else
        OK (Pmov IR14 (SOasr r1 (Int.repr 31)) ::
            Padd IR14 r1 (SOlsr IR14 (Int.sub Int.iwordsize n)) ::
            Pmov r (SOasr IR14 n) :: k)
  | Onegf, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfnegd r r1 :: k)
  | Oabsf, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfabsd r r1 :: k)
  | Oaddf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfaddd r r1 r2 :: k)
  | Osubf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfsubd r r1 r2 :: k)
  | Omulf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfmuld r r1 r2 :: k)
  | Odivf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfdivd r r1 r2 :: k)
  | Onegfs, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfnegs r r1 :: k)
  | Oabsfs, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfabss r r1 :: k)
  | Oaddfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfadds r r1 r2 :: k)
  | Osubfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfsubs r r1 r2 :: k)
  | Omulfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfmuls r r1 r2 :: k)
  | Odivfs, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfdivs r r1 r2 :: k)
  | Osingleoffloat, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfcvtsd r r1 :: k)
  | Ofloatofsingle, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfcvtds r r1 :: k)
  | Ointoffloat, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftosizd r r1 :: k)
  | Ointuoffloat, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftouizd r r1 :: k)
  | Ofloatofint, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfsitod r r1 :: k)
  | Ofloatofintu, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfuitod r r1 :: k)
  | Ointofsingle, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftosizs r r1 :: k)
  | Ointuofsingle, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftouizs r r1 :: k)
  | Osingleofint, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfsitos r r1 :: k)
  | Osingleofintu, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfuitos r r1 :: k)
  | Ocmp cmp, _ =>
      do r <- ireg_of res;
      transl_cond cmp args
        (Pmovite (cond_for_cond cmp) r (SOimm Int.one) (SOimm Int.zero) :: k)
  | _, _ =>
      Error(msg "Asmgen.transl_op")
  end.

(** Accessing data in the stack frame. *)

Definition indexed_memory_access
    (mk_instr: ireg -> int -> instruction)
    (mk_immed: int -> int)
    (base: ireg) (n: int) (k: code) :=
  let n1 := mk_immed n in
  if Int.eq n n1
  then mk_instr base n :: k
  else addimm IR14 base (Int.sub n n1) (mk_instr IR14 n1 :: k).

Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) :=
  indexed_memory_access (fun base n => Pldr dst base (SOimm n)) mk_immed_mem_word base ofs k.

Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
  match ty, preg_of dst with
  | Tint, IR r =>
      OK (indexed_memory_access (fun base n => Pldr r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tany32, IR r =>
      OK (indexed_memory_access (fun base n => Pldr_a r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tsingle, FR r =>
      OK (indexed_memory_access (Pflds r) mk_immed_mem_float base ofs k)
  | Tfloat, FR r =>
      OK (indexed_memory_access (Pfldd r) mk_immed_mem_float base ofs k)
  | Tany64, FR r =>
      OK (indexed_memory_access (Pfldd_a r) mk_immed_mem_float base ofs k)
  | _, _ =>
      Error (msg "Asmgen.loadind")
  end.

Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
  match ty, preg_of src with
  | Tint, IR r =>
      OK (indexed_memory_access (fun base n => Pstr r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tany32, IR r =>
      OK (indexed_memory_access (fun base n => Pstr_a r base (SOimm n)) mk_immed_mem_word base ofs k)
  | Tsingle, FR r =>
      OK (indexed_memory_access (Pfsts r) mk_immed_mem_float base ofs k)
  | Tfloat, FR r =>
      OK (indexed_memory_access (Pfstd r) mk_immed_mem_float base ofs k)
  | Tany64, FR r =>
      OK (indexed_memory_access (Pfstd_a r) mk_immed_mem_float base ofs k)
  | _, _ =>
      Error (msg "Asmgen.storeind")
  end.

(** Translation of memory accesses *)

Definition transl_memory_access
     (mk_instr_imm: ireg -> int -> instruction)
     (mk_instr_gen: option (ireg -> shift_op -> instruction))
     (mk_immed: int -> int)
     (addr: addressing) (args: list mreg) (k: code) :=
  match addr, args with
  | Aindexed n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (indexed_memory_access mk_instr_imm mk_immed r1 n k)
  | Aindexed2, a1 :: a2 :: nil =>
      match mk_instr_gen with
      | Some f =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          OK (f r1 (SOreg r2) :: k)
      | None =>
          Error (msg "Asmgen.Aindexed2")
      end
  | Aindexed2shift s, a1 :: a2 :: nil =>
      match mk_instr_gen with
      | Some f =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          OK (f r1 (transl_shift s r2) :: k)
      | None =>
          Error (msg "Asmgen.Aindexed2shift")
      end
  | Ainstack n, nil =>
      OK (indexed_memory_access mk_instr_imm mk_immed IR13 n k)
  | _, _ =>
      Error(msg "Asmgen.transl_memory_access")
  end.

Definition transl_memory_access_int
     (mk_instr: ireg -> ireg -> shift_op -> instruction)
     (mk_immed: int -> int)
     (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
  do rd <- ireg_of dst;
  transl_memory_access
    (fun r n => mk_instr rd r (SOimm n))
    (Some (mk_instr rd))
    mk_immed addr args k.

Definition transl_memory_access_float
     (mk_instr: freg -> ireg -> int -> instruction)
     (mk_immed: int -> int)
     (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
  do rd <- freg_of dst;
  transl_memory_access
    (mk_instr rd)
    None
    mk_immed addr args k.

Definition transl_load (chunk: memory_chunk) (addr: addressing)
                       (args: list mreg) (dst: mreg) (k: code) :=
  match chunk with
  | Mint8signed =>
      transl_memory_access_int Pldrsb mk_immed_mem_small dst addr args k
  | Mint8unsigned =>
      transl_memory_access_int Pldrb mk_immed_mem_word dst addr args k
  | Mint16signed =>
      transl_memory_access_int Pldrsh mk_immed_mem_small dst addr args k
  | Mint16unsigned =>
      transl_memory_access_int Pldrh mk_immed_mem_small dst addr args k
  | Mint32 =>
      transl_memory_access_int Pldr mk_immed_mem_word dst addr args k
  | Mfloat32 =>
      transl_memory_access_float Pflds mk_immed_mem_float dst addr args k
  | Mfloat64 =>
      transl_memory_access_float Pfldd mk_immed_mem_float dst addr args k
  | _ =>
      Error (msg "Asmgen.transl_load")
  end.

Definition transl_store (chunk: memory_chunk) (addr: addressing)
                       (args: list mreg) (src: mreg) (k: code) :=
  match chunk with
  | Mint8signed =>
      transl_memory_access_int Pstrb mk_immed_mem_small src addr args k
  | Mint8unsigned =>
      transl_memory_access_int Pstrb mk_immed_mem_word src addr args k
  | Mint16signed =>
      transl_memory_access_int Pstrh mk_immed_mem_small src addr args k
  | Mint16unsigned =>
      transl_memory_access_int Pstrh mk_immed_mem_small src addr args k
  | Mint32 =>
      transl_memory_access_int Pstr mk_immed_mem_word src addr args k
  | Mfloat32 =>
      transl_memory_access_float Pfsts mk_immed_mem_float src addr args k
  | Mfloat64 =>
      transl_memory_access_float Pfstd mk_immed_mem_float src addr args k
  | _ =>
      Error (msg "Asmgen.transl_store")
  end.

(** Translation of arguments to annotations *)

Definition transl_annot_param (p: Mach.annot_param) : Asm.annot_param :=
  match p with
  | Mach.APreg r => APreg (preg_of r)
  | Mach.APstack chunk ofs => APstack chunk ofs
  end.

(** Translation of a Mach instruction. *)

Definition transl_instr (f: Mach.function) (i: Mach.instruction)
                        (r12_is_parent: bool) (k: code) :=
  match i with
  | Mgetstack ofs ty dst =>
      loadind IR13 ofs ty dst k
  | Msetstack src ofs ty =>
      storeind src IR13 ofs ty k
  | Mgetparam ofs ty dst =>
      do c <- loadind IR12 ofs ty dst k;
      OK (if r12_is_parent
          then c
          else loadind_int IR13 f.(fn_link_ofs) IR12 c)
  | Mop op args res =>
      transl_op op args res k
  | Mload chunk addr args dst =>
      transl_load chunk addr args dst k
  | Mstore chunk addr args src =>
      transl_store chunk addr args src k
  | Mcall sig (inl arg) =>
      do r <- ireg_of arg; OK (Pblreg r sig :: k)
  | Mcall sig (inr symb) =>
      OK (Pblsymb symb sig :: k)
  | Mtailcall sig (inl arg) =>
      do r <- ireg_of arg;
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
           (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg r sig :: k))
  | Mtailcall sig (inr symb) =>
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
           (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb sig :: k))
  | Mbuiltin ef args res =>
      OK (Pbuiltin ef (map preg_of args) (map preg_of res) :: k)
  | Mannot ef args =>
      OK (Pannot ef (map transl_annot_param args) :: k)
  | Mlabel lbl =>
      OK (Plabel lbl :: k)
  | Mgoto lbl =>
      OK (Pb lbl :: k)
  | Mcond cond args lbl =>
      transl_cond cond args (Pbc (cond_for_cond cond) lbl :: k)
  | Mjumptable arg tbl =>
      do r <- ireg_of arg;
      OK (Pbtbl r tbl :: k)
  | Mreturn =>
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
            (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
             Pbreg IR14 f.(Mach.fn_sig) :: k))
  end.

(** Translation of a code sequence *)

Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool :=
  match i with
  | Msetstack src ofs ty => before
  | Mgetparam ofs ty dst => negb (mreg_eq dst R12)
  | Mop Omove args res => before && negb (mreg_eq res R12)
  | _ => false
  end.

(** This is the naive definition that we no longer use because it
  is not tail-recursive.  It is kept as specification. *)

Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  match il with
  | nil => OK nil
  | i1 :: il' =>
      do k <- transl_code f il' (it1_is_parent it1p i1);
      transl_instr f i1 it1p k
  end.

(** This is an equivalent definition in continuation-passing style
  that runs in constant stack space. *)

Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction)
                         (it1p: bool) (k: code -> res code) :=
  match il with
  | nil => k nil
  | i1 :: il' =>
      transl_code_rec f il' (it1_is_parent it1p i1)
        (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2)
  end.

Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  transl_code_rec f il it1p (fun c => OK c).

(** Translation of a whole function.  Note that we must check
  that the generated code contains less than [2^32] instructions,
  otherwise the offset part of the [PC] code pointer could wrap
  around, leading to incorrect executions. *)

Definition transl_function (f: Mach.function) :=
  do c <- transl_code f f.(Mach.fn_code) true;
  OK (mkfunction f.(Mach.fn_sig)
        (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
         Pstr IR14 IR13 (SOimm f.(fn_retaddr_ofs)) :: c)).

Definition transf_function (f: Mach.function) : res Asm.function :=
  do tf <- transl_function f;
  if zlt Int.max_unsigned (list_length_z tf.(fn_code))
  then Error (msg "code size exceeded")
  else OK tf.

Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
  transf_partial_fundef transf_function f.

Definition transf_program (p: Mach.program) : res Asm.program :=
  transform_partial_program transf_fundef p.


Require Import List Map Envs AllInRel Exp AppExpFree RenamedApart.
Require Import IL Annotation AnnotationLattice.
Require Import AutoIndTac Liveness.Liveness LabelsDefined.
Require Import DoSpill DoSpillRm.
Require Import SpillSound SpillUtil ReconstrLive ReconstrLiveSmall.
Require Import InVD Slot.
Require Import SlotLiftArgs SlotLiftParams.
Require Import PartialOrder AnnotationLattice.

Set Implicit Arguments.

(** * ReconstrLiveSound *)

Lemma sla_extargs_slp_length
      (slot : var -> var)
      RM RMapp
      (ZL : list params)
      (Z : params)
      (l : lab)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (Y : args)
  : length Y = length Z ->
    ❬slot_lift_args slot RM RMapp Y Z❭ = ❬slot_lift_params slot RM Z❭.
Proof.
  intros Len.
  general induction Len; simpl; eauto.
  repeat cases; simpl; eauto.
Qed.

Lemma reconstr_live_sound_s
      (slot : var -> var) o
      (ZL' ZL : list params)
      (G : ⦃var⦄)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (Lv : list ⦃var⦄)
      (s : stmt)
      (sl : spilling)
  :
    (forall G',
        live_sound o ZL' Lv
                   (do_spill slot s (clear_SpL sl) ZL Λ)
                   (reconstr_live (slot_merge slot ⊝ Λ) ZL' G'
                                  (do_spill slot s (clear_SpL sl) ZL Λ)
                                  (do_spill_rm slot (clear_SpL sl))))
   -> live_sound o ZL' Lv
                (do_spill slot s sl ZL Λ)
                (reconstr_live (slot_merge slot ⊝ Λ) ZL' G
                               (do_spill slot s sl ZL Λ)
                               (do_spill_rm slot sl)).
Proof.
  intros sls.

  rewrite do_spill_extract_writes.
  rewrite do_spill_rm_s.

  unfold count.

  (* prepare induction *)
  remember (elements (getSp sl)) as elSp.
  symmetry in HeqelSp.
  remember (elements (getL  sl)) as elL.
  symmetry in HeqelL.
  do 2 rewrite <- elements_length.
  rewrite HeqelL.
  rewrite HeqelSp.
  clear HeqelSp.
  revert G.
  induction elSp;
    intros G;
    simpl.
  - (*apply elements_nil_eset in HeqelSp as empty_Sp.*)
    revert G.
    clear HeqelL.
    induction elL;
      intros G;
      simpl in *.
    + apply sls.

    + rewrite add_anns_S.

      constructor; eauto; fold reconstr_live.
      * simpl.
        apply live_exp_sound_incl with (lv':=singleton (slot a)).
        -- econstructor.
           econstructor.
           cset_tac.
        -- clear.
           cset_tac.
      * clear.
        cset_tac.
      * apply reconstr_live_G.
        cset_tac.
  - rewrite add_anns_S.
    econstructor; simpl; eauto.
    * simpl.
      apply live_exp_sound_incl with (lv':=singleton a).
      -- econstructor.
         econstructor.
         cset_tac.
      -- clear.
         cset_tac.
    * clear.
      cset_tac.
    * apply reconstr_live_G.
      cset_tac.
Qed.

Lemma reconstr_live_sound
      (k : nat) VD
      (slot : Slot VD)
      (ZL : list params)
      (G : ⦃var⦄)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (R M : ⦃var⦄)
      (s : stmt)
      (Lv : list ⦃var⦄)
      (sl : spilling)
      (alv : ann ⦃var⦄)
      (ra : ann (⦃var⦄ * ⦃var⦄))
  : R ⊆ VD
    -> M ⊆ VD
    -> fst (getAnn ra) ∪ snd (getAnn ra) ⊆ VD
    -> app_expfree s
    -> renamedApart s ra
    -> spill_sound k ZL Λ (R,M) s sl
    -> spill_live VD sl alv
    -> PIR2 Equal (merge ⊝ Λ) Lv
    -> (forall (Z : params) n,
          get ZL n Z
          -> of_list Z ⊆ VD)
    -> live_sound Imperative ZL Lv s alv
    -> live_sound Imperative
                 ((slot_lift_params slot) ⊜ Λ ZL)
                 (slot_merge slot ⊝ Λ)
                 (do_spill slot s sl ZL Λ)
                 (reconstr_live (slot_merge slot ⊝ Λ)
                                ((slot_lift_params slot) ⊜ Λ ZL)
                                 G
                                 (do_spill slot s sl ZL Λ)
                                (do_spill_rm slot sl))
.
Proof.
  intros disj_VD R_VD M_VD aeFree renAp spillSnd spilli pir2_EQ Z_VD lvSnd.

  general induction lvSnd;
    invc aeFree;
    invc spillSnd;
    invc spilli;
    inv renAp;
    apply reconstr_live_sound_s;
    intros G'.

  - rename sl0 into sl.
    assert (x ∈ VD) as x_VD by (eapply x_VD; eauto).
    rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    econstructor; eauto.
    + eapply IHlvSnd with (ra:=an) (R:={x; (R\K ∪ L) \Kx}) (M:=Sp ∪ M); eauto.
      * eapply Rx_VD with (R:=R) (M:=M); eauto.
      * eapply M'_VD with (R:=R) (M:=M); eauto.
      * eapply renamedApart_incl in renAp as rena.
        rewrite rena. eauto.
    + apply live_exp_sound_incl with (lv':=Exp.freeVars e).
      * apply live_freeVars.
      * clear; cset_tac.
    + clear; cset_tac.
    + apply reconstr_live_G.
      eauto with cset.

  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    apply renamedApart_incl in renAp as [rena1 rena2].
    assert (R \ K ∪ L ⊆ VD) as R'_VD
        by (eapply R'_VD with (R:=R) (M:=M); eauto).
    assert (Sp ∪ M ⊆ VD) as M'_VD
        by (eapply M'_VD with (R:=R) (M:=M); eauto).
    econstructor.
    + eapply IHlvSnd1 with (ra:=ans) (R:=R\K ∪ L); eauto.
      rewrite rena1. eauto.
    + eapply IHlvSnd2 with (ra:=ant) (R:=R\K ∪ L); eauto.
      rewrite rena2; eauto.
    + apply live_op_sound_incl with (lv':=Ops.freeVars e).
      * apply Ops.live_freeVars.
      * clear; cset_tac.
    + clear; cset_tac.
    + clear; cset_tac.

  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.
    eapply get_get_eq in H; eauto.
    subst Z0.

    econstructor.
    + eapply zip_get; eauto.
    + simpl.
      unfold slot_merge.
      eapply map_get_eq; eauto.
    + simpl.
      assert (nth (labN l) (slot_merge slot ⊝ Λ) ∅ [=] R_f ∪ map slot M_f)
        as nth_EQ.
      {
        unfold slot_merge.
        assert ((fun RM => fst RM ∪ map slot (snd RM)) (R_f,M_f) = R_f ∪ map slot M_f)
          by (simpl; reflexivity).
        eapply map_get_eq in H13; eauto.
        erewrite get_nth; eauto.
        reflexivity.
      }
      rewrite nth_EQ.
      assert (of_list (nth (labN l) (slot_lift_params slot ⊜ Λ ZL) nil)
              [=] of_list (slot_lift_params slot (R_f,M_f) Z))
        as nth_slp by (erewrite nth_zip; eauto; simpl; reflexivity).
      rewrite nth_slp.
      clear; cset_tac.
    + erewrite !get_nth; try eassumption.
      apply sla_extargs_slp_length; eauto.
    + intros; inv_get.
      erewrite !nth_zip; eauto.
      erewrite !get_nth in H; eauto.
      erewrite !get_nth; eauto using map_get_1. simpl.
      eapply live_op_sound_incl. eapply Ops.live_freeVars.
      eapply get_list_union_map with (f:=Ops.freeVars) in H.
      rewrite <- H. cset_tac.
  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    econstructor; simpl; eauto.
    + apply live_op_sound_incl with (lv':=Ops.freeVars e).
      * apply Ops.live_freeVars.
      * clear; cset_tac.

  - rewrite do_spill_empty by apply count_clear_zero.
    unfold do_spill_rec.
    rewrite do_spill_rm_empty by apply count_clear_zero.
    simpl.

    apply renamedApart_incl in renAp as [renaF rena2].
    rewrite fst_zip_pair by eauto with len.
    econstructor; simpl; eauto.
    + rewrite fst_zip_pair by eauto with len.
      rewrite slot_lift_params_app; eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|len_simpl; rewrite <- H13, <- H16; omega].
      rewrite slot_merge_app.
      apply live_sound_monotone with (LV:= slot_merge slot ⊝ (rms ++ Λ)).
      * eapply IHlvSnd with (ra:=ant) (R:=R\K ∪ L) (M:=Sp ∪ M); eauto.
        -- eapply R'_VD with (R:=R) (M:=M); eauto.
        -- eapply M'_VD with (R:=R) (M:=M); eauto.
        -- rewrite rena2; eauto.
        -- eapply getAnn_als_EQ_merge_rms; eauto.
        -- eapply get_ofl_VD; eauto.
      * rewrite <- slot_merge_app.
        apply PIR2_app with (L2:=slot_merge slot ⊝ Λ);
          swap 1 2.
        {
          apply PIR2_refl; eauto.
        }
        apply PIR2_get.
        -- intros n x x' H4 H5.
           inv_get; simpl.
           rename x into Zs.
           rename x0 into rm.
           rename x5 into sl_s.
           rename x1 into a.
           rename x2 into al.
           rename H33 into get_al.
           rename H32 into get_a.
           rename H26 into get_sls.
           rename H30 into get_Zs.
           rename H5 into get_rm.

           rewrite slot_merge_app.

           exploit H19 as H24'; eauto. (*H31*)
           exploit H23 as H20'; eauto. (*H32*)
           exploit renaF as renaF'; eauto.
           exploit H14 as H15'; eauto. (*H33*)
           exploit H2 as H2'; eauto.
           destruct H2' as [H2' _].
           destruct H15' as [A [B [C E]]].
           assert (rm = (fst rm, snd rm)) as rm_eta by apply pair_eta.
           rewrite rm_eta in H24'.
           rewrite <- reconstr_live_setTopAnn.
           erewrite reconstr_live_small with (VD:=VD)
                                             (ra:=a)
                                             (R:=fst rm)
                                             (M:=snd rm); eauto.
           ++ (*clear - pir2_EQ pir3 renaF H24 H20 H15 H2 H16 H20 H8 H13 H14 H H9 H18 ra_VD.*)
             clear - rm_eta H2' get_al get_a get_sls get_rm get_Zs H15.
             rewrite rm_eta in get_rm.
             eapply al_sub_RfMf in get_rm; eauto.
             rewrite rm_eta. unfold slot_merge; simpl.
              repeat apply union_incl_split;
                [clear; cset_tac | clear; cset_tac
                 | eapply ofl_slp_sub_rm; eauto ].
           ++ rewrite renaF'; eauto.
           ++ eapply getAnn_als_EQ_merge_rms; eauto.
           ++ eapply get_ofl_VD; eauto.

        -- eauto with len.
    + symmetry.
      apply zip_length2.
      repeat rewrite length_map.
      rewrite zip_length2;
        eauto with len.
    + intros; inv_get.
      simpl.
      rewrite fst_zip_pair by eauto with len.
      rewrite getAnn_map_setTopAnn.
      rewrite Take.take_eq_ge;
        [|unfold slot_merge; len_simpl; rewrite <- H13, <- H16; omega].
      rewrite slot_merge_app.
      rewrite slot_lift_params_app; eauto with len.
      rewrite <- reconstr_live_setTopAnn.
      apply live_sound_monotone with (LV:= slot_merge slot ⊝ (rms ++ Λ)).
      * assert ((fst x3, snd x3) = x3)
          by (destruct x3; simpl; reflexivity).
        rewrite <- H4 in H31.
        exploit H23; eauto.
        eapply H1 with (ra:=x0) (R:=fst x3) (M:=snd x3); eauto.
        -- exploit renaF as renaF'; eauto.
           rewrite renaF'; eauto.
        -- eapply getAnn_als_EQ_merge_rms; eauto.
        -- eapply get_ofl_VD; eauto.
      * rewrite <- slot_merge_app.
        apply PIR2_app with (L2:=slot_merge slot ⊝ Λ);
          swap 1 2.
        {
          apply PIR2_refl; eauto.
        }
        apply PIR2_get.
        -- intros.
           unfold slot_merge in H5.
           inv_get; simpl.
           rewrite slot_merge_app.
           exploit H19; eauto.
           exploit H23; eauto.
           exploit H9; eauto.
           destruct x5 as [R_f M_f].
           rewrite <- reconstr_live_setTopAnn.
           erewrite reconstr_live_small with (ra:=x6)
                                             (VD:=VD)
                                             (R:=R_f)
                                             (M:=M_f); eauto.
           ++ exploit H2 as H2'; eauto; dcr; simpl in *.

             rewrite ofl_slp_sub_rm; eauto.
             poLe_set. clear; cset_tac.
             eapply al_sub_RfMf; eauto.
           ++ rewrite renaF; eauto.
           ++ eapply getAnn_als_EQ_merge_rms; eauto.
           ++ eapply get_ofl_VD; eauto.
        -- unfold slot_merge. eauto with len.
    + intros.
      inv_get.
      simpl.
      split; [ | auto].
      * apply reconstr_live_G.
      * split; eauto.
        -- exploit H2; eauto; dcr.
           eapply PIR2_nth in H15; eauto; dcr.
           destruct x3. eapply NoDupA_slot_lift_params; eauto.
           unfold merge in H33.
           exploit H23; eauto; dcr. eauto with cset.
           rewrite <- M_VD. simpl.
           rewrite <- H27.
           rewrite <- incl_list_union; eauto using zip_get; [|reflexivity].
           unfold defVars. clear; cset_tac.
Qed.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef2.Layer.
Require Import TableDataOpsRef3.Code.data_create_unknown3.

Require Import TableDataOpsRef3.LowSpecs.data_create_unknown3.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _data_create ↦ gensem data_create_spec
      ⊕ _data_create_unknown2 ↦ gensem data_create_unknown2_spec
      ⊕ _data_create_unknown ↦ gensem data_create_unknown_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_data_create: block.
    Hypothesis h_data_create_s : Genv.find_symbol ge _data_create = Some b_data_create.
    Hypothesis h_data_create_p : Genv.find_funct_ptr ge b_data_create
                                 = Some (External (EF_external _data_create
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons Tptr Tnil))))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr (Tcons Tptr Tnil))))) tulong cc_default).
    Local Opaque data_create_spec.

    Variable b_data_create_unknown2: block.
    Hypothesis h_data_create_unknown2_s : Genv.find_symbol ge _data_create_unknown2 = Some b_data_create_unknown2.
    Hypothesis h_data_create_unknown2_p : Genv.find_funct_ptr ge b_data_create_unknown2
                                          = Some (External (EF_external _data_create_unknown2
                                                           (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default))
                                                 (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default).
    Local Opaque data_create_unknown2_spec.

    Variable b_data_create_unknown: block.
    Hypothesis h_data_create_unknown_s : Genv.find_symbol ge _data_create_unknown = Some b_data_create_unknown.
    Hypothesis h_data_create_unknown_p : Genv.find_funct_ptr ge b_data_create_unknown
                                         = Some (External (EF_external _data_create_unknown
                                                          (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default))
                                                (Tcons Tptr (Tcons tulong (Tcons tulong (Tcons Tptr Tnil)))) tulong cc_default).
    Local Opaque data_create_unknown_spec.

    Lemma data_create_unknown3_body_correct:
      forall m d d' env le g_rd_base g_rd_offset data_addr map_addr g_data_base g_data_offset res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTdata_addr: PTree.get _data_addr le = Some (Vlong data_addr))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTg_data: PTree.get _g_data le = Some (Vptr g_data_base (Int.repr g_data_offset)))
             (Hspec: data_create_unknown3_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned data_addr)) (VZ64 (Int64.unsigned map_addr)) (g_data_base, g_data_offset) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) data_create_unknown3_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec data_create_unknown3_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import ClassTestTypes.
Require Import NotVoidAssignability.

(* Simple function types *)
Definition dt_fun_void_void := dt_function dt_void (dts_cons dt_void dts_nil).
Definition dt_fun_void_dynamic := dt_function dt_dynamic (dts_cons dt_void dts_nil).
Definition dt_fun_dynamic_void := dt_function dt_void (dts_cons dt_dynamic dts_nil).
Definition dt_fun_dynamic_dynamic := dt_function dt_dynamic (dts_cons dt_dynamic dts_nil).
Definition dt_fun_Object_Object := dt_function dt_Object (dts_cons dt_Object dts_nil).
Definition dt_fun_Object_void := dt_function dt_void (dts_cons dt_Object dts_nil).
Definition dt_fun_void_Object := dt_function dt_Object (dts_cons dt_void dts_nil).

Hint Unfold
  dt_fun_void_void dt_fun_void_dynamic dt_fun_dynamic_void
  dt_fun_dynamic_dynamic dt_fun_Object_Object dt_fun_Object_void
  dt_fun_void_Object.

(* -------------------- Test cases from email -------------------- *)

(* A<Object> x = new A<void>(); // No *)
Goal NotVoidAssignable dt_A_void dt_A_Object.
  apply nva_class. unfold ct_A_void.
  apply nvact_upcast with (args1 := dts_cons dt_void dts_nil).
      apply dsscts_cons.
        apply dscts_first. apply dsct_args. apply dsp_cons.
          apply ds_Object.
        apply dsp_nil.
      apply dsscts_cons.
        apply dscts_rest. apply dscts_first. auto.
      apply dsscts_nil.
    apply ctn_first.
  apply nvap_cons_first. apply nva_base; discriminate.
Qed.

(* A<dynamic> x = new A<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_A_dynamic).
  unfold not. intros. inversion H. inversion H2.
    subst. unfold ct_A_void in *.
    assert (args1 = dts_cons dt_void dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1. contradiction H10. reflexivity.
    inversion H1.
  unfold ct_A_dynamic in *.
  assert (args2 = dts_cons dt_dynamic dts_nil).
    inversion H8.
      reflexivity.
    contradiction H15. reflexivity.
  subst args2. inversion H9.
    inversion H11. apply H16. reflexivity.
  inversion H11.
Qed.

(* A<Object> x = new A<dynamic>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_A_dynamic).
  unfold not. intros. inversion H. inversion H2; subst.
    unfold ct_A_void in *.
    assert (args1 = dts_cons dt_void dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1. apply H10. reflexivity.
    inversion H1.
  assert (args2 = dts_cons dt_dynamic dts_nil).
    inversion H8.
      reflexivity.
    contradiction H7. reflexivity.
  subst args2.
  inversion H9.
    inversion H1. apply H10. reflexivity.
  inversion H1.
Qed.

(* A<void> x = new A<dynamic>(); // voidV = dynamicV, yes *)
Goal ~(NotVoidAssignable dt_A_dynamic dt_A_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_A_dynamic in *.
    assert (args1 = dts_cons dt_dynamic dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1.
    inversion H1.
  assert (args2 = dts_cons dt_void dts_nil).
    inversion H8.
      reflexivity.
    contradiction H7. reflexivity.
  subst args2. inversion H9.
    inversion H1.
  inversion H1.
Qed.

(* A<void> x = new A<Object>(); // voidV = objectV, Yes *)
Goal ~(NotVoidAssignable dt_A_Object dt_A_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_A_Object in *.
    assert (args1 = dts_cons dt_Object dts_nil).
      inversion H8.
        reflexivity.
      contradiction H6. reflexivity.
    subst args1. inversion H9.
      inversion H1.
    inversion H1.
  assert (args2 = dts_cons dt_void dts_nil).
    inversion H8.
      reflexivity.
    contradiction H7. reflexivity.
  subst args2. inversion H9.
    inversion H1.
  inversion H1.
Qed.

(* dynamic x = new A<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_dynamic).
  unfold not. intros. inversion H.
Qed.

(* Object x = new A<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_A_void dt_Object).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_A_void in *.
    assert (args1 = dts_nil).
      inversion H9.
    subst args1. inversion H9.
  inversion H8. inversion H10.
Qed.

(* Iterable<void> x = new List<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_List_void dt_Iterable_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_List_void in *.
    assert (args1 = dts_cons dt_void dts_nil).
      inversion H8. inversion H10.
        reflexivity.
      inversion H17. inversion H24.
    subst args1. inversion H9.
      inversion H1. apply H6. reflexivity.
    inversion H1.
  inversion H8. inversion H10. inversion H17.
Qed.

(* List<void> x = new Iterable<void>(); // Yes *)
Goal ~(NotVoidAssignable dt_Iterable_void dt_List_void).
  unfold not. intros. inversion H. inversion H2; subst; unfold ct_Iterable_void in *.
    inversion H8. inversion H10. inversion H17.
  assert (args2 = dts_cons dt_void dts_nil).
    inversion H8. inversion H10.
      reflexivity.
    contradiction H16. reflexivity.
  subst args2. inversion H9.
    inversion H1. apply H7. reflexivity.
  inversion H1.
Qed.

(* Iterable<Object> x = new List<void>(); // No *)
Goal NotVoidAssignable dt_List_void dt_Iterable_Object.
  apply nva_class. apply nvact_upcast with (args1 := dts_cons dt_void dts_nil).
      apply dsscts_cons.
        apply dscts_rest. apply dscts_first. apply dsct_args. apply dsp_cons.
          auto.
        auto.
      apply dsscts_cons.
        apply dscts_rest. apply dscts_rest. apply dscts_first. auto.
      auto.
    apply ctn_rest.
      discriminate.
    apply ctn_first.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* List<Object> x = new Iterable<void>(); // No *)
Goal NotVoidAssignable dt_Iterable_void dt_List_Object.
  apply nva_class. apply nvact_downcast with (args2 := dts_cons dt_Object dts_nil).
      apply dsscts_cons.
        apply dscts_rest. apply dscts_first. apply dsct_args. auto.
      apply dsscts_cons.
        apply dscts_rest. apply dscts_rest. apply dscts_first. apply dsct_args. auto.
      auto.
    apply ctn_rest.
      discriminate.
    apply ctn_first.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* void Function(void) f = func<dynamic, dynamic>; // Yes!! void-to-dynamic is OK! *)
Goal ~(NotVoidAssignable dt_fun_dynamic_dynamic dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5.
  inversion H5.
    inversion H7. intuition H12.
  inversion H7.
Qed.

(* void Function(void) f = func<dynamic, void>; // Yes!! void-to-dynamic is OK! *)
Goal ~(NotVoidAssignable dt_fun_dynamic_void dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5. intuition H0.
  inversion H5.
    inversion H7. intuition H12.
  inversion H7.
Qed.

(* void Function(void) f = func<void, dynamic>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_dynamic dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5.
  inversion H5.
    inversion H7. intuition H11.
  inversion H7.
Qed.

(* void Function(void) f = func<Object, Object>; // No *)
Goal NotVoidAssignable dt_fun_Object_Object dt_fun_void_void.
  apply nva_function_arg.
    unfold DartAssignable. left. apply ds_function.
      apply ds_void.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* void Function(void) f = func<Object, void>; // No *)
Goal NotVoidAssignable dt_fun_Object_void dt_fun_void_void.
  apply nva_function_arg.
    unfold DartAssignable. left. apply ds_function.
      apply ds_void.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nvap_cons_first. apply nva_base.
    discriminate.
  discriminate.
Qed.

(* void Function(void) f = func<void, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_Object dt_fun_void_void).
  unfold not. intros. inversion H.
    inversion H2. inversion H5.
  inversion H5.
    inversion H7. intuition H11.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<void, void>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_void dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. intuition H1.
    inversion H5. intuition H1.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<dynamic, void>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_dynamic_void dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. intuition H1.
    inversion H5. intuition H1.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<void, dynamic>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_dynamic dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<Object, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_Object_Object dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7. inversion H7.
Qed.

(* dynamic Function(dynamic) g = func<Object, void>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_Object_void dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. intuition H8.
    inversion H5. intuition H8.
  inversion H3.
    inversion H5.
      inversion H8.
    inversion H8.
  inversion H5.
    inversion H8.
  inversion H8.
Qed.

(* dynamic Function(dynamic) g = func<void, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_Object dt_fun_dynamic_dynamic).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* Object Function(Object) h = func<void, void>; // No *)
Goal NotVoidAssignable dt_fun_void_void dt_fun_Object_Object.
  apply nva_function_ret.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_void.
    auto.
  apply nva_base; discriminate.
Qed.

(* Object Function(Object) h = func<dynamic, void>; // No *)
Goal NotVoidAssignable dt_fun_dynamic_void dt_fun_Object_Object.
  apply nva_function_ret.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_dynamic.
    auto.
  apply nva_base; discriminate.
Qed.

(* Object Function(Object) h = func<void, dynamic>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_dynamic dt_fun_Object_Object).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5.
    inversion H5.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

(* Object Function(Object) h = func<Object, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_Object_Object dt_fun_Object_Object).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. inversion H9.
        inversion H16.
      inversion H16.
    inversion H5. inversion H9.
      inversion H16.
    inversion H16.
  inversion H5. inversion H7.
    inversion H13.
      inversion H20.
    inversion H20.
  inversion H7.
Qed.

(* Object Function(Object) h = func<Object, void>; // No *)
Goal NotVoidAssignable dt_fun_Object_void dt_fun_Object_Object.
  apply nva_function_ret.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nva_base; discriminate.
Qed.

(* Object Function(Object) h = func<void, Object>; // Yes *)
Goal ~(NotVoidAssignable dt_fun_void_Object dt_fun_Object_Object).
  unfold not. intros. inversion H.
    inversion H3.
      inversion H5. inversion H9.
        inversion H16.
      inversion H16.
    inversion H5. inversion H9.
      inversion H16.
    inversion H16.
  inversion H5.
    inversion H7.
  inversion H7.
Qed.

Goal NotVoidAssignable dt_fun_Object_Object dt_fun_void_Object. (* TODO: different from VoidnessType result *)
  apply nva_function_arg.
    unfold DartAssignable. left. apply ds_function.
      apply ds_Object.
    apply dsp_cons.
      apply ds_Object.
    auto.
  apply nvap_cons_first. apply nva_base; discriminate.
Qed.


(** * IndistRelations.v: indistinguishability relation for annotated programs *)
(*Require FFun.*)
Require Export DEX_BigStepAnnot.
Require Export Annotated.

Open Scope type_scope.

Import DEX_BigStepAnnot.DEX_BigStepAnnot DEX_BigStep.DEX_BigStep DEX_Dom DEX_Prog.

(* Hendra 12082016 - remove beta function, focus on DEX I *)
Inductive Value_in  (*b b':FFun.t Location*) : DEX_value -> DEX_value -> Prop :=
| Value_in_num: forall n,
  Value_in (*b b'*) (Num n) (Num n).

Inductive Value_in_opt (*b b':FFun.t Location*) :
  option DEX_value -> option DEX_value -> Prop :=
| Value_in_opt_some:
  forall v v',
    Value_in (*b b'*) v v' ->
    Value_in_opt (*b b'*) (Some v) (Some v')
| Value_in_opt_none: Value_in_opt (*b b'*) None None.

(* older regs in
Inductive Reg_in (observable:L.t) :
  L.t -> L.t -> DEX_value -> DEX_value -> Prop :=
| Reg_high_in : forall k k' v v', ~(L.leql k observable) -> ~(L.leql k' observable) ->
    Reg_in observable k k' v v'
| Reg_nhigh_in : forall k k' v v', Value_in v v' -> Reg_in observable k k' v v'.

Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| Build_Regs_in : eq_set (VarMap.dom _ rt) (VarMap.dom _ rt') ->
  (forall (rn:DEX_Reg),
  In rn (VarMap.dom _ rt) -> In rn (VarMap.dom _ rt') ->
  (forall v v' k k',
  Some v = DEX_Registers.get r rn -> Some v' = DEX_Registers.get r' rn ->
  Some k = VarMap.get _ rt rn -> Some k' = VarMap.get _ rt' rn ->
  Reg_in observable k k' v v')) -> Regs_in observable r r' rt rt'. *)

Inductive Reg_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) (rn:DEX_Reg) : Prop :=
| Reg_high_in : forall k k', VarMap.get L.t rt rn = Some k -> VarMap.get L.t rt' rn = Some k' ->
    ~(L.leql k observable) -> ~(L.leql k' observable) -> Reg_in observable r r' rt rt' rn
| Reg_nhigh_in : Value_in_opt (DEX_Registers.get r rn) (DEX_Registers.get r' rn) -> Reg_in observable r r' rt rt' rn.

Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| Build_Regs_in : eq_set (VarMap.dom _ rt) (VarMap.dom _ rt') ->
  (forall (rn:DEX_Reg), Reg_in observable r r' rt rt' rn) -> Regs_in observable r r' rt rt'.

(* Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| High_Regs_in :
  (forall (rn:DEX_Reg) k k',
  Some k = VarMap.get _ rt rn -> Some k' = VarMap.get _ rt' rn ->
  ~(L.leql k observable) /\ ~(L.leql k' observable)) -> Regs_in observable r r' rt rt'
| nHigh_Regs_in :
  (forall (rn:DEX_Reg) v v' k k',
(*   In rn (DEX_Registers.dom r) -> In rn (DEX_Registers.dom r') -> *)
  Some v = DEX_Registers.get r rn -> Some v' = DEX_Registers.get r' rn ->
  Some k = VarMap.get _ rt rn -> Some k' = VarMap.get _ rt' rn ->
  Value_in v v') -> Regs_in observable r r' rt rt'. *)

Inductive st_in (observable:L.t) (*newArT : Method * PC -> L.t') (ft:FieldSignature -> L.t'*)
(*lvt:Var->L.t'*)  (*b b':FFun.t Location*) (rt rt':TypeRegisters) :
  DEX_PC * (*Heap.t * OperandStack.t * LocalVar.t*) DEX_Registers.t ->
  DEX_PC * (*Heap.t * OperandStack.t * LocalVar.t*) DEX_Registers.t -> Prop :=
| Build_st_in: forall (*h h'*) pc pc' (*l l'*) r r',
    (*localvar_in observable lvt (*b b'*) l l' ->*)
    Regs_in observable (*b b'*) r r' rt rt' ->
    (*hp_in observable newArT ft b b' h h' ->*)
    st_in observable (*newArT ft lvt b b'*) rt rt' (pc,r(*,l*)) (pc',r'(*,l'*)).

Inductive indist_return_value (observable:L.t) (s:DEX_sign) (*h1 h2:Heap.t*) :
    DEX_ReturnVal -> DEX_ReturnVal -> (*FFun.t Location -> FFun.t Location ->*) Prop :=
| indist_return_val : forall v1 v2 (*b1 b2*) k,
  s.(DEX_resType) = Some k ->
  (L.leql k observable -> Value_in (*b1 b2*) v1 v2) ->
  indist_return_value observable s (*h1 h2*) (Normal (Some v1)) (Normal (Some v2)) (*b1 b2 *)
| indist_return_void : (*forall b1 b2 ,*)
  s.(DEX_resType) = None ->
  indist_return_value observable s (*h1 h2*) (Normal None) (Normal None) (*b1 b2 *).

Inductive high_result (observable:L.t) (s:DEX_sign) (*h:Heap.t*) : DEX_ReturnVal -> Prop :=
| high_result_void :
  s.(DEX_resType) = None ->
  high_result observable s (*h*) (Normal None)
| high_result_value : forall v k,
  s.(DEX_resType) = Some k ->
  ~ L.leql k observable ->
  high_result observable s (*h*) (Normal (Some v)).

Inductive state : Type :=
  intra : DEX_IntraNormalState -> TypeRegisters -> (*FFun.t Location ->*) state
| ret : (*Heap.t ->*) DEX_ReturnVal -> (*FFun.t Location ->*) state.

Inductive indist (observable:L.t) (p:DEX_ExtendedProgram) (m:DEX_Method) (sgn:DEX_sign) : state -> state -> Prop :=
| indist_intra : forall  (*h h'*) pc pc' (*l l'*) r r' rt rt' (*b b'*),
  st_in observable (*newArT p) (ft p sgn.(DEX_lvt) b b'*) rt rt' (pc,(*h,*)r(*,l*)) (pc',(*h',*)r'(*,l'*)) ->
  indist observable p m sgn (intra (pc,((*h,*)r(*,l*))) rt (*b*)) (intra (pc',((*h',*)r'(*,l'*))) rt' (*b'*))
(*| indist_intra_return_case : forall pc h s l st b h' v' b',
  indist_intra_return observable p sgn (pc,(h,s,l)) st b h' v' b' ->
  indist observable p m sgn (intra (pc,(h,s,l)) st b) (ret h' v' b')
| indist_return_intra_case : forall pc h s l st b h' v' b',
  indist_intra_return observable p sgn (pc,(h,s,l)) st b h' v' b' ->
  indist observable p m sgn (ret h' v' b') (intra (pc,(h,s,l)) st b) *)
| indist_return : forall (*b b' h h'*) v v',
  (*hp_in observable (newArT p) (ft p) b b' h h' ->*)
  indist_return_value observable sgn (*h h'*) v v' (*b b'*) ->
  indist observable p m sgn (ret (*h*) v (*b*)) (ret (*h'*) v' (*b'*)).

 (** Indistinguishability relations *)

Section p.
  Variable kobs : L.t.
  Variable p : DEX_ExtendedProgram.
  (*Notation ft := (ft p).
  Notation newArT := (newArT p).*)

 (** Basic results on indistinguishability relations *)

  Lemma Value_in_sym : forall v1 v2 (*b1 b2*),
    Value_in (*b1 b2*) v1 v2 ->
    Value_in (*b2 b1*) v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    (* Hendra 15082016 - related to beta function - constructor 3 with n; auto.*)
  Qed.

  Lemma Value_in_opt_sym : forall v1 v2 (*b1 b2*),
    Value_in_opt (*b1 b2*) v1 v2 ->
    Value_in_opt (*b2 b1*) v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    apply Value_in_sym; auto.
  Qed.

  Lemma Value_in_trans : forall v1 v2 v3 (*b1 b2 b3*),
    (*FFun.is_inj b2 ->*)
    Value_in (*b1 b2*) v1 v2 ->
    Value_in (*b2 b3*) v2 v3 ->
    Value_in (*b1 b3*) v1 v3.
  Proof.
    intros.
    inversion H0; inversion H; subst; rewrite H4; constructor.
    (*inversion_clear H0 in H1; inversion_clear H1; try constructor.
    rewrite <- (H _ _ _ H3 H0) in H4.
    constructor 3 with n; auto.*)
  Qed.

  Lemma Value_in_opt_trans : forall v1 v2 v3 (*b1 b2 b3*),
    (*FFun.is_inj b2 ->*)
    Value_in_opt (*b1 b2*) v1 v2->
    Value_in_opt (*b2 b3*) v2 v3 ->
    Value_in_opt (*b1 b3*) v1 v3.
  Proof.
    intros.
    inversion_clear H in H0; inversion_clear H0; try constructor.
    (*inversion_clear H0 in H1; inversion_clear H1; try constructor.*)
    eapply Value_in_trans; eauto.
  Qed.

  Lemma leql_join1 : forall k1 k2 k3,
    L.leql k2 k3 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_right.
  Qed.

  Lemma leql_join2 : forall k1 k2 k3,
    L.leql k2 k1 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_left.
  Qed.

  Lemma not_leql_trans : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    L.leql k1 k2 ->
    ~ L.leql k2 k3.
  Proof.
    red; intros.
    elim H.
    apply L.leql_trans with (1:=H0); auto.
  Qed.

  Lemma not_leql_join1 : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k1; auto.
    apply L.join_left.
  Qed.

  Lemma not_leql_join2 : forall k1 k2 k3,
    ~ L.leql k2 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k2; auto.
    apply L.join_right.
  Qed.

  Lemma leql_join_each: forall k k1 k2, L.leql (L.join k k1) k2 -> L.leql k k2 /\ L.leql k1 k2.
  Proof. intros.
    split. apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_left.
    apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_right.
  Qed.

(*   Lemma Reg_in_inv : forall obs k k' v v',
    Reg_in obs k k' v v' <->
      (~(L.leql k obs) /\ ~(L.leql k' obs)) \/ (Value_in v v').
  Proof.
    intros. split.
      intros. inversion H. left; auto. right; auto.
      intros. inversion H.
      apply Reg_high_in; inversion H0; auto.
      apply Reg_nhigh_in; auto.
  Qed.

  Lemma Reg_in_sym : forall obs k k' v v',
    Reg_in obs k k' v v' ->
    Reg_in obs k' k v' v.
  Proof.
    intros.
    inversion H.
      constructor 1; auto.
      constructor 2; auto.
      apply Value_in_sym; auto.
  Qed.

  Lemma Reg_in_refl : forall obs k v, Reg_in obs k k v v.
  Proof. intros. constructor 2. destruct v. constructor; auto. Qed.

  Lemma Reg_in_monotony_left : forall obs k k' v v' k'',
    Reg_in obs k k' v v' ->
    L.leql k k'' ->
    Reg_in obs k'' k' v v'.
  Proof.
    intros. inversion H; subst.
    constructor 1; auto.
    apply not_leql_trans with (k1:=k) (k3:=obs) (k2:=k'') in H1; auto.
    constructor 2; auto.
  Qed.  *)

 (* Lemma Regs_in_inv : forall r1 r2 rt1 rt2,
    Regs_in kobs r1 r2 rt1 rt2 -> forall (rn:DEX_Reg), In rn (VarMap.dom _ rt1) -> In rn (VarMap.dom _ rt2) ->
    (forall k k', Some k = VarMap.get _ rt1 rn -> Some k' = VarMap.get _ rt2 rn ->
      (~L.leql k kobs /\ ~L.leql k' kobs)) \/
    (forall v v', (Some v = DEX_Registers.get r1 rn /\ Some v' = DEX_Registers.get r2 rn /\ Value_in v v')).
  Proof.
    intros.
    inversion H.
    specialize (H3 rn H0 H1).
    apply VarMap.in_dom_get_some in H0.
    apply VarMap.in_dom_get_some in H1.
    apply not_none_some with (A:=L.t) (a:=VarMap.get L.t rt1 rn) in H0. admit. apply not_none_some with (A:=L.t) in H1.
    destruct H0; destruct H1.
    apply H4 in H0.
    inversion H0.

    left; split; auto.
    right. repeat (split; auto).
    admit. admit.
 subst. admit. split; auto. *)

  Lemma Reg_in_sym : forall obs r r' rt rt' rn,
    Reg_in obs r r' rt rt' rn ->
    Reg_in obs r' r rt' rt rn.
  Proof.
    intros.
    inversion H.
      constructor 1 with (k:=k') (k':=k); auto.
      constructor 2; auto.
      apply Value_in_opt_sym; auto.
  Qed.

 Lemma Regs_in_sym : forall r1 r2 rt1 rt2,
    Regs_in kobs r1 r2 rt1 rt2 ->
    Regs_in kobs r2 r1 rt2 rt1.
  Proof.
    induction 1.
    constructor. apply eq_set_sym; auto.
    intros.
    apply Reg_in_sym; auto.
(*     apply H0 with (k:=k') (k':=k) (v:=v') (v':=v) in H3; auto. *)
  Qed.

  Lemma st_in_sym : forall (*lvt b b'*) rt rt' r r',
    st_in kobs (*newArT ft lvt b b'*) rt rt' r r' ->
    st_in kobs (*newArT ft lvt b' b*) rt' rt r' r.
  Proof.
    intros.
    inversion_clear H; constructor.
    (*apply localvar_in_sym; auto.
    apply os_in_sym; auto.
    apply hp_in_sym; auto.*)
    apply Regs_in_sym; auto.
  Qed.
  Implicit Arguments st_in_sym.

  Lemma Value_in_opt_some_aux: forall ov ov' v v' (*b b'*),
    Value_in (*b b'*) v v' ->
    ov=(Some v)  ->
    ov'= (Some v') ->
    Value_in_opt (*b b'*) ov ov'.
  Proof.
    intros;  subst; constructor; auto.
  Qed.

  Lemma ex_comp_Z : forall x y z:Z,
    (x <= y < z \/ ~ x <= y < z)%Z.
  Proof.
    intros.
    destruct (Z_le_dec x y).
    destruct (Z_lt_dec y z); intuition.
    intuition.
  Qed.

  Lemma nth_error_none_length : forall (A:Set) (l:list A) i,
    nth_error l i = None -> (length l <= i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try omega.
    discriminate.
    generalize (IHl _ H); omega.
  Qed.

  Lemma nth_error_some_length : forall (A:Set) (l:list A) i a,
    nth_error l i = Some a -> (length l > i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try discriminate; try omega.
    generalize (IHl _ _ H); omega.
  Qed.

  Hint Resolve
    not_leql_join1 (*not_leql_join1'*) not_leql_join2 (*not_leql_join2'*) not_leql_trans
    L.join_left L.join_right (*leql'_leql*)
    L.leql_trans : lattice.

End p.

  Hint Resolve
    not_leql_join1 (*not_leql_join1'*) not_leql_join2 (*not_leql_join2'*) not_leql_trans
    L.join_left L.join_right (*leql'_leql*)
    L.leql_trans : lattice.

(*
*** Local Variables: ***
*** coq-prog-name: "~/Soft/src/coq-8.2pl1/bin/coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../Library" "-I" "../Library/Map/") ***
*** End: ***
 *)


(* F1Prop.v *)

Require Import Utf8 QArith NPeano Sorted.

Require Import Misc.
Require Import QbarM.
Require Import SplitList.
Require Import Field2.
Require Import Fpolynomial.
Require Import Fsummation.
Require Import Newton.
Require Import ConvexHullMisc.
Require Import ConvexHull.
Require Import Puiseux_base.
Require Import Power_series.
Require Import Puiseux_series.
Require Import Ps_add.
Require Import Ps_mul.
Require Import Ps_div.
Require Import PSpolynomial.
Require Import AlgCloCharPol.
Require Import CharactPolyn.
Require Import F1Eq.
Require Import PosOrder.
Require Import InK1m.

Set Implicit Arguments.

Section theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.
Variable acf : algeb_closed_field K.

Theorem eq_poly_lap_add : ∀ α (R : ring α) la lb,
  (POL la + POL lb = POL (la + lb)%lap)%pol.
Proof. reflexivity. Qed.

Theorem ps_poly_lap_summ : ∀ f g l,
  (∀ i, (f i = POL (g i))%pspol)
  → (ps_pol_summ ps_field l f = POL (ps_lap_summ ps_field l g))%pspol.
Proof.
intros f g l Hi.
unfold ps_pol_eq, ps_pol in Hi.
unfold ps_pol_eq, ps_pol, ps_pol_summ, ps_lap_summ.
induction l as [| x]; [ reflexivity | simpl ].
rewrite <- eq_poly_lap_add.
rewrite <- IHl, <- Hi.
reflexivity.
Qed.

(* things similar with order_add, perhaps good theorems? *)
Theorem order_add_eq_min : ∀ a b,
  (order a ≠ order b)%Qbar
  → (order (a + b) = Qbar.min (order a) (order b))%Qbar.
Proof.
intros a b Hab.
set (k₁ := ps_polydo b).
set (k₂ := ps_polydo a).
set (v₁ := (ps_ordnum a * Zpos k₁)%Z).
set (v₂ := (ps_ordnum b * Zpos k₂)%Z).
set (n₁ := Z.to_nat (v₂ - Z.min v₁ v₂)).
set (n₂ := Z.to_nat (v₁ - Z.min v₁ v₂)).
pose proof (ps_adjust_eq K a n₂ k₁) as Ha.
pose proof (ps_adjust_eq K b n₁ k₂) as Hb.
symmetry.
rewrite Hb in Hab.
rewrite Ha in Hab.
rewrite Hb in |- * at 1.
rewrite Ha in |- * at 1.
rewrite eq_ps_add_add₂.
unfold ps_add₂.
unfold adjust_ps_from.
fold k₁ k₂.
fold v₁ v₂.
rewrite Z.min_comm.
fold n₁ n₂.
remember (adjust_ps n₂ k₁ a) as pa eqn:Hpa .
remember (adjust_ps n₁ k₂ b) as pb eqn:Hpb .
remember (order pa) as opa eqn:Hopa .
remember (order pb) as opb eqn:Hopb .
progress unfold order in Hopa, Hopb.
progress unfold order; simpl.
remember (ps_terms pa) as sa eqn:Hsa .
remember (ps_terms pb) as sb eqn:Hsb .
remember (series_order sa 0) as na eqn:Hna .
remember (series_order sb 0) as nb eqn:Hnb .
remember (series_order (sa + sb)%ser 0) as nc eqn:Hnc .
symmetry in Hna, Hnb, Hnc.
clear Hsa Hsb Ha Hb.
apply series_order_iff in Hna; simpl in Hna.
apply series_order_iff in Hnb; simpl in Hnb.
apply series_order_iff in Hnc; simpl in Hnc.
destruct na as [na| ].
 destruct Hna as (Hina, Hna).
 destruct nb as [nb| ].
  destruct Hnb as (Hinb, Hnb).
  subst pa pb; simpl in Hopa, Hopb; simpl.
  subst k₁ k₂ n₁ n₂; simpl in Hopa, Hopb; simpl.
  subst v₁ v₂; simpl in Hopa, Hopb.
  rewrite Pos.mul_comm in Hopb.
  rewrite Z2Nat.id in Hopa.
   rewrite Z2Nat.id in Hopb.
    rewrite Z.sub_sub_distr in Hopa, Hopb.
    rewrite Z.sub_diag, Z.add_0_l in Hopa, Hopb.
    unfold cm_factor; simpl.
    rewrite Z2Nat.id.
     rewrite Z.sub_sub_distr.
     rewrite Z.sub_diag, Z.add_0_l.
     subst opa opb; simpl.
     rewrite Qmin_same_den.
     unfold Qeq; simpl.
     simpl in Hab.
     unfold Qeq in Hab; simpl in Hab.
     destruct nc as [nc| ].
      destruct Hnc as (Hinc, Hnc).
      apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
      rewrite Z.add_min_distr_l.
      apply Z.add_cancel_l.
      rewrite <- Nat2Z.inj_min.
      apply Nat2Z.inj_iff.
      destruct (eq_nat_dec (min na nb) nc) as [| H]; [ assumption | idtac ].
      exfalso; apply Hab; clear Hab.
      apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
      apply Z.add_cancel_l.
      apply Nat2Z.inj_iff.
      destruct (eq_nat_dec na nb) as [| Hab]; [ assumption | idtac ].
      exfalso; apply H; clear H.
      destruct (le_dec na nb) as [H₁| H₁].
       apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
       destruct (lt_dec na nc) as [H₂| H₂].
        apply Hinb in H₁.
        apply Hinc in H₂.
        rewrite H₁, rng_add_0_r in H₂; contradiction.

        apply Nat.nlt_ge in H₂.
        destruct (eq_nat_dec na nc) as [H₃| H₃].
         rewrite Nat.min_l; [ assumption | idtac ].
         apply Nat.lt_le_incl; assumption.

         apply Nat.neq_sym in H₃.
         apply Nat_le_neq_lt in H₂; [ idtac | assumption ].
         eapply Nat.lt_trans in H₁; [ idtac | eassumption ].
         apply Hina in H₂.
         apply Hinb in H₁.
         rewrite H₂, H₁ in Hnc.
         rewrite rng_add_0_l in Hnc.
         exfalso; apply Hnc; reflexivity.

       apply Nat.nle_gt in H₁.
       destruct (lt_dec nb nc) as [H₂| H₂].
        apply Hina in H₁.
        apply Hinc in H₂.
        rewrite H₁, rng_add_0_l in H₂; contradiction.

        apply Nat.nlt_ge in H₂.
        destruct (eq_nat_dec nb nc) as [H₃| H₃].
         rewrite Nat.min_r; [ assumption | idtac ].
         apply Nat.lt_le_incl; assumption.

         apply Nat.neq_sym in H₃.
         apply Nat_le_neq_lt in H₂; [ idtac | assumption ].
         eapply Nat.lt_trans in H₁; [ idtac | eassumption ].
         apply Hinb in H₂.
         apply Hina in H₁.
         rewrite H₂, H₁ in Hnc.
         rewrite rng_add_0_l in Hnc.
         exfalso; apply Hnc; reflexivity.

      simpl in Hab.
      apply Hab; clear Hab.
      apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
      apply Z.add_cancel_l.
      apply Nat2Z.inj_iff.
      destruct (eq_nat_dec na nb) as [| Hab]; [ assumption | idtac ].
      destruct (le_dec na nb) as [H₁| H₁].
       apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
       apply Hinb in H₁.
       pose proof (Hnc na) as H.
       rewrite H₁, rng_add_0_r in H.
       contradiction.

       apply Nat.nle_gt in H₁.
       apply Hina in H₁.
       pose proof (Hnc nb) as H.
       rewrite H₁, rng_add_0_l in H.
       contradiction.

     rewrite <- Z.sub_max_distr_l.
     rewrite Z.sub_diag.
     rewrite <- Z2Nat_id_max.
     apply Nat2Z.is_nonneg.

    rewrite <- Z.sub_max_distr_l.
    rewrite Z.sub_diag.
    rewrite Z.max_comm, <- Z2Nat_id_max.
    apply Nat2Z.is_nonneg.

   rewrite <- Z.sub_max_distr_l.
   rewrite Z.sub_diag.
   rewrite <- Z2Nat_id_max.
   apply Nat2Z.is_nonneg.

  subst opb; simpl.
  rewrite Qbar.min_comm; simpl.
  destruct nc as [nc| ].
   destruct Hnc as (Hinc, Hnc).
   subst opa.
   apply Qbar.qfin_inj_wd.
   unfold Qeq; simpl.
   apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
   apply Z.add_cancel_l.
   apply Nat2Z.inj_iff.
   destruct (eq_nat_dec na nc) as [| Hac]; [ assumption | idtac ].
   destruct (le_dec na nc) as [H₁| H₁].
    apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
    apply Hinc in H₁.
    rewrite Hnb, rng_add_0_r in H₁.
    contradiction.

    apply Nat.nle_gt in H₁.
    apply Hina in H₁.
    rewrite H₁, Hnb, rng_add_0_l in Hnc.
    exfalso; apply Hnc; reflexivity.

   pose proof (Hnc na) as H.
   rewrite Hnb, rng_add_0_r in H.
   contradiction.

 subst opa; simpl.
 destruct nb as [nb| ].
  destruct Hnb as (Hinb, Hnb).
  destruct nc as [nc| ].
   destruct Hnc as (Hinc, Hnc).
   destruct (eq_nat_dec nb nc) as [| Hbc]; [ subst nb | idtac ].
    subst.
    subst n₁ n₂ v₁ v₂ k₁ k₂; simpl.
    unfold cm_factor; simpl.
    rewrite Z2Nat.id.
     rewrite Z2Nat.id.
      do 2 rewrite Z.sub_sub_distr.
      do 2 rewrite Z.sub_diag, Z.add_0_l.
      rewrite Pos.mul_comm; reflexivity.

      rewrite <- Z.sub_max_distr_l.
      rewrite Z.sub_diag.
      rewrite <- Z2Nat_id_max.
      apply Nat2Z.is_nonneg.

     rewrite <- Z.sub_max_distr_l.
     rewrite Z.sub_diag.
     rewrite Z.max_comm, <- Z2Nat_id_max.
     apply Nat2Z.is_nonneg.

    destruct (le_dec nb nc) as [H₁| H₁].
     apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
     apply Hinc in H₁.
     rewrite Hna, rng_add_0_l in H₁.
     contradiction.

     apply Nat.nle_gt in H₁.
     apply Hinb in H₁.
     rewrite Hna, rng_add_0_l in Hnc.
     contradiction.

   pose proof (Hnc nb) as H.
   rewrite Hna, rng_add_0_l in H.
   contradiction.

  subst opb.
  exfalso; apply Hab; reflexivity.
Qed.

Theorem ps_lap_nth_x_le_pow_mul : ∀ la m n,
  (n ≤ m)%nat
  → (ps_lap_nth m ([0; 1 … []] ^ n * la) = ps_lap_nth (m - n) la)%ps.
Proof.
intros la m n Hnm.
revert m Hnm.
induction n; intros.
 progress unfold ps_lap_pow; simpl.
 progress unfold ps_lap_mul.
 rewrite lap_mul_1_l.
 rewrite Nat.sub_0_r.
 reflexivity.

 rewrite <- Nat.add_1_l.
 unfold ps_lap_pow.
 rewrite lap_power_add.
 rewrite lap_power_1.
 progress unfold ps_lap_mul.
 rewrite <- lap_mul_assoc.
 rewrite lap_mul_cons_l.
 rewrite lap_eq_0, lap_mul_nil_l, lap_add_nil_l, lap_mul_1_l.
 destruct m; [ exfalso; revert Hnm; apply Nat.nlt_0_r | simpl ].
 apply le_S_n in Hnm.
 apply IHn; assumption.
Qed.

Theorem ps_lap_nth_x_gt_pow_mul : ∀ la m n,
  (m < n)%nat
  → (ps_lap_nth m ([0; 1 … []] ^ n * la) = 0)%ps.
Proof.
intros la m n Hmn.
revert m Hmn.
induction n; intros.
 exfalso; revert Hmn; apply Nat.nlt_0_r.

 unfold ps_lap_mul, ps_lap_pow; simpl.
 rewrite <- lap_mul_assoc.
 rewrite lap_mul_cons_l.
 rewrite lap_eq_0, lap_mul_nil_l, lap_add_nil_l, lap_mul_1_l.
 destruct m; [ reflexivity | idtac ].
 apply lt_S_n in Hmn.
 unfold ps_lap_nth; simpl.
 apply IHn; assumption.
Qed.

Theorem ps_lap_nth_0_cons_pow : ∀ a la n,
  (ps_lap_nth 0 ([a … la] ^ n) = a ^ n)%ps.
Proof.
intros a la n.
induction n; simpl.
 progress unfold ps_lap_pow; simpl.
 reflexivity.

 unfold ps_lap_pow; simpl.
 unfold ps_lap_nth.
 rewrite list_nth_lap_mul; simpl.
 unfold summation; simpl.
 rewrite IHn.
 rewrite ps_add_0_r; reflexivity.
Qed.

Theorem eq_1_0_all_0 : (1 = 0)%K → ∀ a, (a = 0)%K.
Proof.
intros H a.
rewrite <- rng_mul_1_l.
rewrite H, rng_mul_0_l.
reflexivity.
Qed.

Theorem order_pow : ∀ a n,
  (a ≠ 0)%ps
  → (order (a ^ n) = qfin (Qnat n) * order a)%Qbar.
Proof.
intros a n Ha.
induction n; simpl.
 remember (order a) as v eqn:Hv .
 symmetry in Hv.
 destruct v as [v| ].
  unfold Qnat; simpl.
  rewrite Qmult_0_l.
  unfold ps_one.
  rewrite ps_monom_order; [ reflexivity | idtac ].
  intros H; apply Ha.
  rewrite <- ps_mul_1_l.
  unfold ps_one.
  rewrite H, ps_zero_monom_eq.
  rewrite ps_mul_0_l.
  reflexivity.

  exfalso; apply Ha.
  apply order_inf; assumption.

 rewrite order_mul.
 rewrite IHn.
 remember (order a) as v eqn:Hv .
 symmetry in Hv.
 destruct v as [v| ]; [ simpl | reflexivity ].
 rewrite <- Nat.add_1_l.
 unfold Qnat.
 rewrite Nat2Z.inj_add, QZ_plus.
 rewrite Qmult_plus_distr_l; simpl.
 rewrite Qmult_1_l; reflexivity.
Qed.

Theorem ps_lap_nth_0_apply_0 : ∀ la,
  (ps_lap_nth 0 la = @apply_lap _ (ps_ring K) la 0)%ps.
Proof.
intros la.
induction la as [| a]; [ reflexivity | simpl ].
rewrite ps_mul_0_r, ps_add_0_l.
reflexivity.
Qed.

Theorem apply_lap_inject_K_in_Kx_monom : ∀ P c,
  (@apply_lap _ (ps_ring K) (lap_inject_K_in_Kx P) (ps_monom c 0) =
   ps_monom (apply_lap P c) 0)%ps.
Proof.
intros P c.
unfold apply_lap; simpl.
unfold lap_inject_K_in_Kx.
rename c into d.
rewrite list_fold_right_map.
induction P as [| a]; simpl.
 rewrite ps_zero_monom_eq; reflexivity.

 rewrite IHP.
 rewrite ps_monom_add_l, ps_monom_mul_l.
 reflexivity.
Qed.

Theorem ps_monom_0_coeff_0 : ∀ c pow, (ps_monom c pow = 0)%ps → (c = 0)%K.
Proof.
intros c pow Hc.
apply ps_series_order_inf_iff in Hc.
apply series_order_iff in Hc; simpl in Hc.
pose proof (Hc O); assumption.
Qed.

Theorem in_power_list_lt : ∀ A la h (hv : puiseux_series A) pow,
  (h, hv) ∈ qpower_list pow la
  → (nat_num h < pow + length la)%nat.
Proof.
intros A la h hv pow Hh.
unfold qpower_list in Hh.
unfold pair_rec in Hh; simpl in Hh.
revert pow Hh.
induction la as [| a]; intros; [ contradiction | simpl ].
simpl in Hh.
destruct Hh as [Hh| Hh].
 injection Hh; clear Hh; intros; subst h hv.
 rewrite nat_num_Qnat.
 apply Nat.lt_sub_lt_add_l.
 rewrite Nat.sub_diag.
 apply Nat.lt_0_succ.

 rewrite Nat.add_succ_r, <- Nat.add_succ_l.
 apply IHla; assumption.
Qed.

Theorem in_points_of_ps_lap_gen_lt : ∀ la pow pt,
  pt ∈ points_of_ps_lap_gen pow la
  → (nat_num (fst pt) < pow + length la)%nat.
Proof.
intros la pow pt Hpt.
unfold points_of_ps_lap_gen in Hpt.
destruct pt as (h, hv); simpl.
eapply in_pts_in_ppl with (def := 0%ps) in Hpt; try reflexivity.
destruct Hpt as (Hpt, Hord).
eapply in_power_list_lt; eassumption.
Qed.

Theorem in_points_of_ps_lap_lt : ∀ la pt,
  pt ∈ points_of_ps_lap la
  → (nat_num (fst pt) < length la)%nat.
Proof.
intros la pt Hpt.
apply in_points_of_ps_lap_gen_lt in Hpt.
assumption.
Qed.

(* [Walker, p. 101] «
      Since O(āh-ah.x^αh) > αh, and O(āl.x^lγ₁) > β₁, we obtain
         f₁(x,y₁) = b₁.y₁^r + b₂.y₁^(r+1) + ... + g(x,y₁) »

   We prove here that
         f₁(x,y₁) = y₁^r.(c₁+y)^j.Ψ(c₁+y) + g(x,y₁) »
*)
Theorem f₁_eq_term_with_Ψ_plus_g : ∀ f L j αj c₁ r f₁ Ψ,
  newton_segments f = Some L
  → ini_pt L = (Qnat j, αj)
    → c₁ = ac_root (Φq f L)
      → r = root_multiplicity acf c₁ (Φq f L)
        → Ψ = quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r
          → f₁ = next_pol f (β L) (γ L) c₁
            → (f₁ =
               POL [0%ps; 1%ps … []] ^ r *
               POL [ps_monom c₁ 0; 1%ps … []] ^ j *
               POL (lap_inject_K_in_Kx (al Ψ)) ∘
               POL [ps_monom c₁ 0; 1%ps … []] +
               g_of_ns f L)%pspol.
Proof.
intros f L j αj c₁ r f₁ Ψ HL Hini Hc₁ Hr HΨ Hf₁.
subst f₁.
remember (g_lap_of_ns f L) as gg.
remember Heqgg as H; clear HeqH.
unfold g_lap_of_ns in H; subst gg.
rewrite <- Hc₁ in H.
remember [ini_pt L … oth_pts L ++ [fin_pt L]] as pl eqn:Hpl .
remember (List.map (term_of_point f) pl) as tl eqn:Htl .
remember (List.map (λ t : term α nat, power t) tl) as l₁ eqn:Hl₁ .
remember (list_seq_except 0 (length (al f)) l₁) as l₂ eqn:Hl₂ .
symmetry in Hc₁.
rewrite f₁_eq_term_with_Ψ_plus_sum with (l₂ := l₂); try eassumption.
 rewrite ps_poly_lap_summ; [ idtac | intros i; simpl; apply lap_eq_refl ].
 rewrite ps_poly_lap_summ; [ simpl | intros i; simpl; apply lap_eq_refl ].
 unfold ps_pol_add, poly_add; simpl.
 unfold ps_lap_add in H; simpl in H.
 unfold ps_lap_mul in H; simpl in H.
 progress unfold ps_lap_pow in H.
 simpl in H; rewrite <- H; clear H.
 reflexivity.

 apply except_split_seq; [ idtac | idtac | assumption ].
  rewrite Hl₁, Htl, Hpl.
  do 2 apply Sorted_map; simpl.
  apply Sorted_fst_lt_nat_num_fst.
   intros a Ha.
   remember (points_of_ps_polynom f) as pts.
   symmetry in Heqpts.
   eapply pt_absc_is_nat; [ eassumption | idtac ].
   eapply ns_in_init_pts; [ idtac | eassumption ].
   rewrite <- Heqpts; assumption.

   eapply ini_oth_fin_pts_sorted; eassumption.

  simpl.
  rewrite Hl₁.
  apply List.Forall_forall; intros i Hi.
  split; [ apply Nat.le_0_l | idtac ].
  apply List.in_map_iff in Hi.
  destruct Hi as (x, (Hxi, Hx)).
  subst i.
  rewrite Htl in Hx.
  apply List.in_map_iff in Hx.
  destruct Hx as (y, (Hi, Hy)).
  subst x; simpl.
  rename y into pt.
  rewrite Hpl in Hy.
  eapply ns_in_init_pts in Hy; [ idtac | eassumption ].
  unfold points_of_ps_polynom in Hy.
  apply in_points_of_ps_lap_lt; assumption.
Qed.

Theorem nth_g_order_pos : ∀ f L h,
  newton_segments f = Some L
  → (order (ps_lap_nth h (g_lap_of_ns f L)) > 0)%Qbar.
Proof.
intros f L h HL.
destruct (lt_dec h (length (g_lap_of_ns f L))) as [Hlt| Hge].
 eapply each_power_of_y₁_in_g_has_coeff_pos_ord; try eassumption.
  reflexivity.

  unfold g_of_ns; simpl.
  unfold ps_lap_nth.
  apply list_nth_in; assumption.

 apply Nat.nlt_ge in Hge.
 unfold ps_lap_nth.
 rewrite List.nth_overflow; [ idtac | assumption ].
 rewrite order_0; constructor.
Qed.

Theorem order_nth_inject_K : ∀ la i,
  (0 ≤ order (ps_lap_nth i (lap_inject_K_in_Kx la)))%Qbar.
Proof.
intros la i.
revert i.
induction la as [| a]; intros; simpl.
 unfold ps_lap_nth.
 rewrite list_nth_nil.
 rewrite order_0; constructor.

 destruct i; [ idtac | apply IHla ].
 unfold ps_lap_nth; simpl.
 apply ps_monom_order_ge.
Qed.

Theorem monom_y_plus_c_is_inject_K : ∀ c,
  ([ps_monom c 0; 1%ps … []] = lap_inject_K_in_Kx [c; 1%K … []])%pslap.
Proof.
intros c.
unfold ps_lap_eq.
reflexivity.
Qed.

Theorem fold_lap_inject_K_in_Kx : ∀ la,
  List.map (λ c : α, ps_monom c 0) la = lap_inject_K_in_Kx la.
Proof. reflexivity. Qed.

Theorem lap_add_cons : ∀ α (R : ring α) a b la lb,
  ([a … la] + [b … lb] = [(a + b)%K … la + lb])%lap.
Proof. reflexivity. Qed.

Theorem lap_inject_add : ∀ la lb,
  (lap_inject_K_in_Kx la + lap_inject_K_in_Kx lb =
   lap_inject_K_in_Kx (la + lb)%lap)%pslap.
Proof.
intros la lb.
unfold lap_inject_K_in_Kx.
revert lb.
induction la as [| a]; intros; simpl.
 progress unfold ps_lap_add.
 rewrite lap_add_nil_l; reflexivity.

 destruct lb as [| b]; simpl.
  progress unfold ps_lap_add.
  rewrite lap_add_nil_r; reflexivity.

  progress unfold ps_lap_add.
  rewrite lap_add_cons.
  constructor; [ simpl | apply IHla ].
  rewrite ps_monom_add; reflexivity.
Qed.

Theorem lap_inject_mul : ∀ la lb,
  (lap_inject_K_in_Kx la * lap_inject_K_in_Kx lb =
   lap_inject_K_in_Kx (la * lb)%lap)%pslap.
Proof.
intros la lb.
unfold lap_inject_K_in_Kx.
revert lb.
induction la as [| a]; intros; simpl.
 progress unfold ps_lap_mul.
 do 2 rewrite lap_mul_nil_l; reflexivity.

 destruct lb as [| b]; simpl.
  progress unfold ps_lap_mul.
  do 2 rewrite lap_mul_nil_r; reflexivity.

  progress unfold ps_lap_mul.
  do 2 rewrite lap_mul_cons; simpl.
  constructor; [ simpl; apply ps_monom_mul | idtac ].
  symmetry.
  eapply ps_lap_eq_trans; [ apply lap_add_map_ps | ].
  unfold ps_lap_mul in IHla.
  unfold ps_lap_eq in IHla.
  rewrite IHla.
  progress unfold ps_lap_add.
  simpl.
  rewrite ps_zero_monom_eq.
  apply lap_add_compat; [ idtac | reflexivity ].
  eapply ps_lap_eq_trans; [ apply lap_add_map_ps | ].
  apply lap_add_compat.
   eapply ps_lap_eq_trans; [ apply lap_mul_map_ps | reflexivity ].
   eapply ps_lap_eq_trans; [ apply lap_mul_map_ps | reflexivity ].
Qed.

Theorem lap_inject_comp : ∀ la lb,
  (lap_inject_K_in_Kx la ∘ lap_inject_K_in_Kx lb =
   lap_inject_K_in_Kx (lap_compose la lb))%pslap.
Proof.
intros la lb.
progress unfold lap_inject_K_in_Kx; simpl.
progress unfold ps_lap_comp.
progress unfold lap_compose.
revert lb.
induction la as [| a]; intros; [ reflexivity | simpl ].
rewrite IHla.
do 3 rewrite fold_lap_inject_K_in_Kx.
rewrite fold_ps_lap_mul.
rewrite lap_inject_mul.
rewrite <- lap_inject_add.
reflexivity.
Qed.

(* [Walker, p 101] « O(bi) ≥ 0,  i = 0,...,n » *)
Theorem order_bbar_nonneg : ∀ f L c₁ r f₁,
  newton_segments f = Some L
  → c₁ = ac_root (Φq f L)
    → r = root_multiplicity acf c₁ (Φq f L)
      → f₁ = next_pol f (β L) (γ L) c₁
        → ∀ i, (order (ps_poly_nth i f₁) ≥ 0)%Qbar.
Proof.
intros f L c₁ r f₁ HL Hc₁ Hr Hf₁ i.
remember (quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r) as Ψ eqn:HΨ .
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
rewrite f₁_eq_term_with_Ψ_plus_g; try eassumption.
unfold ps_poly_nth; simpl.
rewrite fold_ps_lap_add.
rewrite ps_lap_nth_add.
rewrite fold_ps_lap_comp.
eapply Qbar.le_trans; [ idtac | apply order_add ].
apply Qbar.min_glb.
 rewrite <- lap_mul_assoc.
 rewrite fold_ps_lap_mul, fold_ps_lap_pow.
 destruct (le_dec r i) as [Hle| Hgt].
  rewrite ps_lap_nth_x_le_pow_mul; [ idtac | assumption ].
  progress unfold ps_lap_comp.
  rewrite monom_y_plus_c_is_inject_K.
  rewrite fold_ps_lap_pow.
  rewrite lap_power_map_ps.
  rewrite fold_ps_lap_comp.
  rewrite lap_inject_comp.
  rewrite fold_ps_lap_mul.
  rewrite lap_inject_mul.
  apply order_nth_inject_K.

  apply Nat.nle_gt in Hgt.
  rewrite ps_lap_nth_x_gt_pow_mul; [ idtac | assumption ].
  rewrite order_0; constructor.

 apply Qbar.lt_le_incl.
 apply nth_g_order_pos; assumption.
Qed.

(* [Walker, p 101] « O(bi) > 0,  i = 0,...,r-1 » *)
Theorem order_bbar_pos : ∀ f L c₁ r f₁,
  newton_segments f = Some L
  → c₁ = ac_root (Φq f L)
    → r = root_multiplicity acf c₁ (Φq f L)
      → f₁ = next_pol f (β L) (γ L) c₁
        → ∀ i, (i < r)%nat
          → (order (ps_poly_nth i f₁) > 0)%Qbar.
Proof.
intros f L c₁ r f₁ HL Hc₁ Hr Hf₁ i Hir.
remember (quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r) as Ψ eqn:HΨ .
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
rewrite f₁_eq_term_with_Ψ_plus_g; try eassumption.
unfold ps_poly_nth; simpl.
rewrite fold_ps_lap_add.
rewrite ps_lap_nth_add.
rewrite fold_ps_lap_comp.
eapply Qbar.lt_le_trans; [ idtac | apply order_add ].
apply Qbar.min_glb_lt.
 rewrite <- lap_mul_assoc.
 rewrite fold_ps_lap_mul.
 rewrite fold_ps_lap_pow.
 rewrite ps_lap_nth_x_gt_pow_mul; [ idtac | assumption ].
 rewrite order_0; constructor.

 apply nth_g_order_pos; assumption.
Qed.

Theorem char_pol_root_ne_0 : ∀ f L m c₁,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → c₁ = ac_root (Φq f L)
  → (c₁ ≠ 0)%K.
Proof.
intros f L m c₁ HL Hm Hc₁.
remember HL as Happ; clear HeqHapp.
eapply cpol_degree_ge_1 with (K := K) in Happ; eauto .
apply ac_prop_root in Happ.
rewrite <- Hc₁ in Happ.
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
intros Hc; rewrite Hc in Happ.
unfold apply_poly in Happ; simpl in Happ.
rewrite Nat.sub_diag, list_pad_0 in Happ.
simpl in Happ.
rewrite rng_mul_0_r, rng_add_0_l in Happ.
revert Happ.
eapply ord_coeff_non_zero_in_newt_segm; eauto .
rewrite Hini; left; simpl.
rewrite nat_num_Qnat; reflexivity.
Qed.

(* [Walker, p 101] « O(br) = 0 » *)
Theorem order_bbar_r_is_0 : ∀ f L m c₁ r f₁,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → c₁ = ac_root (Φq f L)
  → r = root_multiplicity acf c₁ (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c₁
  → (order (ps_poly_nth r f₁) = 0)%Qbar.
Proof.
intros f L m c₁ r f₁ HL Hm Hc₁ Hr Hf₁.
remember (quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r) as Ψ eqn:HΨ .
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
rewrite f₁_eq_term_with_Ψ_plus_g; try eassumption.
unfold ps_poly_nth; simpl.
remember ([0%ps; 1%ps … []] ^ r)%pslap as yr.
remember ([ps_monom c₁ 0; 1%ps … []] ^ j)%pslap as ycj.
remember (lap_inject_K_in_Kx (al Ψ)) as psi.
remember [ps_monom c₁ 0; 1%ps … []] as yc.
assert (order (ps_lap_nth r (yr * ycj * psi ∘ yc)) = 0)%Qbar as Hor.
 subst yr ycj psi yc.
 progress unfold ps_lap_mul.
 rewrite <- lap_mul_assoc.
 do 2 rewrite fold_ps_lap_mul.
 erewrite ps_lap_nth_x_le_pow_mul; [ idtac | reflexivity ].
 rewrite Nat.sub_diag.
 progress unfold ps_lap_mul.
 progress unfold lap_mul.
 progress unfold ps_lap_nth; simpl.
 rewrite list_nth_lap_convol_mul; [ idtac | reflexivity ].
 unfold summation; simpl.
 rewrite ps_add_0_r.
 rewrite order_mul.
 rewrite fold_ps_lap_nth.
 rewrite ps_lap_nth_0_cons_pow.
 rewrite order_pow.
  rewrite ps_monom_order.
   rewrite Qbar.mul_0_r; [ idtac | intros HH; discriminate HH ].
   rewrite Qbar.add_0_l.
   rewrite fold_ps_lap_nth.
   rewrite ps_lap_nth_0_apply_0.
   unfold ps_lap_comp.
   rewrite apply_lap_compose.
   unfold apply_lap at 2; simpl.
   rewrite ps_mul_0_l, ps_add_0_l.
   rewrite ps_mul_0_r, ps_add_0_l.
   rewrite apply_lap_inject_K_in_Kx_monom.
   rewrite ps_monom_order; [ reflexivity | idtac ].
   eapply psi_c₁_ne_0 in HΨ; eassumption.

   eapply char_pol_root_ne_0; eassumption.

  intros HH.
  apply ps_monom_0_coeff_0 in HH.
  revert HH.
  eapply char_pol_root_ne_0; eassumption.

 subst yr ycj psi yc.
 rewrite fold_ps_lap_add.
 rewrite ps_lap_nth_add.
 rewrite fold_ps_lap_comp.
 rewrite order_add_eq_min; rewrite Hor.
 rewrite Qbar.min_l; [ reflexivity | idtac ].
  apply Qbar.lt_le_incl.
  apply nth_g_order_pos; assumption.

  apply Qbar.lt_neq.
  apply nth_g_order_pos; assumption.
Qed.

Theorem exists_pol_ord : ∀ f, ∃ m,
  m = ps_pol_com_polydo f ∧ pol_in_K_1_m f m.
Proof.
intros f.
unfold pol_in_K_1_m.
remember (ps_pol_com_polydo f) as m eqn:Hm.
exists m; split; [ reflexivity | ].
apply ps_lap_forall_forall.
 intros a b Hab H.
 rewrite <- Hab; assumption.

 intros a Ha.
 unfold ps_pol_com_polydo in Hm.
 remember (al f) as la; clear Heqla.
 revert a m Ha Hm.
 induction la as [| b]; intros; [ contradiction | idtac ].
 simpl in Ha.
 destruct Ha as [(Hbla, Hba)| Ha].
  constructor.
  simpl in Hm.
  remember (ps_lap_com_polydo la) as m' eqn:Hm' .
  exists (adjust_ps 0 m' b).
  split; [ idtac | simpl; rewrite Pos.mul_comm; symmetry; assumption ].
  transitivity b; [ idtac | assumption ].
  symmetry; apply ps_adjust_eq.

  subst m; simpl.
  apply in_K_1_m_lap_mul_r_compat.
  apply IHla; [ apply Ha | reflexivity ].
Qed.

(* [Walker, p 101] «
     O(bi) ≥ 0,  i = 0,...,n
     O(bi) > 0,  i = 0,...,r-1
     O(br) = 0
   »
*)
Theorem f₁_orders : ∀ f L c₁ r f₁,
  newton_segments f = Some L
  → c₁ = ac_root (Φq f L)
  → r = root_multiplicity acf c₁ (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c₁
  → (∀ i, (order (ps_poly_nth i f₁) ≥ 0)%Qbar)
    ∧ (∀ i, (i < r)%nat → (order (ps_poly_nth i f₁) > 0)%Qbar)
    ∧ (order (ps_poly_nth r f₁) = 0)%Qbar.
Proof.
intros f L c₁ r f₁ HL Hc₁ Hr Hf₁.
split; [ eapply order_bbar_nonneg; eassumption | idtac ].
split; [ eapply order_bbar_pos; eassumption | idtac ].
pose proof (exists_pol_ord f) as H.
destruct H as (m, (Hm, Hp)).
eapply order_bbar_r_is_0; eassumption.
Qed.

End theorems.