(* begin hide *)
From Coq Require Import
     List
     String
     Logic.FunctionalExtensionality.

From Vellvm Require Import
     Utils.Util
     Utils.ListUtil
     Utils.Tactics
     Syntax.LLVMAst
     Syntax.AstLib
     Syntax.CFG
     Syntax.Traversal
     Syntax.DynamicTypes.

Require Import Coqlib.

Import CFGNotations.
Import ListNotations.
Open Scope list_scope.
(* end hide *)

(** * Conversion from static to dynamic types
    LLVM admits static types than can be recursive in the case of function types.
    At run-time, this information is unnecessary, we therefore pre-process them by
    converting them into a notion of dynamic types whose pointer type contains no
    further information.
    The conversion also inlines globally declared types (field [m_type_defs] of a [modul] (i.e. a [mcfg]).
 *)

Inductive typ_order : typ -> typ -> Prop :=
| typ_order_Pointer : forall (t : typ), typ_order t (TYPE_Pointer t)
| typ_order_Array : forall (sz : N) (t : typ), typ_order t (TYPE_Array sz t)
| typ_order_Vector : forall (sz : N) (t : typ), typ_order t (TYPE_Vector sz t)
| typ_order_Struct : forall (fields : list typ),
    forall f, In f fields -> typ_order f (TYPE_Struct fields)
| typ_order_Packed_struct : forall (fields : list typ),
    forall f, In f fields -> typ_order f (TYPE_Packed_struct fields)
| typ_order_Function_args : forall (ret : typ) (args : list typ),
    forall a, In a args -> typ_order a (TYPE_Function ret args)
| typ_order_Function_ret : forall (ret : typ) (args : list typ),
    typ_order ret (TYPE_Function ret args)
.
#[export] Hint Constructors typ_order : core.

Fixpoint remove_key {A B : Type} (eq_dec : (forall (x y : A), {x = y} + {x <> y})) (a : A) (l : list (A * B)) : list (A * B) :=
  match l with
  | nil => nil
  | cons (h, b) t =>
    match eq_dec a h with
    | left _ => t
    | right _ => (h, b) :: remove_key eq_dec a t
    end
  end.

Theorem wf_typ_order :
    well_founded typ_order.
Proof.
  unfold well_founded.
  induction a; constructor; intros y H'; inversion H'; subst; auto.
Qed.

Theorem wf_lt_typ_order :
  well_founded (lex_ord lt typ_order).
Proof.
  apply wf_lex_ord.
  apply lt_wf. apply wf_typ_order.
Qed.

Ltac destruct_prod :=
  match goal with
  | [ |- context[let (_, _) := ?p in _]] => destruct p
  | [ p: ?A * ?B |- _ ] => destruct p
  end.

Ltac destruct_eq_dec :=
  match goal with
  | [ eq: forall x y : ?A , {x = y} + {x <> y} |- context[eq ?a ?b] ] => destruct (eq a b) eqn:?; simpl
  | [ |- context[Ident.eq_dec ?a ?b] ] => destruct (Ident.eq_dec a b) eqn:?; simpl
  end.

Lemma remove_key_in :
  forall (A B : Type) (a : A)  (b : B) eq_dec l,
    In (a, b) l ->
    (List.length (remove_key eq_dec a l) < List.length l)%nat.
Proof.
  induction l.
  - intros H. inversion H.
  - intros H.
    destruct_prod.
    simpl. destruct_eq_dec.
    + apply Nat.lt_succ_diag_r.
    + simpl. apply lt_n_S. apply IHl.
      destruct H.
      * inversion H. subst. contradiction.
      * assumption.
Qed.

#[export] Hint Resolve wf_lt_typ_order : core.
#[export] Hint Constructors lex_ord : core.

Program Fixpoint typ_to_dtyp (env : list (ident * typ)) (t : typ) {measure (List.length env, t) (lex_ord lt typ_order)} : dtyp :=
  match t with
  | TYPE_Array sz t =>
    let nt := typ_to_dtyp env t in
    DTYPE_Array sz nt

  | TYPE_Function ret args =>
    DTYPE_Pointer

  | TYPE_Struct fields =>
    let nfields := map_In fields (fun t _ => typ_to_dtyp env t) in
    DTYPE_Struct nfields

  | TYPE_Packed_struct fields =>
    let nfields := map_In fields (fun t _ => typ_to_dtyp env t) in
    DTYPE_Packed_struct nfields

  | TYPE_Vector sz t =>
    let nt := typ_to_dtyp env t in
    DTYPE_Vector sz nt

  | TYPE_Identified id =>
    let opt := find (fun a => Ident.eq_dec id (fst a)) env in
    match opt with
    | None => DTYPE_Void   (* TODO: should this be None? *)
    | Some (_, t) => typ_to_dtyp (remove_key Ident.eq_dec id env) t
    end

  | TYPE_I sz => DTYPE_I sz
  | TYPE_Pointer t' => DTYPE_Pointer
  | TYPE_Void => DTYPE_Void
  | TYPE_Half => DTYPE_Half
  | TYPE_Float => DTYPE_Float
  | TYPE_Double => DTYPE_Double
  | TYPE_X86_fp80 => DTYPE_X86_fp80
  | TYPE_Fp128 => DTYPE_Fp128
  | TYPE_Ppc_fp128 => DTYPE_Ppc_fp128
  | TYPE_Metadata => DTYPE_Metadata
  | TYPE_X86_mmx => DTYPE_X86_mmx
  | TYPE_Opaque => DTYPE_Opaque
  end.
Next Obligation.
  left.
  symmetry in Heq_opt. apply find_some in Heq_opt. destruct Heq_opt as [Hin Heqb_ident].
  simpl in Heqb_ident.
  destruct (Ident.eq_dec id wildcard'). subst. eapply remove_key_in. apply Hin.
  inversion Heqb_ident.
Defined.

Lemma typ_to_dtyp_equation  : forall env t,
    typ_to_dtyp env t =
    match t with
    | TYPE_Array sz t =>
      let nt := typ_to_dtyp env t in
      DTYPE_Array sz nt

    | TYPE_Function ret args =>
      DTYPE_Pointer (* Function nret nargs *)

    | TYPE_Struct fields =>
      let nfields := map_In fields (fun t _ => typ_to_dtyp env t) in
      DTYPE_Struct nfields

    | TYPE_Packed_struct fields =>
      let nfields := map_In fields (fun t _ => typ_to_dtyp env t) in
      DTYPE_Packed_struct nfields

    | TYPE_Vector sz t =>
      let nt := typ_to_dtyp env t in
      DTYPE_Vector sz nt

    | TYPE_Identified id =>
      let opt := find (fun a => Ident.eq_dec id (fst a)) env in
      match opt with
      | None => DTYPE_Void   (* TODO: should this be None? *)
      | Some (_, t) => typ_to_dtyp (remove_key Ident.eq_dec id env) t
      end

    | TYPE_I sz => DTYPE_I sz
    | TYPE_Pointer t' => DTYPE_Pointer
    | TYPE_Void => DTYPE_Void
    | TYPE_Half => DTYPE_Half
    | TYPE_Float => DTYPE_Float
    | TYPE_Double => DTYPE_Double
    | TYPE_X86_fp80 => DTYPE_X86_fp80
    | TYPE_Fp128 => DTYPE_Fp128
    | TYPE_Ppc_fp128 => DTYPE_Ppc_fp128
    | TYPE_Metadata => DTYPE_Metadata
    | TYPE_X86_mmx => DTYPE_X86_mmx
    | TYPE_Opaque => DTYPE_Opaque
    end.
Proof.
  intros env t.
  unfold typ_to_dtyp.
  unfold typ_to_dtyp_func at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext.
  destruct t; try reflexivity. simpl.
  destruct (find (fun a : ident * typ => Ident.eq_dec id (fst a)) env).
  destruct p; simpl; eauto.
  reflexivity.
Defined.

(* Specialized version of the characteristic equation for contexts where we don't want to compute *)
Lemma typ_to_dtyp_I : forall s i, typ_to_dtyp s (TYPE_I i) = DTYPE_I i.
Proof.
  intros; rewrite typ_to_dtyp_equation; reflexivity.
Qed.

Lemma typ_to_dtyp_D : forall s, typ_to_dtyp s TYPE_Double = DTYPE_Double.
Proof.
  intros; rewrite typ_to_dtyp_equation; reflexivity.
Qed.

Lemma typ_to_dtyp_P :
  forall t s,
    typ_to_dtyp s (TYPE_Pointer t) = DTYPE_Pointer.
Proof.
  intros t s.
  apply typ_to_dtyp_equation.
Qed.

Lemma typ_to_dtyp_D_array : forall n s, typ_to_dtyp s (TYPE_Array n TYPE_Double) = DTYPE_Array n DTYPE_Double.
Proof.
  intros.
  rewrite typ_to_dtyp_equation.
  rewrite typ_to_dtyp_D.
  reflexivity.
Qed.

(** ** Conversion of syntactic components

    Front-ends and optimizations generate code containing static types.
    Since the semantics always acts upon dynamic types, in order to reason
    about the sub-components of code produce, we need to be able to convert
    types of any syntactic substructure of Vellvm.

    We leverage the parameterized [Tfmap] typeclass to do this in a fairly lightway.
 *)
Section ConvertTyp.

  Class ConvertTyp (F: Set -> Set) : Type :=
    convert_typ : list (ident * typ) -> F typ -> F dtyp.

  #[global] Instance ConvertTyp_exp : ConvertTyp exp :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_instr : ConvertTyp instr :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_term : ConvertTyp terminator :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_code : ConvertTyp code :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_phi : ConvertTyp phi :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_block : ConvertTyp block :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_cfg : ConvertTyp cfg :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_mcfg : ConvertTyp mcfg :=
    fun env => tfmap (typ_to_dtyp env).

  #[global] Instance ConvertTyp_list {A} `{TFunctor A}: ConvertTyp (fun T => list (A T)) :=
    fun env => tfmap (typ_to_dtyp env).

End ConvertTyp.

Lemma convert_typ_list_app :
  forall {F} `{TFunctor F} (a b : list (F typ)) (env : list (ident * typ)),
    convert_typ env (a ++ b)%list = (convert_typ env a ++ convert_typ env b)%list.
Proof.
  intros F H a.
  induction a; cbn; intros; auto.
  rewrite IHa; reflexivity.
Qed.

(**
     Conversion to dynamic types
 *)

Definition convert_types (CFG:(CFG.mcfg typ)) : (CFG.mcfg dtyp) :=
  convert_typ (m_type_defs CFG) CFG.

Lemma convert_typ_ocfg_app : forall (a b : ocfg typ) env, (convert_typ env (a ++ b) = convert_typ env a ++ convert_typ env b)%list.
Proof.
  intros; rewrite convert_typ_list_app; reflexivity.
Qed.

Lemma convert_typ_code_app : forall (a b : code typ) env, (convert_typ env (a ++ b) = convert_typ env a ++ convert_typ env b)%list.
Proof.
  induction a as [| [] a IH]; cbn; intros; auto.
  rewrite IH; reflexivity.
Qed.

Lemma convert_typ_mcfg_app:
  forall mcfg1 mcfg2 : modul (cfg typ),
    convert_typ [] (mcfg1 @@ mcfg2) =
    convert_typ [] mcfg1 @@ convert_typ [] mcfg2.
Proof.
  intros [] []; cbn.
  unfold convert_typ,ConvertTyp_mcfg,tfmap,TFunctor_mcfg; cbn.
  f_equal; try (unfold endo, Endo_option; cbn; repeat flatten_goal; now intuition).
  unfold tfmap, TFunctor_list; rewrite map_app; reflexivity.
  unfold tfmap, TFunctor_list'; rewrite map_app; reflexivity.
  unfold tfmap, TFunctor_list'; rewrite map_app; reflexivity.
  unfold tfmap, TFunctor_list'; rewrite map_app; reflexivity.
Qed.

Lemma convert_types_app_mcfg : forall mcfg1 mcfg2,
    m_type_defs mcfg1 = [] ->
    m_type_defs mcfg2 = [] ->
    convert_types (modul_app mcfg1 mcfg2) =
    modul_app (convert_types mcfg1) (convert_types mcfg2).
Proof.
  unfold convert_types.
  intros * EQ1 EQ2.
  rewrite m_type_defs_app, EQ1,EQ2.
  cbn; rewrite convert_typ_mcfg_app.
  reflexivity.
Qed.

Lemma mcfg_of_tle_app : forall x y,
    m_type_defs (mcfg_of_modul (modul_of_toplevel_entities x)) = nil ->
    m_type_defs (mcfg_of_modul (modul_of_toplevel_entities y)) = nil ->
    convert_types (mcfg_of_tle (x ++ y)) =
    modul_app (convert_types (mcfg_of_tle x)) (convert_types (mcfg_of_tle y)).
Proof.
  intros.
  unfold mcfg_of_tle.
  rewrite modul_of_toplevel_entities_app.
  rewrite mcfg_of_app_modul.
  rewrite convert_types_app_mcfg; auto.
Qed.

Lemma mcfg_of_tle_cons : forall x y,
    m_type_defs (mcfg_of_modul (modul_of_toplevel_entities [x])) = nil ->
    m_type_defs (mcfg_of_modul (modul_of_toplevel_entities y)) = nil ->
    convert_types (mcfg_of_tle (x :: y)) =
    modul_app (convert_types  (mcfg_of_tle [x])) (convert_types  (mcfg_of_tle y)).
Proof.
  intros; rewrite list_cons_app; apply mcfg_of_tle_app; auto.
Qed.


Require Export Db.Inst.
Require Export Db.Lemmas.
Require Export Db.WellScoping.
Require Export StlcIso.SpecSyntax.
Require Export RecTypes.InstTy.

#[export]
#[refine] Instance vrTm : Vr Tm := {| vr := var |}.
Proof. inversion 1; auto. Defined.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     rewrite ?comp_up, ?up_liftSub, ?up_comp_lift
    );
  auto.

Module TmKit <: Kit.

  Definition TM := Tm.
  Definition inst_vr := vrTm.

  Section Application.

    Context {Y: Type}.
    Context {vrY : Vr Y}.
    Context {wkY: Wk Y}.
    Context {liftY: Lift Y Tm}.

    #[export]
    #[refine] Instance inst_ap : Ap Tm Y := {| ap := apTm |}.
    Proof.
      induction x; crush.
    Defined.

    #[export]
    #[refine] Instance inst_ap_vr : LemApVr Tm Y := {}.
    Proof. reflexivity. Qed.

  End Application.

  #[export]
  #[refine] Instance inst_ap_inj: LemApInj Tm Ix := {}.
  Proof.
    intros m Inj_m x. revert m Inj_m.
    induction x; destruct y; simpl; try discriminate;
    inversion 1; subst; f_equal; eauto using InjSubIxUp.
  Qed.

  #[export]
  #[refine] Instance inst_ap_comp (Y Z: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Tm}
    {vrZ: Vr Z} {wkZ: Wk Z} {liftZ: Lift Z Tm}
    {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
    {apLiftYTmZ: LemApLift Y Z Tm} :
    LemApComp Tm Y Z := {}.
  Proof. induction x; crush. Qed.

  #[export]
  #[refine] Instance inst_ap_liftSub (Y: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Tm} :
    LemApLiftSub Tm Y := {}.
  Proof. induction t; crush. Qed.

  Lemma inst_ap_ixComp (t: Tm) :
    ∀ (ξ: Sub Ix) (ζ: Sub Tm), t[ξ][ζ] = t[⌈ξ⌉ >=> ζ].
  Proof. pose proof up_comp_lift. induction t; crush. Qed.

End TmKit.
Module InstTm := Inst TmKit.
Export InstTm. (* Export for shorter names. *)

#[export]
Instance wsVrTm: WsVr Tm.
Proof.
  constructor.
  - now constructor.
  - now inversion 1.
Qed.

Section Application.

  Context {Y: Type}.
  Context {vrY : Vr Y}.
  Context {wkY: Wk Y}.
  Context {liftY: Lift Y Tm}.
  Context {wsY: Ws Y}.
  Context {wsVrY: WsVr Y}.
  Context {wsWkY: WsWk Y}.
  Context {wsLiftY: WsLift Y Tm}.

  Hint Resolve wsLift : ws.
  Hint Resolve wsSub_up : ws.

  Global Instance wsApTm : WsAp Tm Y.
  Proof.
    constructor.
    - intros ξ γ δ t wξ wt; revert ξ δ wξ.
      induction wt; intros ξ δ wξ; crush;
      try econstructor;
      try match goal with
            | |- wsTm ?δ ?t =>
              change (wsTm δ t) with ⟨ δ ⊢ t ⟩
          end; eauto with ws.
    - intros γ t wt.
      induction wt; crush.
      + apply IHwt; inversion 1; crush.
      + apply IHwt2; inversion 1; crush.
      + apply IHwt3; inversion 1; crush.
  Qed.
End Application.

#[export]
Instance wsWkTm: WsWk Tm.
Proof.
  constructor; crush.
  - refine (wsAp _ H); eauto.
    constructor; eauto.
Qed.
(*   - admit. *)
(*     (* induction x; cbn in H; inversion H. *) *)
(*     (* + change (wk i) with (S i) in *. *) *)
(*     (*   inversion H1; subst. eapply WsVar; eassumption. *) *)
(*     (* +  *) *)
(* Admitted. *)


(* this file contains basic definitions and lemmas about registers and addresses *)
From Coq Require Import ssreflect Eqdep_dec ZArith.
From HypVeri Require Import machine monad stdpp_extra.
From stdpp Require Import fin_maps list countable fin vector gmap.

(* these definitions are frequently used *)

Section VMID0.
  Context `{hypconst:HypervisorConstants}.

  Program Definition V0 : VMID := (@nat_to_fin 0 _ _).
  Next Obligation.
  destruct hypconst. simpl. lia.
  Defined.

  Lemma V0eq : (fin_to_nat V0) = 0.
  Proof.
    rewrite /V0.
    apply fin_to_nat_to_fin.
  Qed.

End VMID0.

Program Definition W0 : Word := (finz.FinZ 0 _ _).
Solve Obligations with lia.

Program Definition W1 : Word := (finz.FinZ 1 _ _).
Solve Obligations with lia.

Program Definition W2 : Word := (finz.FinZ 2 _ _).
Solve Obligations with lia.

Program Definition W6 : Word := (finz.FinZ 6 _ _).
Solve Obligations with lia.

Program Definition I0 : Imm := (I W0 _).
Solve Obligations with try lia;solve_finz.

Program Definition I1 : Imm := (I W1 _).
Solve Obligations with try lia; solve_finz.

Program Definition I2 : Imm := (I W2 _).
Solve Obligations with try lia; solve_finz.

Program Definition I6 : Imm := (I W6 _).
Solve Obligations with try lia; solve_finz.

Program Definition R0 :reg_name := (R 0 _).
Solve Obligations with lia.

Program Definition R1 :reg_name := (R 1 _).
Solve Obligations with lia.

Program Definition R2 :reg_name := (R 2 _).
Solve Obligations with lia.

Program Definition R3 :reg_name := (R 3 _).
Solve Obligations with lia.

Program Definition R4 :reg_name := (R 4 _).
Solve Obligations with lia.

Program Definition R5 :reg_name := (R 5 _).
Solve Obligations with lia.

Program Definition R6 :reg_name := (R 6 _).
Solve Obligations with lia.

Program Definition R7 :reg_name := (R 7 _).
Solve Obligations with lia.

Program Definition R8 :reg_name := (R 8 _).
Solve Obligations with lia.

Program Definition R9 :reg_name := (R 9 _).
Solve Obligations with lia.

Program Definition R10 :reg_name := (R 10 _).
Solve Obligations with lia.

Definition page_of_W0: list Word:=
  map (λ _, W0) (seq 0 (Z.to_nat page_size)).

Definition pages_of_W0 (n:nat): list (list Word):=
  map (λ _, page_of_W0) (seq 0 n).

Lemma length_page_of_W0 : length (page_of_W0) = (Z.to_nat page_size).
Proof.
  rewrite /page_of_W0 map_length seq_length //.
Qed.

Lemma length_pages_of_W0 n : length (pages_of_W0 n) = n.
Proof.
  rewrite /pages_of_W0 map_length seq_length //.
Qed.

Lemma length_pages_of_W0_forall n : forall ws, ws ∈  (pages_of_W0 n) -> length ws = (Z.to_nat page_size).
Proof.
  intros.
  apply elem_of_list_In in H.
  rewrite /pages_of_W0 in H.
  apply in_map_iff in H.
  destruct H.
  destruct H.
  rewrite -H length_page_of_W0 //.
Qed.

Definition hvcf_to_tt hvcf:=
  match hvcf with
    | Donate => Some Donation
    | Lend => Some Lending
    | Share => Some Sharing
    | _ => None
  end.

Section list_of_vmids.
Context `{HypervisorConstants}.

(* list of all valid vmids, heavily used in state_interp *)
Definition list_of_vmids  := vec_to_list (fun_to_vec (λ v: fin vm_count, v)).

Lemma length_list_of_vmids : length list_of_vmids = vm_count.
Proof.
  rewrite /list_of_vmids.
  apply vec_to_list_length.
Qed.

Lemma in_list_of_vmids v: In v list_of_vmids.
Proof.
  apply elem_of_list_In.
  apply elem_of_vlookup.
  exists v.
  apply lookup_fun_to_vec.
Qed.

Lemma NoDup_list_of_vmids : NoDup list_of_vmids.
Proof.
  apply NoDup_alt.
  rewrite /list_of_vmids.
  intros ??? Hlk1 Hlk2.
  rewrite <-vlookup_lookup' in Hlk1.
  rewrite <-vlookup_lookup' in Hlk2.
  destruct Hlk1 as [Hlt1 Hlk1], Hlk2 as [Hlt2 Hlk2].
  rewrite lookup_fun_to_vec in Hlk1.
  rewrite lookup_fun_to_vec in Hlk2.
  rewrite -Hlk2 in Hlk1.
  rewrite <-(fin_to_nat_to_fin i vm_count Hlt1).
  rewrite <-(fin_to_nat_to_fin j vm_count Hlt2).
  rewrite Hlk1 //.
Qed.

Lemma lookup_list_of_vmids i (Hlt: i < vm_count):
  list_of_vmids !! i = Some (nat_to_fin Hlt).
Proof.
  unfold list_of_vmids.
  set (f := (nat_to_fin Hlt)).
  assert ( i = fin_to_nat f ).
  subst f.
  rewrite fin_to_nat_to_fin //.
  rewrite H0.
  apply -> (@vlookup_lookup VMID).
  apply lookup_fun_to_vec.
Qed.

End list_of_vmids.

(* an address is in the range of the page with PID p *)
Definition addr_in_page (a: Addr ) (p:PID):=
  ((of_pid p) <=? a)%f ∧ (a <=? ((of_pid p) ^+ (page_size -1 )))%f.

(* a sequence of addresses is in the range of the page with PID p *)
Definition seq_in_page (b :Addr) (l: nat) (p:PID) :=
  l > 0 ∧
  (* the starting address b is greater than the base addr of the page *)
  ((of_pid p) <=? b)%Z
  (* the ending address doesn't excess the boundary of address space *)
  ∧ is_Some (b + (Z.of_nat l - 1))%f
  (* the ending address is less than or equal to the last address of the page *)
  ∧ ((b ^+ (Z.of_nat l -1))%f <=? ((of_pid p) ^+ (page_size-1))%f)%Z.

(* we can always get the last address of a page *)
Lemma last_addr_in_bound (p:PID):
  is_Some ((of_pid p) + (page_size -1)%Z)%f.
Proof.
  destruct p.
  destruct z.
  simplify_eq /=.
  assert (Hy : exists y, (y * page_size = word_size)%Z).
  exists 2000%Z.
  lia.
  destruct Hy.
  assert (Hlt: (z + page_size -1 < word_size)%Z).
  {
    apply Z.ltb_lt in finz_lt.
    apply Z.leb_le in finz_nonneg.
    assert (Hlt': (z  < word_size - page_size + 1 )%Z).
    {
      destruct (decide (z  < word_size - page_size + 1)%Z).
      lia.
      assert(H': ( (x -1 ) * page_size < z )%Z).
      lia.
      apply Z.eqb_eq in align.
      apply Z.rem_divide in align;[|lia].
      destruct align.
      subst z.
      rewrite -H in finz_lt.
      apply Zmult_gt_0_lt_reg_r in finz_lt;[|lia].
      apply Zmult_gt_0_lt_reg_r in H';[|lia].
      lia.
    }
    lia.
  }
  unfold finz.incr.
  simpl.
  destruct (Z_lt_dec (z + (page_size - 1))%Z word_size).
  destruct (Z_le_dec 0%Z (z + (page_size - 1))%Z).
  eauto.
  exfalso.
  apply n.
  lia.
  exfalso.
  apply n.
  lia.
Qed.

(* complementing lemmas for finz *)
Lemma finz_of_z_is_Some {fb} (z : Z):
  (z >= 0)%Z ->
  (z < fb)%Z ->
  is_Some (finz.of_z (finz_bound := fb) z).
Proof.
  intros.
  unfold finz.of_z.
  destruct (Z_lt_dec z fb).
  2: lia.
  destruct (Z_le_dec 0%Z z).
  2: lia.
  exists (finz.FinZ z (match Z.ltb_lt z fb with
                              | conj _ H2 => H2
                              end l) (match Z.leb_le 0 z with
                                      | conj _ H2 => H2
                                      end l0)).
  done.
Qed.

Lemma incr_default_incr{fb} (f1 f2: finz.finz fb) z :
  (f1 + z)%f = Some f2 -> (f1 ^+ z)%f = f2.
Proof.
  intro.
  solve_finz.
Qed.

Lemma finz_incr_z_plus{b} (f1 f2 : (finz.finz b)) z :
  (f1 + z)%f = Some f2 <-> (f1 + z)%Z = (finz.to_z f2).
Proof.
  split;solve_finz.
Qed.

Lemma finz_incr_z_plus'{b} (f1 : (finz.finz b)) z :
  (f1 + z)%f = None <-> (b <= (f1 + z))%Z ∨ ((f1 +z) < 0)%Z .
Proof.
  split; solve_finz.
Qed.

Lemma finz_plus_Z_lt{b} (f: (finz.finz b)) z1 z2:
  (is_Some (f + z1)%f) -> (is_Some (f + z2)%f) ->
  ((f ^+ z1)%f < (f ^+ z2)%f)%Z -> (z1 < z2)%Z.
Proof.
  intros H1 H2 Hlt.
  destruct H1 as [f1 H1].
  destruct H2 as [f2 H2].
  rewrite (incr_default_incr f f1 z1) in Hlt;eauto.
  rewrite (incr_default_incr f f2 z2) in Hlt;eauto.
  solve_finz.
Qed.

Lemma finz_plus_Z_le{b} (f: (finz.finz b)) z1 z2:
  (is_Some (f + z1)%f) ->
  (is_Some (f + z2)%f) ->
  ((f ^+ z1)%f <= (f ^+ z2)%f)%Z ->
  (z1 <= z2)%Z.
Proof.
  intros H1 H2 Hlt.
  destruct H1 as [f1 H1].
  destruct H2 as [f2 H2].
  rewrite (incr_default_incr f f1 z1) in Hlt;eauto.
  rewrite (incr_default_incr f f2 z2) in Hlt;eauto.
  solve_finz.
Qed.

(*  relation between to_pid_aligned and addr_in_page *)
Lemma to_pid_aligned_in_page (a:Addr) (p:PID) :
  addr_in_page a p -> (to_pid_aligned a ) = p.
Proof.
  intro.
  unfold to_pid_aligned.
  unfold addr_in_page in H.
  destruct H.
  pose proof (last_addr_in_bound p).
  destruct H1.
  rewrite (incr_default_incr (of_pid p) x (page_size -1)%Z) in H0;eauto.
  destruct p.
  destruct z.
  assert (Heq : z = (page_size * (a / page_size))%Z).
  {
    destruct a.
    simplify_eq /=.
    unfold finz.leb in H.
    simpl in H.
    unfold finz.ltb in H0.
    simpl in H0.
    apply Is_true_eq_true in H, H0.
    apply Z.leb_le in H.
    apply Z.leb_le in H0.
    apply finz_incr_z_plus in H1.
    simpl in H1.
    rewrite -H1 in H0.
    simpl in H0.
    apply Z.eqb_eq in align.
    apply Z.rem_divide in align;[|lia].
    destruct align.
    subst z.
    apply (fast_Zmult_comm page_size x0) in H.
    apply Z.quot_le_lower_bound in H;[|lia].
    assert (H0': (z0 < page_size* (x0+1) )%Z).
    lia.
    apply Z.quot_lt_upper_bound in H0';[|lia|lia].
    assert (Heq: (z0 `quot` page_size = x0)%Z).
    lia.
    rewrite Z.quot_div_nonneg in Heq;[lia|lia| ].
    solve_finz.
  }
  subst z.
  remember (machine.to_pid_aligned_obligation_3 a) as Ha'.
  simpl in Ha'.
  assert (Heqiv : Ha' = align).
  apply eq_proofs_unicity; decide equality; decide equality.
  rewrite Heqiv.
  remember (machine.to_pid_aligned_obligation_1 a) as Ha''.
  simpl in  Ha''.
  remember (machine.to_pid_aligned_obligation_2 a) as Ha'''.
  simpl in  Ha'''.
  assert (Heqiv' : Ha'' = finz_lt).
  apply eq_proofs_unicity; decide equality; decide equality.
  rewrite Heqiv'.
  assert (Heqiv'' : Ha''' = finz_nonneg).
  apply eq_proofs_unicity; decide equality; decide equality.
  rewrite Heqiv'' // .
Qed.

Lemma in_page_to_pid_aligned a: addr_in_page a (to_pid_aligned a).
Proof.
  unfold addr_in_page, to_pid_aligned.
  split.
  - simpl.
    unfold finz.leb.
    simpl.
    unfold Is_true.
    case_match;[done|].
    apply Z.leb_nle in Heqb.
    apply Heqb.
    apply Z.mul_div_le.
    lia.
  - unfold finz.leb.
    simpl.
    pose proof (last_addr_in_bound (to_pid_aligned a)) as Hplus.
    destruct Hplus as [? Hplus].
    unfold finz.incr_default.
    unfold to_pid_aligned in Hplus.
    rewrite Hplus.
    simpl in Hplus.
    destruct x.
    simpl.
    assert (1000 * a `div` 1000 + (1000 - 1) = z)%Z as <-.
    { solve_finz. }
    pose proof (Z.div_mod a 1000).
    rewrite ->H at 1.
    2: {lia. }
    unfold Is_true.
    case_match;[done|].
    apply Z.leb_nle in Heqb.
    apply Heqb.
    apply Zplus_le_compat_l.
    rewrite -Z.rem_mod_nonneg;[lia|lia|].
    assert (a `rem` 1000 < 1000)%Z.
    {
      pose proof (Z.rem_bound_pos_pos a 1000).
      apply H0;lia.
    }
    lia.
Qed.

Lemma to_pid_aligned_eq (p:PID) : to_pid_aligned p = p.
Proof.
  unfold to_pid_aligned.
  destruct p.
  apply of_pid_eq.
  simpl.
  destruct z.
  apply finz_to_z_eq.
  simplify_eq /=.
  unfold finz.leb in finz_lt.
  unfold finz.ltb in finz_nonneg.
  apply Z.ltb_lt in finz_lt.
  apply Z.leb_le in finz_nonneg.
  apply Z.eqb_eq in align.
  apply Z.rem_divide in align;[|lia].
  destruct align.
  subst z.
  rewrite Z_div_mult;[lia|].
  apply (fast_Zmult_comm page_size x).
  lia.
Qed.

Lemma finz_plus_assoc {fb} (a : finz fb) (n m : Z):
  (0 <= n)%Z ->
  (0 <= m)%Z ->
  ((a ^+ n) ^+ m)%f = (a ^+ (n + m)%Z)%f.
Proof. solve_finz. Qed.

(* complementing lemmas for finz.seq *)
Lemma finz_seq_notin2{b} (f f' : finz.finz b) n :
  (f' ^+ ((Z.of_nat n)-1) < f)%f -> f ∉ finz.seq f' n.
Proof.
  revert f f'. induction n; cbn.
  { intros. inversion 1. }
  { intros. apply not_elem_of_cons. split. solve_finz. eapply IHn. solve_finz. }
Qed.

Lemma finz_seq_in1{b} (f f' : finz.finz b) n :
  f ∈ finz.seq f' n ->  (f' <= f )%f.
Proof.
  revert f f'. induction n; cbn.
  { intros. inversion H. }
  { intros. apply  elem_of_cons in H.
    destruct H.
    solve_finz.
    eapply IHn in H. solve_finz. }
Qed.

Lemma finz_seq_in2{b} (f f' : finz.finz b) n :
  f ∈ finz.seq f' n ->  (f <= f' ^+ ((Z.of_nat n)-1))%f.
Proof.
  revert f f'. induction n; cbn.
  { intros. inversion H. }
  { intros. apply  elem_of_cons in H.
    destruct H.
    solve_finz.
    eapply IHn in H. solve_finz. }
Qed.

(* if the sequcence is included in a page,
then every address in the sequcence is in the page *)
Definition seq_in_page_forall1 (b: Addr) (l:nat) (p:PID) :
  seq_in_page b l p -> (∀ a, a ∈ (finz.seq b l) -> addr_in_page a p).
Proof.
  intros.
  (* apply Forall_forall. *)
  unfold addr_in_page.
  destruct H.
  split.
  - unfold finz.leb.
    unfold Is_true.
    destruct (decide (b <= a)%f).
    unfold Is_true in H.
    assert (Hap: ((of_pid p) <= a)%Z).
    destruct ((((of_pid p) <=? b))%Z) eqn:Heqn.
    apply Z.leb_le in Heqn.
    solve_finz.
    destruct H1.
    inversion H1.
    apply Z.leb_le in Hap.
    rewrite Hap //=.
    exfalso.
    assert (Hlt: (a < b )%f).
    solve_finz.
    apply (finz_seq_notin _ _ l)in Hlt.
    contradiction.
  - destruct l.
    inversion H.
    destruct H1.
    destruct H2.
    destruct H2.
    rewrite (incr_default_incr b x _ ) in H3;eauto.
    pose proof (last_addr_in_bound p).
    destruct H4.
    rewrite (incr_default_incr (of_pid p) x0 _ ) in H3;eauto.
    rewrite (incr_default_incr (of_pid p) x0 _ );eauto.
    apply  finz_incr_z_plus in H4.
    apply finz_seq_in2 in H0.
    apply  finz_incr_z_plus in H2.
    assert (H1': (b + (Z.of_nat l -1))%Z = (x-1)%Z ). by lia.
    assert(Hl : ((Z.of_nat (S l) - 1)%Z = (Z.of_nat l))%Z).  by lia.
    rewrite Hl  in H0 H1.
    rewrite -H4 in H3.
    rewrite -H2 in H3.
    unfold finz.leb.
    rewrite -H4.
    assert (H0': (a <= b + (Z.of_nat l))%Z).
    solve_finz.
    rewrite -H2 in H1'.
    destruct (decide (a <= (of_pid p) + (page_size - 1)))%Z.
    apply Z.leb_le in l0.
    solve_finz.
    exfalso.
    destruct ((b + Z.of_nat l <=? (of_pid p) + (page_size - 1))%Z) eqn:Heqn.
    apply Z.leb_le in Heqn.
    lia.
    rewrite Hl in H3.
    rewrite Heqn in H3.
    contradiction.
Qed.

Lemma finz_seq_lookup'{b} (f0 fi:(finz.finz b)) (i n : nat) :
  is_Some(f0 + (Z.of_nat n - 1))%f ->
  finz.seq f0 n !! i = Some fi ->
  i < n ∧ (f0 + (Z.of_nat i))%f = Some fi.
Proof using.
  revert i fi f0. induction n.
  { intros. done. }
  { intros i fi f0 Hsafe HSome.
    destruct i as [|i].
    { split. solve_finz. simpl in HSome. inversion HSome. solve_finz. }
    { simpl in HSome.
      apply IHn in HSome.
      destruct HSome.
      split.
      lia. rewrite -H0. solve_finz.
      assert (Hlt: i < n).
      {
        apply lookup_lt_Some in HSome.
        rewrite finz_seq_length in HSome.
        done.
      }
      solve_finz.
    }
    }
Qed.

Lemma finz_seq_cons {b} (f: finz.finz b) (l:nat) :
  (l > 0) ->
  (finz.seq f l) = f :: (finz.seq (f ^+ 1)%f (l-1)).
Proof.
  intro.
  destruct l eqn:Hl;[lia|].
  simpl.
  repeat f_equal.
  lia.
Qed.

Definition seq_in_page_forall2 (b: Addr) (l:nat) (p:PID) :
  seq_in_page b l p -> (∀ a, a ∈ (finz.seq b l) -> to_pid_aligned a = p).
Proof.
  intros.
  apply to_pid_aligned_in_page.
  by apply (seq_in_page_forall1 b l p H a).
Qed.

(* Definition seq_in_page_forall2 (b: Addr) (l:nat) (p:PID) : *)
(*    l > 0 -> (∀ a, a ∈ (finz.seq b l) -> addr_in_page a p) -> seq_in_page b l p. *)
(* Proof. *)
(*   intros Hl Hforall. *)
(*   rewrite /seq_in_page. *)
(*   assert (b ∈ finz.seq b l) as Hb. *)
(*   rewrite finz_seq_cons;auto. *)
(*   set_solver. *)
(*   apply (Hforall b) in Hb. *)
(*   rewrite /addr_in_page in Hb. *)
(*   destruct Hb as [Hbge Hble]. *)
(*   split. *)
(*   solve_finz. *)
(*   assert ((b ^+ (Z.of_nat l -1 ))%f ∈ finz.seq b l) as Hbl. *)
(*   admit. *)
(*   pose proof Hbl as Hbl'. *)
(*   apply (Hforall (b ^+ (Z.of_nat l -1 ))%f) in Hbl. *)
(*   rewrite /addr_in_page in Hbl. *)
(*   destruct Hbl. *)
(*   split;[|solve_finz]. *)
(*   pose proof (last_addr_in_bound p). *)
(*   (* don't know how to prove it ... seems the def of addr_in_page need to be changed. *) *)
(*   Admitted. *)

(* fin_to_nat vec_to_list of_imm of_pid finz.to_z NonPropType.frame Is_true NonPropType.callee *)
Lemma seq_in_page_append1 (b:Word) (l l' : nat) p:
  (0 < l) -> (l < l') -> seq_in_page b l' p -> seq_in_page b l p.
Proof.
  intros Hlpos Hlt Hseq.
  rewrite /seq_in_page.
  split;[done|].
  rewrite /seq_in_page in Hseq.
  destruct Hseq as (Hl'pos & Hple & Hbl'isSome & Hbl'le).
  split; auto.
  split.
  solve_finz.
  assert (Hllt: ((Z.of_nat l - 1) < (Z.of_nat l' -1))%Z).
  solve_finz.
  assert (((b ^+ (Z.of_nat l - 1))%f < (b ^+ (Z.of_nat l' - 1)))%f).
  solve_finz.
  rewrite /Is_true in Hbl'le.
  case_match.
  apply Z.leb_le in Heqb0.
  rewrite /Is_true.
  case_match.
  done.
  solve_finz.
  done.
Qed.

Lemma seq_in_page_append2 (b :Word) (l o : nat) p:
  o<l ->
  is_Some (b + (Z.of_nat o))%f->
  seq_in_page b l p ->
  seq_in_page (b ^+ (Z.of_nat o))%f (l - o) p.
Proof.
  intros Holt Hb'in Hseq.
  rewrite /seq_in_page.
  rewrite /seq_in_page in Hseq.
  destruct Hseq as (Hlpos & Hple & HblisSome & Hblle).
  split.
  lia.
  split.
  rewrite /Is_true in Hple.
  case_match;[|done].
  apply Z.leb_le in Heqb0.
  rewrite /Is_true.
  case_match;[done|].
  solve_finz.
  split.
  solve_finz.
  rewrite /Is_true in Hblle.
  case_match;[|done].
  apply Z.leb_le in Heqb0.
  rewrite /Is_true.
  case_match;[done|].
  solve_finz.
Qed.

(* an alternative definition, not sure which is better *)
(* Definition addr_of_page' (p: PID) := map (λ off, ((of_pid p) + off)%f) (seqZ 0%Z page_size). *)

Lemma finz_seq_lookup0{b} n (f : finz.finz b) x :
   is_Some(f + 1)%f ->
   finz.seq f n !! x = Some f -> x=0.
Proof.
  revert f. destruct n; cbn.
  { intros. inversion H0. }
  { intros.
    destruct (decide (x=0)).
    done.
    rewrite lookup_cons_ne_0 in H0;eauto.
    apply elem_of_list_lookup_2 in H0.
    pose proof (finz_seq_notin f (f ^+ 1)%f n).
    assert ( (f < f ^+ 1)%f) as Hlt.
    solve_finz.
    apply H1 in Hlt.
    done.
  }
Qed.

Lemma finz_seq_NoDup'{b} (f : finz.finz b) (n : nat) :
  is_Some (f + (Z.of_nat (n-1)))%f →
  NoDup (finz.seq f n).
Proof using.
  revert f. induction n; intros f Hfn.
  { apply NoDup_nil_2. }
  { cbn.
    destruct n; intros;simpl.
    { apply NoDup_singleton. }
    { apply NoDup_cons_2.
      apply not_elem_of_cons.
      split.
      solve_finz.
      apply finz_seq_notin.
      solve_finz.
      eapply IHn.
      solve_finz. } }
Qed.

Lemma finz_seq_in_inv{b} (f f' : finz.finz b) n:
    (f' <= f )%f -> (f <= f' ^+ (Z.of_nat n))%f ->
    f ∈ finz.seq f' (n+1).
 Proof.
   revert f f'. induction n; cbn.
   { intros.
     assert (f = f')%f as ->.
     {
       solve_finz.
     }
     set_solver +.
   }
   {
     intros.
     destruct (decide (f = f')).
     {
       rewrite e.
       apply elem_of_list_here.
     }
     apply elem_of_list_further.
     apply IHn.
     solve_finz.
     solve_finz.
   }
 Qed.

 Definition addr_of_page (p: PID) := (finz.seq (of_pid p) (Z.to_nat page_size)).

 Lemma elem_of_addr_of_page_tpa (a:Addr) : a ∈ (addr_of_page (tpa a)).
 Proof.
   rewrite /addr_of_page.
   pose proof (in_page_to_pid_aligned a) as [H1 H2].
   assert ((Z.to_nat 1000) = (Z.to_nat 999) + 1) as ->.
   { done. }
   apply finz_seq_in_inv.
   {
     rewrite /Is_true in H1.
     case_match;last done.
     solve_finz.
   }
   {
     rewrite /Is_true in H2.
     case_match;last done.
     solve_finz.
   }
 Qed.

Lemma elem_of_addr_of_page_of_pid (a : Addr) : of_pid (tpa a) ∈ addr_of_page (tpa a).
Proof.
  unfold addr_of_page.
  unfold tpa.
  rewrite finz_seq_cons; first lia.
  apply elem_of_list_here.
Qed.

Lemma elem_of_addr_of_page_iff (a:Addr) (p : PID) : a ∈ (addr_of_page p) <-> p = (tpa a).
Proof.
  split.
  {
     rewrite /addr_of_page.
     intro Hin.
     symmetry.
     apply to_pid_aligned_in_page.
     rewrite /addr_in_page.
     split.
     apply finz_seq_in1 in Hin.
     rewrite Is_true_true.
     solve_finz.
     apply finz_seq_in2 in Hin.
     rewrite Is_true_true.
     solve_finz.
  }
  intros ->.
  apply elem_of_addr_of_page_tpa.
Qed.

Lemma addr_of_page_not_empty_exists (p : PID) : ∃a, a ∈ addr_of_page p.
Proof.
  exists (of_pid p).
  apply elem_of_addr_of_page_iff.
  rewrite to_pid_aligned_eq //.
Qed.

Lemma addr_of_page_not_empty_set (p : PID) : list_to_set (addr_of_page p) ≠ (∅: gset _) .
Proof.
  pose proof (addr_of_page_not_empty_exists p) as H.
  destruct H as [a H].
  intro Heq.
  rewrite -(elem_of_list_to_set (C:= gset Addr) a (addr_of_page p)) in H.
  rewrite Heq in H.
  set_solver + H.
Qed.

Lemma addr_of_page_NoDup (p:PID) : NoDup (addr_of_page p).
Proof.
  rewrite /addr_of_page.
  apply finz_seq_NoDup'.
  apply last_addr_in_bound.
Qed.

Lemma addr_of_page_disj (p1 p2 :PID) :
  p1 ≠ p2 ->
  ((list_to_set (addr_of_page p1)) : gset Addr) ## list_to_set (addr_of_page p2).
Proof.
  intro Hneq.
  apply elem_of_disjoint.
  intros a.
  rewrite !elem_of_list_to_set.
  rewrite !elem_of_addr_of_page_iff.
  intros -> Hin2.
  done.
Qed.

Lemma addr_of_page_subseteq (p : PID) (n:nat) :
  ((Z.of_nat n) <= page_size)%Z ->
  list_to_set (C:=gset _) (finz.seq p n) ⊆ list_to_set (addr_of_page p).
Proof.
  destruct n eqn:Heqn.
  done.
  intro Hle.
  intros a Hin.
  rewrite elem_of_list_to_set.
  rewrite elem_of_list_to_set in Hin.
  pose proof Hin.
  apply finz_seq_in1 in Hin.
  apply finz_seq_in2 in H.
  apply elem_of_addr_of_page_iff.
  symmetry.
  apply to_pid_aligned_in_page.
  rewrite /addr_in_page.
  split.
  apply Is_true_eq_left.
  solve_finz.
  apply Is_true_eq_left.
  pose proof (last_addr_in_bound p).
  solve_finz.
Qed.

Lemma pid_lt_lt (p1 p2:PID):
  ((of_pid p1) < (of_pid p2))%f -> (p1 ^+ (page_size - 1) < p2)%f.
Proof.
  intro.
  pose proof (last_addr_in_bound p1).
  destruct H0.
  rewrite (incr_default_incr (of_pid p1) x);eauto.
  destruct p1,p2.
  destruct z,z0.
  simpl in *.
  apply Z.eqb_eq in align, align0.
  apply Z.rem_divide in align,align0;try lia.
  destruct align, align0.
  assert ( z < z0 )%Z.
  solve_finz.
  subst z.
  subst z0.
  destruct x.
  simpl in H0.
  assert (z = x0 * 1000 + 1000 -1)%Z.
  solve_finz.
  subst z.
  solve_finz.
Qed.

Lemma finz_seq_nonempty_length {b} (x f :finz.finz b) (l:nat):
  x ∈ finz.seq f l-> l >0.
Proof.
  intros.
  destruct l.
  inversion H.
  lia.
Qed.

Lemma addr_in_notin (p1 p2 : PID) (x: Addr) (l1 : nat) :
  ((Z.of_nat l1) < page_size)%Z ->
  p1 ≠ p2 ->
  x ∈ finz.seq (of_pid p1) l1 ->
  ∀ l2 , ((Z.of_nat l2) < page_size)%Z -> x ∉ finz.seq (of_pid p2) l2.
Proof.
  intros.
  pose proof H1.
  apply finz_seq_nonempty_length in H3.
  destruct (decide ((of_pid p1) <= (of_pid p2))%f).
  - assert ( (of_pid p1) ≠ (of_pid p2))%f.
    { intro. apply H0. by apply of_pid_eq. }
    assert ( (of_pid p1) < (of_pid p2))%f. solve_finz.
    apply  finz_seq_notin.
    apply pid_lt_lt in H5.
    apply finz_seq_in2 in H1.
    solve_finz.
  - destruct l2.
    apply not_elem_of_nil.
    assert ( (of_pid p2) < (of_pid p1))%f. solve_finz.
    apply  finz_seq_notin2.
    apply finz_seq_in1 in H1.
    apply pid_lt_lt in H4.
    solve_finz.
Qed.

Lemma finz_seq_zip_page (p: PID) (ws: list Word):
  (length ws) <= (Z.to_nat page_size) ->
  ((zip (finz.seq (of_pid p) (length ws)) ws) = (zip (finz.seq (of_pid p) (Z.to_nat page_size)) ws)).
Proof.
  intro Hlen.
  rewrite <-(zip_fst_snd (zip (finz.seq _ (Z.to_nat page_size)) ws)).
  rewrite !snd_zip; auto.
  f_equal.
  generalize dependent (of_pid p).
  induction ws; first done.
  cbn.
  destruct (Z.to_nat page_size) eqn:Heqn; first done.
  cbn.
  intros f.
  f_equal.
  assert (Hn : n = ((Z.to_nat page_size) - 1)).
  lia.
  subst n.
  rewrite (@zip_length_le _ _ ws
                          (finz.seq (f ^+ 1)%f ((Z.to_nat page_size) -1))
                          (finz.seq (f ^+ 1)%f (Z.to_nat page_size))
                          [(f ^+ page_size)%f]).
  simpl in Hlen.
  rewrite finz_seq_length.
  lia.
  rewrite (finz_seq_decomposition (Z.to_nat page_size) _ ((Z.to_nat page_size) -1)).
  lia.
  f_equal.
  simpl.
  f_equal.
  rewrite Unnamed_thm12.
  lia.
  lia.
  rewrite Z.add_comm.
  assert (H999_1 : Z.add (page_size - 1)%Z 1%Z = 1000%Z).
  reflexivity.
  rewrite H999_1.
  reflexivity.
  rewrite IHws.
  simpl in Hlen.
  lia.
  rewrite -Heqn.
  reflexivity.
Qed.


Set Warnings "-notation-overridden".

Require Import LinearScan.Lib.
Require Import LinearScan.UsePos.
Require Import LinearScan.Range.
Require Import LinearScan.Interval.
Require Import LinearScan.Blocks.
Require Import LinearScan.LiveSets.
Require Import LinearScan.Morph.
Require Import LinearScan.ScanState.
Require Import LinearScan.Loops.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Build.

Variable maxReg : nat.          (* max number of registers *)
Definition PhysReg := 'I_maxReg.

Variables blockType1 blockType2 opType1 opType2 : Set.
Variables mType : Type -> Type.
Context `{mDict : Monad mType}.

Variable binfo : BlockInfo blockType1 blockType2 opType1 opType2.
Variable oinfo : OpInfo maxReg opType1 opType2.

Definition BuildState (b : nat) := IntMap (SortedRanges b.*2.+1).

Definition newBuildState {n} : BuildState n := emptyIntMap.

Definition PendingRanges b e := NonEmpty (BoundedRange b.*2.+1 e.*2.+1).

Definition emptyPendingRanges (b e : nat) (H : b < e) (liveOuts : IntSet) :
  IntMap (PendingRanges b e).
Proof.
  have Hsz : b.*2.+1 < e.*2.+1 by undoubled.
  have empty  := emptyBoundedRange Hsz.
  have f xs vid := IntMap_insert (vid + maxReg) [::: empty] xs.
  exact (IntSet_foldl f emptyIntMap liveOuts).
Defined.

(* We sort ascending in order of range end, with smaller ranges occurring
   after larger ones. *)
Definition BoundedRange_leq {b e} (x y : BoundedRange b.*2.+1 e.*2.+1) : bool.
Proof.
  move: x => [[x _] _].
  move: y => [[y _] _].
  case: (rend x == rend y).
    exact: (rbeg x <= rbeg y).
  exact: (rend x <= rend y).
Defined.

Program Instance BoundedRange_leq_trans {b e} :
  Transitive (@BoundedRange_leq b e).
Obligation 1.
  rewrite /BoundedRange_leq /= in H H0 *.
  destruct x; destruct y; destruct z.
  destruct x; destruct x1; destruct i.
  destruct x0; destruct i0.
  case E1: (rend x == rend x0) in H H0 *;
  case E2: (rend x0 == rend x1) in H H0 *;
  case E3: (rend x1 == rend x) in H H0 *;
  case E4: (rend x == rend x1) in H H0 *;
  move/eqP in E1;
  move/eqP in E2;
  move/eqP in E3;
  move/eqP in E4;
  by ordered.
Qed.

Lemma BoundedRange_leq_antisym {b e} : forall x y,
  ~~ (@BoundedRange_leq b e) y x -> (@BoundedRange_leq b e) x y.
Proof.
  move=> x y Hneg.
  rewrite /BoundedRange_leq /= in Hneg *.
  destruct x; destruct y.
  destruct x; destruct x0.
  case E1: (rend x == rend x0) in Hneg *;
  case E2: (rend x0 == rend x) in Hneg *;
  move/eqP in E1;
  move/eqP in E2;
  by ordered.
Qed.

Definition compilePendingRanges {b e} (Hlt : b < e)
  (ranges : seq (BoundedRange b.*2.+1 e.*2.+1))
  (H : StronglySorted BoundedRange_leq ranges) :
  { rs : SortedRanges b.*2.+1
  | last b.*2.+1 [seq rend r.1 | r <- rs.1] <= e.*2.+1
  & if ranges is _ :: _
    then if rs.1 is r' :: _
         then { H : 0 < size ranges
              | rend (safe_hd ranges H).1.1 <= rend r'.1 }
         else False
    else True}.
Proof.
  elim: ranges => [|r1 rs IHrs] in H *.
    apply: exist2 _ _ (exist2 _ _ [::] _ _) _ _.
    - by constructor.
    - by [].
    - by undoubled.
    - intros; exact: I.

  destruct rs as [|r2 rs2] eqn:R2.
    apply: exist2 _ _ (exist2 _ _ [:: r1.1] _ _) _ _.
    - by constructor; constructor.
    - clear -r1.
      case: r1 => [H1 H2] /=.
      by ordered.
    - clear -r1.
      case: r1 => [H1 H2] /=.
      by ordered.
    - by exists (ltn0Sn _).

  have Hconn : rend r1.1.1 <= rend r2.1.1.
    inv H; inv H2; inv H3.
    rewrite /BoundedRange_leq /= in H2.
    destruct r1; destruct x;
    destruct r2; destruct x0; simpl.
    case E: (rend x == rend x0) => // in H2 *.
    by move/eqP in E; rewrite {}E.

  apply StronglySorted_inv in H.
  move: H => [Hs Hf].
  specialize (IHrs Hs).
  case: IHrs => [[[|r2' rs2'] H2a H2b] /= H3 H4] in Hs *;
    first by [].

  (* Owing to the way the list is sorted, this is the only check we need for
     intersection and adjacency. *)
  case E: (range_ltn r1.1 r2').
    rewrite /=.
    apply: exist2 _ _ (exist2 _ _ [:: r1.1, r2' & rs2'] _ _) _ _.
    - constructor.
        exact: H2a.
      constructor.
        exact: E.
      inv H2a.
      exact/(Forall_ordered E).
    - clear -r1.
      case: r1 => [H1 H2] /=.
      by ordered.
    - by [].
    - by exists (ltn0Sn _).

  move: r1 => [[rd1 r1] Hr1] /= in Hs Hf Hconn E *.
  move: r2' => [rd2' r2'] /= in Hs Hf E R2 H2a H2b H3 H4 *.

  (* Otherwise, if the ranges are directly adjacent, or intersect, coalesce
     them into a single range. *)
  apply: exist2 _ _
    (exist2 _ _ [:: packRange (Range_merge r1 r2') & rs2'] _ _) _ _.

  (* Prove that sorting over range_ltn has been established. *)
  rewrite /range_ltn /= in E *.
  constructor.
    by inv H2a.
  induction rs2' as [|r3 rs3 IHrs3].
    by constructor.
  rewrite /=.
  have Hmax: maxn (rend rd1) (rend rd2') < rbeg r3.1.
    inv Hf.
    clear -Hs H2a H4 Hconn.
    inv H2a; inv H4; inv H1; inv H2.
    rewrite gtn_max.
    rewrite /range_ltn /= in H3.
    by ordered.
  constructor=> //.
  apply IHrs3.
  constructor=> //.
    by inv H2a; inv H1.
  by inv H2a; inv H2.

  rewrite /= in H3 *.
  apply: (last_leq H3).
  rewrite gtn_max in Hmax.
  apply/ltnW.
  move: (Range_bounded r3.2).
  by ordered.

  (* Return a witness to an ordering property [rend rd1 <= maxn (rend rd1)
     (rend rd2')], which makes induction much easier. *)
  rewrite /=.
  rewrite leq_min.
  by ordered.

  rewrite /=.
  intros.
  apply: (last_leq H3).
  rewrite geq_max.
  inv H4.
  by ordered.

  rewrite /=.
  exists (ltn0Sn _).
  rewrite leq_max.
  by apply/orP; left.
Defined.

Program Fixpoint rangesToBoundedRanges {b e} (y : RangeSig) (ys : seq RangeSig)
  (H1 : StronglySorted range_ltn (y :: ys)) (H2 : b.*2.+1 <= rbeg y.1)
  (Hbound : last (rend y.1) [seq rend r.1 | r <- ys] <= e.*2.+1) :
  NonEmpty (BoundedRange b.*2.+1 e.*2.+1) :=
  match ys with
  | nil => NE_Sing y
  | cons z zs =>
      NE_Cons y (@rangesToBoundedRanges b e z zs _ _ _)
  end.
Next Obligation.
  rewrite /= in Hbound.
  by ordered.
Qed.
Next Obligation.
  apply/andP; split=> //.
  apply StronglySorted_impl_cons in H1;
    last exact: range_ltn_trans.
  move: H1 Hbound.
  rewrite [(z; H)]lock.
  rewrite /range_ltn map_comp (last_map rend) /= last_map -lock /=.
  move: (Range_bounded (last (z; H) zs).2).
  case: zs => //= [|w ws].
  by ordered.
  move=> H3 H4 H5.
  apply/(leq_trans _ H5).
  apply/(leq_trans _ H3).
  apply/ltnW.
  by ordered.
Qed.
Next Obligation.
  by inv H1.
Qed.
Next Obligation.
  inv H1; inv H6.
  rewrite /range_ltn /= in H4.
  move: (Range_bounded H0).
  by ordered.
Qed.

Definition compressPendingRanges `(ranges : PendingRanges b e) (H : b < e) :
  PendingRanges b e.
Proof.
  case: ranges => [r|r rs].
    exact: [::: r].
  pose Hsort := sortBy_sorted [::: r & rs] BoundedRange_leq_antisym.
  specialize (Hsort BoundedRange_leq_trans).
  rewrite NE_to_list_from_list /= in Hsort.
  move: (compilePendingRanges H Hsort) => [[srs1 H1 H2] Hbound /= H3].
  clear -srs1 H1 H2 H3 Hbound.
  case E: (insert BoundedRange_leq r (sortBy BoundedRange_leq rs))
    => [|x xs] in H3 *.
    move: E.
    set xs := insert _ _ _.
    move=> E.
    have E1 : size xs = size [::] by rewrite E.
    by rewrite insert_size /= in E1.
  destruct srs1 as [|y ys]; simpl in *.
    contradiction H3.
  exact: (rangesToBoundedRanges H1 H2 Hbound).
Defined.

Definition mergeIntoSortedRanges `(H : b < e)
  (pmap : IntMap (PendingRanges b e)) (rmap : IntMap (SortedRanges e.*2.+1)) :
  IntMap (SortedRanges b.*2.+1).
Proof.
  apply: (IntMap_mergeWithKey _ _ _ pmap rmap).
  - (* The combining function, when entries are present in both maps. *)
    move=> _ brs srs2.
    pose Hsort := sortBy_sorted brs BoundedRange_leq_antisym.
    specialize (Hsort BoundedRange_leq_trans).
    move: (compilePendingRanges H Hsort) => [[srs1 ? ?] Hbound _].
    exact: Some (SortedRanges_cat srs2 Hbound).

  - (* When no rmap entry are present. *)
    apply: IntMap_map _.
    move=> brs.
    pose Hsort := sortBy_sorted brs BoundedRange_leq_antisym.
    specialize (Hsort BoundedRange_leq_trans).
    move: (compilePendingRanges H Hsort) => [srs1 _ _].
    exact: srs1.

  - (* When no pmap entry is present. *)
    move=> sr.
    have H': b.*2.+1 <= e.*2.+1 by undoubled.
    exact: IntMap_map (transportSortedRanges H') sr.
Defined.

Definition upos_before_rend `(r : Range rd) (upos : UsePos) :=
  if ups rd is u :: _
  then upos <= u
  else upos <  rend rd.
Arguments upos_before_rend [rd] r upos /.

Lemma validUsePosition `(r : Range rd) (upos : UsePos)
  (Hbeg : rbeg rd <= upos) (Hend : upos_before_rend r upos) :
  [/\ validRangeBounds (rbeg rd) (rend rd) (upos :: ups rd)
  &   StronglySorted upos_le (upos :: ups rd)].
Proof.
  rewrite /= in Hend.
  split.
    move: (Range_proper r).
    move/andP=> [H1 H2] /=.
    do 3 (apply/andP; split => //).
    case: (ups rd) => //= [u us] in Hend H2 *.
    case: (uvar upos) => // in Hend *;
    case: (uvar u) => //= in Hend H2 *;
    case E: (uloc u == rend rd) => // in Hend *;
    try move/leq_eqF in E;
    by ordered.
  move: (Range_sorted r) => Hsorted.
  constructor=> // {Hbeg}.
  case: (ups rd) => /= [|u us] in Hend Hsorted *.
    by constructor.
  case: (uvar upos) => // in Hend *;
  try case: (uvar u) => //= in Hend *;
  constructor=> //;
  inv Hsorted;
  case: (uloc u == rend rd) => // in Hend;
  try exact/ltnW;
  try exact: Forall_ordered;
  try move/ltnW in Hend;
  apply: Forall_ordered; rewrite /upos_le;
  try exact Hend; auto.
Defined.

Definition makeNewRange {b pos e} (H : b <= pos < e) (upos : UsePos)
  (Heqe : uloc upos == if uvar upos is Input
                       then pos.*2.+1
                       else pos.*2.+2) :
  BoundedRange b.*2.+1 e.*2.+1.
Proof.
  (* If the variable is only [Input], assume it starts from the beginning; and
     if [Output], that it persists until the end.  Only [Temp] variables are
     handled using a single-instruction range. *)
  pose rd :=
    {| rbeg := if (uvar upos == Input) || (uvar upos == InputOutput)
               then b.*2.+1
               else pos.*2.+2
     ; rend := match uvar upos with
               | Input       => pos.*2.+2
               | Temp        => pos.*2.+3
               | InputOutput => e.*2.+1
               | Output      => e.*2.+1
               end
     ; ups  := [:: upos ] |}.

  apply: ((rd; _); _).
    constructor=> /=.
    + case E: (uvar upos) in Heqe rd *;
      move/eqP in Heqe; rewrite {}Heqe;
      try undoubled;
      breakup; try undoubled;
      simpl in *;
      try apply/ltn_addn1;
      rewrite -?doubleS ?ltn_Sdouble;
      try undoubled.
      rewrite doubleS.
      apply ltnW.
      apply ltn_addn1.
      by undoubled.
    + by constructor; constructor.

  rewrite /= => r.
  case: (uvar upos).
  + case U: (pos.*2.+1 == pos.*2.+2).
      move/eqP in U.
      by ordered.
    by undoubled.
  (* jww (2015-08-29): Remove this repetition. *)
  + clear r rd Heqe.
    apply/andP; split;
    rewrite -?doubleS ?ltn_Sdouble;
    by undoubled.
  + clear r rd Heqe.
    apply/andP; split;
    rewrite -?doubleS ?ltn_Sdouble;
    simpl in *;
    try undoubled.
    rewrite doubleS.
    apply ltnW.
    apply ltn_addn1.
    by undoubled.
  + clear r rd Heqe.
    simpl in *.
    apply/andP; split;
    rewrite -?doubleS ?ltn_Sdouble;
    try undoubled.
    rewrite doubleS.
    apply ltnW.
    apply ltn_addn1.
    by undoubled.
Defined.

Definition makeUsePos (pos : nat) (var : VarInfo maxReg) :
  { u : UsePos | uloc u == if uvar u is Input
                           then pos.*2.+1
                           else pos.*2.+2 }.
Proof.
  set upos := {| uloc   := if varKind var is Input
                           then pos.*2.+1
                           else pos.*2.+2
               ; regReq := regRequired var
               ; uvar   := varKind var |}.
  exists upos;
  rewrite /upos;
  case: (varKind var) => //=;
  by rewrite /= odd_double.
Defined.

(* This is the most complex of the variable handling functions, because under
   certain circumstances we need to insert the variable into an existing range
   rather than just create a new range each time, as we do for inputs and
   temporaries. *)
Definition handleOutputVar {b pos e} (H : b <= pos < e)
  (range : option (PendingRanges b e)) (var : VarInfo maxReg) :
  option (PendingRanges b e).
Proof.
  move: (makeUsePos pos var) => [upos Heqe].

  (* If no range exists yet, make a new one that extends from [pos] to [e]. *)
  case: range => [range|]; last first.
    exact (Some [::: makeNewRange H Heqe]).

  (* If [pos] fits within the current range, use it; otherwise, shift the
     beginning of the current range down to [pos] so that our use position may
     fit within it. The boolean value is true if we are to replace the
     beginning of the range list with the new range, and false if we are to
     prepend it only. *)
  have res : (bool * { r1 : RangeSig | (b.*2.+1 <= rbeg r1.1 <= upos) &&
                                       (rend r1.1 <= e.*2.+1) })%type.
    move: (NE_head range) => [r /andP [Hbeg Hend]].
    case E: (upos < head_or_end r.1).
      case: (ups r.1) => /= [|[loc req kind] us].
        split. exact true.
        pose r1 := Range_shift r.2 E.
        have Hr1: r1 = Range_shift r.2 E by [].
        exists r1.
        move: (Range_shift_spec Hr1) => [-> -> _].
        move/eqP: Heqe => ->.
        case: (uvar upos);
        rewrite -?doubleS;
        try undoubled.
          move/andP in H.
          destruct H.
          apply/andP; split.
            apply/andP; split.
              rewrite doubleS.
              apply ltnW.
              apply ltn_addn1.
              by undoubled.
            by undoubled.
          by undoubled.
          apply/andP; split.
            apply/andP; split.
              rewrite doubleS.
              apply ltnW.
              apply ltn_addn1.
              by undoubled.
            by undoubled.
          by undoubled.
          apply/andP; split.
            apply/andP; split.
              rewrite doubleS.
              apply ltnW.
              apply ltn_addn1.
              by undoubled.
            by undoubled.
          by undoubled.
      (* Is the use position at the beginning of the range output only? If so,
         then we can allow a lifetime hole between the current position and
         the beginning of that range. *)
      case: (kind == Output).
        split. exact false.
        have H0 : b <= pos < pos.+1 by ordered.
        pose NR := makeNewRange H0 Heqe.
        exists NR.1.
        rewrite /= {NR}.
        move/eqP: Heqe => ->.
        case: (uvar upos) => /=;
        rewrite -?doubleS;
        try undoubled.
          move/andP in H0.
          destruct H0.
          apply/andP; split.
            apply/andP; split.
              by undoubled.
            rewrite doubleS.
            apply ltnW.
            apply ltn_addn1.
            by undoubled.
          by undoubled.
          apply/andP; split.
            apply/andP; split.
              rewrite doubleS.
              apply ltnW.
              apply ltn_addn1.
              by undoubled.
            by undoubled.
          by undoubled.
          apply/andP; split.
            apply/andP; split.
              rewrite doubleS.
              apply ltnW.
              apply ltn_addn1.
              by undoubled.
            by undoubled.
          by undoubled.
      split. exact true.
      pose r1 := Range_shift r.2 E.
      have Hr1: r1 = Range_shift r.2 E by [].
      exists r1.
      move: (Range_shift_spec Hr1) => [-> -> _].
      move/eqP: Heqe => ->.
      case: (uvar upos);
      rewrite -?doubleS;
      try undoubled.
        move/andP in H.
        destruct H.
        apply/andP; split.
          apply/andP; split.
            rewrite doubleS.
            apply ltnW.
            apply ltn_addn1.
            by undoubled.
          by undoubled.
        by undoubled.
        apply/andP; split.
          apply/andP; split.
            rewrite doubleS.
            apply ltnW.
            apply ltn_addn1.
            by undoubled.
          by undoubled.
        by undoubled.
        apply/andP; split.
          apply/andP; split.
            rewrite doubleS.
            apply ltnW.
            apply ltn_addn1.
            by undoubled.
          by undoubled.
        by undoubled.
    split. exact true.
    move/negbT in E; rewrite -ltnNge /= in E.
    exists r.
    move: (Range_proper r.2) => /=.
    by case: (ups r.1) => [|? ?] /= in E *; ordered.
  move: res => [replaceFirst [r1 /andP [/andP [? Hbeg2] ?]]].

  (* Check whether our use position actually fits within the end of the
     current range, after shifting.  If not, ignore the current range and just
     create a new one.  At the step where we combine the pending ranges, any
     intersecting ranges will be coalesced. *)
  case Hupos : (upos_before_rend r1.2 upos); last first.
    exact: Some [::: makeNewRange H Heqe & range].

  (* We have a valid range to put the use position in; derive this fact from
     what we know so far, and then cons our use position onto the front of the
     existing range. *)
  move: (validUsePosition Hbeg2 Hupos) => [Hloc Hsorted].

  case: replaceFirst.
    have br : BoundedRange b.*2.+1 e.*2.+1.
      exists (Range_cons r1.2 Hloc Hsorted).
      by rewrite /=; ordered.
    case: range => [_|_ rs].
      exact: Some [::: br].
    exact: Some [::: br & rs].
  have br : BoundedRange b.*2.+1 e.*2.+1.
    exists r1.
    by ordered.
  exact: Some [::: br & range].
Defined.

Definition handleVar {b pos e} (H : b <= pos < e)
  (range : option (PendingRanges b e)) (var : VarInfo maxReg) :
  option (PendingRanges b e).
Proof.
  move: (makeUsePos pos var) => [? Heqe].
  case: range => [range|].
    exact: Some [::: makeNewRange H Heqe & range].
  exact: Some [::: makeNewRange H Heqe].
Defined.

Definition handleVars_combine {b pos e} (H : b <= pos < e) (vid : nat)
  (vars : seq (VarInfo maxReg)) (c1 : PendingRanges b e) :
  option (PendingRanges b e).
Proof.
  have Hlt : b < e by ordered.
  have c2 := compressPendingRanges c1 Hlt.
  have c3 := foldl (handleOutputVar H) (Some c2)
                   (filter (fun k => varKind k == Output) vars).
  have c4 := foldl (handleVar H) c3
                   (filter (fun k => varKind k != Output) vars).
  exact: c4.
Defined.

(* If there is no variable reference at this position, do nothing. *)
Definition handleVars_onlyRanges {b pos e} (H : b <= pos < e) :
  IntMap (PendingRanges b e) -> IntMap (PendingRanges b e).
Proof. exact. Defined.

(* If a variable referenced for which no reservation was made (for example, an
   input variable that is not used as an output later in the block), we simply
   add it. *)
Definition handleVars_onlyVars {b pos e} (H : b <= pos < e) :
  IntMap (seq (VarInfo maxReg)) -> IntMap (PendingRanges b e).
Proof.
  apply: IntMap_foldlWithKey _ emptyIntMap => m vid vars.
  have c2 := foldl (handleOutputVar H) None
                   (filter (fun k => varKind k == Output) vars).
  have c3 := foldl (handleVar H) c2
                   (filter (fun k => varKind k != Output) vars).
  case: c3 => [c3|].
    exact: IntMap_insert vid c3 m.
  exact: m.
Defined.

Definition handleVars
  (varRefs : seq (VarInfo maxReg)) `(Hlt : b <= pos < e)
  `(ranges : IntMap (PendingRanges b e)) : IntMap (PendingRanges b e) :=
  let vars := IntMap_map NE_to_list $
              IntMap_groupOn (@nat_of_varId maxReg) varRefs in
  IntMap_mergeWithKey (handleVars_combine Hlt) (handleVars_onlyVars Hlt)
                      (handleVars_onlyRanges Hlt) vars ranges.

Definition reduceOp {b pos e} (block : blockType1) (op : opType1)
  (ranges : IntMap (PendingRanges b e)) (Hlt : b <= pos < e) :
  IntMap (PendingRanges b e) :=
  (* If the operation is a function call, force a flush of every register.

     jww (2015-01-30): This needs to be improved to consider the calling
     convention of the operation. *)
  let refs  := opRefs oinfo op in
  let refs' :=
    if opKind oinfo op is IsCall
    then
      (* Although every register should be dropped, some architectures
         actually pass the address they wish to call to in a variable.  Since
         this is only an input variable, it's OK to allocate it up to the
         call, since we needn't assume it will contain a value after the
         call.  *)
      let regsNeeded :=
          count (fun r => match varId r with
                          | inl _ => false
                          | inr _ => true
                          end) refs in
      drop regsNeeded
           (filter (fun x => varId x \notin map (@varId maxReg) refs)
                   [seq {| varId       := inl n
                           ; varKind     := Temp
                           ; regRequired := true
                        |} | n in ord_enum maxReg]) ++ refs
    else refs in

  handleVars refs' Hlt ranges.

Lemma leq_plus : forall m n, m <= m + n.
Proof. elim=> [|m IHm] //=. Qed.

Lemma ltn_plus : forall m n, 0 < n -> m < m + n.
Proof. elim=> [|m IHm] //=. Qed.

Definition reduceBlock {pos} (bid : BlockId) (block : blockType1)
  (Hsz : 0 < blockSize binfo block)
  (loops : LoopState) (varUses : IntMap IntSet) :
  let sz := blockSize binfo block in
  let b := pos in
  let e := pos + sz in
  IntMap (PendingRanges b e) -> IntMap (PendingRanges b e).
Proof.
  move=> sz b e.
  rewrite /sz /blockSize.
  set ops := allBlockOps binfo block.

  have Hlt : pos <= (pos + sz).-1 < pos + sz.
    apply/andP; split.
      by rewrite -subn1 -addnBA // leq_plus //.
    rewrite prednK.
      by ordered.
    rewrite addn_gt0.
    by apply/orP; right.

  (* If the current block is a loop end block, insert an [Input] pseudo-use
     position at the very end of the block for every variable which was
     referenced within that loop.  This causes the allocation algorithm to
     split other intervals first before those used by the loop. *)
  move=> ranges.
  have :=
    if ~~ IntSet_member bid (loopEndBlocks loops) then ranges else
    let f acc loopIndex blks :=
      if ~~ IntSet_member bid blks then acc else
      if IntMap_lookup loopIndex varUses isn't Some uses then acc else
      IntSet_union acc uses in
    let uses := IntMap_foldlWithKey f emptyIntSet (loopIndices loops) in
    handleVars [seq {| varId       := inr u
                     ; varKind     := Input
                     ; regRequired := false |}
               | u <- IntSet_toList uses] Hlt ranges.
  clear ranges.

  have H : 0 < size ops -> b < pos + (size ops) <= e.
    rewrite /b /e /sz /blockSize.
    replace (allBlockOps binfo block) with ops; last by [].
    move=> ?.
    apply/andP; split=> //.
    exact: ltn_plus.
  elim/last_ind E: ops => [|os o IHos] /= in H *.
    by [].
  move=> ranges.

  have H1 : b <= pos + (size os) < e.
    rewrite size_rcons in H.
    have: 0 < (size os).+1 by [].
    move/H=> /andP [H2 H3].
    apply/andP; split.
      exact: leq_plus.
    by rewrite addnS in H3.
  move: (reduceOp block o ranges H1).

  have: 0 < size os -> b < pos + size os <= e.
    move=> ?.
    apply/andP; split.
      exact: ltn_plus.
    move/andP: H1 => [_ ?].
    exact/ltnW.
  exact: IHos.
Defined.

Definition reduceBlocks (blocks : seq blockType1) (loops : LoopState)
  (varUses : IntMap IntSet) (liveSets : IntMap BlockLiveSets) {pos} :
  BuildState pos.
Proof.
  elim: blocks => [|b blocks IHbs] in pos *.
    exact: newBuildState.

  pose sz := blockSize binfo b.
  case E: (0 < sz);
    last exact: IHbs pos.

  have Hsz : pos < pos + sz by exact: ltn_plus.

  have bid := blockId binfo b.
  have outs := if IntMap_lookup bid liveSets is Some ls
               then blockLiveOut ls
               else emptyIntSet.
  have ranges := emptyPendingRanges Hsz outs.
  have pending := reduceBlock bid E loops varUses ranges.
  exact: mergeIntoSortedRanges Hsz pending (IHbs (pos + sz)).
Defined.

Definition compileIntervals `(bs : BuildState pos) :
  (* Return the set of fixed intervals, and the set of variable intervals,
     respectively. *)
  FixedIntervalsType maxReg * IntMap IntervalSig.
Proof.
  apply: IntMap_foldlWithKey _ (vconst None, emptyIntMap) bs.
  move=> [regs vars] vid rs.
  case E: rs.1 => [|? ?];
    first by exact: (regs, vars).
  case V: (vid < maxReg).
    simpl in E.
    move: (Interval_fromRanges vid E) => /= i.
    exact: (vreplace regs (Ordinal V) (Some (packInterval i)), vars).
  have vid' := vid - maxReg.
  move: (Interval_fromRanges vid' E) => /= i.
  exact: (regs, IntMap_insert vid' (packInterval i) vars).
Defined.

Definition buildIntervals (blocks : seq blockType1) (loops : LoopState)
  (liveSets : IntMap BlockLiveSets) : ScanStateSig maxReg InUse :=
  let add_unhandled_interval (ss  : ScanStateSig maxReg Pending) i :=
        packScanState (ScanState_newUnhandled ss.2 i.2 I) in
  let s0 := ScanState_nil maxReg in
  if blocks isn't b :: bs
  then packScanState (ScanState_finalize s0)
  else
    let varUses := computeVarReferences binfo oinfo (b :: bs) loops in
    let reduced := reduceBlocks (pos:=0) (b :: bs) loops varUses liveSets in
    let: (regs, vars) := compileIntervals reduced in
    let s1 := ScanState_setFixedIntervals s0 regs in
    let s2 := packScanState s1 in
    let s3 := IntMap_foldl add_unhandled_interval s2 vars in
    let s4 := ScanState_finalize s3.2 in
    packScanState s4.

End Build.


From Coq Require Import Lists.List.
From Coq Require Import BinNums.
From Coq Require Import ZArith.BinInt.
From Coq Require Import ZArith.BinIntDef.
From Coq Require Import ZArith.Zdigits.
From Coq Require Import ZArith.Znat.
From Coq Require Import ZArith Psatz.
From Coq Require Import PeanoNat.
Import ListNotations.

Inductive move :=
  | R : nat -> move
  | L : nat -> move
  | U : nat -> move
  | D : nat -> move
.

Definition test_in := [
R 4;
U 4;
L 3;
D 1;
R 4;
D 1;
L 5;
R 2
].

Definition input := [
R 2;
L 2;
D 2;
U 2;
R 2;
D 2;
L 2;
D 2;
U 2;
L 2;
D 1;
R 1;
D 2;
R 2;
U 1;
R 1;
U 2;
R 1;
L 2;
D 2;
L 1;
U 1;
L 1;
D 1;
R 1;
L 2;
U 2;
R 2;
U 1;
R 2;
L 2;
D 1;
U 1;
D 2;
L 1;
U 1;
L 1;
D 1;
U 1;
D 1;
L 2;
D 2;
U 2;
L 2;
U 1;
R 2;
D 2;
L 1;
R 1;
U 1;
R 1;
L 1;
U 2;
D 1;
U 2;
R 1;
U 1;
R 2;
D 2;
R 2;
U 2;
D 2;
U 2;
L 1;
D 2;
R 1;
L 2;
D 2;
R 2;
L 2;
U 2;
L 2;
R 1;
D 1;
R 1;
L 2;
D 1;
L 2;
R 1;
U 1;
R 1;
U 1;
L 2;
U 1;
D 2;
R 1;
L 1;
D 1;
R 1;
L 2;
R 2;
L 2;
R 1;
L 1;
D 1;
L 1;
R 1;
D 2;
U 1;
D 2;
R 1;
D 1;
U 1;
L 1;
R 1;
D 2;
R 2;
L 2;
R 1;
L 1;
R 1;
U 3;
L 2;
R 3;
L 1;
R 1;
L 2;
D 1;
U 3;
L 1;
R 3;
U 1;
L 2;
U 2;
D 2;
R 2;
D 1;
L 2;
U 1;
R 1;
L 3;
R 2;
L 3;
R 2;
L 2;
D 2;
U 3;
R 2;
L 1;
R 2;
U 1;
D 2;
U 3;
D 1;
U 3;
L 1;
R 3;
D 2;
R 1;
L 2;
D 1;
L 1;
D 3;
U 2;
L 3;
R 1;
U 3;
L 1;
R 2;
U 3;
D 2;
U 3;
L 3;
R 1;
L 2;
R 2;
D 3;
L 1;
D 3;
R 3;
L 1;
U 1;
D 1;
L 3;
D 1;
U 2;
D 3;
U 3;
L 1;
U 2;
D 1;
R 3;
D 1;
R 1;
L 2;
U 1;
R 1;
L 1;
U 3;
D 3;
U 3;
R 1;
D 3;
U 1;
L 2;
R 2;
U 2;
R 1;
D 3;
L 1;
D 2;
U 2;
R 2;
D 2;
R 3;
L 2;
R 1;
L 3;
D 3;
R 1;
L 1;
U 3;
R 1;
D 3;
R 3;
D 2;
U 2;
R 2;
D 2;
U 3;
D 2;
R 1;
U 2;
L 3;
D 1;
L 2;
U 1;
D 1;
U 4;
R 4;
U 4;
D 4;
U 3;
D 1;
R 4;
L 1;
D 2;
R 3;
U 1;
R 2;
D 2;
U 4;
R 3;
D 2;
L 1;
U 4;
D 3;
U 1;
D 4;
L 2;
U 3;
D 4;
R 3;
L 2;
D 4;
L 2;
R 3;
U 2;
R 2;
U 1;
L 3;
R 3;
L 3;
U 4;
R 4;
U 2;
R 3;
U 1;
L 3;
D 4;
L 4;
R 4;
D 3;
L 4;
R 1;
U 4;
D 3;
R 3;
U 1;
L 4;
U 2;
L 2;
D 4;
U 3;
R 1;
U 2;
D 4;
U 4;
D 4;
U 1;
L 4;
R 3;
U 2;
R 1;
L 4;
D 4;
U 3;
R 2;
L 2;
U 3;
L 1;
R 1;
L 1;
U 4;
L 1;
R 3;
U 1;
R 1;
D 2;
R 2;
L 4;
D 1;
L 2;
R 1;
D 1;
L 3;
D 3;
U 4;
R 2;
L 4;
U 2;
L 1;
R 3;
U 3;
L 2;
R 2;
D 2;
R 3;
U 4;
L 1;
U 3;
L 3;
U 1;
R 1;
L 2;
D 3;
L 5;
D 2;
U 2;
D 4;
R 2;
L 3;
U 3;
R 1;
U 4;
D 1;
R 2;
U 1;
L 5;
R 4;
D 5;
R 5;
D 2;
U 2;
L 5;
D 2;
U 3;
R 2;
L 4;
D 5;
L 4;
R 4;
U 5;
R 2;
U 5;
L 1;
D 2;
L 3;
U 4;
D 2;
U 2;
L 3;
R 4;
U 4;
R 5;
L 1;
D 2;
U 4;
D 5;
L 5;
R 4;
U 3;
R 2;
U 5;
L 3;
U 5;
R 3;
U 2;
R 2;
D 3;
R 2;
L 2;
D 4;
R 4;
U 3;
R 3;
D 5;
R 2;
U 3;
L 5;
R 1;
U 5;
D 4;
R 3;
D 5;
U 1;
R 4;
L 5;
D 1;
U 3;
L 4;
U 3;
R 3;
D 5;
U 5;
D 5;
L 5;
U 4;
D 5;
L 3;
R 3;
D 4;
U 2;
L 5;
R 1;
U 5;
L 4;
U 4;
D 5;
R 4;
L 1;
U 2;
D 2;
L 1;
R 2;
D 4;
R 5;
L 3;
R 4;
D 4;
L 4;
R 2;
L 1;
D 3;
L 3;
R 2;
D 3;
R 5;
D 2;
U 4;
D 5;
L 1;
U 3;
D 3;
U 6;
L 1;
R 1;
L 4;
R 6;
L 1;
R 1;
D 2;
U 6;
R 1;
U 3;
R 6;
U 1;
R 1;
L 3;
D 5;
R 6;
L 6;
R 1;
U 2;
R 1;
L 5;
R 5;
D 6;
R 4;
D 4;
R 1;
U 6;
R 4;
U 1;
R 5;
U 3;
L 5;
U 1;
R 5;
L 5;
D 5;
R 3;
L 5;
D 3;
L 2;
U 3;
R 1;
U 1;
D 4;
R 4;
L 2;
U 3;
L 1;
U 5;
L 5;
D 4;
R 6;
U 6;
L 5;
U 3;
R 3;
D 1;
U 6;
R 2;
L 4;
R 2;
L 5;
U 3;
D 1;
U 3;
R 1;
D 1;
L 3;
U 6;
L 5;
U 2;
L 3;
D 1;
L 3;
U 6;
L 4;
D 3;
R 4;
D 1;
L 4;
U 1;
R 6;
D 6;
R 5;
D 4;
R 4;
D 4;
U 6;
D 4;
L 3;
R 4;
L 5;
R 1;
D 6;
U 6;
D 2;
R 1;
L 6;
U 6;
L 5;
D 6;
U 4;
R 4;
D 3;
U 5;
D 6;
U 7;
L 5;
U 7;
R 6;
U 1;
L 6;
U 1;
R 2;
D 7;
R 4;
U 1;
R 6;
L 6;
D 4;
L 4;
U 4;
R 1;
D 7;
L 7;
D 7;
L 5;
D 1;
L 1;
U 2;
R 5;
D 5;
L 3;
U 5;
D 6;
L 4;
R 1;
U 6;
L 3;
D 6;
L 7;
D 6;
R 3;
U 7;
R 1;
D 6;
R 3;
U 7;
D 5;
U 1;
L 4;
U 3;
D 3;
U 3;
R 1;
L 2;
R 2;
L 1;
U 3;
D 5;
U 7;
D 1;
U 7;
L 4;
D 3;
U 4;
R 6;
D 2;
L 5;
R 7;
L 5;
R 1;
U 6;
R 7;
U 4;
D 3;
U 1;
L 1;
D 1;
U 6;
L 1;
U 1;
R 7;
L 4;
D 1;
U 2;
R 7;
L 7;
R 5;
U 4;
R 2;
L 7;
U 6;
R 5;
L 1;
R 3;
U 7;
D 7;
L 4;
R 1;
U 4;
R 1;
L 7;
D 4;
L 5;
D 7;
U 4;
L 5;
R 6;
U 1;
L 4;
R 6;
D 2;
L 1;
D 2;
U 4;
L 5;
U 5;
D 4;
U 7;
L 2;
D 3;
U 5;
R 7;
D 1;
R 7;
D 6;
U 4;
R 3;
D 5;
U 5;
D 8;
R 7;
L 7;
R 1;
D 5;
L 3;
R 1;
U 3;
R 6;
D 5;
R 6;
L 5;
D 7;
L 5;
R 2;
D 1;
R 7;
L 1;
D 3;
R 8;
L 5;
U 8;
R 6;
U 4;
D 2;
U 4;
D 5;
U 7;
D 5;
U 2;
D 3;
U 1;
R 4;
L 2;
R 4;
U 7;
R 8;
D 2;
U 3;
R 7;
D 2;
U 1;
D 6;
R 4;
L 4;
R 3;
D 8;
R 8;
U 7;
L 3;
U 7;
D 1;
U 6;
R 8;
L 1;
R 1;
D 8;
U 7;
L 3;
D 4;
L 4;
R 2;
L 6;
D 6;
L 4;
R 7;
D 8;
L 8;
U 8;
R 2;
L 6;
U 5;
D 2;
L 5;
U 1;
L 6;
D 6;
U 7;
L 2;
U 5;
R 6;
D 5;
L 8;
U 8;
R 1;
U 2;
L 3;
D 1;
L 3;
U 4;
D 3;
L 6;
R 9;
L 9;
U 9;
R 1;
D 4;
U 1;
L 3;
R 7;
U 7;
R 1;
U 1;
R 2;
D 4;
U 8;
L 7;
R 3;
U 8;
L 1;
R 1;
D 7;
U 3;
L 3;
U 8;
D 3;
L 1;
D 6;
L 3;
U 4;
D 3;
U 3;
L 3;
D 5;
L 6;
U 9;
L 1;
U 2;
L 3;
R 1;
L 9;
D 2;
U 1;
L 3;
R 9;
L 8;
R 2;
L 7;
D 4;
L 4;
R 2;
L 4;
R 8;
D 4;
L 2;
D 5;
R 8;
U 6;
L 9;
D 1;
L 6;
R 9;
D 4;
L 5;
U 5;
D 1;
U 3;
L 4;
U 2;
L 2;
R 2;
L 1;
R 7;
L 4;
D 4;
U 4;
L 1;
R 2;
D 6;
L 1;
U 8;
D 7;
R 5;
D 7;
R 7;
L 8;
U 8;
L 5;
D 7;
U 2;
D 2;
R 1;
U 2;
L 1;
R 1;
L 2;
D 1;
U 9;
L 9;
U 9;
R 1;
U 3;
R 7;
U 8;
R 1;
L 7;
D 1;
U 7;
R 9;
D 8;
R 2;
D 5;
L 5;
D 2;
L 6;
U 6;
R 1;
L 1;
D 2;
R 4;
L 3;
U 2;
R 5;
L 3;
R 6;
U 8;
R 1;
U 1;
R 7;
D 10;
R 2;
D 4;
R 3;
L 5;
D 1;
U 8;
R 1;
U 4;
D 6;
L 5;
U 8;
D 6;
L 6;
R 4;
L 9;
R 5;
U 6;
L 8;
U 6;
L 10;
D 4;
U 6;
L 8;
U 3;
R 3;
L 6;
U 1;
R 9;
D 8;
U 9;
R 5;
U 10;
R 8;
U 9;
L 7;
R 4;
D 7;
U 3;
L 5;
R 3;
D 9;
L 9;
U 6;
R 10;
L 2;
D 7;
U 8;
D 4;
L 3;
U 4;
R 2;
L 10;
D 4;
U 10;
R 7;
D 5;
R 7;
U 3;
L 10;
R 8;
L 7;
D 3;
L 6;
R 1;
L 2;
U 1;
R 1;
U 8;
R 5;
L 9;
R 9;
L 1;
D 4;
R 6;
U 7;
L 7;
R 3;
U 4;
D 2;
U 8;
L 5;
D 3;
L 6;
D 7;
L 2;
U 1;
R 6;
L 8;
D 9;
R 3;
U 4;
D 8;
L 5;
R 9;
L 1;
U 7;
L 5;
D 4;
U 5;
L 4;
R 4;
L 3;
U 11;
D 1;
L 10;
U 6;
L 5;
D 3;
U 8;
D 11;
L 8;
R 2;
U 5;
L 9;
D 3;
L 11;
R 2;
U 5;
L 7;
D 11;
R 8;
U 1;
L 10;
R 10;
L 9;
R 9;
L 8;
R 7;
D 3;
U 6;
R 11;
U 8;
D 4;
L 9;
U 3;
D 5;
L 4;
R 5;
D 7;
L 5;
U 10;
D 8;
L 3;
D 2;
U 9;
D 6;
L 3;
U 3;
D 8;
U 4;
R 1;
L 9;
U 4;
L 5;
D 10;
L 11;
U 6;
D 8;
L 5;
R 9;
L 2;
U 2;
L 10;
R 5;
U 6;
L 7;
R 7;
U 9;
D 6;
R 7;
D 8;
U 7;
R 6;
L 2;
D 6;
R 8;
L 5;
R 1;
L 10;
R 8;
U 11;
R 10;
L 10;
R 10;
L 4;
U 4;
D 9;
U 8;
R 5;
D 7;
U 7;
L 6;
D 4;
L 9;
R 2;
U 8;
D 2;
L 2;
D 2;
U 6;
L 2;
R 9;
U 10;
D 11;
U 3;
R 9;
U 1;
L 11;
R 7;
L 4;
R 5;
U 10;
L 3;
R 10;
L 10;
D 2;
L 9;
D 9;
L 6;
D 11;
R 10;
L 2;
R 4;
D 2;
R 4;
D 8;
L 3;
U 10;
R 4;
L 2;
U 1;
L 3;
R 1;
L 2;
R 3;
D 2;
L 2;
D 3;
R 5;
U 10;
L 12;
R 5;
D 5;
U 9;
L 9;
D 2;
L 8;
U 2;
L 11;
U 5;
L 8;
U 7;
R 4;
U 10;
D 4;
L 5;
R 3;
D 8;
R 12;
L 5;
U 9;
L 10;
R 5;
U 10;
R 1;
L 5;
U 6;
D 7;
L 12;
D 2;
R 12;
L 1;
U 11;
D 8;
R 12;
L 8;
U 3;
R 9;
L 8;
D 2;
L 10;
D 10;
R 4;
D 2;
R 11;
U 4;
R 10;
U 7;
L 7;
D 5;
U 5;
R 9;
D 10;
L 10;
U 1;
D 11;
U 4;
D 5;
U 5;
D 8;
U 2;
D 4;
R 4;
L 5;
U 10;
D 12;
R 9;
L 11;
R 9;
L 1;
D 9;
L 11;
D 12;
U 4;
R 7;
D 1;
U 3;
L 4;
U 9;
R 12;
D 1;
L 7;
U 7;
D 6;
U 1;
R 3;
L 7;
U 5;
L 2;
D 10;
R 12;
L 3;
U 7;
D 10;
L 5;
R 1;
U 9;
L 1;
D 11;
R 5;
L 2;
D 1;
U 3;
R 2;
L 3;
U 5;
L 3;
D 5;
R 10;
L 7;
R 12;
U 4;
D 3;
R 3;
L 2;
R 7;
U 4;
D 9;
U 7;
D 1;
R 9;
L 2;
U 6;
R 5;
D 3;
U 7;
R 12;
L 10;
D 11;
L 8;
U 12;
D 13;
U 9;
D 5;
U 4;
R 2;
L 3;
U 13;
R 4;
L 9;
U 4;
L 3;
U 9;
R 1;
D 6;
U 4;
D 3;
U 5;
R 5;
L 11;
R 8;
D 1;
U 4;
D 10;
R 5;
D 10;
U 3;
D 4;
R 1;
U 3;
R 13;
L 6;
D 8;
R 12;
L 4;
U 2;
L 13;
D 11;
L 4;
U 8;
L 10;
R 2;
D 8;
R 11;
L 2;
D 8;
R 8;
L 10;
U 10;
L 4;
D 9;
L 7;
D 11;
L 10;
U 13;
L 6;
U 7;
D 8;
L 3;
R 10;
L 14;
U 13;
L 11;
D 5;
R 8;
U 2;
D 9;
L 14;
U 7;
R 4;
U 1;
D 8;
U 8;
D 9;
L 2;
D 7;
R 1;
D 9;
R 2;
U 4;
D 8;
L 9;
R 6;
L 2;
R 11;
D 6;
L 5;
U 8;
L 4;
R 3;
D 5;
L 3;
U 9;
R 3;
U 1;
D 7;
R 1;
L 10;
U 1;
L 8;
U 11;
D 8;
U 12;
R 9;
L 5;
D 10;
L 2;
R 8;
D 10;
R 6;
D 1;
L 11;
D 8;
R 7;
L 14;
D 12;
L 11;
R 11;
U 9;
R 12;
D 10;
L 12;
R 4;
L 8;
D 2;
R 3;
L 14;
R 7;
U 10;
R 1;
L 6;
R 4;
D 11;
L 13;
R 12;
U 4;
L 12;
U 10;
D 8;
R 10;
D 9;
R 13;
L 2;
U 2;
D 7;
U 7;
R 3;
D 3;
R 13;
U 8;
R 10;
U 13;
D 14;
R 11;
D 7;
R 2;
U 5;
D 2;
L 6;
U 14;
L 10;
R 9;
U 11;
R 12;
D 5;
L 11;
R 12;
U 11;
R 8;
L 2;
D 14;
U 3;
D 9;
U 5;
L 4;
U 5;
L 6;
D 3;
L 1;
R 10;
L 4;
D 12;
U 15;
L 5;
D 11;
L 15;
D 10;
L 14;
U 1;
L 14;
D 6;
R 6;
U 9;
R 1;
L 7;
D 11;
U 12;
D 2;
R 7;
L 2;
D 13;
U 13;
R 6;
L 3;
D 3;
R 11;
U 3;
D 3;
U 11;
L 10;
U 7;
R 7;
D 9;
U 10;
R 11;
U 12;
D 11;
R 11;
U 2;
R 2;
D 9;
R 12;
D 1;
L 11;
R 1;
U 2;
R 14;
L 4;
R 1;
D 12;
R 7;
U 12;
L 2;
U 5;
D 7;
R 15;
D 5;
L 9;
D 7;
R 10;
U 12;
D 10;
R 11;
D 5;
U 10;
R 2;
U 11;
R 3;
U 6;
D 14;
U 11;
D 5;
L 8;
D 6;
L 2;
U 2;
L 14;
R 8;
U 15;
L 10;
D 1;
R 4;
L 8;
D 7;
L 15;
U 10;
D 14;
U 9;
L 7;
R 13;
U 11;
R 15;
L 11;
R 2;
L 11;
R 14;
L 1;
D 10;
L 2;
U 7;
L 9;
D 12;
R 2;
L 4;
U 4;
R 9;
L 6;
R 13;
D 1;
U 13;
R 7;
D 3;
R 14;
L 12;
D 15;
R 16;
L 7;
R 2;
U 3;
R 9;
U 10;
D 6;
U 7;
L 11;
D 12;
L 16;
R 12;
D 10;
U 16;
D 9;
U 14;
L 14;
U 11;
D 14;
L 14;
D 10;
L 3;
D 10;
U 6;
D 11;
L 8;
U 4;
D 1;
U 5;
D 5;
L 4;
U 8;
R 3;
D 12;
U 4;
R 8;
D 6;
U 8;
D 2;
U 12;
L 6;
D 12;
R 7;
D 6;
U 7;
D 12;
L 3;
R 2;
L 12;
R 13;
U 16;
L 6;
D 8;
U 13;
R 14;
D 4;
U 7;
D 1;
R 4;
D 13;
R 10;
D 7;
R 11;
L 6;
U 6;
R 7;
L 8;
D 2;
L 11;
U 3;
L 12;
U 4;
D 11;
U 8;
D 10;
U 1;
R 12;
U 1;
L 15;
R 15;
D 2;
L 8;
D 13;
L 3;
R 8;
U 14;
R 5;
U 3;
D 15;
U 7;
D 1;
L 6;
D 8;
U 13;
R 6;
L 6;
D 3;
L 9;
D 17;
U 8;
R 16;
L 6;
D 9;
U 3;
L 10;
R 13;
L 14;
U 8;
R 7;
U 12;
D 14;
R 1;
D 3;
L 11;
R 8;
D 9;
R 17;
D 5;
R 17;
U 8;
L 10;
D 7;
U 4;
D 16;
L 9;
D 1;
L 16;
R 7;
L 1;
R 11;
U 10;
R 2;
U 10;
L 15;
U 10;
R 2;
D 11;
U 12;
L 15;
U 4;
D 2;
R 4;
U 2;
L 11;
R 16;
U 10;
R 4;
D 9;
U 7;
D 2;
R 10;
D 14;
L 10;
U 9;
R 7;
D 3;
R 7;
L 3;
U 15;
D 13;
L 17;
R 12;
U 13;
D 16;
U 13;
R 13;
U 14;
L 16;
U 7;
D 2;
R 11;
U 17;
D 9;
R 12;
U 16;
L 11;
R 3;
U 9;
L 6;
D 2;
U 1;
D 7;
L 1;
U 7;
D 8;
U 11;
L 4;
R 6;
L 2;
U 12;
L 13;
U 5;
L 17;
R 16;
D 10;
U 12;
L 7;
R 4;
U 8;
D 17;
R 13;
L 2;
D 5;
L 1;
R 2;
D 16;
U 9;
D 15;
L 8;
U 14;
R 9;
D 18;
U 16;
L 17;
U 9;
D 11;
U 17;
R 8;
D 17;
U 14;
D 8;
U 8;
R 8;
U 14;
R 5;
L 1;
R 3;
D 5;
U 10;
R 16;
U 18;
D 16;
U 11;
D 18;
U 13;
L 11;
D 2;
R 16;
D 15;
L 9;
D 12;
R 11;
L 8;
U 8;
R 10;
L 2;
D 6;
L 5;
D 9;
L 3;
D 1;
U 18;
D 12;
U 13;
L 6;
R 17;
D 10;
R 9;
L 6;
R 3;
U 1;
R 1;
U 6;
L 15;
U 8;
D 15;
U 14;
R 10;
L 6;
U 1;
L 12;
R 9;
D 13;
U 1;
L 16;
U 16;
L 13;
R 4;
U 3;
D 11;
L 12;
R 11;
U 17;
R 18;
L 4;
R 6;
L 18;
D 10;
L 16;
R 2;
D 4;
R 14;
D 11;
L 12;
R 7;
L 9;
U 12;
D 12;
R 4;
L 1;
D 14;
R 14;
L 3;
U 2;
L 6;
R 7;
D 6;
U 18;
L 17;
U 12;
R 12;
L 5;
D 13;
R 7;
D 8;
L 16;
D 13;
U 4;
D 3;
R 16;
L 9;
U 8;
D 15;
R 8;
L 12;
R 5;
L 1;
U 11;
D 11;
L 10;
U 7;
D 6;
L 15;
D 9;
R 10;
D 6;
U 14;
L 7;
U 19;
R 17;
L 12;
U 1;
L 9;
R 17;
D 12;
U 3;
L 15;
R 16;
D 15;
R 15;
L 1;
U 16;
R 19;
D 9;
L 16;
D 12;
R 8;
L 2;
D 16;
L 17;
U 16;
D 9;
L 9;
U 8;
L 9;
R 16;
L 3;
D 8;
U 7;
D 10;
U 17;
R 2;
D 16;
R 6;
U 9;
R 4;
L 17;
D 10;
U 10;
L 14;
D 9;
R 8;
L 9;
R 18;
U 13;
L 16;
R 2;
U 16;
L 11;
U 4;
L 13;
R 8;
L 19;
U 4;
D 10;
R 10;
U 14;
R 13;
L 17;
U 17;
R 12;
D 18;
R 2;
D 5;
L 12;
U 6;
D 7;
R 9;
L 13;
D 15;
R 9;
U 16;
D 14;
R 8;
L 8;
U 10;
L 8;
D 18;
U 8;
D 9;
L 6;
R 8;
U 4;
D 14;
L 13;
D 4;
R 3;
U 13;
L 2].

Open Scope Z_scope.
Fixpoint set_add (pos : (Z*Z)) (l : list (Z*Z)) :=
  let (x,y) := pos in
  match l with
  | nil => [pos]
  | (x',y') :: r => if x <? x' then (x',y') :: set_add pos r else if y <? y' then (x',y') :: set_add pos r else if andb (x =? x') (y =? y') then l else pos :: l
  end.

Definition state : Type := ((Z*Z)*list (Z*Z)*list (Z*Z)).

Definition move_close (h : Z*Z) (t : Z*Z) : Z*Z :=
  let (hx,hy) := h in
  let (tx,ty) := t in
  if Z.max (Z.abs (hx-tx)) (Z.abs (hy-ty)) >? 1 then
    (tx+Z.sgn (hx-tx),ty+Z.sgn (hy-ty))
  else
    t
.

Fixpoint update_rope (prev : Z*Z) (l : list (Z*Z)) :=
  match l with
  | nil => nil
  | h :: r => let h' := (move_close prev h) in h' :: update_rope h' r
  end.

Fixpoint plast (l : list (Z*Z)) :=
  match l with
  | nil => (0,0)
  | [x] => x
  | h :: t => plast t
  end.

Definition step_right (curState : state) : state :=
  let (p,seen)  := curState in
  let (h,t)  := p in
  let (hx,hy) := h in
  let h' := (hx+1,hy) in
  let t' := update_rope h' t in
  (h',t',set_add (plast t') seen)
.

Definition step_left (curState : state) : state :=
  let (p,seen)  := curState in
  let (h,t)  := p in
  let (hx,hy) := h in
  let h' := (hx-1,hy) in
  let t' := update_rope h' t in
  (h',t',set_add (plast t') seen)
.
Definition step_up (curState : state) : state :=
  let (p,seen)  := curState in
  let (h,t)  := p in
  let (hx,hy) := h in
  let h' := (hx,hy+1) in
  let t' := update_rope h' t in
  (h',t',set_add (plast t') seen)
.
Definition step_down (curState : state) : state :=
  let (p,seen)  := curState in
  let (h,t)  := p in
  let (hx,hy) := h in
  let h' := (hx,hy-1) in
  let t' := update_rope h' t in
  (h',t',set_add (plast t') seen)
.

Fixpoint n_times {A} (t : nat) (f : A -> A) (a : A):=
  match t with
  | O => a
  | S n => n_times n f (f a)
  end.

Definition step (m : move) (curState : state) : state :=
  match m with
  | R n => n_times n step_right curState
  | L n => n_times n step_left curState
  | U n => n_times n step_up curState
  | D n => n_times n step_down curState
  end.

Definition flip {A B C} (f : A -> B -> C) (b : B) (a : A) :=
  f a b.

Definition impl_1 (i : list move) :=
  let (p,seen) := (fold_left (flip step) i ((0,0),[(0,0)],[(0,0)])) in
  length seen.

Example test1 : impl_1 test_in = 13%nat. Proof. vm_compute. reflexivity. Qed.

Compute (impl_1 input).

Definition impl_2 (i : list move) :=
  let (p,seen) := (fold_left (flip step) i ((0,0),[(0,0);(0,0);(0,0);(0,0);(0,0);(0,0);(0,0);(0,0);(0,0)],[(0,0)])) in
  length seen.

Example test2 : impl_2 test_in = 1%nat. Proof. vm_compute. reflexivity. Qed.

Compute (impl_2 input).


From cap_machine Require Export logrel.
From iris.proofmode Require Import proofmode.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine.ftlr Require Import ftlr_base interp_weakening.
From cap_machine.rules Require Import rules_base rules_UnSeal.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg: sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MachineParameters}.

  Notation D := ((leibnizO Word) -n> iPropO Σ).
  Notation R := ((leibnizO Reg) -n> iPropO Σ).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  (* Proving the meaning of unsealing in the LR sane. Note the use of the later in the result. *)
  Lemma unsealing_preserves_interp sb p0 b0 e0 a0:
        permit_unseal p0 = true →
        withinBounds b0 e0 a0 = true →
        fixpoint interp1 (WSealed a0 sb) -∗
        fixpoint interp1 (WSealRange p0 b0 e0 a0) -∗
        ▷ fixpoint interp1 (WSealable sb).
  Proof.
    iIntros (Hpseal Hwb) "#HVsd #HVsr".
    rewrite (fixpoint_interp1_eq (WSealRange _ _ _ _)) (fixpoint_interp1_eq (WSealed _ _)) /= Hpseal /interp_sb.
    iDestruct "HVsr" as "[_ Hss]".
    apply seq_between_dist_Some in Hwb.
    iDestruct (big_sepL_delete with "Hss") as "[HSa0 _]"; eauto.
    iDestruct "HSa0" as (P) "[HsealP HWcond]".
    iDestruct "HVsd" as (P') "[% [HsealP' HP']]".
    iDestruct (seal_pred_agree with "HsealP HsealP'") as "Hequiv". iSpecialize ("Hequiv" $! (WSealable sb)).
    iAssert (▷ P (WSealable sb))%I as "HP". { iNext. by iRewrite "Hequiv". }
    by iApply "HWcond".
  Qed.

  Lemma unseal_case (r : leibnizO Reg) (p : Perm)
        (b e a : Addr) (w : Word) (dst r1 r2 : RegName) (P:D):
    ftlr_instr r p b e a w (UnSeal dst r1 r2) P.
  Proof.
    intros Hp Hsome i Hbae Hi.
    iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap".
    rewrite delete_insert_delete.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_UnSeal with "[$Ha $Hmap]"); eauto.
    { simplify_map_eq; auto. }
    { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _.
      apply elem_of_dom. apply lookup_insert_is_Some'; eauto. }

    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".
    destruct HSpec as [ * Hr1 Hr2 Hunseal Hwb HincrPC | ].
    { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') .

      assert (r1 ≠ PC) as Hne1.
      { destruct (decide (PC = r1)); last auto. simplify_map_eq; auto. }
      rewrite lookup_insert_ne in Hr1; auto.
      assert (r2 ≠ PC) as Hne2.
      { destruct (decide (PC = r2)); last auto. simplify_map_eq; auto. }
      rewrite lookup_insert_ne in Hr2; auto.

      unshelve iDestruct ("Hreg" $! r1 _ _ Hr1) as "HVsr"; eauto.
      unshelve iDestruct ("Hreg" $! r2 _ _ Hr2) as "HVsd"; eauto.
      (* Generate interp instance before step, so we get rid of the later *)
      iDestruct (unsealing_preserves_interp with "HVsd HVsr") as "HVsb"; auto.

      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext; iIntros "_".

      (* If PC=dst and perm of unsealed cap = E -> error! *)
      destruct (decide (PC = dst ∧ p'' = E)) as [ [Herr1 Herr2] | HNoError].
      { (* Error case *)
        simplify_map_eq.
        iDestruct ((big_sepM_delete _ _ PC) with "Hmap") as "[HPC Hmap]".
        { subst. by rewrite lookup_insert. }
        iApply (wp_bind (fill [SeqCtx])).
        iApply (wp_notCorrectPC_perm with "[HPC]"); eauto. split; auto.
        iIntros "!> _".
        iApply wp_pure_step_later; auto.
        iNext; iIntros "_".
        iApply wp_value.
        iIntros (a1); inversion a1.
      }
      (* Otherwise, we will be able to derive validity of the PC below*)

      iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri v Hri Hvs).
        subst regs'.
        rewrite lookup_insert_ne in Hvs; auto.
        destruct (decide (ri = dst)).
        { subst ri.
          rewrite lookup_insert in Hvs; inversion Hvs. auto. }
        { repeat (rewrite lookup_insert_ne in Hvs); auto.
          iApply "Hreg"; auto. } }
        { subst regs'. rewrite insert_insert. iApply "Hmap". }
      iModIntro.
      destruct (reg_eq_dec PC dst) as [Heq | Hne]; simplify_map_eq.
      - iApply (interp_weakening with "IH HVsb"); auto; try solve_addr. (* HNoError used here *)
        { by rewrite PermFlowsToReflexive. }
      - iApply (interp_weakening with "IH Hinv"); auto; try solve_addr.
        { destruct Hp; by subst p''. }
        { by rewrite PermFlowsToReflexive. }
    }
    { iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext ; iIntros "_".
      iApply wp_value; auto. iIntros; discriminate. }
    Qed.

End fundamental.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Simple C11 *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition A := unknown_set "A".
Definition ACQ := unknown_set "ACQ".
Definition ACQ_REL := unknown_set "ACQ_REL".
Definition I := unknown_set "I".
Definition REL := unknown_set "REL".
Definition SC := unknown_set "SC".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition CACQ := ACQ ⊔ (SC ⊓ R ⊔ ACQ_REL).
Definition CREL := REL ⊔ (SC ⊓ W ⊔ ACQ_REL).
Definition Access := R ⊔ W.
Definition a_id := toid A.
Definition rmw_id := toid RMW.
Definition crel_id := toid CREL.
Definition cacq_id := toid CACQ.
Definition sc_id := toid SC.
Definition asw := [I] ⋅ top ⋅ [(M ⊓ !I)].
Definition A_0 := ((*failed: try X with emptyset_0*) emptyset_0) ⊔ ((*successful: try A with emptyset_0*) A).
Definition P := M ⊓ !A_0.
Definition WW r := r ⊓ [W] ⋅ top ⋅ [W].
Definition WR r := r ⊓ [W] ⋅ top ⋅ [R].
Definition RW r := r ⊓ [R] ⋅ top ⋅ [W].
Definition RR r := r ⊓ [R] ⋅ top ⋅ [R].
Definition RM r := r ⊓ [R] ⋅ top ⋅ [M].
Definition MR r := r ⊓ [M] ⋅ top ⋅ [R].
Definition WM r := r ⊓ [W] ⋅ top ⋅ [M].
Definition MW r := r ⊓ [M] ⋅ top ⋅ [W].
Definition MM r := r ⊓ [M] ⋅ top ⋅ [M].
Definition AA r := r ⊓ [A_0] ⋅ top ⋅ [A_0].
Definition AP r := r ⊓ [A_0] ⋅ top ⋅ [P].
Definition PA r := r ⊓ [P] ⋅ top ⋅ [A_0].
Definition PP r := r ⊓ [P] ⋅ top ⋅ [P].
Definition AM r := r ⊓ [A_0] ⋅ top ⋅ [M].
Definition MA r := r ⊓ [M] ⋅ top ⋅ [A_0].
Definition noid r : relation events := r ⊓ !id.
Definition atom := [A_0].
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition rsElem := coi ⊔ co ⋅ rmw_id.
Definition breakRseq := co ⊓ !rsElem.
Definition rseq := id ⊔ rsElem ⊓ !(breakRseq ⋅ co).
Definition fence_id := toid F.
Definition fid := fence_id ⋅ po ⊔ 1.
Definition idf := po ⋅ fence_id ⊔ 1.
Definition sw := ext ⊓ crel_id ⋅ (fid ⋅ (rseq ⋅ (rf ⋅ (a_id ⋅ (idf ⋅ cacq_id))))).
Definition Y := po.
Definition hb := (po ⊔ (asw ⊔ sw))^+.
Definition hb_loc := hb ⊓ loc.
Definition scp := hb ⊔ co.
Definition ConsSC := acyclic scp.
Variable S : relation events.
Definition rfNA := rf ⊓ !AA rf.
Definition ConsRFna := is_empty (rfNA ⊓ !hb_loc).
Definition S_loc := MM S ⊓ loc.
Definition minWRSC := let aux := WR S_loc in aux ⊓ !(WW S_loc ⋅ aux).
Definition rfSCSC := sc_id ⋅ (rf ⋅ sc_id).
Definition rfXSC := rf ⋅ sc_id ⊓ !rfSCSC.
Definition X := hb ⋅ minWRSC.
Definition badRFSC := rfSCSC ⊓ !minWRSC ⊔ rfXSC ⊓ hb ⋅ minWRSC.
Definition SCReads := is_empty badRFSC.
Definition IrrHB := irreflexive hb.
Definition chapo := rf ⊔ (fr ⊔ (co ⊔ (co ⋅ rf ⊔ fr ⋅ rf))).
Definition Coh := acyclic (hb_loc ⊔ chapo).
Definition cosucc := co ⊓ !(co ⋅ co).
Definition AtRMW := is_empty (rf ⋅ rmw_id ⊓ !cosucc).
Definition locSomeW := loc ⊓ !RR loc.
Definition dr := let r1 := locSomeW ⊓ ext in let r2 := r1 ⊓ !AA r1 in r2 ⊓ !(hb ⊔ hb°).
Definition dataRace := is_empty dr.
Definition ur := let r1 := locSomeW ⊓ int in let r2 := noid r1 in r2 ⊓ !(po ⊔ po°).
Definition unsequencedRace := not (is_empty ur).
Definition witness_conditions := generate_cos cobase co /\ linearisations SC scp S.
Definition model_conditions := ConsSC /\ (ConsRFna /\ (SCReads /\ (IrrHB /\ (Coh /\ (AtRMW /\ (dataRace /\ unsequencedRace)))))).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc A ACQ ACQ_REL I REL SC tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW CACQ CREL Access a_id rmw_id crel_id cacq_id sc_id asw A_0 P WW WR RW RR RM MR WM MW MM AA AP PA PP AM MA noid atom generate_orders generate_cos cobase coi coe fr fri fre rsElem breakRseq rseq fence_id fid idf sw Y hb hb_loc scp ConsSC rfNA ConsRFna S_loc minWRSC rfSCSC rfXSC X badRFSC SCReads IrrHB chapo Coh cosucc AtRMW locSomeW dr dataRace ur unsequencedRace witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co S : relation (events c),
    witness_conditions c co S /\
    model_conditions c co S.

(* End of translation of model Simple C11 *)


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

From QArithSternBrocot Require Export quadratic_correctness.
From Coq Require Import Eqdep_dec.
Import Field_Theory_Q.

Lemma Qopp_lazy_Qopp : forall x : Q, Qopp_lazy x = Qopp x.
Proof.
 intros x.
 unfold Qopp_lazy in |- *.
 rewrite homography.
 unfold spec_h in |- *.
 replace (Z_to_Q 1) with Qone; trivial.
 replace (Z_to_Q (-1)) with (Qopp Qone); trivial.
 unfold Z_to_Q in |- *.
 rewrite Qmult_Qopp_left.
 rewrite Qmult_zero.
 rewrite Qplus_zero_right.
 rewrite Qplus_zero_left.
 rewrite Qmult_one_right.
 rewrite Qmult_one_left.
 reflexivity.
Defined.

Lemma Qinv_lazy_Qinv :
 forall (x : Q) (Hx : x <> Zero), Qinv_lazy x Hx = Qinv x.
Proof.
 intros x Hx.
 unfold Qinv_lazy in |- *.
 rewrite homography.
 unfold spec_h in |- *.
 replace (Z_to_Q 1) with Qone; trivial.
 unfold Z_to_Q in |- *.
 repeat rewrite Qmult_one_left.
 rewrite Qplus_zero_right.
 reflexivity.
Defined.

Lemma Qplus_lazy_Qplus : forall x y : Q, Qplus_lazy x y = Qplus x y.
Proof.
 intros x y.
 unfold Qplus_lazy in |- *.
 rewrite quadratic.
 unfold spec_q in |- *.
 replace (Z_to_Q 1) with Qone; trivial.
 unfold Z_to_Q in |- *.
 repeat rewrite Qmult_one_left.
 rewrite Qmult_one_right.
 repeat rewrite Qmult_zero.
 rewrite Qplus_zero_left.
 rewrite Qplus_zero_right.
 reflexivity.
Defined.

Lemma Qminus_lazy_Qminus : forall x y : Q, Qminus_lazy x y = Qminus x y.
intros x y.
unfold Qminus_lazy in |- *.
rewrite quadratic in |- *.
unfold spec_q in |- *.
change (Z_to_Q 1) with Qone in |- *.
unfold Z_to_Q in |- *.
simpl Qpositive_c in |- *.
field.
discriminate.
Defined.

Lemma Qmult_lazy_Qmult : forall x y : Q, Qmult_lazy x y = Qmult x y.
Proof.
 intros x y.
 unfold Qmult_lazy in |- *.
 rewrite quadratic.
 unfold spec_q in |- *.
 change (Z_to_Q 1) with Qone.
 unfold Z_to_Q in |- *.
 rewrite Qmult_one_left.
 rewrite Qmult_one_right.
 repeat rewrite Qmult_zero.
 repeat rewrite Qplus_zero_right.
 repeat rewrite Qplus_zero_left.
 reflexivity.
Defined.

Lemma Qdiv_lazy_Qdiv :
  forall (x y : Q) (Hy : y <> Zero), Qdiv_lazy x y Hy = Qdiv x y.
intros x y Hy.
unfold Qdiv_lazy in |- *.
rewrite quadratic in |- *.
unfold spec_q in |- *.
change (Z_to_Q 1) with Qone in |- *.
unfold Z_to_Q in |- *.
field.
trivial.
Defined.

Lemma second_Q_Ring_Theory :
 ring_theory Zero Qone Qplus_lazy Qmult_lazy Qminus_lazy Qopp_lazy (eq(A:=Q)).
  split; intros n m p || intros n m || intros n;
  repeat rewrite Qplus_lazy_Qplus;
  repeat rewrite Qmult_lazy_Qmult;
  repeat rewrite Qminus_lazy_Qminus;
  repeat rewrite Qdiv_lazy_Qdiv;
  repeat rewrite Qopp_lazy_Qopp;
  repeat rewrite Qinv_lazy_Qinv;
 try first
      [ apply Qplus_sym
      | apply Qplus_assoc
      | apply Qmult_sym
      | apply Qmult_assoc
      | apply Qplus_zero_left
      | apply Qmult_one_left
      | apply Q_opp_def
      | apply Q_distr_left
      | reflexivity ].
Defined.

(** If we want to use the Field tactic , the multiplicative inverse
should be total. We make our [Qinv_lazy] a total function by
outputting a dummy variable (Zero) whenever the denominator is
zero. Note that we can not do this in the case of real numbers (being
Zero is undecidable) but for rational numbers there is no problem *)
Definition total_Qinv_lazy (x : Q) :=
  match Q_zerop x with
  | left _ => Zero
  | right h => Qinv_lazy x h
  end.

Lemma Qinv_lazy_defT :
 forall (n : Q) (Hn : n <> Zero), Qmult_lazy (Qinv_lazy n Hn) n = Qone.
Proof.
 intros n Hn; rewrite Qinv_lazy_Qinv; rewrite Qmult_lazy_Qmult;
  rewrite Qmult_sym; apply Qinv_def; intro; apply Hn;
  assumption.
Defined.

Lemma total_Qinv_lazy_defT :
 forall n : Q, n <> Zero -> Qmult_lazy (total_Qinv_lazy n) n = Qone.
Proof.
 intros n Hn.
 unfold total_Qinv_lazy in |- *; case (Q_zerop n); intros Hn';
  [ Falsum
  | apply Qinv_lazy_defT ].
Defined.

Definition total_Qdiv_lazy (x y : Q) :=
  match Q_zerop y with
  | left _ => Zero
  | right h => Qdiv_lazy x y h
  end.

Lemma second_QField :
  field_theory Zero Qone Qplus_lazy Qmult_lazy Qminus_lazy
    Qopp_lazy total_Qdiv_lazy total_Qinv_lazy (eq(A:=Q)).
constructor.
 apply second_Q_Ring_Theory.
 discriminate.
 intros; unfold total_Qdiv_lazy, total_Qinv_lazy in |- *.
  destruct (Q_zerop q).
   rewrite Qmult_lazy_Qmult in |- *.
   ring.
   rewrite Qdiv_lazy_Qdiv in |- *; rewrite Qmult_lazy_Qmult in |- *;
     rewrite Qinv_lazy_Qinv in |- *; reflexivity.
 exact total_Qinv_lazy_defT.
Defined.

Add Field second_Qfield : second_QField
  (decidable Q_eq_prop, constants [Qcst]).

Definition not_eq2eqT (A : Type) (x y : A) (H1 : x <> y) :
  x <> y := fun H2 : x = y => H1 H2.


Require Import ExtLib.Tactics.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.IsSolved.

Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Context {typ : Set}.
  Context {expr : Set}.
  Context {RType_typ : RType typ}.
  Context {Expr_expr : Expr typ expr}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {ExprUVar_expr : ExprUVar expr}.

  Definition SOLVE (tac : rtac typ expr) : rtac typ expr :=
    fun ctx s g =>
      match is_solved (tac ctx s g) with
      | Some s => Solved s
      | _ => Fail
      end.

  Theorem SOLVE_sound
  : forall tac, rtac_sound tac -> rtac_sound (SOLVE tac).
  Proof.
    unfold SOLVE, rtac_sound.
    intros.
    specialize (H ctx s g).
    destruct (is_solved (tac ctx s g)) eqn:?; subst; try apply rtac_spec_Fail.
    eapply is_solved_sound in Heqo.
    eapply Proper_rtac_spec_impl.
    { reflexivity. }
    { eapply Heqo. }
    { eapply H. reflexivity. }
  Qed.

  Fixpoint SOLVES (tacs : list (rtac typ expr)) : rtac typ expr :=
    match tacs with
    | nil => fun ctx s g => Fail
    | tac :: tacs =>
      let rec := SOLVES tacs in
      fun ctx s g =>
        match is_solved (tac ctx s g) with
        | Some s => Solved s
        | _ => rec ctx s g
        end
    end.

  Theorem SOLVES_sound
  : forall tacs, Forall rtac_sound tacs -> rtac_sound (SOLVES tacs).
  Proof.
    induction 1; simpl.
    { red. intros; subst. eapply rtac_spec_Fail. }
    { red.
      intros.
      destruct (is_solved (x ctx s g)) eqn:?; subst; eauto.
      eapply is_solved_sound in Heqo.
      eapply Proper_rtac_spec_impl.
      { reflexivity. }
      { eapply Heqo. }
      { eapply H. reflexivity. } }
  Qed.

End parameterized.

Arguments SOLVE {_ _} _%rtac _ _ _.
Arguments SOLVES {_ _} _%or_rtac _ _ _.


Require Import FloydSeq.base2.
Require Import FloydSeq.client_lemmas.
Require Import VST.floyd.nested_field_lemmas.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.reptype_lemmas.
Require Import VST.floyd.aggregate_type.
Require Import VST.floyd.sublist.

Section PROJ_REPTYPE.

Context {cs: compspecs}.

Definition proj_gfield_reptype (t: type) (gf: gfield) (v: reptype t): reptype (gfield_type t gf) :=
  match t, gf return (REPTYPE t -> reptype (gfield_type t gf))
  with
  | Tarray t0 hi a, ArraySubsc i => fun v => @Znth _ (default_val _) i v
  | Tstruct id _, StructField i => fun v => proj_struct i (co_members (get_co id)) v (default_val _)
  | Tunion id _, UnionField i => fun v => proj_union i (co_members (get_co id)) v (default_val _)
  | _, _ => fun _ => default_val _
  end (unfold_reptype v).

Fixpoint proj_reptype (t: type) (gfs: list gfield) (v: reptype t) : reptype (nested_field_type t gfs) :=
  let res :=
  match gfs as gfs'
    return reptype (match gfs' with
                    | nil => t
                    | gf :: gfs0 => gfield_type (nested_field_type t gfs0) gf
                    end)
  with
  | nil => v
  | gf :: gfs0 => proj_gfield_reptype _ gf (proj_reptype t gfs0 v)
  end
  in eq_rect_r reptype res (nested_field_type_ind t gfs).

End PROJ_REPTYPE.