(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Floating-point format with gradual underflow *)
Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Require Import FLX FIX Ulp Round_NE.

Section RND_FLT.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FLT_format (x : R) : Prop :=
  FLT_spec (f : float beta) :
    x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z -> FLT_format x.

Definition FLT_exp e := Z.max (e - prec) emin.

(** Properties of the FLT format *)
Global Instance FLT_exp_valid : Valid_exp FLT_exp.
Proof.
intros k.
unfold FLT_exp.
generalize (prec_gt_0 prec).
repeat split ;
  intros ; zify ; omega.
Qed.

Theorem generic_format_FLT :
  forall x, FLT_format x -> generic_format beta FLT_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2 H3].
simpl in H2, H3.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLT_exp.
rewrite mag_F2R with (1 := Zmx).
apply Z.max_lub with (2 := H3).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLT_format_generic :
  forall x, generic_format beta FLT_exp x -> FLT_format x.
Proof.
intros x.
unfold generic_format.
set (ex := cexp beta FLT_exp x).
set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)).
intros Hx.
rewrite Hx.
eexists ; repeat split ; simpl.
apply lt_IZR.
rewrite IZR_Zpower. 2: now apply Zlt_le_weak.
apply Rmult_lt_reg_r with (bpow ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
change (F2R (Float beta (Z.abs mx) ex) < bpow (prec + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold cexp in ex.
destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - prec <= ex)%Z. omega.
unfold ex, FLT_exp.
apply Z.le_max_l.
apply Z.le_max_r.
Qed.

Theorem FLT_format_bpow :
  forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e).
Proof.
intros e He.
apply generic_format_bpow; unfold FLT_exp.
apply Z.max_case; try assumption.
unfold Prec_gt_0 in prec_gt_0_; omega.
Qed.

Theorem FLT_format_satisfies_any :
  satisfies_any FLT_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)).
intros x.
split.
apply FLT_format_generic.
apply generic_format_FLT.
Qed.

Theorem cexp_FLT_FLX :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  cexp beta FLT_exp x = cexp beta (FLX_exp prec) x.
Proof.
intros x Hx.
assert (Hx0: x <> 0%R).
intros H1; rewrite H1, Rabs_R0 in Hx.
contradict Hx; apply Rlt_not_le, bpow_gt_0.
unfold cexp.
apply Zmax_left.
destruct (mag beta x) as (ex, He).
unfold FLX_exp. simpl.
specialize (He Hx0).
cut (emin + prec - 1 < ex)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
Qed.

(** Links between FLT and FLX *)
Theorem generic_format_FLT_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  generic_format beta (FLX_exp prec) x ->
  generic_format beta FLT_exp x.
Proof.
intros x Hx H.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
now rewrite cexp_FLT_FLX.
Qed.

Theorem generic_format_FLX_FLT :
  forall x : R,
  generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x.
Proof.
clear prec_gt_0_.
intros x Hx.
unfold generic_format in Hx; rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
unfold cexp, FLX_exp, FLT_exp.
apply Z.le_max_l.
Qed.

Theorem round_FLT_FLX : forall rnd x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x.
Proof.
intros rnd x Hx.
unfold round, scaled_mantissa.
rewrite cexp_FLT_FLX ; trivial.
Qed.

(** Links between FLT and FIX (underflow) *)
Theorem cexp_FLT_FIX :
  forall x, x <> 0%R ->
  (Rabs x < bpow (emin + prec))%R ->
  cexp beta FLT_exp x = cexp beta (FIX_exp emin) x.
Proof.
intros x Hx0 Hx.
unfold cexp.
apply Zmax_right.
unfold FIX_exp.
destruct (mag beta x) as (ex, Hex).
simpl.
cut (ex - 1 < emin + prec)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := Hx).
now apply Hex.
Qed.

Theorem generic_format_FIX_FLT :
  forall x : R,
  generic_format beta FLT_exp x ->
  generic_format beta (FIX_exp emin) x.
Proof.
clear prec_gt_0_.
intros x Hx.
rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
apply Z.le_max_r.
Qed.

Theorem generic_format_FLT_FIX :
  forall x : R,
  (Rabs x <= bpow (emin + prec))%R ->
  generic_format beta (FIX_exp emin) x ->
  generic_format beta FLT_exp x.
Proof with auto with typeclass_instances.
apply generic_inclusion_le...
intros e He.
unfold FIX_exp.
apply Z.max_lub.
omega.
apply Z.le_refl.
Qed.

Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R ->
    ulp beta FLT_exp x = bpow emin.
Proof with auto with typeclass_instances.
intros x Hx.
unfold ulp; case Req_bool_spec; intros Hx2.
(* x = 0 *)
case (negligible_exp_spec FLT_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FLT_exp.
apply Z.le_trans with (2:=Z.le_max_r _ _); omega.
assert (V:FLT_exp emin = emin).
unfold FLT_exp; apply Z.max_r.
unfold Prec_gt_0 in prec_gt_0_; omega.
intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
omega.
(* x <> 0 *)
apply f_equal; unfold cexp, FLT_exp.
apply Z.max_r.
assert (mag beta x-1 < emin+prec)%Z;[idtac|omega].
destruct (mag beta x) as (e,He); simpl.
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=Hx).
now apply He.
Qed.

Theorem ulp_FLT_le :
  forall x, (bpow (emin + prec - 1) <= Rabs x)%R ->
  (ulp beta FLT_exp x <= Rabs x * bpow (1 - prec))%R.
Proof.
intros x Hx.
assert (Zx : (x <> 0)%R).
  intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt.
  rewrite Z, Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0 with (1 := Zx).
unfold cexp, FLT_exp.
destruct (mag beta x) as (e,He).
apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R.
rewrite <- bpow_plus.
right; apply f_equal.
replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring.
apply Z.max_l.
assert (emin+prec-1 < e)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=Hx).
now apply He.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply He.
Qed.

Theorem ulp_FLT_gt :
  forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0.
rewrite Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLT_exp.
apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply bpow_mag_gt.
rewrite <- bpow_plus.
apply bpow_le.
apply Z.le_max_l.
Qed.

(** FLT is a nice format: it has a monotone exponent... *)
Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
Proof.
intros ex ey.
unfold FLT_exp.
zify ; omega.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLT : Exists_NE beta FLT_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
intros e.
unfold FLT_exp.
destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ;
  rewrite H2 ; clear H2.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (e - prec + 1 - prec) emin).
omega.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (emin + 1 - prec) emin).
omega.
Qed.

End RND_FLT.


(** * Autosubst Header for Unnamed Syntax

Version: December 11, 2019.
 *)

Require Export Utils.headers.axioms.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

(** ** Primitives of the Sigma Calculus. *)

Definition None := 0.
Definition Some := S.

Notation fin := nat.
Definition shift  := S.

Definition var_zero := 0.

Definition id {X} (x: X) := x.

Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
          |0 => x
          |S n => xi n
          end.

Notation "s .: sigma" := (scons s sigma) (at level 70).

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

(** ** Type Class Instances for Notation
Required to make notation work. *)

(** *** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Declare Scope fscope.
Declare Scope subst_scope.

Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(** *** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

(** *** Type Class for Variables *)

Class Var X Y :=
  ids : X -> Y.

(** ** Proofs for the substitution primitives. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (*fun x => g (f x)*) (at level 50) : subst_scope.
Open Scope subst_scope.

(** A generic lifting of a renaming. *)
Definition up_ren (xi : nat -> nat) :=
  0 .: (xi >> S).

(** A generic proof that lifting of renamings composes. *)
Lemma up_ren_ren (xi: nat -> nat) (zeta : nat -> nat) (rho: nat -> nat) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [|x].
  - reflexivity.
  - unfold up_ren. simpl. unfold funcomp. rewrite <- E. reflexivity.
Qed.

(** Eta laws. *)
Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.

(** ** Notations for unscoped syntax *)

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  unfold up_ren; repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) (* AsimplComp *)
         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma)var_zero) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h))
        | [|- context[?f >> (?x .: ?g)]] =>
           change (f >> (x .: g)) with g
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: shift >> ?f]] =>
           change x2 with (f 0); rewrite (@scons_eta _ _ f)
         | [|- context[(?v .: ?g) 0]] =>
           change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] =>
           change ((v .: g) (S n)) with (g n)
         | [|- context[?f 0 .: ?g]] =>
           change g with (shift >> f); rewrite scons_eta
         | _ => first [progress (rewrite ?scons_comp) | progress (rewrite ?scons_eta_id)]
 end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  unfold up_ren; repeat match goal with
         | [H : context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id] |- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s] |- _]  => change (id s) with s in H
         | [H:  context[(?f >> ?g) >> ?h]  |- _] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) in H(* AsimplComp *)
         | [H : context[(?s.:?sigma) var_zero]  |- _] => change ((s.:sigma)var_zero) with s in H
         | [H: context[(?f >> ?g) >> ?h]  |- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H
        | [H: context[?f >> (?x .: ?g)]  |- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[var_zero]  |- _] =>  change var_zero with 0 in H
         | [H: context[?x2 .: shift >> ?f]  |- _] =>
           change x2 with (f 0) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[(?v .: ?g) 0]  |- _] =>
           change ((v .: g) 0) with v in H
         | [H: context[(?v .: ?g) (S ?n)]  |- _] =>
           change ((v .: g) (S n)) with (g n) in H
         | [H: context[?f 0 .: ?g]  |- _] =>
           change g with (shift >> f); rewrite scons_eta in H
         | _ => first [progress (rewrite ?scons_comp in *)  | progress (rewrite ?scons_eta_id in *) ]
 end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope.

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.
Instance idsRen : Var nat nat := id.

Notation "↑" := (shift).

(** ** Tactics for unscoped syntax *)

(** Unfold of the instances in goal and context. *)
Ltac auto_unfold := unfold subst1, ren1, subst2, ren2, ids; unfold Subst1, Ren1, Subst2, Ren2, Var.

Ltac unfold_funcomp := match goal with
                       | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                       end.

(** Automatically does a case analysis on a natural number, useful for proofs with context renamings/context morphisms. *)
Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : nat), _] => intros []; t
                                           end).


Require Import Coq.Init.Byte List ZArith Lia.
Import ListNotations.

From Minirust.def Require Import ty encoding thm wf int_encoding le utils.
From Minirust.proof.lemma Require Import unique_prov wrap_abstract le utils.
From Minirust.proof Require Import defs high int.

Section ptr.

Context {memory: Memory}.
Context [layout: Layout].

Notation align := (
  match layout with
  | mkLayout align size => align
  end).

Notation size := (
  match layout with
  | mkLayout align size => size
  end).

Context [ptr_ty: PtrTy].

Notation t := (TPtr ptr_ty layout).
Context (Hwf: wf t).

Notation Constraints addr align := (
  match ptr_ty with
  | Raw => true
  | Ref => ((addr >? 0)%Z && (addr mod (Z.of_nat align) =? 0)%Z)%bool
  end).

Lemma ptr_dec {v} {l} (Hdec: decode t l = Some v) :
exists addr, v = VPtr addr (unique_prov l) /\
exists bl, encode_int_raw PTR_SIZE Unsigned addr = Some bl
/\ decode_int_raw PTR_SIZE Unsigned bl = Some addr
/\ Constraints addr align = true /\ unwrap_abstract l = Some bl.
Proof.
unfold decode,decode_ptr in Hdec.

destruct (unwrap_abstract l) eqn:Hunw; cycle 1.
{ simpl in Hdec. discriminate Hdec. }

simpl in Hdec.
destruct (decode_int_raw PTR_SIZE Unsigned l0) eqn:Hidec; cycle 1.
{ simpl in Hdec. discriminate Hdec. }

unfold assuming in Hdec.
simpl in Hdec.
destruct (Constraints i align) eqn:Hconstr; cycle 1.
{ simpl in Hdec. discriminate Hdec. }

simpl in Hdec.
exists i.
split.
{ inversion Hdec. auto. }

exists l0.
assert (length l0 = PTR_SIZE). {
  destruct (Nat.eq_dec (length l0) PTR_SIZE). { assumption. }
  rewrite decode_int_none in Hidec; try assumption. discriminate Hidec.
}

split. {
  destruct (rt2_int PTR_SIZE Unsigned l0 H PTR_SIZE_GT0) as (i' & B & C & D).
  assert (i = i'). {
    rewrite <- B in Hidec. inversion Hidec. auto.
  }
  rewrite <- H0 in C.
  apply C.
}

split. { assumption. }
split. { assumption. }
auto.
Qed.

Lemma ptr_mono1 : mono1 t.
Proof.
intros v1 v2 Hle Hv1 Hv2.
assert (exists a b l, VPtr a b = v1 /\ encode_int_raw PTR_SIZE Unsigned a = Some l). {
  destruct Hv1 as [la H].
  destruct (ptr_dec H) as [addr [Hv [l [Henc [Hdec HConstr]]]]].
  exists addr, (unique_prov la), l.
  auto.
}
destruct H as [addr].
destruct H as [p [l [Hv Henc]]].
rewrite <- Hv.
rewrite <- Hv in Hle,Hv1. clear v1 Hv.
assert (exists b, VPtr addr b = v2). {
  destruct v2 eqn:E; try contradiction Hle.
  simpl in Hle.
  destruct Hle.
  rewrite H.
  exists o.
  reflexivity.
}
destruct H as [p' Hrew].
rewrite <- Hrew. rewrite <- Hrew in Hle,Hv2. clear Hrew v2.
unfold encode,encode_ptr.

rewrite Henc.
exists (wrap_abstract l p), (wrap_abstract l p').
split; try auto.
split; try auto.
clear Henc.

induction l as [|b l IH].
{ simpl. trivial. }

simpl.
split.
- destruct p,p'; repeat (split || reflexivity || simpl in Hle).
-- inversion Hle.
   destruct (P_EQ_REFLECT p p0); auto.
   discriminate H0.
-- inversion Hle. assumption.
- apply IH.
Qed.

Lemma ptr_mono2 : mono2 t.
Proof.
intros l1 l2 Hle.
destruct (unwrap_abstract l1) eqn:Hunw; cycle 1. {
  unfold decode,decode_ptr. rewrite Hunw. simpl. trivial.
}
destruct (decode_int_raw PTR_SIZE Unsigned l) eqn:Hdec; cycle 1. {
  unfold decode,decode_ptr. rewrite Hunw. simpl. rewrite Hdec. simpl.
  trivial.
}
destruct (Constraints i align) eqn:Hc; cycle 1. {
  unfold decode,decode_ptr. rewrite Hunw. simpl. rewrite Hdec. simpl.
  unfold utils.assuming.
  rewrite Hc. simpl. trivial.
}

unfold decode,decode_ptr. rewrite Hunw. simpl. rewrite Hdec. simpl.
unfold utils.assuming. rewrite Hc.
simpl.

assert (unwrap_abstract l2 = Some l).
{ apply (unwrap_le_some Hle Hunw); assumption. }

rewrite H.
simpl.
rewrite Hdec.
simpl.
rewrite Hc.
simpl.
split. { auto. }

destruct (unique_prov l1) eqn:E; cycle 1. { trivial. }
rewrite (unique_le Hle p).
- destruct (P_EQ_REFLECT p p); auto.
- assumption.
Qed.

Lemma ptr_rt1 : rt1 t.
Proof.
intros v Hval.
unfold is_valid_for in Hval.
destruct (Hval) as [l Hl].
destruct (ptr_dec Hl) as [addr [Hrew [bl [Henc [Hdec [Hconstr _]]]]]].
rewrite Hrew. rewrite Hrew in Hval,Hl. clear v Hrew.

exists (wrap_abstract bl (unique_prov l)).
split.
{ simpl. rewrite Henc. simpl. auto. }

simpl.
unfold decode_ptr.
rewrite unwrap_wrap.
simpl.

rewrite Hdec.
simpl.

destruct (Nat.eq_dec (length bl) PTR_SIZE) eqn:E; cycle 1.
{ rewrite decode_int_none in Hdec; try assumption. discriminate Hdec. }

assert (length bl > 0) as H.
{ rewrite e. apply PTR_SIZE_GT0. }

rewrite (unique_wrap H).

unfold assuming.
rewrite Hconstr.
simpl.
auto.
Qed.

Lemma ptr_rt2 : rt2 t.
Proof.
intros l v Hdec.
destruct (ptr_dec Hdec) as [addr [Hv [bl (He & Hd & [Hconstr Hl])]]].
rewrite Hv.
exists (wrap_abstract bl (unique_prov l)).
split.
{ simpl. rewrite He. simpl. auto. }

apply wrap_unique_le; assumption.
Qed.

Lemma ptr_encode_len : encode_len t.
Proof.
intros v l Henc.
unfold encode,encode_ptr in Henc.
destruct v; try discriminate Henc.
destruct (int_in_range a PTR_SIZE Unsigned) eqn:E; cycle 1.
{ rewrite (encode_int_none E) in Henc. discriminate Henc. }

destruct (rt1_int PTR_SIZE Unsigned a E PTR_SIZE_GT0) as (bl' & Hbl' & _ & Out).
rewrite <- Hbl' in Henc.
simpl in Henc.
inversion Henc.
rewrite wrap_len.
assumption.
Qed.

Lemma ptr_props : Props t.
Proof.
split.
- auto.
- apply ptr_rt1.
- apply ptr_rt2.
- apply ptr_mono1.
- apply ptr_mono2.
- apply ptr_encode_len.
Qed.

End ptr.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Prop.
Variable l_ : Universe -> Prop.
Variable i_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable e_ : Universe -> Universe -> Prop.
Variable dom_ : Universe -> Prop.

Variable s3_ : Universe.
Variable s2_ : Universe.
Variable s1_ : Universe.
Variable s_ : Universe.
Variable p3_ : Universe.
Variable p2_ : Universe.
Variable p1_ : Universe.
Variable b3b1_ : Universe.
Variable b3_ : Universe.
Variable b2b3_ : Universe.
Variable b2_ : Universe.
Variable b1b2_ : Universe.
Variable b1_ : Universe.
Variable a3a1_ : Universe.
Variable a3_ : Universe.
Variable a2a3_ : Universe.
Variable a2_ : Universe.
Variable a1a2_ : Universe.
Variable a1_ : Universe.

Variable initial_model_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ b1_ /\ (dom_ b2_ /\ (dom_ b3_ /\ (dom_ s_ /\ (dom_ p1_ /\ (dom_ p2_ /\ (dom_ p3_ /\ (dom_ a1a2_ /\ (dom_ a2a3_ /\ (dom_ a3a1_ /\ (dom_ b1b2_ /\ (dom_ b2b3_ /\ (dom_ b3b1_ /\ (dom_ s1_ /\ (dom_ s2_ /\ (dom_ s3_ /\ (i_ a1_ a1a2_ /\ (i_ a2_ a1a2_ /\ (i_ a2_ a2a3_ /\ (i_ a3_ a2a3_ /\ (i_ a3_ a3a1_ /\ (i_ a1_ a3a1_ /\ (i_ b1_ b1b2_ /\ (i_ b2_ b1b2_ /\ (i_ b2_ b2b3_ /\ (i_ b3_ b2b3_ /\ (i_ b3_ b3b1_ /\ (i_ b1_ b3b1_ /\ (i_ s_ s1_ /\ (i_ s_ s2_ /\ (i_ s_ s3_ /\ (i_ a1_ s1_ /\ (i_ a2_ s2_ /\ (i_ a3_ s3_ /\ (i_ b1_ s1_ /\ (i_ b2_ s2_ /\ (i_ b3_ s3_ /\ (i_ p3_ a1a2_ /\ (i_ p3_ b1b2_ /\ (i_ p1_ a2a3_ /\ (i_ p1_ b2b3_ /\ (i_ p2_ a3a1_ /\ i_ p2_ b3b1_))))))))))))))))))))))))))))))))))))))))))))).
Variable perpectivity_line_2 : (forall L : Universe, ((i_ p3_ L /\ (i_ p1_ L /\ i_ p2_ L)) -> goal_)).
Variable triangle_a_in_b_3 : ((i_ a1_ b2b3_ /\ (i_ a2_ b3b1_ /\ i_ a3_ b1b2_)) -> goal_).
Variable triangle_b_in_a_4 : ((i_ b1_ a2a3_ /\ (i_ b2_ a3a1_ /\ i_ b3_ a1a2_)) -> goal_).
Variable diff_a1_a2_5 : (e_ a1_ a2_ -> goal_).
Variable diff_a2_a3_6 : (e_ a2_ a3_ -> goal_).
Variable diff_a3_a1_7 : (e_ a3_ a1_ -> goal_).
Variable diff_b1_b2_8 : (e_ b1_ b2_ -> goal_).
Variable diff_b2_b3_9 : (e_ b2_ b3_ -> goal_).
Variable diff_b3_b1_10 : (e_ b3_ b1_ -> goal_).
Variable not12_11 : (e_ a1a2_ b1b2_ -> goal_).
Variable not23_12 : (e_ a2a3_ b2b3_ -> goal_).
Variable not31_13 : (e_ a3a1_ b3b1_ -> goal_).
Variable ref_14 : (forall X : Universe, (dom_ X -> e_ X X)).
Variable sym_15 : (forall X Y : Universe, (e_ X Y -> e_ Y X)).
Variable tra_16 : (forall X Y Z : Universe, ((e_ X Y /\ e_ Y Z) -> e_ X Z)).
Variable conp_17 : (forall P Q L : Universe, ((e_ P Q /\ i_ Q L) -> i_ P L)).
Variable conl_18 : (forall P L M : Universe, ((i_ P L /\ e_ L M) -> i_ P M)).
Variable sortp_19 : (forall P L : Universe, (i_ P L -> p_ P)).
Variable sortl_20 : (forall P L : Universe, (i_ P L -> l_ L)).
Variable gap1_21 : (True -> (i_ a1_ b2b3_ \/ i_ b3_ a1a2_)).
Variable gap2_22 : (True -> (i_ a2_ b3b1_ \/ i_ b1_ a2a3_)).
Variable gap3_23 : (True -> (i_ a3_ b1b2_ \/ i_ b2_ a3a1_)).
Variable unique_24 : (forall P L M Q : Universe, ((i_ P L /\ (i_ P M /\ (i_ Q L /\ i_ Q M))) -> (e_ P Q \/ e_ L M))).
Variable meet_25 : (forall L M : Universe, ((l_ L /\ l_ M) -> (exists P : Universe, (dom_ P /\ (i_ P L /\ i_ P M))))).
Variable join_26 : (forall P Q : Universe, ((p_ P /\ p_ Q) -> (exists L : Universe, (dom_ L /\ (i_ P L /\ i_ Q L))))).

Theorem cro_8_2_27 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Context (bitwidth : Z)
              (lgcarrymax : Z).

      Definition VerifiedRewriterMulSplit : VerifiedRewriter_with_args false false true (mul_split_rewrite_rules_proofs bitwidth lgcarrymax).
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterMulSplit.
      Let optsT := Eval hnf in optsT VerifiedRewriterMulSplit.

      Definition RewriteMulSplit (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterMulSplit opts t.

      Lemma Wf_RewriteMulSplit opts {t} e (Hwf : Wf e) : Wf (@RewriteMulSplit opts t e).
      Proof. now apply VerifiedRewriterMulSplit. Qed.

      Lemma Interp_RewriteMulSplit opts {t} e (Hwf : Wf e) : API.Interp (@RewriteMulSplit opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterMulSplit. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
    Hint Resolve Wf_RewriteMulSplit : wf wf_extra.
    Hint Opaque RewriteMulSplit : wf wf_extra interp interp_extra rewrite.
    Hint Rewrite @Interp_RewriteMulSplit : interp interp_extra.
  End Hints.
End Compilers.


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)
Require Import Coq.NArith.BinNat.
Require Import Coq.Lists.List.

Require Import Common.Definitions.
Require Import Common.CoqMaps.
Require Import Intermediate.Machine.
Require Import Intermediate.CS.
Require Import CompTestUtil.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Import QcNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Import Common.Values.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype.

Require Import extructures.ord.

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

Module DoNotation.
  Import ssrfun.
  Notation "'do!' X <- A ; B" :=
    (bindGen A (fun X => B))
      (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.
Import DoNotation.

Definition Component_id := N.
Definition Procedure_id := N.
Definition Block_id := N.
Definition prog_int := BinNatMap.t ((list Procedure_id) *
                                    (list (Component_id*Procedure_id))).

Inductive undef_allowed : Type :=
| UndefAllowed : undef_allowed
| NoUndef : undef_allowed
| StrictNoUndef : undef_allowed
.

Inductive instr_type :=
| Nop : instr_type
| Label : instr_type
| Const : instr_type
| Mov : instr_type
| BinOp : instr_type
| Load : instr_type
| Store : instr_type
| Alloc : instr_type
| Bnz : instr_type
| Jump : instr_type
| Jal : instr_type
| Call : instr_type
| Return : instr_type
| Halt : instr_type.

Definition instr_weight := instr_type -> nat.
Definition code_address_const_instr :=
             Intermediate.Machine.register ->
             prog_int ->
             Component_id -> G (list instr).
Definition data_address_const_instr :=
  Intermediate.Machine.register ->
  Intermediate.Machine.register ->
  prog_int -> BinNatMap.t (list (Block_id * (nat+list value))) ->
  Component_id -> G (list instr).

Definition empty_cag : code_address_const_instr :=
  (fun _ _ _ => returnGen nil).

Definition empty_dag : data_address_const_instr :=
  (fun _ _ _ _ _ => returnGen nil).

Theorem label_eq_dec:
  forall l1 l2 : Intermediate.Machine.label,  {l1 = l2} + {l1 <> l2}.
Proof.
  repeat decide equality.
Defined.

Theorem procs_eqdec:
  forall p1 p2 : (N*N), {p1 = p2} + {p1 <> p2}. Proof.
                                            repeat decide equality.
                                          Defined.

(***************************************************************************
 * Intermediate program generation
 ***************************************************************************)

Definition DEBUG := false.

Definition MAX_PROC_PER_COMP := 10%nat.

Definition MAX_NO_BUFFERS_PER_COMP := 10%nat.

Definition MAX_BUFFER_SIZE := 10%nat.

Definition MAX_PROC_LENGTH := 10%nat.

Definition choose_N ( p : N * N) :=
  let (lo,hi) := p in
  do! p <- choose (N.to_nat lo, N.to_nat hi);
    returnGen (N.of_nat p).

Definition N_list (l : nat) : list N :=
  List.map N.of_nat (List.seq 0 l).

Definition arbitrary_N : G N :=
  do! z <- arbitrary;
    returnGen (Z.abs_N z).

Definition gen_pair_list {A B : Type} (ga : G (list A)) (gb : G (list B)) : G (list (A*B)) :=
  liftGen (fun '(la,lb) => List.combine la lb)
          (liftGen2 pair ga gb).

Definition gen_sublist {A : Type} ( default : A ) ( all : list A ) : G (list A) :=
  match all with
  | [] => returnGen []
  | _ =>
    do! n <- (choose (1%nat,(List.length all)));
      (vectorOf n (elements default all))
  end.

Definition get_freq (wf : instr_weight) (i:instr_type) : nat :=
  wf i.

Definition gen_program_interface (cids : list N) : G prog_int :=

  let proc_ids := do! n <- choose(0%nat,MAX_PROC_PER_COMP); returnGen (N_list n) in
  do! exported_procs <- (vectorOf (List.length cids) proc_ids);
    let all_procs := List.flat_map
                       (fun '(cid,lp) => List.map (fun pid => (cid,pid)) lp)
                       (List.combine cids exported_procs) in
    do! imported_procs <-
      sequenceGen (
        List.map (fun cid =>
                    do! import_procs <- (gen_sublist
                                           (N.of_nat Component.main,
                                            N.of_nat Procedure.main) all_procs);
                      returnGen (List.filter (fun '(cid',_) =>
                                                negb (N.eqb cid cid'))
                                             (List.nodup procs_eqdec import_procs))
                 ) cids);
      returnGen (BinNatMapExtra.of_list
                   (List.combine
                      cids
                      (List.combine exported_procs
                                    imported_procs
                      )
                   )
                ).

Definition gen_value
           (cid : N)
           (all_buffers : list (N*(list (N * nat))))
  : G value :=
  let buffers := List.filter (fun '(cid',_) => N.eqb cid cid') all_buffers in
  freq [ (3%nat, (do! i <- arbitrary; returnGen (Int i)))
         ; (1%nat, (match buffers with
                  | nil => (do! i <- arbitrary; returnGen (Int i))
                  | p::xs =>
                    let (cid,blocks) := p in
                    do! p' <- elements p xs;
                      let (cid',blocks') := p' in
                      (match blocks' with
                       | nil => (do! i <- arbitrary; returnGen (Int i))
                       | b::xs' =>
                         let (bid,s) := b in
                         do! b' <- elements (bid,s) xs';
                           let (bid',s') := b' in
                           do! off <- choose (0%nat, (s'-1)%nat);
                             returnGen (Ptr (N.to_nat cid'
                                             , N.to_nat bid'
                                             , Z.of_nat off))
                       end)
                  end
                 )
           )
       ].

Definition gen_sum (cid : N) (bsize : nat) (buffers : list (N * list (N * nat)))
  : G ( nat+ list value) :=
  freq [ (3%nat, returnGen (inl bsize))
         ; (1%nat,
            (do! vals <- vectorOf bsize (gen_value cid buffers);
               returnGen (inr vals)))
       ].

Definition gen_buffers (cids : list N)
  : G (BinNatMap.t (list (N * (nat + list value)))) :=

  let gen_n_buffers : G (list (N * nat)) :=
      do! n <- choose (1%nat,MAX_NO_BUFFERS_PER_COMP);
        let ids := N_list n in
        do! sizes <- vectorOf n (choose (1%nat, MAX_BUFFER_SIZE));
          returnGen (List.combine ids sizes) in

  do! buffers <- (vectorOf (List.length cids) gen_n_buffers);
    let comp_buffers := (List.combine cids buffers) in
    do! init_buffers <- sequenceGen
      (List.map
         (fun '(cid,bl_lst) =>
            do! bvals <- sequenceGen
              (List.map (fun '(bid,bsize) =>
                           gen_sum cid bsize comp_buffers
                        )
                        bl_lst
              );
              returnGen (List.combine (List.map fst bl_lst) bvals)
         )
         comp_buffers
      );
      returnGen (BinNatMapExtra.of_list (List.combine cids init_buffers)).

Derive Arbitrary for Common.Values.binop.
Derive Arbitrary for Intermediate.Machine.register.

Definition genPointer (cid : N)
           (buffers : BinNatMap.t (list (N * (nat+list value)))) :=
  let nat_cid := N.to_nat cid in
  match BinNatMap.find cid buffers with
  | None => returnGen None
  | Some lst =>
    match lst with
    | nil => returnGen None
    | b::xs =>
      do! b' <- elements b xs;
        let '(bid,bs) := b in
        let nat_bid := N.to_nat bid in
        match bs with
        | inl sz =>
          if Nat.eqb sz 0%nat
          then returnGen None
          else
            if Nat.eqb sz 1%nat
            then
              returnGen
                (Some (Intermediate.Machine.IPtr
                         ((nat_cid, nat_bid), 0%Z)))
            else
              let up := (sz-1)%nat in
              do! offset <- choose (0%nat, up);
                returnGen (Some (Intermediate.Machine.IPtr
                                   ((nat_cid, nat_bid), Z.of_nat offset)))
        | inr lst =>
          if (Nat.eqb (List.length lst) 1%nat)
          then
            returnGen (Some (Intermediate.Machine.IPtr
                               ((nat_cid, nat_bid), Z0) ))
          else
            do! offset <- choose (0%nat,((List.length lst) - 1)%nat);
            returnGen (Some (Intermediate.Machine.IPtr
                               ((nat_cid, nat_bid), Z.of_nat offset)))
        end
    end
  end.

Definition genPtrImVal
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (cid : N)
           (sameComponent : bool)
  : G (option Intermediate.Machine.imvalue) :=
  if sameComponent
  then
    genPointer cid buffers
  else
    backtrack [
        ( 4%nat, (genPointer cid buffers) )
        ; ( 1%nat,
            (do! id <- (elements (1%N) (List.map fst (BinNatMap.elements pi)));
               (genPointer id buffers)))
      ].

Definition genIntImVal : G Intermediate.Machine.imvalue :=
  do! n<-arbitrary; returnGen (Intermediate.Machine.IInt n).

Definition genImVal
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (cid : N)  : G imvalue :=
  let genImValAux : G Intermediate.Machine.imvalue :=
      do! res <- genPtrImVal pi buffers cid false;
        match res with
        | None => genIntImVal
        | Some ptr => returnGen ptr
        end in
  freq
    [ (4%nat, genIntImVal)
      ; (1%nat, genImValAux) ].

Definition genIConst
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (cid : N) : G (list instr) :=
  do! v <- genImVal pi buffers cid;
    do! r <- arbitrary;
    returnGen ([IConst v r]).

Definition gen2Reg (it :  register -> register -> instr) : G (list instr) :=
  do! r1 <- arbitrary;
    do! r2 <- arbitrary;
    returnGen ([it r1 r2]).

Definition genMemReg
           (it :  register -> register -> instr)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (cid : N)
  : G (list instr) :=
  do! r1 <- arbitrary;
    do! r2 <- arbitrary;
    do! res <- genPtrImVal pi buffers cid true;
    match res with
    | None => returnGen [it r1 r2]
    | Some ptr =>
      returnGen [IConst ptr r1; it r1 r2]
    end.

Definition genIAlloc (t : undef_allowed) : G (list instr) :=
  do! r1 <- arbitrary;
    do! r2 <- arbitrary;
    match t with
    | UndefAllowed => returnGen [IAlloc r1 r2]
    | _ =>
      do! v <- choose (1%nat,10%nat);
        returnGen [IConst (IInt (Z.of_nat v)) r2; IAlloc r1 r2]
    end.

Definition genILoad
           (t : undef_allowed)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (Block_id * (nat+list value))))
           (cid : Component_id)
  : G (list instr) :=
  match t with
  | UndefAllowed => gen2Reg ILoad
  | _ => genMemReg ILoad pi buffers cid
  end.

Definition genIStore
           (t : undef_allowed)
           (addr_gen : data_address_const_instr)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (Block_id * (nat+list value))))
           (cid : Component_id)
  : G (list instr) :=
  match t with
  | UndefAllowed =>
    gen2Reg IStore
  | StrictNoUndef =>
    genMemReg IStore pi buffers cid
  | _ =>
    do! r1 <- arbitrary;
      do! r2 <- arbitrary;
      do! constInstr <- addr_gen r1 r2 pi buffers cid;
      returnGen (constInstr++[IStore r1 r2])%list
  end.

Definition genIBinOp : G (list instr) :=
  do! op <- arbitrary;
    do! r1 <- arbitrary;
    do! r2 <- arbitrary;
    do! r3 <- arbitrary;
    returnGen ([IBinOp op r1 r2 r3]).

Definition genIJump
           (t : undef_allowed)
           (cag : code_address_const_instr)
           (pi : prog_int)
           (cid : Component_id)
  : G (list instr) :=
  match t with
  | UndefAllowed  =>
    do! r <- arbitrary;
      returnGen ([IJump r])
  | StrictNoUndef => returnGen ([INop])
  | _ =>
    do! r <- arbitrary;
      do! li <- cag r pi cid;
      returnGen (li ++ [IJump r])%list
  end.

Definition genICall
           (pi : prog_int)
           (cid : N)
           (pid : N) : G (list instr) :=
  match BinNatMap.find cid pi with
  | None => returnGen [INop] (* This should not happen *)
  | Some comp_interface =>
    let imports := (snd comp_interface) in
    match imports with
    | nil => returnGen [INop] (* no imports; can't generate ICall *)
    | (cid1,pid1)::xs =>
      do! p <- elements (cid1,pid1) imports;
        do! v <- arbitrary;
        let (cid',pid') := p in
        let call_instr := ICall (N.to_nat cid') (N.to_nat pid') in
        let const_instr := IConst (Intermediate.Machine.IInt v) R_COM in
        returnGen ([const_instr;call_instr])
    end
  end.

Definition genIJal : G (list instr) :=
  do! l <- choose (1%nat,20%nat);
    returnGen ([IJal l]).

Definition genIBnz (t : undef_allowed)
           (first_label : nat) (lbl : nat) : G (list instr) :=
  match t with
  | UndefAllowed =>
    do! r <- arbitrary;
      if (Nat.ltb first_label (lbl+3))%nat
      then
        do! target <- choose (first_label,(lbl+3)%nat);
          returnGen ([IBnz r target])
      else
        do! target <- choose (lbl,(lbl+3)%nat);
      returnGen ([IBnz r target])
  | StrictNoUndef => returnGen ([INop])
  | _ =>
    do! r <- arbitrary;
      do! v <- arbitrary;
      if (Nat.ltb first_label (lbl+3))%nat
      then
        do! target <- choose (first_label,(lbl+3)%nat);
          returnGen ([IConst (IInt v) r; IBnz r target])
      else
        do! target <- choose (lbl,(lbl+3)%nat);
      returnGen ([IConst (IInt v) r; IBnz r target])
  end.

Definition genILabel (lbl : nat) : G (list instr) :=
  returnGen ([ILabel lbl]).

Definition delared_labels_in_proc (proc : Intermediate.Machine.code) :=
  List.map (fun i =>
              match i with
              | ILabel l => l
              | _ => 1%nat (* this is not happening *)
              end
           )
           (List.filter (fun i => match i with
                               | ILabel _ => true
                               | _ => false
                               end ) proc ).

(************ gen procedure *********************)

Definition get_missing_labels proc :=
  let decl := delared_labels_in_proc proc in
  let uses :=  List.map
                 (fun i =>
                    match i with
                    | IBnz _ l => l
                    | _ => 1%nat (* this is not happening *)
                    end
                 )
                 (List.filter (fun i => match i with
                                     | IBnz _ _ => true
                                     | _ => false
                                     end ) proc ) in
  List.nodup label_eq_dec
             (List.filter (fun l => Nat.eqb 0%nat (List.count_occ label_eq_dec decl l))
                          uses).

Fixpoint gen_proc_with_labels proc missing_labels :=
  match missing_labels with
  | nil => returnGen proc
  | lbl::xs =>
    do! pos <- choose (0%nat,((List.length missing_labels)-1)%nat);
      let new_proc := ((List.firstn pos proc)
                         ++ [ILabel lbl]
                         ++ (List.skipn pos proc))%list in
      gen_proc_with_labels new_proc xs
  end.

Definition gen_instr
           (t : undef_allowed)
           (wf : instr_weight)
           (cag : code_address_const_instr)
           (dag : data_address_const_instr)
           (first_label : nat)
           (next_label : nat)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (cid : N)
           (pid : N)
  :=
    freq [
        ( (get_freq wf Call), genICall pi cid pid)
        ; ( (get_freq wf Const), genIConst pi buffers cid)
        ; ( (get_freq wf Label) , genILabel next_label)
        ; ( (get_freq wf Mov), gen2Reg IMov)
        ; ( (get_freq wf BinOp), genIBinOp)
        ; ( (get_freq wf Load) , genILoad t pi buffers cid)
        ; ( (get_freq wf Store), genIStore t dag pi buffers cid)
        ; ( (get_freq wf Bnz), genIBnz t first_label next_label)
        ; ( (get_freq wf Jump), genIJump t cag pi cid)
        ; ( (get_freq wf Jal), genIJal)
        ; ( (get_freq wf Alloc), genIAlloc t)
        ; ( (get_freq wf Halt), (returnGen [IHalt]))
        ; ( (get_freq wf Return), (returnGen [IReturn]))
        ; ( (get_freq wf Nop) ,(returnGen [INop]))
      ].

Definition gen_procedure
           (t : undef_allowed)
           (wf : instr_weight)
           (cag : code_address_const_instr)
           (dag : data_address_const_instr)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (Block_id * (nat+list value))))
           (cid : Component_id)
           (pid : Procedure_id)
           (next_label : nat)
  : G Intermediate.Machine.code :=

  let fix gen_proc_rec proc len first_lbl lbl :=
      match len with
      | O =>
        do! p <- gen_proc_with_labels proc (get_missing_labels proc);
          returnGen (p ++ [IReturn])%list
      | S len' =>
        do! il <- gen_instr t wf cag dag first_lbl lbl pi buffers cid pid;
          match il with
          | [ILabel _] => gen_proc_rec (proc ++ il)%list len' first_lbl (lbl+1)%nat
          | [IReturn] | [IHalt] =>
                        do! p <- gen_proc_with_labels proc (get_missing_labels proc);
                          returnGen (p ++ il)%list
          | _ => gen_proc_rec (proc ++ il)%list len' first_lbl lbl
          end
      end in
  gen_proc_rec [] MAX_PROC_LENGTH next_label next_label.

(****************** Done gen_procedure (split to avoid stack overflow) *******)

Definition max_label (procs : BinNatMap.t Intermediate.Machine.code) :=
  List.fold_left
    (fun acc '(_,proc)  =>
       (List.fold_left (fun acc' i =>
                          match i with
                          | ILabel l => if (Nat.ltb acc' l) then l else acc'
                          | _ => acc'
                          end
                       ) proc acc)
    ) (BinNatMap.elements procs) 1%nat.

Definition gen_procedures
           (t : undef_allowed)
           (wf : instr_weight)
           (cag : code_address_const_instr)
           (dag : data_address_const_instr)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (no_undef_cids : list N)
  : G (BinNatMap.t (BinNatMap.t Intermediate.Machine.code)) :=

  foldGen
    (fun acc '(cid, comp_interface)  =>
       let no_undef := List.existsb (N.eqb cid) no_undef_cids in
       do! proc_map <- (
           let '(lexp,limp) := comp_interface in
           foldGen
             (fun acc pid =>
                if no_undef
                then
                  do! proc <- gen_procedure StrictNoUndef wf cag dag pi
                    buffers cid pid ((max_label acc) + 1)%nat;
                    returnGen (BinNatMap.add pid proc acc)
                else
                  do! proc <- gen_procedure t wf cag dag pi
                  buffers cid pid ((max_label acc) + 1)%nat;
                  returnGen (BinNatMap.add pid proc acc)
             ) lexp (BinNatMap.empty Intermediate.Machine.code));

         (* check add labels as needed for IJal *)
         let all_decl_labels :=
             List.fold_left
               (fun acc elt => (acc ++ elt)%list )
               (List.map (fun p => delared_labels_in_proc (snd p))
                         (BinNatMap.elements proc_map))
               (@nil nat) in
         let uses :=
             List.fold_left
               (fun acc elt => (acc ++ elt)%list )
               (List.map
                  (fun p =>
                     List.map
                       (fun i =>
                          match i with
                          | IJal l => l
                          | _ => 1%nat (* this is not happening *)
                          end
                       )
                       (List.filter
                          (fun i =>
                             match i with
                             | IJal _  => true
                             | _ => false
                             end )
                          (snd p) ))
                  (BinNatMap.elements proc_map))
               (@nil nat) in
         let lbls := List.nodup label_eq_dec
                                (List.filter
                                   (fun l =>
                                      Nat.eqb 0%nat
                                              (List.count_occ
                                                 label_eq_dec
                                                 all_decl_labels
                                                 l
                                              )
                                   )
                                   uses
                                ) in
         (* TODO do something smarter *)
         match BinNatMap.elements proc_map with
         | nil => returnGen (BinNatMap.add cid proc_map acc)
         | (pid,code)::_ =>
           returnGen (BinNatMap.add
                        cid
                        (BinNatMap.add
                           pid
                           ((List.map
                               (fun l => ILabel l)
                               lbls
                            )++code)%list
                           proc_map
                        )
                        acc
                     )
         end
    ) (BinNatMap.elements  pi)
    (BinNatMap.empty (BinNatMap.t Intermediate.Machine.code))
.

Definition gen_main_pid (pi : prog_int) : G (N) :=
  match BinNatMap.find (N.of_nat Component.main) pi with
  | None => returnGen (N.of_nat Procedure.main)
  | Some cint =>
    returnGen
      ((List.fold_left
          (fun acc elt => if (N.leb acc elt) then elt else acc)
          (fst cint)
          (N.of_nat Procedure.main))+1)%N
  end.

Definition convert_program_interface (pi : prog_int) : Program.interface :=
  BinNatMap.fold
    (fun cid cint acc =>
       let '(lexp,limp) := cint in
       setm acc (N.to_nat cid) (Component.mkCompInterface
                                  (list2fset (List.map N.to_nat lexp))
                                  (list2fset (List.map
                                                (fun '(c,p) => (N.to_nat c,N.to_nat p))
                                                limp)))
    ) pi (emptym).

Definition convert_procedures (all : BinNatMap.t (BinNatMap.t Intermediate.Machine.code))
  : NMap (NMap Intermediate.Machine.code) :=
  BinNatMap.fold
    (fun cid pm (acc : NMap ( NMap Intermediate.Machine.code ) ) =>
       setm acc (N.to_nat cid)
            (
              BinNatMap.fold
                (fun pid pcode (acc1 : NMap Intermediate.Machine.code) =>
                   setm acc1 (N.to_nat pid) pcode)
                pm (emptym)
            )
    ) all (emptym).

Definition convert_buffers (buffs : BinNatMap.t  (list (N * (nat+list value))))
  : NMap {fmap Block.id -> nat + list value} :=
  BinNatMap.fold
    (fun cid b acc =>
       setm acc (N.to_nat cid)
            (list2fmap
               (
                 List.map (fun '(bid,v) => (N.to_nat bid,v) ) b
               )
            )
    (* (List.map (fun '(id,s)=>(N.to_nat id,s)) b)) *)
    )
    buffs emptym.

Definition gen_main_code
           (t : undef_allowed)
           (wf : instr_weight)
           (cag : code_address_const_instr)
           (dag : data_address_const_instr)
           (pi : prog_int)
           (buffers : BinNatMap.t (list (N * (nat+list value))))
           (all : BinNatMap.t (BinNatMap.t Intermediate.Machine.code))
           (pid : Procedure_id) :=

  do! p' <-
    match BinNatMap.find (N.of_nat Component.main) all with
    | None =>
      gen_procedure t wf cag dag pi buffers (N.of_nat Component.main) pid 1%nat
    | Some pmap =>
      match BinNatMap.find pid pmap with
      | None => (* must generate code for this procedure *)
        gen_procedure t wf cag dag pi buffers
                      (N.of_nat Component.main)
                      pid (max_label pmap )
      | Some l => returnGen l
      end
    end;
        (* check add labels as needed for IJal *)
    let all_decl_labels := delared_labels_in_proc p' in
    let uses := List.map
                  (fun i =>
                     match i with
                     | IJal l => l
                     | _ => 1%nat (* this is not happening *)
                     end
                  )
                  (List.filter (fun i => match i with
                                         | IJal _  => true
                                         | _ => false
                                         end )
                               p' ) in
    let lbls := List.nodup label_eq_dec
                           (List.fold_left (fun acc elt =>
                                              (List.remove label_eq_dec elt acc))
                                           all_decl_labels uses) in
    let pmap := match BinNatMap.find (N.of_nat Component.main) all with
                | None => BinNatMap.empty (code)
                | Some m => m
                end in
    let p := List.map
               (fun i => match i with
                         | IReturn => IHalt
                         | _ => i
                         end
               ) p' in
    returnGen
      ( match BinNatMap.elements pmap with
        | nil =>
          (BinNatMap.add
             (N.of_nat Component.main)
             (BinNatMap.add
                pid
                ((List.map (fun l => ILabel l) lbls) ++ p)%list
                pmap)
             all)
        | (pid',code)::_ =>
          let code' := ((List.map (fun l => ILabel l) lbls) ++ code)%list in
          BinNatMap.add (N.of_nat Component.main)
                        (BinNatMap.add
                           pid
                           p
                           (BinNatMap.add pid' code' pmap)
                        ) all
        end).

Definition genIntermediateProgram
           (t : undef_allowed)
           (wf : instr_weight)
           (cag : code_address_const_instr)
           (dag : data_address_const_instr)
           (min_components : nat)
           (max_components : nat)
  : G Intermediate.program :=

  do! n <-
      (if (Nat.eqb min_components max_components)
       then returnGen max_components
       else choose (min_components, max_components));

    let cids := N_list n in

    do! pi <- (gen_program_interface cids);

      do! buffers <- gen_buffers cids;
      do! procs <- gen_procedures t wf cag dag pi buffers nil;
      do! main <- gen_main_pid pi;
      do! all_procs <- gen_main_code t wf cag dag pi buffers procs main;
      returnGen {|
          Intermediate.prog_interface := convert_program_interface pi;
          Intermediate.prog_procedures := convert_procedures all_procs;
          Intermediate.prog_buffers := convert_buffers buffers;
          Intermediate.prog_main := Some (N.to_nat main)
        |}.

Fixpoint gen_ids size cids : G (list N) :=
  match size with
  | O => returnGen ((N.of_nat Component.main)::nil)
  | S n =>
    do! prev <- gen_ids n cids;
      do! cid <- elements (N.of_nat Component.main) cids;
      returnGen (cid::prev)
  end.

Definition genRSCIntermediateProgram
           (t : undef_allowed)
           (wf : instr_weight)
           (cag : code_address_const_instr)
           (dag : data_address_const_instr)
           (min_components : nat)
           (max_components : nat)
  : G Intermediate.program :=

  do! n <-
      (if (Nat.eqb min_components max_components)
       then returnGen max_components
       else choose (min_components, max_components));

    let cids := N_list n in
    do! size <- choose (2%nat, (Nat.max 3%nat (max_components - 3%nat)%nat));
      do! no_undef_cids <- gen_ids size cids;

      do! pi <- (gen_program_interface cids);

      do! buffers <- gen_buffers cids;

      do! procs <- gen_procedures t wf cag dag pi buffers no_undef_cids;

      do! main <- gen_main_pid pi;
      do! all_procs <- gen_main_code t wf cag dag pi buffers procs main;
      returnGen {|
          Intermediate.prog_interface := convert_program_interface pi;
          Intermediate.prog_procedures := convert_procedures all_procs;
          Intermediate.prog_buffers := convert_buffers buffers;
          Intermediate.prog_main := Some (N.to_nat main)
        |}.