(* DEC1 language development.
   Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* weakening lemmas *)

Require Export Basics.

Require Export EnvLibA.
Require Export RelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import StaticSemA.
Require Import DynamicSemA.

Import ListNotations.

Module Weaken (IdT: IdModType) <: IdModType.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module DynamicI := Dynamic IdT.
Export DynamicI.

Lemma QValWeakening (env env': valEnv)
      (n1 n2: W)
      (q1 q2: QValue):
  QVStep env (Conf QValue n1 q1) (Conf QValue n2 q2) ->
  QVStep (env ++ env') (Conf QValue n1 q1) (Conf QValue n2 q2).
Proof.
  intros.
  inversion X; subst.
  constructor.
  inversion X0; subst.
  eapply override_simpl1 with (env2:=env') in H.
  constructor.
  rewrite H.
  inversion X0; subst.
  assumption.
Defined.

Lemma QFunWeakening (env env': funEnv)
      (n1 n2: W)
      (q1 q2: QFun):
  QFStep env (Conf QFun n1 q1) (Conf QFun n2 q2) ->
  QFStep (env ++ env') (Conf QFun n1 q1) (Conf QFun n2 q2).
Proof.
  intros.
  inversion X; subst.
  constructor.
  inversion X0; subst.
  eapply override_simpl1 with (env2:=env') in H.
  constructor.
  rewrite H.
  inversion X0; subst.
  assumption.
Defined.

Lemma weaken
           (fenv fenv': funEnv) (env env': valEnv)
           (n1 n2: W) (e1 e2: Exp):
      EClosure fenv env (Conf Exp n1 e1) (Conf Exp n2 e2) ->
      EClosure (fenv ++ fenv') (env ++ env')
               (Conf Exp n1 e1) (Conf Exp n2 e2).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2 as [n0 e0].
  specialize (IHX n0 n2 e0 e2 eq_refl eq_refl).
  econstructor.
  Focus 2.
  eassumption.

  (***)

  clear IHX.
  clear X.
  rename e into H.
  clear n2 e2.
  revert fenv' env'.

  (***)

    eapply (EStep_mut (fun fenv env c1 c2
 (ExIH: EStep fenv env c1 c2) => forall fenv' env',
  EStep (fenv ++ fenv') (env ++ env')
        c1 c2)
  (fun fenv env c1 c2
  (PsIH: PrmsStep fenv env c1 c2) => forall fenv' env',
  PrmsStep (fenv ++ fenv') (env ++ env')
           c1 c2)).

  - intros.
    constructor.
  - intros.
    constructor.
    eapply QValWeakening.
    assumption.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply QValWeakening.
    assumption.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
  - intros.
    econstructor.
    + reflexivity.
    + reflexivity.
    + rewrite app_assoc.
      rewrite app_assoc.
      specialize (X fenv'0 env'0).
      rewrite e2 in X.
      rewrite e3 in X.
      eapply X.
  - intros.
    econstructor.
    auto.
    eassumption.
    assumption.
    assumption.
  - intros.
    econstructor.
    eassumption.
    assumption.
    assumption.
  - intros.
    econstructor.
    eapply X.
  - intros.
    econstructor.
    eapply QFunWeakening.
    assumption.
  - intros.
    constructor.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
    eapply X.
  - assumption.
Defined.

Definition FunWeaken :=
     fun (f: Fun) (ft: FTyp)
         (k: FunTyping f ft) => True.

Definition QFunWeaken :=
     fun (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp)
         (k: QFunTyping ftenv fenv q ft) =>
       MatchEnvsT FunTyping fenv ftenv ->
       forall (ftenv': funTC) (fenv': funEnv),
          MatchEnvsT FunTyping fenv' ftenv' ->
          QFunTyping (ftenv ++ ftenv') (fenv ++ fenv') q ft.

Definition ExpWeaken :=
     fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t: VTyp)
         (k: ExpTyping ftenv tenv fenv e t) =>
   MatchEnvsT FunTyping fenv ftenv ->
   forall (ftenv': funTC) (tenv': valTC) (fenv': funEnv),
       MatchEnvsT FunTyping fenv' ftenv' ->
       ExpTyping (ftenv ++ ftenv') (tenv ++ tenv') (fenv ++ fenv') e t.

Definition PrmsWeaken :=
     fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (ps: Prms) (pt: PTyp)
         (k: PrmsTyping ftenv tenv fenv ps pt) =>
   MatchEnvsT FunTyping fenv ftenv ->
   forall (ftenv': funTC) (tenv': valTC) (fenv': funEnv),
       MatchEnvsT FunTyping fenv' ftenv' ->
       PrmsTyping (ftenv ++ ftenv') (tenv ++ tenv') (fenv ++ fenv') ps pt.

Definition ExpWeaken_rect :=
  ExpTyping_str_rect
                     FunWeaken QFunWeaken
                     ExpWeaken PrmsWeaken.

Lemma weakenTyping
           (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
           (e: Exp) (t: VTyp):
   ExpTyping ftenv tenv fenv e t ->
   MatchEnvsT FunTyping fenv ftenv ->
   forall (ftenv': funTC) (tenv': valTC) (fenv': funEnv),
       MatchEnvsT FunTyping fenv' ftenv' ->
       ExpTyping (ftenv ++ ftenv') (tenv ++ tenv') (fenv ++ fenv') e t.
Proof.
  eapply ExpWeaken_rect.
  - unfold Par_SSL, ExpWeaken.
    intros.
    constructor.
  - unfold Par_SSL, ExpWeaken.
    intros.
    constructor.
    auto.
    auto.
    auto.
  - unfold Par_SSA.
    constructor.
  - unfold Par_SSA.
    econstructor.
    eauto.
    auto.
  - unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    auto.
    auto.
    auto.
    auto.
    eauto.
  - unfold ExpWeaken, FunWeaken.
    intros.
    constructor.
  - unfold ExpWeaken, FunWeaken.
    intros.
    constructor.
  - unfold QFunWeaken, FunWeaken.
    intros.
    constructor.
    auto.
  - unfold QFunWeaken, FunWeaken, Par_SSB, Par_SSA.
    intros.
    econstructor.
    instantiate (1:=f).
    inversion m; subst.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite <- app_comm_cons.
    rewrite <- app_comm_cons.
    econstructor.
    assumption.
    exact X3.
    eapply appEnvLemmaT.
    exact X4.
    exact X1.
    assumption.
    reflexivity.
    reflexivity.
  - unfold ExpWeaken.
    intros.
    constructor.
    inversion k; subst.
    constructor.
    auto.
    constructor.
    inversion X1; subst.
    constructor.
    constructor.
    inversion X2; subst.
    rewrite (override_simpl1 tenv0 tenv' x (vtyp T1)).
    exact H.
    exact H.
  - unfold ExpWeaken.
    intros.
    constructor.
    inversion k; subst.
    constructor.
    auto.
    constructor.
    inversion X1; subst.
    constructor.
    constructor.
    inversion X2; subst.
    rewrite (override_simpl1 tenv0 tenv' x t0).
    exact H.
    exact H.

  - unfold ExpWeaken.
    intros.
    specialize (X X1 ftenv' tenv' fenv' X2).
    specialize (X0 X1 ftenv' tenv' fenv' X2).
    econstructor.
    exact X.
    exact X0.
  - unfold ExpWeaken.
    intros.
    specialize (X X1 ftenv' tenv' fenv' X2).
    econstructor.
    exact X.
    eapply X0.
    exact X1.
    exact X2.
  - unfold ExpWeaken.
    intros.
    econstructor.
    exact k1.
    eapply overrideEnvLemmaT.
    exact X0.
    exact X1.
    exact m2.
    reflexivity.
    reflexivity.
    reflexivity.
    assert (MatchEnvsT FunTyping (fenvP ++ fenv0) (ftenvP ++ ftenv0)).
    eapply overrideEnvLemmaT.
    exact m2.
    exact m1.
    rewrite h1 in X.
    rewrite h2 in X.
    rewrite h3 in X.

    specialize (X X2 ftenv'0 tenv'0 fenv'0 X1).
    repeat rewrite app_assoc.
    auto.
  - unfold ExpWeaken, QFunWeaken, PrmsWeaken.
    intros.
    econstructor.
    reflexivity.

    eapply overrideEnvLemmaT.
    assumption.
    assumption.
    eapply X.
    assumption.
    assumption.
    rewrite h in X0.
    eapply X0.
    assumption.
    assumption.
  - unfold ExpWeaken.
    intros.
    constructor.
    assumption.
  - unfold ExpWeaken.
    intros.
    constructor.
    eapply X.
    assumption.
    assumption.
    eapply X0.
    assumption.
    assumption.
    eapply X1.
    assumption.
    assumption.
  - unfold Par_SSL, PrmsWeaken, ExpWeaken.
    intros.
    constructor.
    induction X.
    constructor.
    constructor.
    eapply p0.
    assumption.
    assumption.
    eapply IHX.
    inversion m; subst.
    exact X3.
Defined.

Definition PrmsWeaken_rect :=
  PrmsTyping_str_rect
                     FunWeaken QFunWeaken
                     ExpWeaken PrmsWeaken.

Lemma weakenPrmsTyping
           (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
           (ps: Prms) (pt: PTyp):
   PrmsTyping ftenv tenv fenv ps pt ->
   MatchEnvsT FunTyping fenv ftenv ->
   forall (ftenv': funTC) (tenv': valTC) (fenv': funEnv),
       MatchEnvsT FunTyping fenv' ftenv' ->
       PrmsTyping (ftenv ++ ftenv') (tenv ++ tenv') (fenv ++ fenv') ps pt.
Proof.
  eapply PrmsWeaken_rect.
  - unfold Par_SSL, ExpWeaken.
    intros.
    constructor.
  - unfold Par_SSL, ExpWeaken.
    intros.
    constructor.
    auto.
    auto.
    auto.
  - unfold Par_SSA.
    constructor.
  - unfold Par_SSA.
    econstructor.
    eauto.
    auto.
  - unfold Par_SSB, Par_SSA.
    intros.
    econstructor.
    exact m0.
    exact m1.
    auto.
    auto.
    auto.
    auto.
    eauto.
  - unfold ExpWeaken, FunWeaken.
    intros.
    constructor.
  - unfold ExpWeaken, FunWeaken.
    intros.
    constructor.
  - unfold QFunWeaken, FunWeaken.
    intros.
    constructor.
    auto.
  - unfold QFunWeaken, FunWeaken, Par_SSB, Par_SSA.
    intros.
    econstructor.
    instantiate (1:=f).
    inversion m; subst.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite <- app_comm_cons.
    rewrite <- app_comm_cons.
    econstructor.
    assumption.
    exact X3.
    eapply appEnvLemmaT.
    exact X4.
    exact X1.
    assumption.
    reflexivity.
    reflexivity.
  - unfold ExpWeaken.
    intros.
    constructor.
    inversion k; subst.
    constructor.
    auto.
    constructor.
    inversion X1; subst.
    constructor.
    constructor.
    inversion X2; subst.
    rewrite (override_simpl1 tenv0 tenv' x (vtyp T1)).
    exact H.
    exact H.
  - unfold ExpWeaken.
    intros.
    constructor.
    inversion k; subst.
    constructor.
    auto.
    constructor.
    inversion X1; subst.
    constructor.
    constructor.
    inversion X2; subst.
    rewrite (override_simpl1 tenv0 tenv' x t).
    exact H.
    exact H.

  - unfold ExpWeaken.
    intros.
    specialize (X X1 ftenv' tenv' fenv' X2).
    specialize (X0 X1 ftenv' tenv' fenv' X2).
    econstructor.
    exact X.
    exact X0.
  - unfold ExpWeaken.
    intros.
    specialize (X X1 ftenv' tenv' fenv' X2).
    econstructor.
    exact X.
    eapply X0.
    exact X1.
    exact X2.
  - unfold ExpWeaken.
    intros.
    econstructor.
    exact k1.
    eapply overrideEnvLemmaT.
    exact X0.
    exact X1.
    exact m2.
    reflexivity.
    reflexivity.
    reflexivity.
    assert (MatchEnvsT FunTyping (fenvP ++ fenv0) (ftenvP ++ ftenv0)).
    eapply overrideEnvLemmaT.
    exact m2.
    exact m1.
    rewrite h1 in X.
    rewrite h2 in X.
    rewrite h3 in X.

    specialize (X X2 ftenv'0 tenv'0 fenv'0 X1).
    repeat rewrite app_assoc.
    auto.
  - unfold ExpWeaken, QFunWeaken, PrmsWeaken.
    intros.
    econstructor.
    reflexivity.

    eapply overrideEnvLemmaT.
    assumption.
    assumption.
    eapply X.
    assumption.
    assumption.
    rewrite h in X0.
    eapply X0.
    assumption.
    assumption.
  - unfold ExpWeaken.
    intros.
    constructor.
    assumption.
  - unfold ExpWeaken.
    intros.
    constructor.
    eapply X.
    assumption.
    assumption.
    eapply X0.
    assumption.
    assumption.
    eapply X1.
    assumption.
    assumption.
  - unfold Par_SSL, PrmsWeaken, ExpWeaken.
    intros.
    constructor.
    induction X.
    constructor.
    constructor.
    eapply p0.
    assumption.
    assumption.
    eapply IHX.
    inversion m; subst.
    exact X3.
Defined.

End Weaken.


Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Sorting.Permutation.

Require Import GenericTactics.
Require Import GenericLemmas.
Require Import Names.
Require Import AST.
Require Import BodyTypeDefs.
Require Import Skeleton.
Require Import ProgramDef.
Require Import Unique.
Require Import Sublist.
Require Import Subterm.
Require Import Typechecker.
Require Import Permutations.

Require Import InlineComatch.
Require Import LiftComatch.

Fixpoint extract_local_gfuns_expr (e : expr) : list QName :=
  match e with
  | E_Var x => []
  | E_Constr _ args => concat (map extract_local_gfuns_expr args)
  | E_DestrCall _ e args => (extract_local_gfuns_expr e) ++ (concat (map extract_local_gfuns_expr args))
  | E_FunCall _ args => concat (map extract_local_gfuns_expr args)
  | E_GenFunCall _ args => concat (map extract_local_gfuns_expr args)
  | E_ConsFunCall _ e args => (extract_local_gfuns_expr e) ++ (concat (map extract_local_gfuns_expr args))
  | E_Match qn e bs cases rtype =>
    (extract_local_gfuns_expr e)
      ++ (concat (map (fun exp_typ => extract_local_gfuns_expr (fst exp_typ)) bs))
      ++ (concat (map (fun sn_exp => extract_local_gfuns_expr (snd sn_exp)) cases))
  | E_CoMatch qn bs cocases =>
    (concat (map (fun exp_typ => extract_local_gfuns_expr (fst exp_typ)) bs))
      ++ (concat (map (fun sn_exp => extract_local_gfuns_expr (snd sn_exp)) cocases))
  | E_Let e1 e2 => (extract_local_gfuns_expr e1) ++ (extract_local_gfuns_expr e2)
  end.

Definition extract_local_gfuns_program (p : program) : list QName :=
  (flat_map extract_local_gfuns_expr (map snd (program_fun_bods p)))
  ++ (flat_map extract_local_gfuns_expr (map snd (flat_map snd (program_gfun_bods_g p))))
  ++ (flat_map extract_local_gfuns_expr (map snd (flat_map snd (program_gfun_bods_g p)))).

Fixpoint extract_gfuns_depth_one (cs: gfun_bods) (qn : QName) : list QName :=
  match cs with
  | [] => []
  | ((qn',e) :: cs') =>
    if eq_QName qn qn'
    then flat_map (fun x => extract_local_gfuns_expr (snd x)) e
    else extract_gfuns_depth_one cs' qn
  end.

Fixpoint extract_gfuns_by_depth (fuel : nat) (cs : gfun_bods) (qns: list QName) : list QName :=
  match fuel with
  | 0 => []
  | S n => let new_qns := map (extract_gfuns_depth_one cs) qns in
          let new_cs  := filter (fun bod => negb (existsb (eq_QName (fst bod)) (concat new_qns))) cs in
          let new_rec := map (extract_gfuns_by_depth n new_cs) new_qns in
          concat (zipWith cons qns new_rec)
  end.

Definition sort_gfuns_for_inline (p : program) (cs: gfun_bods) : gfun_bods :=
  let qns := extract_local_gfuns_program p in
  let fuel := length cs in
  sort_by_index_list (fun qn bod => eq_QName qn (fst bod))  (extract_gfuns_by_depth fuel cs qns) cs.

Lemma extract_gfuns_depth_one_unique: forall (cs : gfun_bods) (qn : QName),
    unique (flat_map extract_local_gfuns_expr (map snd (flat_map snd cs))) ->
    unique (extract_gfuns_depth_one cs qn).
Proof.
  intros cs qn H_uniq.
  induction cs; simpl; auto.
  destruct a as [qn_a e_a]; simpl in *.
  rewrite map_app in H_uniq;
    rewrite flat_map_app in H_uniq;
    unique_app_destr_tac.
  match_destruct_tac; auto.
  clear - H_uniq0.
  rewrite flat_map_concat_map in *.
  rewrite map_compose in H_uniq0; auto.
Qed.

Lemma extract_gfuns_by_depth_permutes: forall p : program,

    unique ((flat_map extract_local_gfuns_expr (map snd (flat_map snd (program_gfun_bods_l p))))
              ++ (extract_local_gfuns_program p)) ->
    Permutation (extract_gfuns_by_depth (length (program_gfun_bods_l p)) (program_gfun_bods_l p) (extract_local_gfuns_program p)) (map fst (program_gfun_bods_l p)).
Proof.
  intros p H_uniq.
  generalize dependent (extract_local_gfuns_program p).
  intro orig_qns; intros.
  pose proof (skeleton_gfun_sigs_names_unique_l (program_skeleton p)) as H_uniq_gfuns;
    pose proof (program_has_all_gfun_bods_l p);
    unfold gfun_sigs_names_unique in H_uniq_gfuns; unfold has_all_gfun_bods in H;
      rewrite H in H_uniq_gfuns; clear H.
  unfold extract_gfuns_by_depth in *; simpl.

  induction (program_gfun_bods_l p) as [| bod bods]; auto.
  simpl in H_uniq_gfuns.
  inversion_clear H_uniq_gfuns as [| _x _xx H_nin H_uniq_bod].
Admitted. (* check Results.v for details on missing proofs *)

Lemma sort_gfuns_for_inline_permutes': forall (p : program),
    unique (flat_map extract_local_gfuns_expr (map snd (flat_map snd (program_gfun_bods_l p))) ++ extract_local_gfuns_program p) ->
    Permutation (program_gfun_bods_l p) (sort_gfuns_for_inline p (program_gfun_bods_l p)).
Proof.
  intros p H.
  unfold sort_gfuns_for_inline.
  apply sort_by_index_list_permutes.
  exists fst.
  split; [ | symmetry; apply eq_QName_eq].
  apply extract_gfuns_by_depth_permutes; easy.
Qed.

Lemma sort_gfuns_for_inline_permutes: forall (p : program),
    Permutation (program_gfun_bods_l p) (sort_gfuns_for_inline p (program_gfun_bods_l p)).
Proof.
Admitted. (* check Results.v for details on missing proofs *)

Definition new_gfun_sigs_l (s : skeleton) (qns: list QName) :=
  sort_by_index_list (fun qn sig => eq_QName qn (fst sig)) qns (skeleton_gfun_sigs_l s).

Lemma new_gfun_sigs_in_cdts_l: forall (s : skeleton) (qns : list QName)
                                (H: Permutation qns (map fst (skeleton_gfun_sigs_l s))),
    gfun_sigs_in_cdts (skeleton_cdts s) (new_gfun_sigs_l s qns).
Proof.
  intros s qns H.
  unfold gfun_sigs_in_cdts.
  unfold new_gfun_sigs_l.
  eapply Permutation_Forall;
  [ | pose proof (skeleton_gfun_sigs_in_cdts_l s); unfold gfun_sigs_in_cdts in H0; eauto].
  apply sort_by_index_list_permutes.
  exists fst; split; auto.
  clear; intros a b.
  split; apply eq_QName_eq; auto.
Qed.

Lemma new_gfun_sigs_names_unique_l: forall (s : skeleton) (qns : list QName)
                                (H: Permutation qns (map fst (skeleton_gfun_sigs_l s))),
    gfun_sigs_names_unique (new_gfun_sigs_l s qns).
Proof.
  intros s qns H.
  pose proof (skeleton_gfun_sigs_names_unique_l s).
  unfold gfun_sigs_names_unique in *.
  unfold new_gfun_sigs_l.
  eapply Permutation_unique; [| eassumption].
  apply Permutation_map.
  apply sort_by_index_list_permutes.
  exists fst; split; auto.
  clear; intros a b.
  split; apply eq_QName_eq.
Qed.

Definition sort_gfuns_for_inline_skeleton (s : skeleton) (qns: list QName)
           (H: Permutation qns (map fst (skeleton_gfun_sigs_l s)))
            : skeleton :=
  let gfun_sigs := new_gfun_sigs_l s qns in
  {|
    skeleton_dts := skeleton_dts s;
    skeleton_ctors := skeleton_ctors s;
    skeleton_dts_ctors_in_dts := skeleton_dts_ctors_in_dts s;
    skeleton_dts_ctor_names_unique := skeleton_dts_ctor_names_unique s;
    skeleton_cdts := skeleton_cdts s;
    skeleton_dtors := skeleton_dtors s;
    skeleton_cdts_dtors_in_cdts := skeleton_cdts_dtors_in_cdts s;
    skeleton_cdts_dtor_names_unique := skeleton_cdts_dtor_names_unique s;
    skeleton_dts_cdts_disjoint := skeleton_dts_cdts_disjoint s;
    skeleton_fun_sigs := skeleton_fun_sigs s;
    skeleton_fun_sigs_names_unique := skeleton_fun_sigs_names_unique s;
    skeleton_cfun_sigs_g := skeleton_cfun_sigs_g s;
    skeleton_cfun_sigs_in_dts_g := skeleton_cfun_sigs_in_dts_g s;
    skeleton_cfun_sigs_names_unique_g := skeleton_cfun_sigs_names_unique_g s;
    skeleton_cfun_sigs_l := skeleton_cfun_sigs_l s;
    skeleton_cfun_sigs_in_dts_l := skeleton_cfun_sigs_in_dts_l s;
    skeleton_cfun_sigs_names_unique_l := skeleton_cfun_sigs_names_unique_l s;
    skeleton_gfun_sigs_g := skeleton_gfun_sigs_g s;
    skeleton_gfun_sigs_in_cdts_g := skeleton_gfun_sigs_in_cdts_g s;
    skeleton_gfun_sigs_names_unique_g := skeleton_gfun_sigs_names_unique_g s;
    skeleton_gfun_sigs_l := gfun_sigs;
    skeleton_gfun_sigs_in_cdts_l := new_gfun_sigs_in_cdts_l s qns H;
    skeleton_gfun_sigs_names_unique_l := new_gfun_sigs_names_unique_l s qns H;
  |}.

Definition sort_gfuns_for_inline_bods (p : program) : gfun_bods :=
  sort_gfuns_for_inline p (program_gfun_bods_l p).

Lemma sorted_gfuns_permutation_of_original_sigs: forall (p : program),
    Permutation (map fst (sort_gfuns_for_inline_bods p))
                (map fst (skeleton_gfun_sigs_l (program_skeleton p))).
Proof.
  intros p.
  unfold sort_gfuns_for_inline_bods.
  pose proof (sort_gfuns_for_inline_permutes p).
  apply (Permutation_map fst) in H.
  apply Permutation_sym in H.
  eapply (perm_trans); [ eassumption | ].
  pose proof (program_has_all_gfun_bods_l p).
  unfold has_all_gfun_bods in H0; rewrite H0; auto.
Qed.

Lemma sort_gfuns_for_inline_bods_Permutation_with_gfun_bods: forall (p : program),
    Permutation (program_gfun_bods_l p) (sort_gfuns_for_inline_bods p).
Proof.
  intros p.
  unfold sort_gfuns_for_inline_bods.
  apply sort_gfuns_for_inline_permutes.
Qed.

Definition new_skeleton (p : program) :=
  let sorted := sort_gfuns_for_inline_bods p in
  sort_gfuns_for_inline_skeleton (program_skeleton p) (map fst sorted) (sorted_gfuns_permutation_of_original_sigs p).

Lemma new_skeleton_tc:
  forall (p : program) (e : expr) (ctxt : list TypeName) (t : TypeName),
    (program_skeleton p / ctxt |- e : t) ->
    new_skeleton p / ctxt |- e : t.
Proof.
  intros p e ctxt t H.
  unfold new_skeleton.
  gen_dep (ctxt, t);
    induction e using expr_strong_ind; intros;
      match goal with
      | [ H: _ / _ |- _ : _ |- _ ] =>
        inversion_clear H
      end.
  - apply T_Var; auto.
  - eapply T_Constr; eauto.
    clear H1.
    gen_induction cargs ls.
    + inversion_clear H2.
      apply ListTypeDeriv_Nil.
    + destruct cargs; inversion_clear H2.
      inversion_clear H.
      apply ListTypeDeriv_Cons; auto.
  - eapply T_DestrCall; eauto.
    clear H1.
    gen_induction dargs ls; destruct dargs; inversion_clear H3; try apply ListTypeDeriv_Nil.
    inversion_clear H.
    apply ListTypeDeriv_Cons; auto.
  - eapply T_FunCall; eauto.
    clear H1.
    gen_induction argts ls; destruct argts; inversion_clear H2; try apply ListTypeDeriv_Nil.
    inversion_clear H.
    apply ListTypeDeriv_Cons; auto.
  - eapply T_GlobalConsFunCall; eauto.
    clear H1.
    gen_induction argts ls; destruct argts; inversion_clear H3; try apply ListTypeDeriv_Nil.
    inversion_clear H.
    apply ListTypeDeriv_Cons; auto.
  - eapply T_LocalConsFunCall; eauto.
    clear H1.
    gen_induction argts ls; destruct argts; inversion_clear H3; try apply ListTypeDeriv_Nil.
    inversion_clear H.
    apply ListTypeDeriv_Cons; auto.
  - eapply T_GlobalGenFunCall; eauto.
    clear H1.
    gen_induction argts ls; destruct argts; inversion_clear H2; try apply ListTypeDeriv_Nil.
    inversion_clear H.
    apply ListTypeDeriv_Cons; auto.
  - eapply T_LocalGenFunCall; eauto.
    + match goal with
      | [ H: In _ ?ls |- In _ ?ls'] =>
        eapply Permutation_in; [ | eassumption ]
      end.
      unfold sort_gfuns_for_inline_skeleton; simpl.
      unfold new_gfun_sigs_l.
      apply sort_by_index_list_permutes.
      exists fst; split; [ | intros; split; apply eq_QName_eq ].
      apply sorted_gfuns_permutation_of_original_sigs.
    + clear H1.
    gen_induction argts ls; destruct argts; inversion_clear H2; try apply ListTypeDeriv_Nil.
    inversion_clear H.
    apply ListTypeDeriv_Cons; auto.
  - eapply T_Match; eauto.
    + subst. clear - H4 H0.
      gen_induction bindings_types bindings_exprs; destruct bindings_types; inversion_clear H4; try apply ListTypeDeriv_Nil.
      simpl in H0; inversion_clear H0.
      apply ListTypeDeriv_Cons; auto.
    + clear - H7 H.
      gen_induction ctorlist ls; destruct ctorlist; inversion_clear H7; try apply ListTypeDeriv'_Nil.
      inversion_clear H; simpl.
      apply ListTypeDeriv'_Cons; auto.
  - eapply T_CoMatch; eauto.
    + subst. clear - H3 H0.
      gen_induction bindings_types bindings_exprs; destruct bindings_types; inversion_clear H3; try apply ListTypeDeriv_Nil.
      simpl in H0; inversion_clear H0.
      apply ListTypeDeriv_Cons; auto.
    + clear - H6 H.
      gen_induction dtorlist ls; destruct dtorlist; inversion_clear H6; try apply ListTypeDeriv'_Nil.
      inversion_clear H; simpl.
      apply ListTypeDeriv'_Cons; auto.
  - eapply T_Let; eauto.
Qed.

Lemma new_program_fun_bods_tc: forall (p : program),
    fun_bods_typecheck (new_skeleton p) (program_fun_bods p).
Proof.
  intros p.
  pose proof (program_fun_bods_typecheck p).
  unfold fun_bods_typecheck in *.
  match goal with
  | [ H: Forall ?P1 ?ls |- Forall ?P2 ?ls ] =>
    apply (@Forall_impl _ P1); auto
  end.
  clear; intros a H.
  repeat match goal with
         | [ H: exists _, _ |- _ ] =>
           inversion_clear H
         end.
  inversion_clear H0.
  repeat eexists; eauto.
  apply new_skeleton_tc; assumption.
Qed.

Lemma new_program_cfun_bods_g_tc: forall (p : program),
    cfun_bods_g_typecheck (new_skeleton p) (program_cfun_bods_g p).
Proof.
  intros p.
  pose proof (program_cfun_bods_typecheck_g p).
  unfold cfun_bods_g_typecheck in *.
  match goal with
  | [ H: Forall ?P1 ?ls |- Forall ?P2 ?ls ] =>
    apply (@Forall_impl _ P1); auto
  end.
  clear; intros a H.
  repeat match goal with
         | [ H: exists _, _ |- _ ] =>
           inversion_clear H
         end.
  inversion_clear H0.
  repeat eexists; eauto.
  apply new_skeleton_tc; assumption.
Qed.

Lemma new_program_cfun_bods_l_tc: forall (p : program),
    cfun_bods_l_typecheck (new_skeleton p) (program_cfun_bods_l p).
Proof.
  intros p.
  pose proof (program_cfun_bods_typecheck_l p).
  unfold cfun_bods_l_typecheck in *.
  match goal with
  | [ H: Forall ?P1 ?ls |- Forall ?P2 ?ls ] =>
    apply (@Forall_impl _ P1); auto
  end.
  clear; intros a H.
  repeat match goal with
         | [ H: exists _, _ |- _ ] =>
           inversion_clear H
         end.
  inversion_clear H0.
  repeat eexists; eauto.
  apply new_skeleton_tc; assumption.
Qed.

Lemma new_program_gfun_bods_g_tc: forall (p : program),
    gfun_bods_g_typecheck (new_skeleton p) (program_gfun_bods_g p).
Proof.
  intros p.
  pose proof (program_gfun_bods_typecheck_g p).
  unfold gfun_bods_g_typecheck in *.
  match goal with
  | [ H: Forall ?P1 ?ls |- Forall ?P2 ?ls ] =>
    apply (@Forall_impl _ P1); auto
  end.
  clear; intros a H.
  repeat match goal with
         | [ H: exists _, _ |- _ ] =>
           inversion_clear H
         end.
  inversion_clear H.
  repeat eexists; eauto.
  apply new_skeleton_tc; assumption.
Qed.

Lemma new_program_gfun_bods_l_tc: forall (p : program),
    gfun_bods_l_typecheck (new_skeleton p) (sort_gfuns_for_inline_bods p).
Proof.
  intros p.
  pose proof (program_gfun_bods_typecheck_l p).
  unfold gfun_bods_l_typecheck in *.
  match goal with
  | [ H: Forall ?P1 _ |- Forall ?P2 _ ] =>
    apply (@Forall_impl _ P1); auto
  end.
  - clear; intros a H.
    repeat match goal with
           | [ H: exists _, _ |- _ ] =>
             inversion_clear H
           end.
    inversion_clear H.
    repeat eexists; eauto;
      [ | apply new_skeleton_tc; eassumption].
    unfold new_skeleton.
    pose proof UtilsSkeleton.lookup_gfun_sig_name_correct_l as E.
    specialize (E _ _ _ H0); simpl in *; subst.
    unfold sort_gfuns_for_inline_skeleton; simpl;
    unfold UtilsSkeleton.lookup_gfun_sig_l in *;
    unfold UtilsSkeleton.lookup_gfun_sig_x in *; simpl.
    pose proof (skeleton_gfun_sigs_names_unique_l (program_skeleton p)) as H;
      unfold gfun_sigs_names_unique in H.
    match goal with
    | [ H: find _ ?l' = Some ?sig |- find _ ?l = Some _ ] =>
      eapply (unique_sig_lookup l sig)
    end.
    + apply find_in in H0.
      unfold new_gfun_sigs_l.
      eapply Permutation_in; [ | eassumption].
      apply sort_by_index_list_permutes.
      exists fst; split;
        [ | clear; intros; split; apply eq_QName_eq ].
      apply sorted_gfuns_permutation_of_original_sigs.
    + match goal with
      | [ H: unique ?ls |- _ ] =>
        apply (Permutation_unique ls); auto
      end.
      apply Permutation_map.
      unfold new_gfun_sigs_l.
      apply sort_by_index_list_permutes.
      exists fst; split;
        [ | clear; intros; split; apply eq_QName_eq ].
      apply sorted_gfuns_permutation_of_original_sigs.
  - match goal with
    | [ H: Forall ?P ?ls |- Forall ?P ?ls' ] =>
      apply (Permutation_Forall P ls); auto
    end.
    apply  sort_gfuns_for_inline_bods_Permutation_with_gfun_bods.
Qed.

Lemma new_program_has_all_gfun_bods_l: forall (p : program),
    has_all_gfun_bods (skeleton_gfun_sigs_l (new_skeleton p)) (sort_gfuns_for_inline_bods p).
Proof.
  intros p.
  pose proof (program_has_all_gfun_bods_l p).
  unfold has_all_gfun_bods in *.
  unfold new_skeleton.
  unfold sort_gfuns_for_inline_skeleton; simpl.
  unfold new_gfun_sigs_l.
  pose proof (skeleton_gfun_sigs_names_unique_l (program_skeleton p)).
  unfold gfun_sigs_names_unique in H0.
  rewrite H in H0.
  match goal with
  | [  |- context [sort_by_index_list ?f ?index ?to_sort] ] =>
    apply (sort_by_index_list_sorted_like_index f index to_sort)
  end;
   [ unfold sort_gfuns_for_inline_bods;
    match goal with
    | [ H: unique ?ls |- _ ] =>
      apply (Permutation_unique ls); auto
    end;
    apply Permutation_map;
    apply sort_gfuns_for_inline_permutes
    | apply sorted_gfuns_permutation_of_original_sigs
    | intros; split; apply eq_QName_eq ].
Qed.

Lemma new_program_match_names_unique: forall (p : program),
    match_names_unique (program_fun_bods p)
                       (program_cfun_bods_g p ++ program_cfun_bods_l p)
                       (program_gfun_bods_g p ++ (sort_gfuns_for_inline_bods p)).
Proof.
  intros p.
  pose proof (program_match_names_unique p).
  unfold match_names_unique in *.
  repeat (repeat rewrite map_app in *; rewrite concat_app in * ).
  match goal with
  | [ H: unique ?ls |- unique ?ls' ] =>
    apply (Permutation_unique ls); eauto
  end.
  repeat apply Permutation_app; auto.
  repeat (repeat apply Permutation_concat; apply Permutation_map).
  apply sort_gfuns_for_inline_bods_Permutation_with_gfun_bods.
Qed.

Lemma new_program_comatch_names_unique: forall (p : program),
    comatch_names_unique (program_fun_bods p)
                         (program_cfun_bods_g p ++ program_cfun_bods_l p)
                         (program_gfun_bods_g p ++ (sort_gfuns_for_inline_bods p)).
Proof.
  intros p.
  pose proof (program_comatch_names_unique p).
  unfold comatch_names_unique in *.
  repeat (repeat rewrite map_app in *; rewrite concat_app in * ).
  match goal with
  | [ H: unique ?ls |- unique ?ls' ] =>
    apply (Permutation_unique ls); eauto
  end.
  repeat apply Permutation_app; auto.
  repeat (repeat apply Permutation_concat; apply Permutation_map).
  apply sort_gfuns_for_inline_bods_Permutation_with_gfun_bods.
Qed.

Definition sort_gfuns_for_inline_program (p : program) : program :=
  let sorted := sort_gfuns_for_inline_bods p in
  let new_skel := new_skeleton p in
  {|
    program_skeleton := new_skel;
    program_fun_bods := program_fun_bods p;
    program_has_all_fun_bods := program_has_all_fun_bods p;
    program_fun_bods_typecheck := new_program_fun_bods_tc p;
    program_cfun_bods_g := program_cfun_bods_g p;
    program_has_all_cfun_bods_g := program_has_all_cfun_bods_g p;
    program_cfun_bods_typecheck_g := new_program_cfun_bods_g_tc p;
    program_cfun_bods_l := program_cfun_bods_l p;
    program_has_all_cfun_bods_l := program_has_all_cfun_bods_l p;
    program_cfun_bods_typecheck_l := new_program_cfun_bods_l_tc p;
    program_gfun_bods_g := program_gfun_bods_g p;
    program_has_all_gfun_bods_g := program_has_all_gfun_bods_g p;
    program_gfun_bods_typecheck_g := new_program_gfun_bods_g_tc p;
    program_gfun_bods_l := sorted;
    program_has_all_gfun_bods_l := new_program_has_all_gfun_bods_l p;
    program_gfun_bods_typecheck_l := new_program_gfun_bods_l_tc p;
    program_match_names_unique := new_program_match_names_unique p;
    program_comatch_names_unique := new_program_comatch_names_unique p;
  |}.

Lemma contains_at_most_list_Permutation: forall (qn : QName) (ls ls' : list expr),
    Permutation ls ls' ->
    contains_at_most_one_local_gfun_call_list qn ls ->
    contains_at_most_one_local_gfun_call_list qn ls'.
Proof.
  intros qn ls ls' H_per H_most.
  inversion_clear H_most as [H_no|H_one]; [ left; eapply Permutation_Forall; eauto | right ].
  induction H_per; auto.
  - inversion_clear H_one.
    + apply contains_one_local_gfun_call_list_here; auto.
      eapply Permutation_Forall; eauto.
    + apply contains_one_local_gfun_call_list_there; auto.
  - repeat match goal with
           | [ H: contains_one_local_gfun_call_list _ (_ :: _) |- _ ] =>
             inversion_clear H
           end;
      repeat match goal with
             | [ H: Forall _ (_ :: _) |- _ ] =>
               inversion_clear H
             end.
    + apply contains_one_local_gfun_call_list_there; auto.
      apply contains_one_local_gfun_call_list_here; auto.
    + apply contains_one_local_gfun_call_list_here; auto.
    + repeat apply contains_one_local_gfun_call_list_there; auto.
Qed.

Lemma sort_gfuns_for_inline_preserves_local_gfuns_only_used_once: forall (p : program),
    local_gfuns_only_used_once p ->
    local_gfuns_only_used_once (sort_gfuns_for_inline_program p).
Proof.
  intros p H.
  unfold local_gfuns_only_used_once in *.
  unfold sort_gfuns_for_inline_program in *; simpl.
  unfold new_gfun_sigs_l.
  match goal with
  | [ H: Forall ?P1 _ |- Forall ?P2 ?ls ] =>
    apply (@Forall_impl _ P1)
  end.
  - intro qn.
    apply contains_at_most_list_Permutation.
    repeat apply Permutation_app; auto.
    apply Permutation_map.
    repeat rewrite flat_map_concat_map.
    apply Permutation_concat.
    apply Permutation_map.
    apply sort_gfuns_for_inline_bods_Permutation_with_gfun_bods.
  - match goal with
    | [ H: Forall ?P ?ls |- Forall ?P ?ls' ] =>
      eapply (Permutation_Forall P); [ | eapply H]
    end.
    apply Permutation_map.
    apply sort_by_index_list_permutes.
    exists fst; split;
      [ | clear; intros; split; apply eq_QName_eq].
    apply sorted_gfuns_permutation_of_original_sigs.
Qed.

Lemma sort_gfuns_for_inline_ordered_gfun: forall (p : program),
    local_gfuns_only_used_once p ->
    inline_ordered_gfun (sort_gfuns_for_inline_bods p).
Proof.
  intros p H.
  unfold sort_gfuns_for_inline_bods.
  unfold sort_gfuns_for_inline.
Admitted. (* check Results.v for details on missing proofs *)

Theorem sort_gfuns_for_inline_program_ordered_gfun: forall (p : program),
    local_gfuns_only_used_once p ->
    inline_ordered_gfun (program_gfun_bods_l (sort_gfuns_for_inline_program p)).
Proof.
  intros p H. simpl.
  apply sort_gfuns_for_inline_ordered_gfun; assumption.
Qed.


Require Export Bedrock.Platform.Cito.StringMap Bedrock.Platform.Cito.StringMapFacts.
Require Export Bedrock.Platform.Cito.SyntaxExpr Bedrock.Platform.Facade.DFacade.
Require Import Bedrock.Platform.Facade.DFacadeFacts2.
Require Import Coq.Setoids.Setoid.

Add Parametric Morphism {av} : (@eval av)
    with signature (StringMap.Equal ==> eq ==> eq)
      as eval_Morphism.
Proof.
  eauto using DFacadeFacts2.eval_Morphism.
Qed.

Lemma IL_weqb_refl : forall x,
    IL.weqb x x = true.
Proof.
  unfold IL.weqb.
  intros; rewrite Word.weqb_true_iff; reflexivity.
Qed.

Lemma IL_weqb_sound : forall x y,
    IL.weqb x y = true -> x = y.
Proof.
  eauto using Word.weqb_sound.
Qed.

Add Parametric Morphism {av} {env} {prog} : (@Safe av env prog)
    with signature (StringMap.Equal ==> iff)
      as Safe_Morphism.
Proof.
  eauto using DFacadeFacts2.Safe_Morphism.
Qed.

Add Parametric Morphism {av} {env} {prog} : (@RunsTo av env prog)
    with signature (StringMap.Equal ==> StringMap.Equal ==> iff)
      as RunsTo_Morphism.
Proof.
  eauto using DFacadeFacts2.RunsTo_Morphism.
Qed.

Require Import GLabelMap GLabelMapFacts.
Require Import Program.Basics.

Add Parametric Morphism av
  : (@RunsTo av)
    with signature
    (GLabelMap.Equal ==> eq ==> StringMap.Equal ==> StringMap.Equal ==> impl)
      as Proper_RunsTo.
Proof.
  unfold impl; intros.
  revert y y1 y2 H0 H1 H.
  induction H2; intros.
  - econstructor; rewrite <- H0, <- H1; eauto.
  - econstructor 2; eauto.
    eapply IHRunsTo1; eauto.
    reflexivity.
    eapply IHRunsTo2; eauto.
    reflexivity.
  - econstructor 3; eauto.
    unfold is_true, eval_bool.
    setoid_rewrite <- H0; apply H.
  - econstructor 4; eauto.
    unfold is_false, eval_bool.
    setoid_rewrite <- H0; apply H.
  - econstructor 5; eauto.
    unfold is_true, eval_bool.
    setoid_rewrite <- H0; apply H.
    eapply IHRunsTo1; eauto.
    reflexivity.
    eapply IHRunsTo2; eauto.
    reflexivity.
  - econstructor 6; eauto.
    unfold is_false, eval_bool.
    setoid_rewrite <- H1; apply H.
    rewrite <- H1, <- H2; eauto.
  - econstructor 7;
    rewrite <- H2; eauto.
    rewrite <- H1; symmetry; eauto.
  - econstructor 8; eauto.
    rewrite <- H8; eauto.
    rewrite <- H6; eauto.
    rewrite <- H6; eauto.
    rewrite <- H7.
    subst st'; subst st'0; rewrite <- H6; eauto.
  - econstructor 9; eauto.
    rewrite <- H9; eauto.
    rewrite <- H7; eauto.
    rewrite <- H7; eauto.
    eapply IHRunsTo; eauto.
    reflexivity.
    reflexivity.
    subst st'; subst st'0; subst output; rewrite <- H8.
    rewrite <- H7; eauto.
Qed.

Add Parametric Morphism av
  : (@Safe av)
    with signature
    (GLabelMap.Equal ==> eq ==> StringMap.Equal ==> impl)
      as Proper_Safe.
Proof.
  unfold impl; intros.
  rewrite <- H0.
  apply Safe_coind with (R := fun st ext => Safe x st ext); eauto.
  - intros; inversion H2; subst; intuition.
    eapply H4.
    setoid_rewrite H; eauto.
  - intros; inversion H2; subst; intuition.
  - intros; inversion H2; try subst; intuition.
    left; intuition eauto.
    subst loop; subst loop1; subst loop2.
    rewrite <- H4.
    eapply H8.
    rewrite H; eauto.
  - intros; inversion H2; try subst; intuition.
    eauto.
  - intros; inversion H2; try subst; intuition.
    + eexists; intuition eauto.
      left; eexists; intuition eauto.
      rewrite <- H; eauto.
    + eexists; intuition eauto.
      right; eexists; intuition eauto.
      rewrite <- H; eauto.
      eapply H12; eauto.
      rewrite H; eauto.
      eapply H12.
      rewrite H; eauto.
Qed.

Add Parametric Morphism elt
  : (@GLabelMapFacts.UWFacts.WFacts.P.update elt)
    with signature
    (GLabelMap.Equal ==> GLabelMap.Equal ==> GLabelMap.Equal)
      as GLabelMapFacts_UWFacts_WFacts_P_update_morphism.
Proof.
  apply GLabelMapFacts.UWFacts.WFacts.P.update_m.
Qed.

Ltac isDeterministicStmtConstructor stmt :=
  match stmt with
  | Skip => idtac
  | Seq _ _ => idtac
  | Assign _ _ => idtac
  | _ => fail 1 "This statement has multiple RunsTo and Safe constructors"
  end.

Ltac isSafelyInvertibleStmtConstructor stmt :=
  match stmt with
  | Skip => idtac
  | Seq _ _ => idtac
  | If _ _ _ => idtac
  | Call _ _ _ => idtac
  | Assign _ _ => idtac
  | _ => fail 1 "Not a safely invertible constructor"
  end.


Set Implicit Arguments.

Require Import AutoSep.

Definition empty_vs : vals := fun _ => $0.

Definition has_extra_stack sp offset e_stack e_stack_real :=
  ((sp ^+ $4) =*> $(e_stack) *
   (sp ^+ $8 ^+ $(4 * offset)) =?> e_stack_real)%Sep.

Definition cptr_AlX G (p : W) (stn : settings) a : propX _ _ G :=
  (ExX,
   Cptr p #0 /\
   Al st : state,
           AlX : settings * smem,
                 a (stn, st) ---> #1 (stn, st))%PropX.

Require Import ADT.

Module Make (Import E : ADT).

  Require Import Semantics.
  Module Import SemanticsMake := Semantics.Make E.

  Fixpoint make_triples pairs (outs : list ArgOut) :=
    match pairs, outs with
      | p :: ps, o :: os => {| Word := fst p; ADTIn := snd p; ADTOut := o |} :: make_triples ps os
      | _, _ => nil
    end.

  Definition store_pair heap (p : W * ArgIn) :=
    match snd p with
      | inl _ => heap
      | inr a => heap_upd heap (fst p) a
    end.

  Definition make_heap pairs := fold_left store_pair pairs heap_empty.

  Require Import RepInv.

  Module Make (Import R : RepInv E).

    Require Import Bags.

    Definition is_heap (h : Heap) : HProp := starL (fun p => rep_inv (fst p) (snd p)) (heap_elements h).

    Section TopSection.

      Definition is_state sp rp e_stack e_stack_real vars (v : State) temps : HProp :=
        (
          locals vars (fst v) 0 (sp ^+ $8) *
          array temps (sp ^+ $8 ^+ $(4 * length vars)) *
          is_heap (snd v) *
          sp =*> rp *
          has_extra_stack sp (length vars + length temps) e_stack e_stack_real
        )%Sep.

      Require Import Malloc.
      Require Import Basics.

      Definition layout_option addr ret : HProp :=
        match ret with
          | None  => ([| True |])%Sep
          | Some a => rep_inv addr a
        end.

      Definition word_scalar_match (p : W * ArgIn) :=
        let word := fst p in
        let in_ := snd p in
        match in_ with
          | inl w => word = w
          | _ => True
        end.

      Definition good_scalars pairs := List.Forall word_scalar_match pairs.

      Open Scope type.

      Require Import ConvertLabel.
      (* universe inconsistency *)
      Set Printing Universes.
      Definition internal_spec G fs spec st : propX _ _ (settings * smem :: G) :=
        (Ex v, Ex rp, Ex e_stack,
         ![^[is_state st#Sp rp e_stack e_stack (ArgVars spec) v nil * mallocHeap 0] * #0] st /\
         let stn := fst st in
         let env := (from_bedrock_label_map (Labels stn), fs stn) in
         [| Safe env (Body spec) v |] /\
         (st#Rp, stn)
           @@@ (
             st' ~> Ex v', Ex rp',
             (* the callee needn't have the right extra stack size recorded in the end, but the extra stack should be there *)
             Ex e_stack',
             ![^[ is_state st'#Sp rp' e_stack' e_stack (ArgVars spec) v' nil * mallocHeap 0] * #1] st' /\
             [| exists vs',
                RunsTo env (Body spec) v (vs', snd v') /\
                st'#Rv = sel vs' (RetVar spec) /\
                st'#Sp = st#Sp |]))%PropX.

      Definition foreign_spec G spec st : propX _ _ (settings * smem :: G) :=
        (Ex pairs, Ex rp, Ex e_stack,
         let heap := make_heap pairs in
         ![^[is_state st#Sp rp e_stack e_stack nil (empty_vs, heap) (map fst pairs) * mallocHeap 0] * #0] st /\
         let stn := fst st in
         [| disjoint_ptrs pairs /\
            good_scalars pairs /\
            PreCond spec (map snd pairs) |] /\
         (st#Rp, stn)
           @@@ (
             st' ~> Ex args', Ex addr, Ex ret, Ex rp', Ex outs,
             let t := decide_ret addr ret in
             let ret_w := fst t in
             let ret_a := snd t in
             let triples := make_triples pairs outs in
             let heap := fold_left store_out triples heap in
             (* the callee needn't have the right extra stack size recorded in the end, but the extra stack should be there *)
             Ex vs, Ex e_stack',
             ![^[is_state st#Sp rp' e_stack' e_stack nil (vs, heap) args' * layout_option ret_w ret_a * mallocHeap 0] * #1] st' /\
             [| length outs = length pairs /\
                PostCond spec (map (fun x => (ADTIn x, ADTOut x)) triples) ret /\
                length args' = length triples /\
                st'#Rv = ret_w /\
                st'#Sp = st#Sp |]))%PropX.

      Definition funcs_ok stn (fs : settings -> W -> option Callee) : PropX W (settings * state) :=
        ((Al i, Al spec,
          [| fs stn i = Some (Internal spec) |]
            ---> cptr_AlX i stn (internal_spec _ fs spec)) /\
         (Al i, Al spec,
          [| fs stn i = Some (Foreign spec) |]
            ---> cptr_AlX i stn (foreign_spec _ spec)))%PropX.

      Section vars.

        Variable vars : list string.

        Variable temp_size : nat.

        Definition inv_template rv_precond rv_postcond s : assert :=
          st ~> Ex fs,
          let stn := fst st in
          funcs_ok stn fs /\
          ExX, Ex v, Ex temps, Ex rp, Ex e_stack,
          ![^[is_state st#Sp rp e_stack e_stack vars v temps * mallocHeap 0] * #0] st /\
          let env := (from_bedrock_label_map (Labels stn), fs stn) in
          [| Safe env s v /\
             length temps = temp_size /\
             rv_precond st#Rv v |] /\
          (rp, stn)
            @@@ (
              st' ~> Ex v', Ex temps',
              ![^[is_state st'#Sp rp e_stack e_stack vars v' temps' * mallocHeap 0] * #1] st' /\
              [| RunsTo env s v v' /\
                 length temps' = temp_size /\
                 st'#Sp = st#Sp /\
                 rv_postcond st'#Rv (fst v') |]).

        Definition inv := inv_template (fun _ _ => True).

      End vars.

    End TopSection.

  End Make.

End Make.


Set Primitive Projections.

Inductive ConeF (X A : Type) : Type :=
| Z : A -> ConeF X A
| S : X -> ConeF X A.

Arguments Z {X A} _.
Arguments S {X A} _.

CoInductive Cone (A : Type) : Type := MkCone
{
  Out : ConeF (Cone A) A;
}.

Arguments MkCone {A} _.
Arguments Out {A} _.


From isla Require Import opsem.

Definition a18 : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R1" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 39%Z (Val (Val_Symbolic 38%Z) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 44%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (ZeroExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xffffffffffffffff%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 48%Z (Unop (Extract 63%N 0%N) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop Concat [Manyop Concat [Manyop Concat [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Bvnot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 48%Z) Mk_annot) (Unop (Extract 63%N 0%N) (Val (Val_Bits (BV 128%N 0x3f%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Val (Val_Symbolic 48%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (SignExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (SignExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xffffffffffffffffffffffffffffffff%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
  Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
  Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
  Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
  Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
  Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  tnil
.


(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import QArith.Qround.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.ProductMetric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.reals.fast.RasterizeQ.
Require Import CoRN.reals.fast.Interval.
Require Export CoRN.metric2.Graph.
Require Import CoRN.model.totalorder.QMinMax.
Require Export CoRN.model.totalorder.QposMinMax.

(**
* Plotting
Plotting a uniformly continuous function on a finite interval consists
of producing the graph of a function as a compact set, approximating that
graph, and finally rasterizing that approximation.

A range for the plot must be provided. We choose to clamp the plotted
function so that it lies inside the specified range.  Thus we plot
[compose (clip b t) f] rather than [f].

Afterwards we will plot more general located subsets of the plane:
- Each blank pixels is correct, meaning there are no points of the subset
  inside the rectangular regions it represents. In other words, filled
  pixels cover the subset.
- Each filled pixel means there exists a point of the subset inside its
  rectangular region, or inside one of the adjacent pixels. Thus when we
  zoom in the filled pixels, we will see more structure.
- The pixels overlap, meaning each edge belongs to the 2 pixels that
  touch it, and each corner belongs to the 4 pixels that touch it.

*)

Local Open Scope uc_scope.

Section PlotPath.
Variable (from to:Q).
Hypothesis Hfromto:from<=to.

Variable (l r:Q).
Hypothesis Hlr : l < r.

Variable (b t:Q).
Hypothesis Hbt : b < t.

Variable n : positive.

Let w := r - l.
Let h := t - b.

Lemma wpos : 0 < w.
Proof.
  apply Qlt_minus_iff in Hlr. exact Hlr.
Qed.

Lemma hpos : 0 < h.
Proof.
  apply Qlt_minus_iff in Hbt. exact Hbt.
Qed.

(* Compute the number of pixels on the Y-axis to make square pixels. *)
Let m : positive := Z.to_pos (Qceiling ((t-b) * inject_Z (Z.pos n) / (r-l))).

(**
Half the error in the Plot example, since we need to approximate twice.
*)
Let err := Qpos_max ((1 # 8 * n) * (exist _ _ wpos))
                    ((1 # 8 * m) * (exist _ _ hpos)).

Variable path:Q_as_MetricSpace --> Complete Q2.

(** The actual plot function.
    The approximation of PathImage make a list (Complete Q2), ie a list
    of points in the real plane. Those points still need to be approximated
    by rational numbers, which map approximate does. *)
Definition PlotPath : positive * positive * Q * sparse_raster n m
  := (n, m, 2#1,
      sparse_raster_data n m
    (map
       (fun x : Z =>
        rasterize2 n m t l b r
          ((let (approximate, _) :=
              path
                (from +
                 (to - from) * (2 * x + 1 # 1) /
                 (2 *
                  Z.pos
                    (Z.to_pos
                       (Qceiling
                          ((to - from) /
                           (inject_Z 2 *
                            proj1_sig (FinEnum_map_modulus (1 # 1) (mu path) err)))))
                  # 1)) in
            approximate) err))
       (iterateN_succ 0
          (Z.to_pos
             (Qceiling
                ((to - from) /
                 (inject_Z 2 * proj1_sig (FinEnum_map_modulus (1 # 1) (mu path) err)))))))).

Definition PlotPath_slow : positive * positive * Q * sparse_raster n m
  := (n, m, 2#1,
      RasterizeQ2
        (map (fun x : Q_as_MetricSpace => approximate (path x) err)
             (approximate (CompactIntervalQ Hfromto)
                          (FinEnum_map_modulus (1 # 1) (mu path) err)))
        n m t l b r).

Lemma PlotPath_correct : eq PlotPath PlotPath_slow.
Proof.
  unfold PlotPath, PlotPath_slow, RasterizeQ2.
  rewrite map_map.
  unfold CompactIntervalQ, approximate.
  unfold CompactIntervalQ_raw, UniformPartition.
  rewrite map_map.
  reflexivity.
Qed.

End PlotPath.

Lemma plFEQ : PrelengthSpace (FinEnum Q_as_MetricSpace).
Proof.
 apply FinEnum_prelength.
  apply locatedQ.
 apply QPrelengthSpace.
Qed.

Section Plot.

Variable (l b:Q).
Variable w h:Qpos.

Let r:=l+proj1_sig w.
Let t:=b+proj1_sig h.

Let clip := uc_compose (boundBelow b) (boundAbove t).

Variable f : Q_as_MetricSpace --> CR.

Lemma lrle : l <= r.
Proof.
  rewrite <- (Qplus_0_r l).
  unfold r. apply Qplus_le_r, Qpos_nonneg.
Qed.

Definition graphQ f : Compact Q2
  := CompactGraph_b f plFEQ (CompactIntervalQ lrle).

Lemma graphQ_bonus : forall e x y,
    In (x, y) (approximate (graphQ (uc_compose clip f)) e)
    -> l <= x <= r /\ b <= y <= t.
Proof.
 intros [e|] x y;[|intros; contradiction].
 simpl.
 unfold Cjoin_raw.
 Opaque CompactIntervalQ.
 simpl.
 unfold FinCompact_raw.
 rewrite map_map.
 rewrite -> in_map_iff.
 unfold graphPoint_b_raw; simpl.
 unfold Couple_raw; simpl.
 intros [z [Hz0 Hz1]].
 inversion Hz0.
 subst x. subst y.
 clear Hz0.
 split.
 eapply CompactIntervalQ_bonus_correct.
 apply Hz1.
 split. apply Qmax_ub_l.
 apply Qmax_lub.
 rewrite <- (Qplus_0_r b).
 unfold t. apply Qplus_le_r, Qpos_nonneg.
 apply Qmin_lb_l.
Qed.

Variable n m : positive. (* Number of horizontal and vertical pixels *)

Let err := Qpos_max ((1 # 4 * n) * w)
                    ((1 # 4 * m) * h).

(** [PlotQ] is the function that computes the pixels. *)
Definition PlotQ : sparse_raster n m
  := RasterizeQ2 (approximate (graphQ (uc_compose clip f)) err) n m t l b r.

Local Open Scope raster.

(** The resulting plot is close to the graph of [f] *)
Theorem Plot_correct :
  @ball (Compact Q2)
        (proj1_sig (err + Qpos_max ((1 # 2 * n) * w) ((1 # 2 * m) * h))%Qpos)
        (graphQ (uc_compose clip f))
        (Cunit (CentersOfPixels (PixelizeQ2 PlotQ) (l,t) (r,b))).
Proof.
 apply ball_triangle with (Cunit (approximate (graphQ (uc_compose clip f)) err)).
  apply ball_approx_r.
 unfold Compact.
 rewrite -> ball_Cunit.
 apply ball_sym.
  split. apply Qpos_nonneg.
  apply RasterizeQ2_correct.
  intros.
  destruct (InStrengthen H) as [[zx xy] [Hz0 [Hz1 Hz2]]].
  simpl in Hz1, Hz2.
  apply Qball_0 in Hz1.
  apply Qball_0 in Hz2.
  rewrite -> Hz1, Hz2.
  eapply graphQ_bonus.
  apply Hz0.
Qed.

End Plot.

(** Some nice notation for the graph of f. *)
Notation "'graphCR' f [ l '..' r ]" :=
 (graphQ l r (refl_equal _) f) (f at level 0) : raster.

(*
(* Some graph examples *)
Local Open Scope raster. (* enables pretty printing of rasters *)
Definition id_raster : raster _ _
  := PlotQ 0 1 eq_refl 0 1 eq_refl (@Cunit Q_as_MetricSpace) 30 30.
Compute id_raster.

Require Import CoRN.reals.fast.CRexp.
Definition exp_raster
  := PlotQ (-2) 1 eq_refl 0 3 eq_refl (exp_bound_uc 3) 30 30.
Compute exp_raster.
*)

(* Difficult to make tail-recursive, because the current vector
   has no clear size to declare. Vector.map is not tail-recursive either. *)
Fixpoint PlotLine (A : CR*CR -> Prop) (i:nat)
           (r step:Q) (y : CR) (d e:Q) (ltde : d < e)
           (loc : LocatedSubset (ProductMS CR CR) A)
           { struct i }
  : list bool :=
  match i with
  | O => nil
  | S p =>
    cons (let xi := inject_Q_CR (r - inject_Z (Z.of_nat i) * step)%Q in
          if loc d e (xi,y) ltde then false else true)
         (PlotLine A p r step y d e ltde loc)
  end.

Fixpoint PlotSubset_fix (A : CR*CR -> Prop) (n j:nat)
         (b r stepX stepY:Q) (d e:Q) (ltde : d < e)
         (loc : LocatedSubset (ProductMS CR CR) A)
         { struct j }
  : list (list bool) :=
  match j with
  | O => nil
  | S p => let yj := inject_Q_CR (b + inject_Z (Z.of_nat j) * stepY)%Q in
          cons (PlotLine A n r stepX yj d e ltde loc)
               (PlotSubset_fix A n p b r stepX stepY d e ltde loc)
  end.

Definition PlotRadius (n m : positive) (t l b r : Q) : Q
  := Qmax ((r-l) * (1#n))%Q
          ((t-b) * (1#m))%Q.

Lemma PlotRadiusInc
  : forall n m t l b r,
    l < r -> (1#2) * PlotRadius n m t l b r < PlotRadius n m t l b r.
Proof.
  intros. rewrite <- (Qmult_1_l (PlotRadius n m t l b r)) at 2.
  apply Qmult_lt_r.
  2: reflexivity. apply (Qlt_le_trans _ ((r-l) * (1#n))%Q).
  apply Qlt_minus_iff in H.
  apply (Qpos_ispos (exist _ _ H * (1 # n))).
  apply Qmax_ub_l.
Qed.

Definition PlotSubset {A : CR*CR -> Prop} (n m : positive) (t l b r : Q)
           (ltlr : l < r) (loc : LocatedSubset (ProductMS CR CR) A)
  : raster n m
  := let stepX := ((r-l) * (1#n))%Q in
     let stepY := ((t-b) * (1#m))%Q in
     (* A pixel is a square ball and its radius it half its side. *)
     raster_data
       _ _
       (PlotSubset_fix A (Pos.to_nat n) (Pos.to_nat m) (b-(1#2)*stepY) (r+(1#2)*stepX)
                       stepX stepY _ _
                       (PlotRadiusInc n m t l b r ltlr) loc).

(*
Definition PlotDiagLocated := (PlotSubset
         10 10 (1#1) (0#1) (0#1) (1#1) eq_refl
         (undistrib_Located (CompactIsLocated
         _ (graphQ 0 1 eq_refl (@Cunit Q_as_MetricSpace))
         (ProductMS_located locatedQ locatedQ)))).
Local Open Scope raster. (* enables pretty printing of rasters *)
Time Eval vm_compute in PlotDiagLocated.
*)

(* The blank pixels have no points of the subset, in other words
   the filled pixels cover the subset. *)
Lemma PlotLine_blank
  : forall (A : CR*CR -> Prop) (n i:nat) (ltni : (n < i)%nat)
      (r step:Q) (x y z : CR) (d e:Q) (ltde : d < e)
      (loc : LocatedSubset (ProductMS CR CR) A),
    ball d x (inject_Q_CR (r - inject_Z (Z.of_nat (i-n)) * step)%Q)
    -> ball d y z
    -> nth n (PlotLine A i r step y d e ltde loc) false = false
    -> ~A (x,z).
Proof.
  induction n.
  - intros. intro abs.
    destruct i. exfalso; inversion ltni.
    simpl in H1.
    destruct (loc d e
             (@pair (@RegularFunction Q Qball) (@RegularFunction Q Qball)
                (inject_Q_CR
                   (Qminus r (Qmult (inject_Z (Zpos (Pos.of_succ_nat i))) step))) y)
             ltde).
    2: discriminate. clear H1.
    specialize (n (x,z) abs).
    contradict n. split.
    + unfold fst.
      apply ball_sym.
      exact H.
    + exact H0.
  - intros. intro abs.
    destruct i. inversion ltni. simpl in H1.
    revert abs.
    refine (IHn i (lt_S_n n i ltni) r step x y z d e
                ltde loc _ H0 H1).
    replace (i-n)%nat with (S i - S n)%nat by reflexivity.
    exact H.
Qed.

Lemma PlotSubset_fix_blank
  : forall (A : CR*CR -> Prop) (x y : CR) (i j n m:nat)
      (ltin : (i < n)%nat) (ltjm : (j < m)%nat)
      (b r stepX stepY:Q) (d e:Q) (ltde : d < e)
      (loc : LocatedSubset (ProductMS CR CR) A),
    ball d x (inject_Q_CR (r - inject_Z (Z.of_nat (n-i)) * stepX)%Q)
    -> ball d y (inject_Q_CR (b + inject_Z (Z.of_nat (m-j)) * stepY)%Q)
    -> nth i
        (nth j (PlotSubset_fix A n m b r stepX stepY
                                    d e ltde loc)
             nil)
        false = false
    -> ~A (x,y).
Proof.
  induction j.
  - intros. intro abs.
    destruct m. exfalso; inversion ltjm.
    simpl in H1.
    refine (PlotLine_blank
              A i n ltin r stepX x
              (' (b + inject_Z (Z.pos (Pos.of_succ_nat m)) * stepY)%Q)%CR
              y d e ltde loc H _ H1 abs).
    apply ball_sym.
    exact H0.
  - intros. intro abs.
    destruct m. inversion ltjm.
    simpl in H1.
    apply (IHj n m ltin (lt_S_n j m ltjm) b r stepX stepY
                    d e ltde loc H H0 H1 abs).
Qed.

Lemma PlotSubset_blank
  : forall {A : CR*CR -> Prop} (i j : nat) (n m : positive) (t l b r : Q) (x y : CR)
      (ltin : (i < Pos.to_nat n)%nat) (ltjm : (j < Pos.to_nat m)%nat) (ltlr : l < r)
      (loc : LocatedSubset (ProductMS CR CR) A),
    RasterIndex (PlotSubset n m t l b r ltlr loc) j i = false
    -> let stepX := ((r-l) * (1#n))%Q in
      let stepY := ((t-b) * (1#m))%Q in
      ball ((1#2)*(Qmax stepX stepY)) x
           (inject_Q_CR (l + (inject_Z (Z.of_nat i) + (1#2)) * stepX)%Q)
      -> ball ((1#2)*(Qmax stepX stepY)) y
             (inject_Q_CR (t - (inject_Z (Z.of_nat j) + (1#2)) * stepY)%Q)
      -> ~A (x,y).
Proof.
  intros.
  setoid_replace (l + (inject_Z (Z.of_nat i)+(1#2)) * stepX)%Q
    with ((r + (1#2)*stepX) - inject_Z (Z.of_nat (Pos.to_nat n - i)) * stepX)%Q
    in H0.
  setoid_replace (t - (inject_Z (Z.of_nat j) + (1#2)) * stepY)%Q
    with ((b-(1#2)*stepY) + inject_Z (Z.of_nat (Pos.to_nat m - j)) * stepY)%Q
    in H1.
  exact (PlotSubset_fix_blank
           A x y i j (Pos.to_nat n) (Pos.to_nat m) ltin ltjm
           _ _ stepX stepY
           ((1#2)*(Qmax stepX stepY))
           (Qmax stepX stepY)
           (PlotRadiusInc n m t l b r ltlr) loc
           H0 H1 H).
  - unfold canonical_names.equiv, stdlib_rationals.Q_eq.
    rewrite Nat2Z.inj_sub.
    unfold Zminus. rewrite Q.Zplus_Qplus, inject_Z_opp.
    rewrite <- (Qplus_inj_r _ _ ((inject_Z (Z.of_nat j)+(1#2)) * stepY)).
    ring_simplify.
    rewrite positive_nat_Z.
    unfold stepY.
    rewrite <- Qmult_assoc.
    setoid_replace ((1 # m) * inject_Z (Z.pos m)) with 1%Q by reflexivity.
    rewrite Qmult_1_r. ring.
    apply (le_trans _ (S j)).
    apply le_S, le_refl. exact ltjm.
  - unfold canonical_names.equiv, stdlib_rationals.Q_eq.
    rewrite Nat2Z.inj_sub.
    unfold Zminus. rewrite Q.Zplus_Qplus, inject_Z_opp.
    rewrite positive_nat_Z.
    rewrite <- (Qplus_inj_r _ _ (stepX * inject_Z (Z.pos n)
                                -inject_Z (Z.of_nat i) * stepX
                                - (1#2)*stepX)).
    ring_simplify.
    unfold stepX.
    rewrite <- Qmult_assoc.
    setoid_replace ((1 # n) * inject_Z (Z.pos n)) with 1%Q by reflexivity.
    rewrite Qmult_1_r. ring.
    apply (le_trans _ (S i)).
    apply le_S, le_refl. exact ltin.
Qed.


From Perennial.program_proof Require Import disk_prelude.
From Goose.github_com.tchajed.goose Require Import unittest.

Section proof.
Context `{!heapGS Σ}.

Lemma proph_test : ⊢ WP unittest.Oracle #() {{ _, True }}.
Proof.
  wp_lam.
  wp_apply wp_NewProph_list.
  iIntros (p pvs1) "Hp".
  wp_apply (wp_ResolveProph_list with "Hp").
  iIntros (pvs2) "[_ Hp]".
  wp_apply (wp_ResolveProph_list with "Hp").
  iIntros (pvs3) "[_ Hp]".
  wp_pures. auto.
Qed.

End proof.


From ExtLib.Structures Require Import Monad MonadWriter MonadExc Monoid.
Require Import ExtLib.Data.Monads.WriterMonad.

From ExtLib.Structures Require Export MonadWriter MonadExc Monoid.

Import MonadNotation.

Open Scope monad.

Section Error.

(* Error type *)
Context {E : Type}.
(* Log type that must implement monoid typeclass *)
Context {T : Type}.
Context {MT : Monoid T}.

(* Custom monad parametrized by Error type, Log type and return type *)
Definition errW A := T -> E + (T * A).

Global Instance Monad_errW : Monad errW := {
  ret := fun _ x => fun w => inr (w, x) ;
  bind := fun _ _ m f => fun w => match m w with
                            | inl v => inl v
                            | inr (w', x) => f x (monoid_plus MT w w')
                            end
}.

Global Instance Exception_errW : MonadExc E errW := {
  raise := fun _ v => fun w => inl v ;
  catch := fun _ c h => fun w => match c w with
                           | inl v => h v w
                           | inr x => inr x
                           end
}.

Global Instance Writer_errW : MonadWriter MT errW := {
  tell := fun w => fun _ => inr (w, tt) ;
  listen := fun _ m => fun w => match m w with
                          | inl v => inl v
                          | inr (w', x) => inr (w', (x, w'))
                          end ;
  pass := fun _ m => fun w => match m w with
                        | inl v => inl v
                        | inr (w', (x, f)) => inr (f w', x)
                        end ;
}.

(* Run monad and get inner value *)
Definition evalErrW {A : Type} (e : errW A) (init : T) : option A :=
  match e init with
  | inl _ => None
  | inr (_, v) => Some v
  end.

(* Run monad and get log value *)
Definition execErrW {A : Type} (e : errW A) (init : T) : option T :=
  match e init with
  | inl _ => None
  | inr (w, _) => Some w
  end.

End Error.


Require Import FunctionalExtensionality.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.RTac.Simplify.

Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.ListType.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.SemiEqDecTyp.
Require Import Charge.ModularFunc.Denotation.

Require Import Charge.Tactics.Lists.ListTacs.
Require Import Charge.Tactics.Base.DenotationTacs.
Require Import Charge.Tactics.Base.MirrorCoreTacs.

Require Import ExtLib.Core.RelDec.

Section Zip.
  Context {typ func : Type} {RType_typ : RType typ} {RSym_func : RSym func}.
  Context {LT : ListType typ} {LTD : ListTypeD LT}.
  Context {BT : BaseType typ} {BTD : BaseTypeD BT}.
  Context {BF : BaseFunc typ func} {LF: ListFunc typ func}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.
  Context {Heqd : SemiEqDecTyp typ} {HeqdOk : SemiEqDecTypOk Heqd}.
  Context {Typ2_Fun : Typ2 RType_typ Fun}.
  Context {Typ0_Prop : Typ0 RType_typ Prop}.
  Context {BFOk : BaseFuncOk typ func} {LFOk : ListFuncOk typ func}.

  Context {RTypeOk_typ : RTypeOk}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.

  Fixpoint zipExpr (t u : typ) (e1 e2 : expr typ func) : expr typ func :=
    match e1 with
      | App (App (Inj f) x) xs =>
        match listS f with
          | Some (pCons _) =>
            match e2 with
              | App (App (Inj g) y) ys =>
                match listS g with
                  | Some (pCons _) => mkCons (tyProd t u) (mkPair t u x y) (zipExpr t u xs ys)
                  | _ => mkZip t u e1 e2
                end
              | Inj g =>
                match listS g with
                  | Some (pNil _) => mkNil (tyProd t u)
                  | _ => mkZip t u e1 e2
                end
              | _ => mkZip t u e1 e2
            end
          | _ => mkZip t u e1 e2
        end
      | Inj f =>
        match listS f with
          | Some (pNil _) => mkNil (tyProd t u)
          | _ => mkZip t u e1 e2
        end
      | _ => mkZip t u e1 e2
    end.

  (* This function should have lst is it's third arguments, but for reasons that I cannot figure out at the moment
     the function does not reduce with lst as the last argument. *)

  Fixpoint zipExprConst_left (t u : typ) (lst : list (typD u)) (e : expr typ func) : expr typ func :=
    match lst with
      | nil => mkNil (tyProd t u)
      | y :: ys =>
        match e with
	      | App (App (Inj f) x) xs =>
	        match listS f with
	          | Some (pCons _) => mkCons (tyProd t u) (mkPair t u x (mkConst u y)) (zipExprConst_left t u ys xs)
	          | _ => mkZip t u e (mkConst (tyList u) (listR lst))
	        end
	      | Inj f =>
	        match listS f with
	          | Some (pNil _) => mkNil (tyProd t u)
	          | _ => mkZip t u e (mkConst (tyList u) (listR lst))
	        end
	      | _ => mkZip t u e (mkConst (tyList u) (listR lst))
      end
    end.

  Fixpoint zipExprConst_right (t u : typ) (lst : list (typD t)) (e : expr typ func) : expr typ func :=
    match lst with
      | nil => mkNil (tyProd t u)
      | x :: xs =>
        match e with
	      | App (App (Inj f) y) ys =>
	        match listS f with
	          | Some (pCons _) => mkCons (tyProd t u) (mkPair t u (mkConst t x) y) (zipExprConst_right t u xs ys)
	          | _ => mkZip t u (mkConst (tyList t) (listR lst)) e
	        end
	      | Inj f =>
	        match listS f with
	          | Some (pNil _) => mkNil (tyProd t u)
	          | _ => mkZip t u (mkConst (tyList t) (listR lst)) e
	        end
	      | _ => mkZip t u (mkConst (tyList t) (listR lst)) e
      end
    end.

  Lemma combine_nil {A B : Type} (lst : list A) : combine lst (@nil B) = nil.
  Proof.
    destruct lst; reflexivity.
  Qed.

  Lemma trmR_nil_eq {T U : Type} {t : typ} (eq1 : typD t = T) (eq2 : typD t = U) :
    trmR nil (listE eq1) = trmR nil (listE eq2).
  Proof.
    clear.
    unfold listE, eq_ind, trmR, eq_rect_r, eq_rect, eq_sym, id.
    generalize (btList t).
    revert eq1 eq2.
    remember (tyList t).
    generalize dependent (typD t); intros; subst.
    destruct eq2.

    generalize dependent (typD (tyList t)).
    intros; subst. reflexivity.
  Qed.

    Lemma trmR_cons_eq (t : typ) T (x : T) (xs : list T) (e : typD t = T) :
      trmR (x :: xs) (listE e) = trmR ((trmR x e) :: (trmD (trmR xs (listE e)) (listE eq_refl))) (listE eq_refl).
    Proof.
      unfold trmR, trmD, listE, eq_ind, eq_rect_r, eq_rect, eq_sym, id.
      generalize (btList t).
      generalize dependent (typD t); intros; subst.
      generalize dependent (typD (tyList t)); intros; subst. reflexivity.
    Qed.

  Lemma zipExprConst_left_sound tus tvs (t u : typ) (xs : expr typ func) (ys : list (typD u))
    (xsD : ExprI.exprT tus tvs (typD (tyList t)))
    (Hxs : ExprDsimul.ExprDenote.exprD' tus tvs (tyList t) xs = Some xsD) :
	ExprDsimul.ExprDenote.exprD' tus tvs (tyList (tyProd t u)) (zipExprConst_left t u ys xs) =
	  Some (ExprDsimul.ExprDenote.exprT_App (ExprDsimul.ExprDenote.exprT_App (fun _ _ => zipD t u) xsD) (fun _ _ => listR ys)).
  Proof.
    generalize dependent xs. generalize dependent xsD.
    induction ys; simpl; intros.
    + rewrite listR_nil.
      reduce.
      rewriteD @combine_nil.
      rewrite mkNil_sound.
      erewrite trmR_nil_eq. reflexivity.
    + do 3 (destruct_exprs; try (apply mkZip_sound; [assumption | apply mkConst_sound])).
      * reduce.
        rewrite mkNil_sound.
        simpl.
        erewrite trmR_nil_eq. reflexivity.
      * do 2 (destruct_exprs; try (apply mkZip_sound; [assumption | apply mkConst_sound])).
        reduce.
        erewrite mkCons_sound; try eassumption; [| eapply mkPair_sound; [eassumption | apply mkConst_sound] | eapply IHys; eassumption].
        simpl.
        unfold consD, zipD, pairD, tyArrR2, tyArrR2', tyArrR', tyArrD, tyArrD'.
        do 6 rewrite exprT_App_tyArrD.
        unfold tyArrD, tyArrD'.
        repeat rewriteD @trmDR.
        unfold listR. unfold listD.
        unfold prodR.
        rewriteD @trmDR.
        symmetry.
        rewriteD trmR_cons_eq. reflexivity.
  Qed.

  Lemma zipExprConst_right_sound tus tvs (t u : typ) (xs : list (typD t)) (ys : expr typ func)
    (ysD : ExprI.exprT tus tvs (typD (tyList u)))
    (Hys : ExprDsimul.ExprDenote.exprD' tus tvs (tyList u) ys = Some ysD) :
	ExprDsimul.ExprDenote.exprD' tus tvs (tyList (tyProd t u)) (zipExprConst_right t u xs ys) =
	  Some (ExprDsimul.ExprDenote.exprT_App (ExprDsimul.ExprDenote.exprT_App (fun _ _ => zipD t u) (fun _ _ => listR xs)) ysD).
  Proof.
    generalize dependent ys. generalize dependent ysD.
    induction xs; simpl; intros.
    + rewrite listR_nil.
      reduce.
      rewriteD mkNil_sound.
      simpl. erewrite trmR_nil_eq; reflexivity.
    + do 3 (destruct_exprs; try (apply mkZip_sound; [apply mkConst_sound| assumption])).
      * reduce.
        rewrite mkNil_sound.
        simpl.
        erewrite trmR_nil_eq; reflexivity.
      * do 2 (destruct_exprs; try (apply mkZip_sound; [apply mkConst_sound | assumption])).
        reduce.
        erewrite mkCons_sound; try eassumption; [| eapply mkPair_sound; [apply mkConst_sound | eassumption] | eapply IHxs; eassumption].
        unfold consD, zipD, pairD, tyArrR2, tyArrR2', tyArrR', tyArrD, tyArrD'.
        do 6 rewrite exprT_App_tyArrD.
        unfold tyArrD, tyArrD'.
        repeat rewriteD @trmDR.
        unfold listR. unfold listD.
        unfold prodR.
        rewriteD @trmDR. simpl.
        symmetry.
        rewriteD trmR_cons_eq. reflexivity.
  Qed.

  Lemma zipExprOk tus tvs (t u : typ) (xs ys : expr typ func)
    (xsD : ExprI.exprT tus tvs (typD (tyList t))) (ysD : ExprI.exprT tus tvs (typD (tyList u)))
    (Hxs : ExprDsimul.ExprDenote.exprD' tus tvs (tyList t) xs = Some xsD)
    (Hys : ExprDsimul.ExprDenote.exprD' tus tvs (tyList u) ys = Some ysD) :
    ExprDsimul.ExprDenote.exprD' tus tvs (tyList (tyProd t u)) (zipExpr t u xs ys) =
      Some (ExprDsimul.ExprDenote.exprT_App (ExprDsimul.ExprDenote.exprT_App (fun _ _ => zipD t u) xsD) ysD).
  Proof.
    generalize dependent ys; generalize dependent xsD; generalize dependent ysD.
    induction xs using expr_strong_ind; simpl; intros;
      try (apply mkZip_sound; eassumption).
    + do 2 (destruct_exprs; try (apply mkZip_sound; eassumption)).
      reduce.
      rewriteD mkNil_sound. simpl.
      erewrite trmR_nil_eq; reflexivity.
    + do 7 (destruct_exprs; try (apply mkZip_sound; eassumption)).
      * reduce.
        rewriteD @combine_nil.
        erewrite trmR_nil_eq. rewrite mkNil_sound. reflexivity.
      * do 2 (destruct_exprs; try (apply mkZip_sound; eassumption)).
        reduce. simpl.
        erewrite mkCons_sound; [| eapply mkPair_sound; eassumption | eapply H; [repeat constructor | eassumption | eassumption]].
        unfold consD, zipD, pairD, tyArrR2, tyArrR2', tyArrR', tyArrD, tyArrD'. simpl.
        repeat rewrite exprT_App_tyArrD.
        unfold tyArrD, tyArrD'.
        repeat rewrite @trmDR.
        unfold listR, listD, prodR.
        repeat rewriteD @trmDR. simpl.
        symmetry.
        rewriteD trmR_cons_eq. reflexivity.
  Qed.

  Definition zipTac  (_ : list (option (expr typ func))) (e : expr typ func) (args : list (expr typ func)) : expr typ func :=
    match listS e with
      | Some (pZip t u) =>
        match args with
          | xs :: ys :: nil =>
            match baseS xs, baseS ys with
              | Some (pConst v xs'), Some (pConst w ys') =>
                match type_cast v (tyList t), type_cast w (tyList u) with
                  | Some pfxs, Some pfys =>
                    mkConst (tyList (tyProd t u))
                      (listR (eq_rect _ list
                        (combine (listD (eq_rect _ typD xs' _ pfxs))
                           (listD (eq_rect _ typD ys' _ pfys))) _ (eq_sym (btProd t u))))
                  | _, _ => apps e args
                end
              | Some (pConst v xs'), None =>
                match type_cast v (tyList t) with
                  | Some pf => zipExprConst_right t u (listD (eq_rect _ typD xs' _ pf)) ys
                  | None => apps e args
                end
              | None, Some (pConst v ys') =>
                match type_cast v (tyList u) with
                  | Some pf => zipExprConst_left t u (listD (eq_rect _ typD ys' _ pf)) xs
                  | None => apps e args
                end
              | _, _ => zipExpr t u xs ys
            end
          | _ => apps e args
        end
      | _ => apps e args
    end.
Require Import MirrorCore.Lambda.ExprD.
Check typeof_expr.
  Lemma zipTacOk : partial_reducer_ok (zipTac nil).
  Proof.
    unfold partial_reducer_ok; intros.
    eexists; split; [|reflexivity].
    unfold zipTac.
    do 6 (destruct_exprs; try assumption).
    destruct_exprs.
    Focus 2.
    (* Here we have a problem at H as we have to prove False from
       tyList = tyArr.
    *)
    (*
red_exprD_hyp.
forward_step.
forward_step.
forward_step.
Locate typ2_cast.
inversion H.
forward_step.
repeat forward_step.
  (try red_exprD_hyp); repeat forward_step; (repeat exprD_saturate_types); (repeat (first [rewrite_in_match | bf_rewrite_in_match])); (try red_exprD_goal); repeat (
        first [red_unfold | red_rewrite]).

    rewrite zipExprOk.
    destruct_exprs; [|apply zipExprOk].
    destruct_exprs; (try (reduce; apply zipExprOk; [reduce | eassumption])).
    destruct_exprs. destruct e1; try congruence.
    destruct_exprs; (try (reduce; apply zipExprOk; reduce)).
    destruct_exprs; try assumption.
    destruct_exprs; try assumption.
	+ reduce.
	  unfold zipD, fun_to_typ2.
	  do 2 rewrite exprT_App_wrap. reflexivity.
	+ destruct_exprs; try assumption.
	  reduce.
	  erewrite zipExprConst_right_sound; [|eassumption].
	  unfold zipD, fun_to_typ2.
	  do 4 rewrite exprT_App_wrap.
	  rewriteD listDR. reflexivity.
	+ do 2 (destruct_exprs; (try (reduce; apply zipExprOk; reduce; assumption))).
      destruct_exprs; try assumption.
      reduce.
	  erewrite zipExprConst_left_sound; [|eassumption].
	  unfold zipD, fun_to_typ2.
	  do 3 rewrite exprT_App_wrap.
	  rewrite listDR. reflexivity.
   *)
   admit.
   admit.
   admit.
   admit.

  Qed.

Definition ZIP := SIMPLIFY (typ := typ) (fun _ _ _ _ => beta_all zipTac).

End Zip.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 assumption *)
Inductive mode :=
  | NearestTiesToEven : mode
  | ToZero : mode
  | Up : mode
  | Down : mode
  | NearestTiesToAway : mode.
Axiom mode_WhyType : WhyType mode.
Existing Instance mode_WhyType.


(************************************************************
* Core Caml                                                 *
* Small-big-step semantics                                  *
*************************************************************)

Set Implicit Arguments.
Require Export LibEnv CoreCaml_Syntax.

(*==========================================================*)
(* * Updated Definitions *)

(************************************************************)
(* ** Syntax of the language *)

(** Grammar of values *)

Inductive val : Type :=
  | val_cst : cst -> val
  | val_loc : loc -> val
  | val_abs : option var -> pat -> trm -> val
  | val_constr : constr -> list val -> val
  | val_tuple : list val -> val
  | val_record : list (lab*val) -> val

(** Grammar of terms *)

with trm : Type :=
  | trm_var : var -> trm
  | trm_cst : cst -> trm
  | trm_abs : option var -> pat -> trm -> trm
  | trm_constr : constr -> list trm -> trm
  | trm_tuple : list trm -> trm
  | trm_record : list (lab*trm) -> trm
  | trm_unary : prim -> trm -> trm
  | trm_binary : prim -> trm -> trm -> trm
  | trm_lazy_binary : prim -> trm -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_seq : trm -> trm -> trm
  | trm_let : pat -> trm -> trm -> trm
  | trm_get : trm -> lab -> trm
  | trm_set : trm -> lab -> trm -> trm
  | trm_if : trm -> trm -> option trm -> trm
  | trm_while : trm -> trm -> trm
  | trm_for : var -> dir -> trm -> trm -> trm -> trm
  | trm_match : trm -> list branch -> trm
  | trm_try : trm -> list branch -> trm
  | trm_assert : trm -> trm
  | trm_rand : trm

(** including intermediate forms for the semantics *)

  | trm_val : val -> trm
  | trm_match_1 : val -> list branch -> trm -> trm -> trm
  | trm_try_1 : val -> list branch -> trm
  | trm_try_2 : val -> list branch -> trm -> trm -> trm

with branch : Type :=
  | branch_intro : pat -> option trm -> trm -> branch.

(** Representation of the memory store *)

Definition mem := Heap.heap loc val.

(************************************************************)
(* ** Auxiliary definitions *)

(** Substitution *)

Definition inst := LibEnv.env val.

Parameter subst : forall (x:var) (v:val) (t:trm), trm.
Parameter substs : forall (i:inst) (t:trm), trm.

(** [val] is inhabited *)

Instance val_inhab : Inhab val.
Proof. intros. apply (Inhab_of_val (val_cst (cst_bool true))). Qed.

(** Coercions *)
(*
Coercion cst_int : Z >-> cst.
Coercion cst_bool : bool >-> cst.
Coercion pat_var : var >-> pat.
*)
Coercion val_loc : loc >-> val.
Coercion val_cst : cst >-> val.

(** Shortnames for lists of terms and values *)

Definition trms := list trm.
Definition vals := list val.
Definition labtrms := list (lab*trm).
Definition labvals := list (lab*val).

(** Shortcuts for building terms and values *)

Definition val_exn k := val_constr k nil.

Definition val_unit := val_constr constr_unit nil.

(** Fresh locations *)

Definition fresh (m:mem) l :=
  ~ Heap.indom m l.

(************************************************************)
(* ** Auxiliary definitions specific to small-step *)

Coercion trm_val : val >-> trm.

(** From list of values to list of terms *)

Definition trms_vals (vs : vals) : trms :=
  LibList.map trm_val vs.

Definition trms_lab_vals (avs : labvals) : labtrms :=
  LibList.map (fun av => let '(a,v) := av in (a, trm_val v)) avs.

(** Auxiliary terms *)

Definition trm_raise := trm_unary prim_raise.

Definition trm_error k := trm_raise (val_exn k).

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

Implicit Types x : var.
Implicit Types c : cst.
Implicit Types f : prim.
Implicit Types k : constr.
Implicit Types v : val.
Implicit Types t : trm.
Implicit Types m : mem.
Implicit Types b : branch.
Implicit Types a : lab.
Implicit Types l : loc.
Implicit Types i : inst.
Implicit Types n : int.
Implicit Types r : bool.

(************************************************************)
(* ** Auxiliary semantics definitions *)

(** Semantics of Pattern matching *)

Inductive matching (i : inst) : val -> pat -> Prop :=
  | matching_var : forall x v,
      LibEnv.binds x v i ->
      matching i v (pat_var x)
  | matching_wild : forall v,
      matching i v pat_wild
  | matching_alias : forall x v p,
      matching i v p ->
      LibEnv.binds x v i ->
      matching i v (pat_alias p x)
  | matching_or : forall v p p1 p2,
      matching i v p ->
      (p = p1 \/ p = p2) ->
      matching i v (pat_or p1 p2)
  | matching_cst : forall c,
      matching i c (pat_cst c)
  | matching_constr : forall k vs ps,
      Forall2 (matching i) vs ps ->
      matching i (val_constr k vs) (pat_constr k ps)
  | matching_tuple : forall vs ps,
      Forall2 (matching i) vs ps ->
      matching i (val_tuple vs) (pat_tuple ps)
  | matching_record_nil : forall avs,
      matching i (val_tuple avs) (pat_tuple nil)
  | matching_record_cons : forall avs a v p aps,
      LibListAssoc.Assoc a v avs ->
      matching i v p ->
      matching i (val_record avs) (pat_record aps) ->
      matching i (val_record avs) (pat_record ((a,p)::aps)).

Definition mismatching v p :=
  forall i, ~ matching i v p.

(** Semantics of primitive equality *)

Parameter primitive_eq : val -> val -> bool -> Prop.

(************************************************************)
(* ** Reduction contexts *)

(** Grammar of contexts *)

Inductive ctx :=
  | ctx_hole : ctx
  | ctx_constr : constr -> list val -> ctx -> list trm -> ctx
  | ctx_tuple : list val -> ctx -> list trm -> ctx
  | ctx_record : list (lab*val) -> lab -> ctx -> list (lab*trm) -> ctx
  | ctx_unary : prim -> ctx -> ctx
  | ctx_binary_1 : prim -> ctx -> trm -> ctx
  | ctx_binary_2 : prim ->val -> ctx -> ctx
  | ctx_lazy_binary : prim ->ctx -> trm -> ctx
  | ctx_app_1 : ctx -> trm -> ctx
  | ctx_app_2 : val -> ctx -> ctx
  | ctx_seq : ctx -> trm -> ctx
  | ctx_let : pat -> ctx -> trm -> ctx
  | ctx_get : ctx -> lab -> ctx
  | ctx_set_1 : ctx -> lab -> trm -> ctx
  | ctx_set_2 : val -> lab -> ctx -> ctx
  | ctx_if : ctx -> trm -> option trm -> ctx
  | ctx_for_1 : var -> dir -> ctx -> trm -> trm -> ctx
  | ctx_for_2 : var -> dir -> val -> ctx -> trm -> ctx
  | ctx_match : ctx -> list branch -> ctx
  | ctx_try : ctx -> list branch -> ctx
  | ctx_assert : ctx -> ctx
  | ctx_match_1 : val -> list branch -> ctx -> trm -> ctx
  | ctx_try_2 : val -> list branch -> ctx -> trm -> ctx.

Implicit Types C : ctx.

(** Application of contexts *)

Fixpoint ctx_apply C t :=
  let r C' := ctx_apply C' t in
  match C with
  | ctx_hole => t
  | ctx_constr k vs C' ts => trm_constr k (trms_vals vs ++ (r C') :: ts)
  | ctx_tuple vs C' ts => trm_tuple (trms_vals vs ++ (r C') :: ts)
  | ctx_record avs a C' ats => trm_record (trms_lab_vals avs ++ (a, (r C')) :: ats)
  | ctx_unary f C' => trm_unary f (r C')
  | ctx_binary_1 f C' t2 => trm_binary f (r C') t2
  | ctx_binary_2 f v1 C' => trm_binary f v1 (r C')
  | ctx_lazy_binary f C' t2 => trm_lazy_binary f (r C') t2
  | ctx_app_1 C' t2 => trm_app (r C') t2
  | ctx_app_2 v1 C' => trm_app v1 (r C')
  | ctx_seq C' t2 => trm_seq (r C') t2
  | ctx_let p C' t2 => trm_let p (r C') t2
  | ctx_get C' a => trm_get (r C') a
  | ctx_set_1 C' a t2 => trm_set (r C') a t2
  | ctx_set_2 v1 a C' => trm_set v1 a (r C')
  | ctx_if C' t2 ot3 => trm_if (r C') t2 ot3
  | ctx_for_1 x d C' t2 t3 => trm_for x d (r C') t2 t3
  | ctx_for_2 x d v1 C' t3 => trm_for x d v1 (r C') t3
  | ctx_match C' bs => trm_match (r C') bs
  | ctx_try C' bs => trm_try (r C') bs
  | ctx_assert C' => trm_assert (r C')
  | ctx_match_1 v bs C' t => trm_match_1 v bs (r C') t
  | ctx_try_2 v bs C' t => trm_try_2 v bs (r C') t
  end.

(** Contexts that do not contain [try] construct *)

Fixpoint ctx_notry C :=
  let r := ctx_notry in
  match C with
  | ctx_try C' bs => False
  | ctx_hole => True
  | ctx_constr k vs C' ts => r C'
  | ctx_tuple vs C' ts => r C'
  | ctx_record avs a C' ats => r C'
  | ctx_unary f C' => r C'
  | ctx_binary_1 f C' t2 => r C'
  | ctx_binary_2 f v1 C' => r C'
  | ctx_lazy_binary f C' t2 => r C'
  | ctx_app_1 C' t2 => r C'
  | ctx_app_2 v1 C' => r C'
  | ctx_seq C' t2 => r C'
  | ctx_let p C' t2 => r C'
  | ctx_get C' a => r C'
  | ctx_set_1 C' a t2 => r C'
  | ctx_set_2 v1 a C' => r C'
  | ctx_if C' t2 ot3 => r C'
  | ctx_for_1 x d C' t2 t3 => r C'
  | ctx_for_2 x d v1 C' t3 => r C'
  | ctx_match C' bs => r C'
  | ctx_assert C' => r C'
  | ctx_match_1 v bs C' t => r C'
  | ctx_try_2 v bs C' t => r C'
  end.

(************************************************************)
(* ** Small-step reduction relation *)

(** Configuration *)

Definition conf := (trm * mem)%type.

(** Reduction *)

Reserved Notation "t1 '/' m1 '--->' t2 '/' m2"
  (at level 40, m1 at level 30, t2 at level 30, m2 at level 30).

Inductive step : binary conf :=

  | step_ctx : forall C t1 m1 t2 m2,
      t1 / m1 ---> t2 / m2 ->
      (ctx_apply C t1) / m1 --->
      (ctx_apply C t2) / m2
  | step_raise : forall C v m,
      ctx_notry C ->
      (ctx_apply C (trm_raise v)) / m --->
      (trm_raise v) / m

  | step_abs : forall oy p t m,
      (trm_abs oy p t) / m --->
      (val_abs oy p t) / m
  | step_constr : forall k vs m,
      (trm_constr k (trms_vals vs)) / m --->
      (val_constr k vs) / m
  | step_tuple : forall vs m,
      (trm_tuple (trms_vals vs)) / m --->
      (val_tuple vs) / m

  | step_unary_not : forall r m,
      (trm_unary prim_not r) / m --->
      (neg r) / m
  | step_unary_neg : forall n m,
      (trm_unary prim_not n) / m --->
      (cst_int (-n)) / m
  | step_binary_eq : forall v1 v2 r m,
      primitive_eq v1 v2 r ->
      (trm_binary prim_eq v1 v2) / m --->
      r / m
  | step_binary_add : forall n1 n2 m,
      (trm_binary prim_add n1 n2) / m --->
      (n1+n2) / m
  | step_binary_sub : forall n1 n2 m,
      (trm_binary prim_sub n1 n2) / m --->
      (n1-n2) / m
  | step_binary_mul : forall n1 n2 m,
      (trm_binary prim_mul n1 n2) / m --->
      (n1*n2) / m
  | step_binary_div_notzero : forall n1 n2 m,
      n2 <> 0 ->
      (trm_binary prim_div n1 n2) / m --->
      (Z.div n1 n2) / m
  | step_binary_div_zero : forall n1 n2 m,
      (trm_binary prim_div n1 0) / m --->
      (trm_error constr_div_by_zero) / m
  | step_lazy_binary_and_true : forall v1 t2 m,
      (trm_lazy_binary prim_and true t2) / m --->
      t2 / m
  | step_lazy_binary_and_false : forall v1 t2 m,
      (trm_lazy_binary prim_and false t2) / m --->
      false / m
  | step_lazy_binary_or_true : forall v1 t2 m,
      (trm_lazy_binary prim_or true t2) / m --->
      true / m
  | step_lazy_binary_or_false : forall v1 t2 m,
      (trm_lazy_binary prim_or false t2) / m --->
      t2 / m

  | step_app_mismatch : forall p oy t3 v2 m,
      mismatching v2 p ->
      (trm_app (val_abs oy p t3) v2) / m --->
      (trm_error constr_matching_failure) / m
  | step_app_match : forall i p oy t3 t4 t5 v2 m,
      matching i v2 p ->
      t4 = substs i t3 ->
      t5 = match oy with
         | None => t4
         | Some y => (subst y (val_abs oy p t3) t4) end ->
      (trm_app (val_abs None p t3) v2) / m --->
      t5 / m

  | step_seq : forall v1 t2 m,
      (trm_seq v1 t2) / m --->
      t2 / m
  | step_let_match : forall i p x v1 t2 m,
      matching i v1 p ->
      (trm_let p v1 t2) / m --->
      (substs i t2) / m
  | step_let_mismatch : forall p x v1 t2 m,
       mismatching v1 p ->
      (trm_let p v1 t2) / m --->
      (trm_error constr_matching_failure) / m

  | step_record : forall avs l m1 m2,
      fresh m1 l ->
      m2 = Heap.write m1 l (val_record avs) ->
      (trm_record (trms_lab_vals avs)) / m1 --->
      l / m2
  | step_get : forall l a v avs m,
      Heap.binds m l (val_record avs) ->
      LibListAssoc.Assoc a v avs ->
      (trm_get l a) / m --->
      v / m
  | step_set : forall l a v avs m1 m2,
      Heap.binds m1 l (val_record avs) ->
      m2 = Heap.write m1 l (val_record ((a,v)::avs)) ->
      (trm_set l a v) / m1 --->
      val_unit / m2

  | step_while : forall t1 t2 m,
      (trm_while t1 t2) / m --->
      (trm_if t1 (trm_seq t2 (trm_while t1 t2)) None) / m
  | step_if_true : forall t2 ot3 m,
      (trm_if true t2 ot3) / m --->
      t2 / m
  | step_if_false_none : forall t2 m,
      (trm_if false t2 None) / m --->
      val_unit / m
  | step_if_false_some : forall t2 t3 m,
      (trm_if false t2 (Some t3)) / m --->
      t3 / m
  | step_for_upto_leq : forall x n1 n2 t3 m,
      n1 <= n2 ->
      (trm_for x dir_upto n1 n2 t3) / m --->
      (trm_seq (trm_let x n1 t3) (trm_for x dir_upto (n1+1) n2 t3)) / m
  | step_for_upto_gt : forall x n1 n2 t3 m,
      n1 > n2 ->
      (trm_for x dir_upto n1 n2 t3) / m --->
      val_unit / m
  | step_for_downto_geq : forall x n1 n2 t3 m,
      n1 >= n2 ->
      (trm_for x dir_downto n1 n2 t3) / m --->
      (trm_seq (trm_let x n1 t3) (trm_for x dir_upto (n1-1) n2 t3)) / m
  | step_for_downto_lt : forall x n1 n2 t3 m,
      n1 < n2 ->
      (trm_for x dir_downto n1 n2 t3) / m --->
      val_unit / m

  | step_match_nil : forall v m,
      (trm_match v nil) / m --->
      (trm_error constr_matching_failure) / m
  | step_match_cons_mismatch : forall v p bs ot1 t2 m,
      mismatching v p ->
      (trm_match v ((branch_intro p ot1 t2)::bs)) / m --->
      (trm_match v bs) / m
  | step_match_cons_match_unguarded : forall v p bs t2 i m,
      matching i v p ->
      (trm_match v ((branch_intro p None t2)::bs)) / m --->
      (substs i t2) / m
  | step_match_cons_match_guarded : forall v p bs t1 t2 i m,
      matching i v p ->
      (trm_match v ((branch_intro p (Some t1) t2)::bs)) / m --->
      (trm_match_1 v bs (substs i t1) (substs i t2)) / m
  | step_match_1_true : forall v bs t2 m,
      (trm_match_1 v bs true t2) / m --->
      t2 / m
  | step_match_1_false : forall v bs t2 m,
      (trm_match_1 v bs false t2) / m --->
      (trm_match v bs) / m

  | step_try_val : forall v bs m,
      (trm_try v bs) / m ---> v / m
  | step_try_raise : forall v bs m,
      (trm_try (trm_raise v) bs) / m --->
      (trm_try_1 v bs) / m
  | step_try_1_nil : forall v m,
      (trm_try_1 v nil) / m --->
      (trm_raise v) / m
  | step_try_1_cons_mismatch : forall v p bs ot1 t2 m,
      mismatching v p ->
      (trm_try_1 v ((branch_intro p ot1 t2)::bs)) / m --->
      (trm_try_1 v bs) / m
  | step_try_1_cons_match_unguarded : forall v p bs t2 i m,
      matching i v p ->
      (trm_try_1 v ((branch_intro p None t2)::bs)) / m --->
      (substs i t2) / m
  | step_try_1_cons_match_guarded : forall v p bs t1 t2 i m,
      matching i v p ->
      (trm_try_1 v ((branch_intro p (Some t1) t2)::bs)) / m --->
      (trm_try_2 v bs (substs i t1) (substs i t2)) / m
  | step_try_2_true : forall v bs t2 m,
      (trm_try_2 v bs true t2) / m --->
      t2 / m
  | step_try_2_false : forall v bs t2 m,
      (trm_try_2 v bs false t2) / m --->
      (trm_try_1 v bs) / m

  | step_assert_true : forall m,
      (trm_assert true) / m --->
      val_unit / m
  | step_assert_false : forall m,
      (trm_assert false) / m --->
      (trm_error constr_assert_failure) / m

  | step_rand : forall m z,
      trm_rand / m --->
      (val_cst z) / m

where "t1 / m1 ---> t2 / m2" := (step (t1:trm,m1) (t2:trm,m2)).

(************************************************************)
(* ** Complete reduction sequences *)

(** Complete evaluation  [TODO]

Definition sredstar t t' := (rtclosure step) t t'.

Definition sredplus t t' := (tclosure step) t t'.

Definition sredval t v := sredstar t v.

Definition sredexn t v := sredstar t (trm_raise v).

Definition sdiverge t := (infclosure step) t.

*)