(** ** Pre-lB-systems (unital)

By Vladimir Voevodsky, split off the file prelBsystems.v on March 3, 2015 *)

Unset Automatic Introduction.

Require Export lBsystems.prelB_non_unital.
Require Export lBsystems.dlt.

(** ** pre-lB-systems (unital) *)

(** *** The main layers *)

(** **** The structure formed by operations dlt *)

Definition dlt_layer_0 ( BB : lBsystem_carrier ) :=
  total2 ( fun dlt : dlt_ops_type BB => dlt_ax0_type dlt ) .

Definition dlt_layer_0_to_dlt_ops_type ( BB : lBsystem_carrier ) :
  dlt_layer_0 BB -> dlt_ops_type BB := pr1 .
Coercion dlt_layer_0_to_dlt_ops_type : dlt_layer_0 >-> dlt_ops_type .

(** **** Complete definition of a (unital) pre-lB-system *)

Definition prelBsystem :=
  total2 ( fun BB : prelBsystem_non_unital => dlt_layer_0 BB ) .

Definition prelBsystem_pr1 : prelBsystem -> prelBsystem_non_unital := pr1 .
Coercion prelBsystem_pr1 : prelBsystem >-> prelBsystem_non_unital .

(** *** Access functions for the operation dlt and its zeros axiom *)

Definition dlt_op { BB : prelBsystem } : dlt_ops_type BB := pr2 BB .

Definition dlt_ax0 { BB : prelBsystem } : dlt_ax0_type ( @dlt_op BB ) :=
  pr2 ( pr2 BB ) .

(* End of the file prelB.v *)


Require Import Spec.ConcurExec.
Require Import Spec.Equiv.
Require Import Spec.ConcurProc.
Require Import ProofAutomation.
Require Import Helpers.Instances.
Require Import Omega.

(** Helpers for connecting different [threads_state]s *)

Definition proc_match `(R : forall T, proc Op T -> proc Op' T -> Prop)
                      `(ts1 : threads_state Op)
                      `(ts2 : threads_state Op') :=
  forall tid,
    match ts1 tid with
    | Proc p1 =>
      (* needs to be an exists since need type of ts2 tid to be T *)
      exists p2, ts2 tid = Proc p2 /\
            R _ p1 p2
    | NoProc => ts2 tid = NoProc
    end.

Theorem proc_match_sym : forall `(R : forall T, proc Op T -> proc Op' T -> Prop)
                           ts1 ts2,
    proc_match R ts1 ts2 ->
    proc_match (fun T x y => R T y x) ts2 ts1.
Proof.
  unfold proc_match; intros.
  specialize (H tid).
  destruct_with_eqn (ts1 tid); propositional;
    replace (ts2 tid);
    eauto.
Qed.

Theorem proc_match_subrelation : forall Op Op'
                                   (R1 R2: forall T, proc Op T -> proc Op' T -> Prop)
                                   ts1 ts2,
    proc_match R1 ts1 ts2 ->
    (forall T p1 p2, R1 T p1 p2 -> R2 T p1 p2) ->
    proc_match R2 ts1 ts2.
Proof.
  unfold proc_match; intros.
  specialize (H tid); destruct matches in *; propositional; eauto.
Qed.

Theorem proc_match_max_eq : forall `(R : forall T, proc Op T -> proc Op' T -> Prop)
                           ts1 ts2,
    proc_match R ts1 ts2 ->
    thread_max ts1 = thread_max ts2.
Proof.
  intros.
  apply thread_max_eq; intros.
  specialize (H tid).
  destruct_with_eqn (ts1 tid); propositional;
    (intuition auto);
    congruence.
Qed.

Lemma proc_match_del : forall `(ts1 : threads_state Op)
                              `(ts2 : threads_state Op') R tid,
  proc_match R ts1 ts2 ->
  proc_match R (ts1 [[ tid := NoProc ]]) (ts2 [[ tid := NoProc ]]).
Proof.
  unfold proc_match; intros.
  specialize (H tid0).
  destruct (tid == tid0); subst;
    autorewrite with t; eauto.
Qed.

Lemma proc_match_upd : forall `(ts1 : threads_state Op)
                              `(ts2 : threads_state Op') R tid
                              T (p1 : proc _ T) p2,
  proc_match R ts1 ts2 ->
  R _ p1 p2 ->
  proc_match R (ts1 [[ tid := Proc p1 ]]) (ts2 [[ tid := Proc p2 ]]).
Proof.
  unfold proc_match; intros.
  specialize (H tid0).
  destruct (tid == tid0); subst;
    autorewrite with t;
    eauto.
Qed.

Lemma proc_match_nil : forall `(R : forall T, proc Op T -> proc Op' T -> Prop),
  proc_match R thread_empty thread_empty.
Proof.
  unfold proc_match; intros.
  rewrite ?empty_is_empty; eauto.
Qed.

Theorem proc_match_pick : forall tid `(ts1 : threads_state Op)
                                     `(ts2 : threads_state Op') R,
  proc_match R ts1 ts2 ->
    (ts1 [[ tid ]] = NoProc /\ ts2 [[ tid ]] = NoProc) \/
    exists T (p1 : proc _ T) p2,
    ts1 [[ tid ]] = Proc p1 /\ ts2 [[ tid ]] = Proc p2 /\ R T p1 p2.
Proof.
  unfold proc_match; intros.
  specialize (H tid).
  destruct_with_eqn (ts1 tid); propositional; eauto 10.
Qed.

Theorem proc_match_trans : forall `(ts1: threads_state Op)
                            `(ts2: threads_state Op') R1
                            `(ts3: threads_state Op'') R2,
  proc_match R1 ts1 ts2 ->
  proc_match R2 ts2 ts3 ->
  proc_match (fun T x z => exists y, R1 T x y /\ R2 T y z)  ts1 ts3.
Proof.
  unfold proc_match; intros.
  specialize (H tid).
  specialize (H0 tid).
  destruct matches in *;
    propositional;
    repeat simpl_match; repeat maybe_proc_inv; eauto 10.
Qed.

Theorem proc_match_map : forall `(ts1: threads_state Op)
                           `(f: forall T, proc Op T -> proc Op' T),
    proc_match (fun T p1 p2 => p2 = f T p1) ts1 (thread_map f ts1).
Proof.
  unfold proc_match; intros.
  rewrite thread_map_get_match.
  destruct matches; propositional; repeat simpl_match; eauto.
Qed.

Theorem proc_match_map1 : forall `(ts1: threads_state Op)
                            `(f: forall T, proc Op T -> proc Op' T)
                            `(ts2: threads_state Op'') R,
    proc_match (fun T p1 p2 => R T (f T p1) p2) ts1 ts2 ->
    proc_match R (thread_map f ts1) ts2.
Proof.
  intros.
  unfold proc_match; intros.
  rewrite thread_map_get_match.
  specialize (H tid).
  destruct matches; propositional; repeat simpl_match; eauto.
Qed.

Theorem proc_match_map2 : forall `(ts1: threads_state Op)
                            `(f: forall T, proc Op' T -> proc Op'' T)
                            `(ts2: threads_state Op') R,
    proc_match (fun T p1 p2 => R T p1 (f T p2)) ts1 ts2 ->
    proc_match R ts1 (thread_map f ts2).
Proof.
  intros.
  unfold proc_match; intros.
  rewrite thread_map_get_match.
  specialize (H tid).
  destruct_with_eqn (ts1 tid); propositional; repeat simpl_match; eauto.
Qed.

(** proving equivalence based on per-process equivalence *)

Fixpoint take_threads Op (src: threads_state Op) n (dst: threads_state Op) :=
  match n with
  | 0 => dst
  | S n => (take_threads src n dst) [[ n := src n ]]
  end.

Lemma take_threads_complete_helper : forall Op (src dst: threads_state Op) n tid,
    tid < n ->
    take_threads src n dst tid = src tid.
Proof.
  induction n; simpl; intros.
  - exfalso; omega.
  - destruct (tid == n); subst;
      autorewrite with t;
      eauto.
    apply IHn; omega.
Qed.

Lemma take_threads_unchanged_helper : forall Op (src dst: threads_state Op) n tid,
    tid >= n ->
    take_threads src n dst tid = dst tid.
Proof.
  induction n; simpl; intros; auto.
  destruct (tid == n); subst;
    autorewrite with t.
  exfalso; omega.
  apply IHn; omega.
Qed.

Theorem take_threads_max : forall Op (src dst: threads_state Op) n,
    n <= thread_max dst ->
    thread_max (take_threads src n dst) <= thread_max dst.
Proof.
  induction n; simpl; intros.
  auto.
  specialize (IHn ltac:(omega)).
  destruct (le_dec n (thread_max (take_threads src n dst))).
  rewrite thread_upd_thread_max_bound; auto.
  rewrite thread_upd_thread_max_extend_bound; omega.
Qed.

Lemma take_threads_complete_general : forall Op (src dst: threads_state Op) n,
    n > thread_max src ->
    thread_max dst <= thread_max src ->
    take_threads src n dst = src.
Proof.
  intros.
  apply thread_ext_eq; intros.
  destruct (lt_dec tid n).
  apply take_threads_complete_helper; auto.
  rewrite take_threads_unchanged_helper by omega.
  rewrite ?mapping_finite by omega.
  reflexivity.
Qed.

Theorem take_threads_complete : forall Op (src dst: threads_state Op),
    thread_max src = thread_max dst ->
    src = take_threads src (1 + thread_max src) dst.
Proof.
  intros.
  rewrite take_threads_complete_general; auto; omega.
Qed.

Lemma take_threads_none : forall Op (src dst: threads_state Op),
    dst = take_threads src 0 dst.
Proof.
  reflexivity.
Qed.

Theorem trace_incl_ts_general : forall Op State (op_step: OpSemantics Op State) (ts1 ts2: threads_state _),
    (forall tid ts,
        trace_incl_ts op_step
                      (ts [[ tid := ts1 tid ]])
                      (ts [[ tid := ts2 tid ]])) ->
    thread_max ts1 = thread_max ts2 ->
    trace_incl_ts op_step ts1 ts2.
Proof.
  intros.
  rewrite (take_threads_complete ts2 ts1) by auto.
  generalize dependent (1 + thread_max ts2).
  induction n; simpl.
  reflexivity.
  etransitivity; eauto.
  replace (take_threads ts2 n ts1) with
      ((take_threads ts2 n ts1) [[n := ts1 n]]) at 1;
    swap 1 2.
  rewrite thread_upd_same_eq; auto.
  rewrite take_threads_unchanged_helper; auto.
  generalize dependent (take_threads ts2 n ts1); intros ts' **.
  apply H.
Qed.

Theorem trace_incl_ts_proc_match : forall Op State (op_step: OpSemantics Op State) ts1 ts2,
    proc_match (fun T => trace_incl op_step (T:=T)) ts1 ts2 ->
    trace_incl_ts op_step ts1 ts2.
Proof.
  intros.
  apply trace_incl_ts_general.
  - intros.
    unfold trace_incl in *.
    specialize (H tid).
    destruct_with_eqn (ts1 tid); propositional; try congruence.
    rewrite H in *; auto.
  - eauto using proc_match_max_eq.
Qed.

Inductive proc_optR Op Op' (R: forall T, proc Op T -> proc Op' T -> Prop) :
  maybe_proc Op -> maybe_proc Op' -> Prop :=
| ProcOptR : forall T p1 p2, R T p1 p2 -> proc_optR R (Proc p1) (Proc p2)
| ProcOptR_NoProc : proc_optR R NoProc NoProc.

Hint Constructors proc_optR.

Theorem proc_match_upd_opt : forall `(ts1: threads_state Op) `(ts2: threads_state Op')
                               R tid p1 p2,
    proc_match R ts1 ts2 ->
    proc_optR R p1 p2 ->
    proc_match R (ts1 [[tid := p1]]) (ts2 [[tid := p2]]).
Proof.
  intros.
  invert H0.
  auto using proc_match_upd.
  auto using proc_match_del.
Qed.


Require Import Software.Language.Execution.
Require Import Software.Language.ExecutionProp.
Require Import Software.Language.Syntax.
Require Import Software.Language.State.
Require Import Software.Language.Value.

Section Verification.

Lemma value_irreducible__exec_step:
  value_irreducible exec_step.
Proof with auto.
  intros t Hval.
  induction Hval;
  try solve [intros t' st st' Hcontra; inversion Hcontra].
  intros t' st st' Hcontra.
  inversion Hcontra; subst.
  apply IHHval1 in H0. inversion H0.
  apply IHHval2 in H5. inversion H5.
  intros t' st st' Hcontra.
  inversion Hcontra; subst.
  apply IHHval in H0. inversion H0.
  Qed.

Ltac value_exec_step_impossible :=
  match goal with
  | H: value ?t, H0: exec_step (Cexec_state ?t ?st) (Cexec_state ?t' ?st') |- _ =>
    solve [destruct (value_irreducible__exec_step t H t' st st'); assumption]
  end.

Ltac exec_step_impossible :=
  match goal with
  | H: exec_step _ _ |- _ =>
    solve [inversion H]
  end.

Ltac exec_step_inductive :=
  match goal with
  | H: forall z, exec_step ?x z -> z = ?y, H0: exec_step ?x ?a |- _ = _ =>
    solve [apply H in H0; inversion H0; auto]
  end.

Ltac rewrite_invert :=
  match goal with
  | H: ?x = ?y, H0: ?x = ?z |- _ = _ =>
    solve [rewrite H in H0; inversion H0; reflexivity]
  end.

Ltac equality_contradiction :=
  match goal with
  | H: ?x = ?x -> False |- _ =>
    solve [exfalso; apply H; reflexivity]
  end.

Lemma deterministic__exec_step:
  deterministic exec_step.
Proof with auto.
  intros x y Hxy.
  induction Hxy; intros z Hxz; inversion Hxz; subst;
  try solve [value_exec_step_impossible];
  try solve [auto];
  try solve [exec_step_inductive];
  try solve [rewrite_invert];
  try solve [equality_contradiction];
  try solve [exec_step_impossible].
  Qed.

End Verification.


Require Export Types.

Require Import GHC.Base.
Require Import Proofs.GHC.Base.
Require Import Proofs.Data.Foldable.

Require Import GHC.List.
Require GHC.Char.

Require Import ssrbool ssreflect.

Definition eq_CharType (x : CharType) (y:CharType) :=
  match x , y with
    | IsSpace , IsSpace => true
    | NotSpace, NotSpace => true
    | _ , _ => false
  end.

Instance Eq_CharType : Eq_ CharType := eq_default eq_CharType.

Instance EqLaws_CharType : EqLaws CharType. Admitted.

Instance EqExact_CharType : EqExact CharType.
constructor; intros x y.
apply iff_reflect. split.
- inversion 1. apply Eq_refl.
- destruct x; destruct y; inversion 1; reflexivity.
Qed.

Fixpoint eq_flux (x : Flux) (y: Flux) : bool :=
  match x , y with
  | Mk_Flux c1 i c2 , Mk_Flux d1 j d2 =>
    (c1 == d1) && (i == j) && (c2 == d2)
  | Unknown , Unknown => true
  | _ , _ => false
  end.

Instance Eq_Flux : Eq_ Flux := eq_default eq_flux.

Instance EqLaws_Flux : EqLaws Flux. Admitted.

Instance EqExactFlux : EqExact Flux.
Proof.
  constructor; intros x y.
  apply iff_reflect. split.
  - intro h. subst. apply Eq_reflI. reflexivity.
  - generalize dependent y. induction x.
    + destruct y.
      * unfold op_zeze__, Eq_Flux, eq_default. simpl.
        move /andP => [H1 H2]. move /andP in H1. destruct H1.
        move /Eq_eq in H. move /Eq_eq in H2. move /Eq_eq in H0.
        subst. reflexivity.
      * inversion 1.
    + destruct y; inversion 1. reflexivity.
Qed.

Instance SemigroupLaws_Flux : SemigroupLaws Flux.
Proof.
  constructor.
  intros x y z.
  destruct x eqn:Hx; destruct y eqn:Hy; destruct z eqn:Hz;
    unfold op_zlzlzgzg__, Semigroup__Flux, Types.Semigroup__Flux_op_zlzlzgzg__; simpl.
  all: try destruct c0.
  all: try destruct c1.
  all: try destruct c2.
  all: try destruct c3.
  all: apply Eq_reflI; f_equal.
  all: try reflexivity.
  all: omega.
Qed.

Instance Lawful_Flux : MonoidLaws Flux.
constructor.
+ intros x. apply Eq_reflI. reflexivity.
+ intros x. destruct x. apply Eq_reflI.
  unfold mappend, mempty, Monoid__Flux , mappend__ , mempty__, Types.Monoid__Flux_mempty .
  unfold Types.Monoid__Flux_mappend.
  unfold op_zlzlzgzg__, Semigroup__Flux, Types.Semigroup__Flux_op_zlzlzgzg__; simpl.
  destruct c0; reflexivity.
  apply Eq_reflI. reflexivity.
+ intros x y. apply Eq_reflI. reflexivity.
+ intros x. apply Eq_reflI. reflexivity.
Qed.

Definition eq_counts (x:Counts) (y:Counts) : bool :=
  match x , y with
    | Mk_Counts x1 x2 x3, Mk_Counts y1 y2 y3 =>
      (x1 == y1) && (x2 == y2) && (x3 == y3)
  end.

Instance Eq_Counts : Eq_ Counts := eq_default eq_counts.

Instance EqLaws_Counts : EqLaws Counts. Admitted.

Instance EqExact_Counts : EqExact Counts.
constructor; intros x y.
apply iff_reflect. split.
- inversion 1. apply Eq_refl.
- destruct x; destruct y.
  unfold op_zeze__, Eq_Counts, eq_default. simpl.
  move /andP => [H1 H2]. move /andP in H1. destruct H1.
  move /Eq_eq in H. move /Eq_eq in H2. move /Eq_eq in H0.
  subst. reflexivity.
Qed.

Instance SemigroupLaws_Counts : SemigroupLaws Counts.
Proof.
  constructor.
  intros x y z.
  destruct x eqn:Hx; destruct y eqn:Hy; destruct z eqn:Hz;
    unfold op_zlzlzgzg__, Semigroup__Counts, Types.Semigroup__Counts_op_zlzlzgzg__; simpl.
  unfold op_zeze__, Eq_Counts, eq_default, op_zeze____,eq_counts .
Admitted.

Instance MonoidLaws_Counts : MonoidLaws Counts.
Proof.
  constructor.
  + intros x. destruct x. apply Eq_reflI. reflexivity.
  + intros x. destruct x. apply Eq_reflI.
  unfold mappend, mempty, Monoid__Counts , mappend__ , mempty__, Types.Monoid__Counts_mempty .
  unfold Types.Monoid__Counts_mappend.
  unfold op_zlzlzgzg__, Semigroup__Counts, Types.Semigroup__Counts_op_zlzlzgzg__; simpl.
  f_equal. omega. admit. omega.
  + intros x y. apply Eq_reflI. reflexivity.
  + intros x. apply Eq_reflI. reflexivity.
Admitted.

Lemma Counts_assoc : forall x y z : Counts, ((x <<>> (y <<>> z)) = ((x <<>> y) <<>> z)).
  intros x y z. apply /Eq_eq.
  eapply semigroup_assoc; eauto.
Qed.


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

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1, and Inria Futurs (Logical)
*)

Require Import Arith.
Require Import Omega.
Require Import List.
Require Import EPSILON0.
Require Import MSE0.

Unset Standard Proposition Elimination Names.

(* An hydra is a finitely branched tree *)

Inductive Hydra : Set :=
|  head : Hydra
|  node : Hydrae -> Hydra
with Hydrae : Set :=
| single : Hydra -> Hydrae
| hcons : Hydra -> Hydrae -> Hydrae.

(* a small example *)
Definition Lerne: Hydra :=
 node (hcons head
        (single (node (hcons
                        (node (hcons (node (single head))
                               (single (node (hcons head (single head))))))
                        (single head))))).

Scheme Hydra_rect2 := Induction for Hydra Sort Type
with   Hydrae_rect2 := Induction for Hydrae Sort Type.

(* occurrences = lists of nats *)
Definition occurrence := list nat.

(* reaction of the Hydra : the occurrence parameter points to
   the head just removed *)

(* reduction at distance 1 from the root *)

(* one head is removed, and no new head is built *)
Open Scope list_scope.
(* mettre u comme metavariable pour les occurrences *)

Inductive S1 : occurrence -> Hydrae -> Hydrae -> Set :=
| S1_first : forall s, S1 (0::nil) (hcons head s) s
| S1_last : forall h, S1 (1::nil) (hcons h (single head)) (single h)
| S1_rest : forall i h s s', S1 (i::nil)%list s s' ->
                               S1 (S i::nil) (hcons h s)
                                   (hcons h s').

Inductive R1 : occurrence -> Hydra -> Hydra -> Set :=
| R1_single : R1 (0::nil) (node (single head)) head
| R1_node   : forall u l l', S1 u l l' ->
                         R1 u (node l) (node l').

(* reduction at distance 2 from the root *)

(* some head at level 2 is cut, the new level 1 sub_hydra is replicated
   n times *)

Fixpoint replicate (h:Hydra)(n:nat)(s:Hydrae){struct n}:Hydrae :=
  match n with
  | 0 => s
  | S p => hcons h (replicate h p s)
  end.

Inductive S2 (n:nat) : occurrence -> Hydrae -> Hydrae ->  Set :=
| S2_single : forall oc h h', R1 oc h h' ->
                             S2 n (0::oc) (single h)
                                   (replicate h' n (single h'))
| S2_first : forall oc h h' s, R1 oc h h' ->
                              S2 n (0::oc) (hcons h s)
                                    (replicate h' (S n) s)

| S2_rest  : forall oc ocs  h s s', S2 n (oc::ocs) s s' ->
                                S2 n (S oc::ocs) (hcons h s)
                                          (hcons h s').

(* reduction at any level >= 2 *)

Inductive Rn (n:nat) : occurrence -> Hydra -> Hydra -> Set :=

| Rn_here : forall u l l', S2 n u l l' ->
                             Rn n u (node l) (node l')
| Rn_plus : forall u l l', Sn n u l l' ->
                             Rn n u (node l) (node l')
with Sn (n:nat) : occurrence -> Hydrae -> Hydrae -> Set :=
|  Sn_single : forall u h h', Rn n u h h' ->
                                   Sn n (0::u)
                                       (single h) (single h')

|  Sn_first : forall h h' u r, Rn n u h h'->
                                   Sn n (0::u)
                                              (hcons h r) (hcons h' r)

|  Rnl_rest : forall h  occ u r r', Sn n (occ::u)r r' ->
                                  Sn n (S occ::u)
                                              (hcons h r) (hcons h r').

Scheme Rn_rect2 := Induction for Rn Sort Type
with   Sn_rect2 := Induction for Sn Sort Type.

(* general decapitation-grow relationship :
   n is the replication factor (chosen by the hydra ) *)

Inductive Rh (n:nat) : occurrence -> Hydra -> Hydra -> Set :=
 depth1 : forall occ h h', R1 occ h h' -> Rh n occ h h'
|depth2 : forall occ h h', Rn n occ h h' -> Rh n occ h h'.

(* an hydra of size > 1 is always tranformed by any factor *)

Inductive Sh (n:nat) : occurrence -> Hydrae -> Hydrae -> Set :=
| Sh_1 : forall occ l l', S1 occ l l' -> Sh n occ l l'
| Sh_2 : forall occ l l', S2 n occ l l' -> Sh n occ l l'
| Sh_3 : forall occ l l', Sn n occ l l' -> Sh n occ l l'.

Fixpoint head_at (h:Hydra)(o:occurrence) {struct h}: bool :=
 match h, o with head, nil => true
               | node hs, o => head_at_l hs o
               | _, _ => false
 end
with head_at_l (hs:Hydrae)(o:occurrence){struct hs} : bool :=
 match hs, o with single h, 0::o' => head_at h o'
                | hcons h hs', 0::o' => head_at h o'
                | hcons h hs', S p::o' => head_at_l hs' (p::o')
                | _, _ => false
end.

Lemma head_at_nil : forall h, head_at h nil = true ->
                               h = head.
Proof.
 destruct h; simpl; auto.
 case h; simpl; discriminate 1 .
Qed.

Lemma head_at_zero_nil : forall h, head_at h (0::nil) = true ->
   {h' : Hydrae | h = node (hcons head h')} + {h = node (single head)}.
Proof.
 destruct h.
 simpl.
 discriminate 1.
 case h;simpl.
 destruct h0.
 right;auto.
 simpl.
 case h0.
 simpl.
 discriminate 1.
 simpl.
 discriminate 1.
 destruct h0.
 simpl.
 left;exists h0;auto.
 simpl.
 case h0.
 simpl.
 discriminate 1.
 simpl.
 discriminate 1.
Qed.

Lemma head_at_S_nil : forall h p, head_at h (S p::nil) = true ->
   {h' : Hydrae & {h0 : Hydra | h = node (hcons h0 h') /\
                                head_at_l h' (p::nil) = true}}.
Proof.
 destruct h.
 simpl.
 discriminate 1.
 case h;simpl.
 discriminate 1.
 intros h0 h1 p;exists h1;exists h0;auto.
Qed.

Lemma head_at_O_cons : forall h l p, head_at h (0::p::l) = true ->
    {h0:Hydra & {h' : Hydrae | h = node (hcons h0 h') /\
                     head_at h0 (p::l) = true}} +
    {h0:Hydra | h = node (single h0) /\ head_at h0 (p::l) = true}.
Proof.
 destruct h.
 simpl.
 discriminate 1.
 case h.
 simpl.
 right.
 exists h0.
 auto.
 simpl.
 left.
 exists h0;exists h1;auto.
Qed.

Lemma head_at_S_cons : forall h l q p, head_at h (S q::p::l) = true ->
    {h0:Hydra & {h' : Hydrae | h = node (hcons h0 h') /\
                               head_at_l h' (q::p::l) = true}}.
Proof.
 destruct h.
 simpl.
 discriminate 1.
 case h.
 simpl.
 discriminate 1.
 simpl.
 intros h0 h1 l q p.
 exists h0;exists h1.
 auto.
Qed.

Lemma head_at_l_nil : forall h, head_at_l h nil = true ->
                               False.
Proof.
 destruct h; simpl;  discriminate 1 .
Qed.

Lemma head_at_l_zero_nil : forall h, head_at_l h (0::nil) = true ->
   {h' : Hydrae | h = (hcons head h')} + {h = (single head)}.
Proof.
 destruct h.
 simpl.
 case h.
 right;auto.
 simpl.
 destruct h0.
 simpl.
 discriminate 1.
 simpl.
  discriminate 1.
 simpl.
 case h.
 simpl.
 left; exists h0;auto.
 simpl.
 intros.
 case (head_at_l_nil _  H).
Qed.

Lemma head_at_l_S_nil : forall h p, head_at_l h (S p::nil) = true ->
   {h' : Hydrae & {h0 : Hydra | h =  (hcons h0 h') /\
                                head_at_l h' (p::nil) = true}}.
Proof.
 destruct h.
 simpl.
 discriminate 1.
 simpl.
 exists h0; exists h; auto.
Qed.

Lemma head_at_l_O_cons : forall h l p, head_at_l h (0::p::l) = true ->
    {h0:Hydra & {h' : Hydrae | h =  (hcons h0 h') /\
                               head_at h0 (p::l) = true}} +
    {h0:Hydra | h =  (single h0) /\ head_at h0 (p::l) = true}.
Proof.
 destruct h.
 simpl.
 case h.
 simpl.
 discriminate 1.
 right.
 exists (node h0);auto.
 left.
 exists h.
 exists h0.
 split;auto.
Qed.

Lemma head_at_l_S_cons : forall h l q p, head_at_l h (S q::p::l) = true ->
    {h0:Hydra & {h' : Hydrae | h =  (hcons h0 h') /\
                               head_at_l h' (q::p::l) = true}}.
Proof.
 destruct h.
 simpl.
 discriminate 1.
 intros.
 exists h;exists h0; split;auto.
Qed.

Lemma S1_head : forall o h h', S1 o h h' ->
                                    head_at_l h o = true.
Proof.
 induction 1;  simpl; auto.
Qed.

Lemma R1_head : forall o h h', R1 o h h' -> head_at h o = true.
Proof.
 induction 1; simpl; auto.
 eapply S1_head; eauto.
Qed.

Lemma S2_head : forall n o h h', S2 n o h h' -> head_at_l h o =
                                                          true.
Proof.
 induction 1; simpl; auto;
 eapply R1_head; eauto.
Qed.

Lemma Rn_head : forall n o h h', Rn n o h h' -> head_at h o = true.
Proof.
 intros n o h h0 H.
 pattern o, h, h0, H.
 elim H using Rn_rect2  with
     (P0 := fun o h h0 (H: Sn n o h h0) =>
                       head_at_l h o = true); simpl;auto.
 intros.
 generalize (S2_head n u l l' s).
 simpl.
 auto.
Qed.

Lemma Rh_head : forall n o h h', Rh n o h h' -> head_at h o = true.
Proof.
 destruct 1.
 eapply R1_head; eauto.
 eapply Rn_head.
 eauto.
Qed.

Lemma Sh_head : forall n o h h', Sh n o h h' ->
                       head_at_l h o = true.
Proof.
 destruct 1.
 eapply S1_head; eauto.
 eapply S2_head.
 eauto.
 elim s.
 simpl.
 intros;eapply Rn_head;eauto.
 simpl.
 intros;eapply Rn_head;eauto.
 simpl; auto.
Qed.

Lemma Hydra_answers_nil :
 forall h, h <> head -> head_at h nil = false.
Proof.
 intro h;case h;simpl.
 intro; absurd (head = head);auto.
 destruct h0;simpl;auto.
Qed.

(* quite long, huh ? *)

Lemma Hydra_answers :
 forall h u n, h <> head -> head_at h u = true ->
                 {h':Hydra & Rh n u h h'}.
Proof.
 intro h;
 elim h using Hydra_rect2 with
        (P0 := fun hs => hs <>  (single head) ->
                         forall u n, head_at_l hs u = true ->
                                    {h':Hydrae & Sh n u hs h'}).
 intros; absurd (head=head);auto.
 destruct u.
 simpl.
 intros.
 case (head_at_l_nil _ H1).
 case u.
 case n.
 intros.
 case (head_at_zero_nil _ H1).
 destruct 1.
 injection e.
 intros; subst h0.
 exists (node x).
 left.
 constructor.
 constructor.
 injection 1.
 intro; subst h0.
 exists head.
 left.
 constructor .
 intros.
 case (head_at_S_nil _ _ H1).
 destruct 1.
 case a.
 intros.
 injection H2.
 intro; subst h0.
 assert( hcons x0 x <> single head).
 discriminate.
 case (H H4 (S n0::nil) n1  H1).

 intros;exists (node x1).
 case s.
 left.
 constructor;auto.
 right.
 left;auto.
 right;auto.
 right;auto.
 case n.
 intros.
 simpl in H1.
 case (head_at_l_O_cons _ _ _ H1).
 destruct 1.
 case s.
 destruct 1.
 assert (h0 <> single head).
 rewrite H2;discriminate.
 case (H H4 (0::n0::l) n1 H1).
 intro x1;exists (node x1).
 case s0.
 left; constructor.
 auto.
 right;left.
 auto.
 right.
 right.
 auto.
 destruct 1.
 case a;intros.
 clear a.
 subst h0.
 assert (single x <> single head).
 red; intro.
 injection H2;intro; subst x.
 simpl in H1.
 discriminate H1.
 case (H H2 (0::n0::l) n1).
 auto.
 intros;exists (node x0).
 case s.
 left;constructor.
 auto.
 right;left.
 auto.
 right;right.
 auto.
 simpl.
 intros.
 assert( h0 <> single head).
 red;intro; subst h0.
 discriminate H1.
 case (H H2 _ n2 H1).
 intros; exists (node x).
 case s.
 left;auto.
 constructor;auto.
 right;left;auto.
 right;right.
 auto.
 destruct u.
  simpl.
 discriminate 1.
 destruct n.
 simpl.
 assert (h0 <> head).
 red;intro;apply H0;subst h0;auto.
 intros.
 case (H u n H1 H2).
 destruct 1.
 exists (replicate h' n (single h')).
 constructor 2.
 constructor.
 auto.
 exists (single h').
 constructor 3.
 constructor;auto.
 simpl.
 discriminate 1.
 destruct u.
 intros.
 case (head_at_l_nil _ H2).
 case n.
 simpl.
 case u.
 intros.
 assert (h0=head).
 apply head_at_nil.
 auto.
 subst h0.
 exists h1.
 constructor 1;constructor.
 destruct n0.
 intros.
 assert (h0 <> head).
 red;intro;subst h0.
 discriminate H2.
 case (H (0::l) n0 H3 H2).
 destruct 1.
 exists (replicate h' (S n0) h1).
 constructor 2.
 constructor.
 auto.
 exists (hcons h' h1).
 constructor 3.
 constructor.
 auto.
 simpl.
 intros.
 assert (h0 <> head).
 red;intro;subst h0;discriminate H2.
 case (H (S n0::l) n1 H3 H2).
 destruct 1.
 exists (replicate h' (S n1) h1).
 constructor 2.
 constructor 2.
 auto.
 exists (hcons h' h1).
 constructor 3.
 constructor 2.
 auto.
 intros.
 simpl in H2.
 generalize H2; case n0;case u.
 simpl.
 intros.
 case (head_at_l_zero_nil _ H3).
 destruct 1.
 assert (h1 <> single head).
 rewrite e; discriminate.
 case (H0 H4 (0::nil) n1).
 auto.
 inversion 1.
 exists (hcons h0 x0).
 constructor 1.
 constructor 3.
 auto.
 exists (hcons h0 x0).
 constructor 2.
 constructor 3.
 auto.
 exists (hcons h0 x0).
 constructor 3.
 constructor 3.
 auto.
 intro H4;subst h1.
 exists (single h0).
 constructor 1.
 constructor.
 intros.
 assert (h1 <> single head).
 intro ; subst h1; discriminate H3.
 case (H0 H4 (0::n2::l) n1 H3).
 inversion 1.
 exists (hcons h0 x).
 constructor 1.
 inversion H5.
 exists (hcons h0 x).
 constructor 2.
 constructor 3.
 auto.
 exists (hcons h0 x).
 constructor 3.
 constructor 3.
 auto.
 intros; assert (h1 <> single head).
 intro; subst h1;discriminate H3.
 case (H0 H4 (S n2::nil) n1 H3).
 inversion 1.
 exists (hcons h0 x).
 constructor 1.
 constructor 3.
 auto.
 exists (hcons h0 x).
 constructor 2.
 constructor 3;auto.
 exists (hcons h0 x).
 constructor 3.
 constructor 3.
 auto.
 intros.
 assert (h1 <> single head).
 red;intro;subst h1;discriminate H3.
 case (H0 H4 _ n1 H3).
 inversion 1.
 inversion H5.
 exists (hcons h0 x).
 constructor 2.
 constructor 3.
 auto.
 exists (hcons h0 x).
 constructor 3.
 constructor 3.
 auto.
Defined.

(* converting an hydra into an ordinal notation *)

(* it would be better (i.e. more abstract) to omega-raise
   the h2o of the sub_hydrae before sorting.
   (nearer to the concept of natural sum)

*)

Fixpoint h2o (h:Hydra) : T1 :=
  match h with head => zero
             | node hs => (sort (h2ol hs))
end
with h2ol (hs:Hydrae) : T1 :=
  match hs with single h => (cons (h2o h) 0 zero)
              | hcons h hs' => (cons (h2o h) 0 (h2ol hs'))
 end.

Theorem h2o_nf : forall h, nf (h2o h).
Proof.
 intro h; elim h using Hydra_rect2
            with (P0 := fun hs => nfs (h2ol hs)).
 simpl.
 constructor.
 simpl.
 intros.
 apply sort_nf.
 auto.
  intros;apply nf_to_nfs.
  simpl.
 constructor.
 auto.
 simpl;auto.
 constructor;auto.
Qed.

Theorem h2ol_nfs : forall hs, nfs (h2ol hs).
Proof.
 induction hs.
  simpl.
  constructor.
  apply h2o_nf.
  constructor.
 simpl;constructor.
 apply h2o_nf.
 auto.
Qed.

(*
Let l l' be lists of hydras, if l' is obtained from l by removing
some element of l (which must be a head), then multiset of ordinal terms
associed with l is lesser than the multiset associed with l'
*)

Lemma S1_decrease:
  forall u l l', S1 u l l' -> exists a, ltM a (h2ol l') (h2ol l).
Proof.
 induction 1.
 simpl.
 exists zero.
 apply ltM_tail;auto.
 simpl.
 exists zero.
 unfold ltM.
 split.
 Opaque T1_eq_dec.
 simpl; case (T1_eq_dec (h2o h) zero).
 intro e; rewrite e; simpl.
 case (T1_eq_dec zero zero).
 auto with arith.
 intros; absurd (zero=zero);auto.
 case (T1_eq_dec zero (h2o h)).
 intros; absurd (zero = h2o h);auto.
 case (T1_eq_dec zero zero).
 auto.
 intro; absurd (zero=zero).
 auto.
 auto.
 simpl.
 intros;case (T1_eq_dec b (h2o h)).
 intros;case (T1_eq_dec b zero).
 intro; clear e; subst b; inversion H.
 auto.
 intros;case (T1_eq_dec b zero).
 intro;  subst b; inversion H.
 auto.
 simpl.
 case IHS1; intros a Ha;exists a; apply ltM_cons;auto.
Qed.

(*
  If h' is obtained from h by removing a head at distance 1 from its root,
  then the ordinal term associed with h' is lesser than the ordinal term
  associed with h
*)

Lemma R1_decrease : forall u h h', R1 u h h' -> h2o h' <  h2o h.
Proof.
 induction 1.
 simpl.
 auto with T1.
 simpl.
 generalize (S1_decrease u l l' s).
 destruct 1.
 generalize (sort_equiv (h2ol l)).
 intro He.
 generalize (sort_equiv (h2ol l')).
 intro He'.
 generalize (sort_nf (h2ol l)).
 intro Hs.
 generalize (sort_nf (h2ol l')).
 intro Hs'.
 apply ltM_lt with x ; auto.
 apply sort_nf.
 apply h2ol_nfs.
  apply sort_nf.
 apply h2ol_nfs.
 eapply ltM_equiv_ltM.
 2:eauto.
 eapply ltM_equiv_ltMR.
 eauto.
 auto.
Qed.

(*
  Let l l' be lists of hydras.

  Let us assume than l' is obtained fromp l by
  a) choosing an hydra li element of l
  b) chopping off a head from li (at distance 1 from its root)
  c) replicating n times the decapited hydra

  then the multiset of ordinal terms associed to l' is lesser than
   the multiset associed with l
*)

Lemma S2_decrease : forall n u l l', S2 n u l l' ->
                                        exists a:T1,
                                          ltM a (h2ol l') (h2ol l).
Proof.
 induction 1.
 simpl.
 generalize (R1_decrease _ _ _ r).
 exists (h2o h).
 induction n.
 simpl.
 apply ltM_head.
 auto with arith.
 auto.
 simpl.
 apply lt_ltM.
 auto.
 auto.
 exists (h2o h).
 induction n.
 simpl.
 apply ltM_head.
 auto with arith.
 eapply R1_decrease.
 eauto.
 simpl.
 simpl in IHn.
 apply lt_ltM.
 eapply R1_decrease.
 eauto.
 auto.
 case IHS2; intros.
 exists x.
 simpl.
 apply ltM_cons.
 auto.
Qed.

(*

If h' is obtained from h by
 a) chopping off a head at a level >= 2
 b) letting the hydra react

 then the mesaure associed with h' is lesser than the measure associed with h

*)

Theorem Rn_decrease : forall n u h h', Rn n u h h' ->
                                        h2o h' <  h2o h.
Proof.
 intros n o h h' H.
 elim H using Rn_rect2 with
   (P0 := fun o (h h0: Hydrae)(H:Sn n o h h0) =>
                    exists a, ltM a (h2ol h0) (h2ol h)).
 simpl;intros.
 case (S2_decrease _ _ _ _ s).
 intros.
 eapply ltM_lt with x.
 apply sort_nf.
 apply h2ol_nfs.
 apply sort_nf.
 apply h2ol_nfs.

eapply ltM_equiv_ltM.
 2:eapply sort_equiv.

 eapply ltM_equiv_ltMR.
 2:eapply sort_equiv.
 auto.
 intros.
 case H0;intros a Ha.
 apply ltM_lt with a;auto.
 apply h2o_nf.
 apply h2o_nf.
  simpl.
  eapply ltM_equiv_ltM.
 2:eapply sort_equiv.
 eapply ltM_equiv_ltMR.
 2:eapply sort_equiv.
 auto.

 intros.
 exists (h2o h0).
 simpl. apply ltM_head.
 auto .
 intros.
 exists (h2o h0).
 simpl;apply ltM_head.
 auto with arith.
 intros.
 case H0.
 intros.
 exists x.
 simpl;apply ltM_cons;auto.
Qed.

Theorem Rh_decrease : forall n u h h', Rh n u h h' -> h2o h' <  h2o h.
Proof.
 induction 1.
 eapply R1_decrease.
 eauto.
 eapply Rn_decrease.
 eauto.
Qed.

Definition Hercules_strat := nat ->  Hydra -> occurrence.

Definition Hydra_strat := nat -> Hydra -> occurrence -> nat.

Section game.
 Variable str : Hercules_strat.
 Hypothesis str_ok : forall t h, head_at h (str t h) = true.
 Variable str_hy : Hydra_strat.

 Inductive Hercules_wins  :  nat -> Hydra  -> Prop :=
    Now  : forall t, Hercules_wins t head
 |  Later  : forall t h , ( forall h', Rh (str_hy (S t) h (str (S t) h))
                                           (str (S t) h) h h' ->
                                        Hercules_wins t h' ) ->
            Hercules_wins t h.

Definition Hercules_ok (alpha:T1) := forall t h, h2o h = alpha ->
   Hercules_wins t h.

Lemma Winner : forall alpha, nf alpha -> Hercules_ok alpha.
Proof.
 intros o Ho;  apply  EPSILON0.transfinite_induction.
 2:auto.
 intros.
 unfold Hercules_ok.
 destruct h.
 constructor.
 unfold Hercules_ok in H0.
 intro.
 right.
 intros.
 generalize  (H0 (h2o h') ).
 intros; eapply H0.
 3:reflexivity.
 apply h2o_nf.
 case H1.
 eapply Rh_decrease.
 eauto.
Qed.

Theorem Legend : forall t h, Hercules_wins t h.
Proof.
 generalize Winner.
 unfold Hercules_ok.
 intros.
 eapply H.
 eapply h2o_nf.
 reflexivity.
Qed.

End game.

Transparent T1_eq_dec.


Require VC.Preface. (* Check for the right version of VST *)
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VC.stack.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Require Import VC.hints. (* Import special hints for this tutorial. *)

Definition malloc_spec_example :=
 DECLARE _malloc
 WITH t:type, gv: globals
 PRE [ tuint ]
    PROP (0 <= sizeof t <= Int.max_unsigned;
          complete_legal_cosu_type t = true;
          natural_aligned natural_alignment t = true)
    PARAMS (Vint (Int.repr (sizeof t)))
    SEP (mem_mgr gv)
 POST [ tptr tvoid ] EX p:_,
    PROP ()
    RETURN (p)
    SEP (mem_mgr gv;
            if eq_dec p nullval then emp
            else (malloc_token Ews t p * data_at_ Ews t p)).
Definition free_spec_example :=
 DECLARE _free
 WITH t: type, p:val, gv: globals
 PRE [ tptr tvoid ]
     PROP ()
     PARAMS (p)
     SEP (mem_mgr gv; malloc_token Ews t p; data_at_ Ews t p)
 POST [ Tvoid ]
     PROP () RETURN () SEP (mem_mgr gv).

Fixpoint listrep (il: list Z) (p: val) : mpred :=
 match il with
 | i::il' => EX y: val,
        malloc_token Ews (Tstruct _cons noattr) p *
        data_at Ews (Tstruct _cons noattr) (Vint (Int.repr i),y) p *
        listrep il' y
 | nil => !! (p = nullval) && emp
 end.

Arguments listrep il p : simpl never.

(*standard (stack_listrep_properties)*)
Lemma listrep_local_prop: forall il p, listrep il p |--
        !! (is_pointer_or_null p /\ (p=nullval <-> il=nil)).
Proof.
  intros. unfold listrep. induction il.
  - entailer!.
    split; auto.
  - fold listrep. Intros y. entailer!. split.
    + intro.
      eapply field_compatible_nullval. subst p. eapply H0.
    + intro. inversion H2.
Qed.

#[export] Hint Resolve listrep_local_prop : saturate_local.

Lemma listrep_valid_pointer:
  forall il p,
    listrep il p |-- valid_pointer p.
Proof.
  intros. unfold listrep. destruct il.
  - entailer!.
  - Intro y. hint.  auto with valid_pointer.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.
(*/standard (stack_listrep_properties)*)

Definition stack (il: list Z) (p: val) :=
 EX q: val,
  malloc_token Ews (Tstruct _stack noattr) p *
  data_at Ews (Tstruct _stack noattr) q p *
  listrep il q.
Arguments stack il p : simpl never.

(*standard (stack_properties)*)
Lemma stack_local_prop: forall il p, stack il p |-- !! (isptr p).
Proof.
  intros. unfold stack. entailer. hint. entailer!.
Qed.

#[export] Hint Resolve stack_local_prop : saturate_local.

Lemma stack_valid_pointer:
  forall il p,
   stack il p |-- valid_pointer p.
Proof.
  intros. unfold stack. hint. entailer!. auto with valid_pointer.
Qed.
#[export] Hint Resolve stack_valid_pointer : valid_pointer.
(*/standard (stack_properties)*)

Definition newstack_spec : ident * funspec :=
 DECLARE _newstack
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS(gv) SEP (mem_mgr gv)
 POST [ tptr (Tstruct _stack noattr) ]
 EX p: val, PROP ( ) RETURN (p) SEP (stack nil p; mem_mgr gv).

Definition push_spec : ident * funspec :=
 DECLARE _push
 WITH p: val, i: Z, il: list Z, gv: globals
 PRE [ tptr (Tstruct _stack noattr), tint ]
    PROP (Int.min_signed <= i <= Int.max_signed)
    PARAMS (p; Vint (Int.repr i)) GLOBALS(gv)
    SEP (stack il p; mem_mgr gv)
 POST [ tvoid ]
 PROP ( ) RETURN () SEP (stack (i::il) p; mem_mgr gv).

Definition pop_spec : ident * funspec :=
 DECLARE _pop
 WITH p: val, i: Z, il: list Z, gv: globals
 PRE [ tptr (Tstruct _stack noattr) ]
    PROP ()
    PARAMS (p) GLOBALS(gv)
    SEP (stack (i::il) p; mem_mgr gv)
 POST [ tint ]
 PROP ( ) RETURN (Vint (Int.repr i)) SEP (stack il p; mem_mgr gv).

Definition Gprog : funspecs :=
        ltac:(with_library prog [
                   newstack_spec; push_spec; pop_spec
             ]).

(*standard (body_pop)*)

Lemma body_pop: semax_body Vprog Gprog f_pop pop_spec.
Proof.
  start_function.
  unfold stack.
  Intros q.
  Print listrep.

  unfold listrep.
  fold listrep.
  Intros y.
  forward.
  forward.
  forward.
  forward.
  hint.
  Print free_spec'.
  hint.
  assert_PROP(q<>nullval) by entailer!.
  forward_call(Tstruct _cons noattr, q, gv).
  - hint.
    Print eq_dec.
    destruct (eq_dec q nullval).
    + contradiction.
    + hint. entailer!.
  - forward. hint. unfold stack. hint. Exists y. hint. entailer!.
Qed.

Lemma body_push: semax_body Vprog Gprog f_push push_spec.
Proof.
  start_function.
  forward_call (Tstruct _cons noattr, gv).
  unfold stack.
  Intros q x.
  destruct (eq_dec q nullval).
  - hint. forward_if(q<>nullval).
    + Print exit_spec'. forward_call(1). entailer!.
    + contradiction.
    + Intros. contradiction.
  - hint. forward_if(q<>nullval).
    + forward_call(1). entailer!.
    + hint. forward. hint. entailer!.
    + Intros. forward. forward. forward. forward. unfold stack. fold stack. hint. Exists q. hint.
      unfold listrep. fold listrep. Exists x.
      entailer!.
Qed.

Lemma body_newstack: semax_body Vprog Gprog f_newstack newstack_spec.
Proof.
  start_function.
  forward_call ((Tstruct _stack noattr) , gv).
  Intro p.
  destruct (eq_dec p nullval).
  - forward_if(p<>nullval).
    + forward_call(1). entailer!.
    + contradiction.
    + Intros. contradiction.
  - forward_if(p<>nullval).
    + forward_call(1). entailer!.
    + forward. entailer!.
    + hint. Intros. forward. forward. unfold stack. hint. Exists p. hint.  entailer!. hint.
      Exists nullval. unfold listrep.  entailer!.
Qed.


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import CodeGen.
Require Import PolyLang.
Require Import Instr.
Require Import ImpureAlarmConfig.
Require Import List.
Require Import String.
Require Import Linalg.
Require Import ZArith.
Require Import TopoSort.

Open Scope Z_scope.
Import ListNotations.

Require Extraction.

Set Extraction AccessOpaque.

Extract Inlined Constant CoqAddOn.posPr => "CoqPr.posPr'".
Extract Inlined Constant CoqAddOn.posPrRaw => "CoqPr.posPrRaw'".
Extract Inlined Constant CoqAddOn.zPr => "CoqPr.zPr'".
Extract Inlined Constant CoqAddOn.zPrRaw => "CoqPr.zPrRaw'".

(*
Extract Inlined Constant CoqAddOn.posPr => "(fun x -> Vpl.CoqPr.posPr' (Obj.magic x))".
Extract Inlined Constant CoqAddOn.posPrRaw => "(fun x -> Vpl.CoqPr.posPrRaw' (Obj.magic x))".
Extract Inlined Constant CoqAddOn.zPr => "(fun x -> Vpl.CoqPr.zPr' (Obj.magic x))".
Extract Inlined Constant CoqAddOn.zPrRaw => "(fun x -> Vpl.CoqPr.zPrRaw' (Obj.magic x))".

Extract Constant PedraQBackend.t => "Vpl.PedraQOracles.t".
Extract Constant PedraQBackend.top => "Vpl.PedraQOracles.top".
Extract Constant PedraQBackend.isEmpty => "(fun x -> Vpl.PedraQOracles.isEmpty (Obj.magic x))".
Extract Constant PedraQBackend.add => "(fun x -> Vpl.PedraQOracles.add (Obj.magic x))".
Extract Constant PedraQBackend.pr => "(fun x -> Vpl.PedraQOracles.pr (Obj.magic x))".
*)

Extract Inductive sumbool => "bool" [ "true" "false" ].

Extract Inlined Constant topo_sort_untrusted => "(fun l -> (Topo.coq_toposort l, true))".

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlString.

Extract Inlined Constant instr => "int".

Extraction Blacklist String List.
Extraction Blacklist Misc. (* used by the VPL *)

Axiom make_instr : nat -> instr.
Extract Inlined Constant dummy_instr => "0".
Extract Inlined Constant make_instr => "Conversions.coqnat_to_int".

(* begin: debugging code *)
Extract Inlined Constant Debugging.failwith =>
  "(fun st mesg _ -> raise (CertcheckerConfig.CertCheckerFailure (st, (CoqPr.charListTr mesg))))".
(*
Extract Inlined Constant Debugging.trace =>
   "(fun mode l a -> if (Debugging.traceCmp INFO mode) then (print_string (CoqPr.charListTr l); print_newline()); a)".
*)
Definition vr n := (assign n 1 nil, 0).
Arguments vr n%nat.

Delimit Scope aff_scope with aff.
Notation "x * y" := (mult_constraint x y) : aff_scope.
Local Arguments mult_constraint k%Z c%aff.

Notation "x + y" := (add_constraint x y) : aff_scope.
Notation "- x" := (mult_constraint (-1) x) : aff_scope.
Notation "x - y" := (x + -y)%aff : aff_scope.
Notation "$ x" := (nil, x) (at level 30) : aff_scope.

Notation "x /\ y" := (x ++ y) : aff_scope.
Notation "x <= y" := [ (mult_constraint_cst (-1) (add_constraint x (mult_constraint (-1) y))) ] : aff_scope.
Notation "x >= y" := (y <= x)%aff : aff_scope.
Notation "x <= y <= z" := (x <= y /\ y <= z)%aff : aff_scope.
Notation "x >= y >= z" := (x >= y /\ y >= z)%aff (at level 70, y at next level) : aff_scope.
Notation "x == y" := (x <= y /\ y <= x)%aff (at level 70) : aff_scope.

Notation "{{ x }}" := x (only parsing).

Definition a := vr 0. Definition b := vr 1. Definition c := vr 2. Definition d := vr 3. Definition e := vr 4. Definition f := vr 5.

(*
Definition test_pi_1 := {|
   pi_instr := dummy ;
   pi_poly := [ ([0; 0; -1; 0], 0); ([0; 0; 0; -1], 0); ([-1; 0; 1; 0], 0); ([0; -1; 0; 1], 0) ] ;
   pi_schedule := [([0; 0; 0; 1], 0); ([0; 0; 1; 0], 0)] ;
   pi_transformation := [([0; 0; 1; 0], 0); ([0; 0; 0; 1], 0)] ;
|}%aff.

Definition test_pi_2 := {|
   pi_instr := dummy ;
   pi_poly := [ ([0; 0; 0; -1], 0); ([-1; 0; 0; 1], 0); ([0; 1; 0; -3], 0); ([0; -1; 0; 3], 0); ([0; 0; 1; -2], 0); ([0; 0; -1; 2], 0) ] ;
   pi_schedule := [([0; 1; 0; 0], 0); ([0; 0; 1; 0], 0); ([0; 0; 0; 1], 0)] ;
   pi_transformation := [([0; 1; 0; 0], 0); ([0; 0; 1; 0], 0); ([0; 0; 0; 1], 0)] ;
|}.

Definition test_pi_3 := {|
   pi_instr := dummy ;
   pi_poly := [ ([0; 0; -1], 0); ([-1; 0; 1], 0); ([0; 3; -1], 0); ([0; -3; 1], 2) ] ;
   pi_schedule := [([0; 1; 0], 0); ([0; -3; 1], 0)] ;
   pi_transformation := [([0; 0; 1], 0)] ;
|}.

Definition test_pi_4 := {|
   pi_instr := dummy ;
   pi_poly := [ ([0; 0; -1], 0); ([-1; 0; 1], 0); ([0; 3; -1], 0); ([0; -3; 1], 2) ] ;
   pi_schedule := [([0; -3; 1], 0); ([0; 1; 0], 0)] ;
   pi_transformation := [([0; 0; 1], 0)] ;
|}.
*)

Open Scope aff_scope.

Definition test_pi_1 := {|
   pi_instr := make_instr 0%nat ;
   pi_poly := {{ $0 <= c <= a /\ $0 <= d <= b }} ;
   pi_schedule := [d ; c] ;
   pi_transformation := [c ; d] ;
|}.

Definition test_pi_2 := {|
   pi_instr := make_instr 0%nat ;
   pi_poly := {{ $0 <= d <= a /\ b == 3 * d /\ c == 2 * d }} ;
   pi_schedule := [b ; c ; d] ;
   pi_transformation := [b ; c ; d] ;
|}.

Definition test_pi_3 := {|
   pi_instr := make_instr 0%nat ;
   pi_poly := {{ $0 <= c <= a /\ $0 <= c - 3 * b <= $2 }} ;
   pi_schedule := [b ; c - 3 * b] ;
   pi_transformation := [c] ;
|}.

Definition test_pi_4 := {|
   pi_instr := make_instr 0%nat ;
   pi_poly := {{ $0 <= c <= a /\ $0 <= c - 3 * b <= $2 }} ;
   pi_schedule := [c - 3 * b ; b] ;
   pi_transformation := [c] ;
|}.

Definition test_pi_5 := {|
   pi_instr := make_instr 0%nat ;
   pi_poly := {{ $0 <= b <= a }} ;
   pi_schedule := [2 * b] ;
   pi_transformation := [b] ;
|}.

Open Scope string_scope.

Definition test_pis := [
  (2%nat, 2%nat, "Swap Loop", test_pi_1) ;
  (1%nat, 3%nat, "Linear 3-2-1", test_pi_2) ;
  (1%nat, 2%nat, "Tiling-1", test_pi_3) ;
  (1%nat, 2%nat, "Tiling-2", test_pi_4) ;
  (1%nat, 1%nat, "Modulo", test_pi_5)
].

Definition test_many := [{|
   pi_instr := make_instr 0%nat ;
   pi_poly := {{ $1 <= c <= a /\ d == c}} ;
   pi_schedule := [] ;
   pi_transformation := [c ; d] ;
  |};
  {|
   pi_instr := make_instr 1%nat ;
   pi_poly := {{ $1 <= c <= a /\ c <= d <= a}} ;
   pi_schedule := [] ;
   pi_transformation := [c ; d] ;
  |};
  {|
   pi_instr := make_instr 2%nat ;
   pi_poly := {{ $1 <= c <= b /\ d == a}} ;
   pi_schedule := [] ;
   pi_transformation := [c ; d] ;
|}].

Extraction Inline CoreAlarmed.Base.pure CoreAlarmed.Base.imp.

Cd "extraction".

Separate Extraction ZArith_dec complete_generate complete_generate_lex_many complete_generate_many test_many pi_elim_schedule test_pis Ring_polynom_AddOnQ CstrLCF ProgVar LinTerm(* test_pi_lex test_pi_generate *).


Require Import hdl.

Record semantics (G C M : Type) : Type :=
  mkSemantics {
      at_external : C -> ee -> Prop;
      after_external : C -> C;
      step : G -> C*M -> C*M (*bigstep*)
    }.

Definition hdl_process : semantics st st env :=
  mkSemantics
    _ _ _
    guarded
    unguard
    (fun restart p =>
       let (c,m) := p in
       match interp m c with
       | (m', stskip) => (restart, m')
       | (m', c') => (c', m')
       end).


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e174m3_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal71.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (H:not (@eq natural x y)) (Heqb:@eq bool (eqb x y) true):@eq natural (Succ Zero) Zero.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal71_theorem0_75_Nat_beq_eq/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e213m3_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.Arith Coq.Vectors.Vector
     Coq.NArith.NArith Coq.ZArith.ZArith.
Require Import Cava.Arrow.ArrowExport Cava.BitArithmetic.

Require Import AesSpec.StateTypeConversions.
Require Import AesSpec.Tests.CipherTest AesSpec.Tests.Common.
Require Import Aes.Pkg Aes.MixColumns Aes.SubBytes Aes.ShiftRows.

Require Import coqutil.Z.HexNotation.

Import VectorNotations.
Import KappaNotation.
Open Scope kind_scope.

Definition test_key := byte_reverse (n:=32) (N2Bv_sized 256 (Z.to_N (Ox "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f"))).
Definition test_data := byte_reverse (n:=16) (N2Bv_sized 128 (Z.to_N (Ox "00112233445566778899aabbccddeeff"))).
Definition test_encrypted := byte_reverse (n:=16) (N2Bv_sized 128 (Z.to_N (Ox "8ea2b7ca516745bfeafc49904b496089"))).

(* Vector.eqb is extracted under a different namespace, so we redefine
* boolean vector equality here *)
Definition vector_equality {n} (v1: Vector.t bool n) (v2: Vector.t bool n) :=
  Vector.fold_left andb true (Vector.map2 Bool.eqb v1 v2).

Definition print_cipher_fwd (cipher: bool -> Vector.t bool 256 -> Vector.t bool 128 -> Vector.t bool 128): Z
  := Z.of_N (Bv2N (byte_reverse (n:=16) (cipher false test_key test_data))).
Definition print_cipher_rev (cipher: bool -> Vector.t bool 256 -> Vector.t bool 128 -> Vector.t bool 128): Z
  := Z.of_N (Bv2N (byte_reverse (n:=16) (cipher true test_key test_encrypted))).

Definition test_cipher_fwd (cipher: bool -> Vector.t bool 256 -> Vector.t bool 128 -> Vector.t bool 128): bool
  := vector_equality (cipher false test_key test_data) test_encrypted.

Definition test_cipher_rev (cipher: bool -> Vector.t bool 256 -> Vector.t bool 128 -> Vector.t bool 128): bool
  := vector_equality (cipher true test_key test_encrypted) test_data.

(* AES-256 expanded empty key *)
(*
0x00, 0x00, 0x00, 0x00, ~ 0x00, 0x00, 0x00, 0x00, ~ 0x00, 0x00, 0x00, 0x00, ~ 0x00, 0x00, 0x00, 0x00 = k0
0x00, 0x00, 0x00, 0x00, ~ 0x00, 0x00, 0x00, 0x00, ~ 0x00, 0x00, 0x00, 0x00, ~ 0x00, 0x00, 0x00, 0x00 = k1
0x62, 0x63, 0x63, 0x63, ~ 0x62, 0x63, 0x63, 0x63, ~ 0x62, 0x63, 0x63, 0x63, ~ 0x62, 0x63, 0x63, 0x63 = k2
0xaa, 0xfb, 0xfb, 0xfb, ~ 0xaa, 0xfb, 0xfb, 0xfb, ~ 0xaa, 0xfb, 0xfb, 0xfb, ~ 0xaa, 0xfb, 0xfb, 0xfb = k3
0x6f, 0x6c, 0x6c, 0xcf, ~ 0x0d, 0x0f, 0x0f, 0xac, ~ 0x6f, 0x6c, 0x6c, 0xcf, ~ 0x0d, 0x0f, 0x0f, 0xac = k4
0x7d, 0x8d, 0x8d, 0x6a, ~ 0xd7, 0x76, 0x76, 0x91, ~ 0x7d, 0x8d, 0x8d, 0x6a, ~ 0xd7, 0x76, 0x76, 0x91 = k5
0x53, 0x54, 0xed, 0xc1, ~ 0x5e, 0x5b, 0xe2, 0x6d, ~ 0x31, 0x37, 0x8e, 0xa2, ~ 0x3c, 0x38, 0x81, 0x0e = k6
0x96, 0x8a, 0x81, 0xc1, ~ 0x41, 0xfc, 0xf7, 0x50, ~ 0x3c, 0x71, 0x7a, 0x3a, ~ 0xeb, 0x07, 0x0c, 0xab = k7
0x9e, 0xaa, 0x8f, 0x28, ~ 0xc0, 0xf1, 0x6d, 0x45, ~ 0xf1, 0xc6, 0xe3, 0xe7, ~ 0xcd, 0xfe, 0x62, 0xe9 = k8
0x2b, 0x31, 0x2b, 0xdf, ~ 0x6a, 0xcd, 0xdc, 0x8f, ~ 0x56, 0xbc, 0xa6, 0xb5, ~ 0xbd, 0xbb, 0xaa, 0x1e = k9
0x64, 0x06, 0xfd, 0x52, ~ 0xa4, 0xf7, 0x90, 0x17, ~ 0x55, 0x31, 0x73, 0xf0, ~ 0x98, 0xcf, 0x11, 0x19 = k10
0x6d, 0xbb, 0xa9, 0x0b, ~ 0x07, 0x76, 0x75, 0x84, ~ 0x51, 0xca, 0xd3, 0x31, ~ 0xec, 0x71, 0x79, 0x2f = k11
0xe7, 0xb0, 0xe8, 0x9c, ~ 0x43, 0x47, 0x78, 0x8b, ~ 0x16, 0x76, 0x0b, 0x7b, ~ 0x8e, 0xb9, 0x1a, 0x62 = k12
0x74, 0xed, 0x0b, 0xa1, ~ 0x73, 0x9b, 0x7e, 0x25, ~ 0x22, 0x51, 0xad, 0x14, ~ 0xce, 0x20, 0xd4, 0x3b = k13
0x10, 0xf8, 0x0a, 0x17, ~ 0x53, 0xbf, 0x72, 0x9c, ~ 0x45, 0xc9, 0x79, 0xe7, ~ 0xcb, 0x70, 0x63, 0x85 = k14
*)

(* Plug aes subroutines into testing infrastructure *)
Definition aes_impl_for_tests
           (step : AESStep) (k st : Vector.t bool 128) : Vector.t bool 128 :=
  (* forward vs inverse direction flag *)
  let FWD := kinterp CIPH_FWD tt in
  let INV := kinterp CIPH_INV tt in
  (* convert between flat-vector representation and state type *)
  (* Note: implementation uses row-major state *)
  let from_flat : Vector.t bool 128 ->
                  denote_kind << Vector (Vector (Vector Bit 8) 4) 4 >> :=
      fun st => Vector.map (Vector.map (fun r => byte_to_bitvec r)) (to_rows st) in
  let to_flat : denote_kind << Vector (Vector (Vector Bit 8) 4) 4 >> ->
                Vector.t bool 128 :=
      fun st => from_rows (Vector.map (Vector.map (fun r => bitvec_to_byte r)) st) in
  match step with
  | AddRoundKey =>
    (* no specific definition for the xor; use spec version *)
    aes_impl step k st
  | SubBytes =>
    to_flat (kinterp (aes_sub_bytes SboxCanright) (FWD, (from_flat st, tt)))
  | InvSubBytes =>
    to_flat (kinterp (aes_sub_bytes SboxCanright) (INV, (from_flat st, tt)))
  | ShiftRows =>
    to_flat (kinterp aes_shift_rows (FWD, (from_flat st, tt)))
  | InvShiftRows =>
    to_flat (kinterp aes_shift_rows (INV, (from_flat st, tt)))
  | MixColumns =>
    to_flat (kinterp aes_mix_columns (FWD, (from_flat st, tt)))
  | InvMixColumns =>
    to_flat (kinterp aes_mix_columns (INV, (from_flat st, tt)))
  end.

(* TODO: native_compute is faster here, but fails on CI because "ocaml compiler
   is not installed" *)
(* Run full encryption test from FIPS *)
Goal (aes_test_encrypt Matrix aes_impl_for_tests = Success).
Proof. vm_compute. reflexivity. Qed.
(* Run full decryption test from FIPS *)
Goal (aes_test_decrypt Matrix aes_impl_for_tests = Success).
Proof. vm_compute. reflexivity. Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.arrival_sequence prosa.classic.model.priority prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.global.jitter.job
               prosa.classic.model.schedule.global.jitter.schedule
               prosa.classic.model.schedule.global.jitter.interference
               prosa.classic.model.schedule.global.jitter.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module InterferenceEDF.

  Import ScheduleWithJitter Priority Platform Interference Priority.

  Section Lemmas.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_jitter: Job -> time.

    (* Assume any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* Consider any schedule. *)
    Variable num_cpus: nat.
    Variable sched: schedule Job num_cpus.

    (* Assume that the schedule satisfies the global scheduling invariant
       for EDF, i.e., if any job of tsk is backlogged, every processor
       must be busy with jobs with no larger absolute deadline. *)
    Hypothesis H_scheduler_uses_EDF:
      respects_JLFP_policy job_arrival job_cost job_jitter arr_seq sched
                           (EDF job_arrival job_deadline).

    (* Under EDF scheduling, a job only causes interference if its deadline
       is not larger than the deadline of the analyzed job. *)
    Lemma interference_under_edf_implies_shorter_deadlines :
      forall j j' t1 t2,
        arrives_in arr_seq j ->
        arrives_in arr_seq j' ->
        job_interference job_arrival job_cost job_jitter sched j' j t1 t2 != 0 ->
        job_arrival j + job_deadline j <= job_arrival j' + job_deadline j'.
    Proof.
      rename H_scheduler_uses_EDF into PRIO.
      intros j j' t1 t2 ARR ARR' INTERF.
      unfold job_interference in INTERF.
      destruct ([exists t': 'I_t2,
                   [exists cpu: processor num_cpus,
                      (t' >= t1) &&
                      backlogged job_arrival job_cost job_jitter sched j' t' &&
                      scheduled_on sched j cpu t']]) eqn:EX.
      {
        move: EX => /existsP [t' /existsP [cpu /andP [/andP [LE BACK] SCHED]]].
        apply PRIO with (t := t'); try (by done).
        by apply/existsP; exists cpu.
      }
      {
        apply negbT in EX; rewrite negb_exists in EX; move: EX => /forallP ALL.
        rewrite big_nat_cond (eq_bigr (fun x => 0)) in INTERF;
          first by rewrite -big_nat_cond big_const_nat iter_addn mul0n  addn0 eq_refl in INTERF.
        move => i /andP [/andP [GEi LTi] _].
        specialize (ALL (Ordinal LTi)).
        rewrite negb_exists in ALL.
        move: ALL => /forallP ALL.
        rewrite (eq_bigr (fun x => 0));
          first by rewrite big_const_ord iter_addn mul0n addn0.
        intros cpu _; specialize (ALL cpu); simpl in ALL.
        destruct (backlogged job_arrival job_cost job_jitter sched j' i); last by rewrite andFb.
        rewrite GEi 2!andTb in ALL; rewrite andTb.
        by apply negbTE in ALL; rewrite ALL.
      }
    Qed.

  End Lemmas.

End InterferenceEDF.


From Coq Require Import NArith.BinNat Arith Relations.Relations MSets.MSets MSets.MSetRBT
     Lists.List micromega.Lia Sets.Ensembles.

Require Import LambdaANF.cps LambdaANF.eval LambdaANF.Ensembles_util LambdaANF.List_util LambdaANF.tactics LambdaANF.set_util LambdaANF.ctx
        LambdaANF.logical_relations LambdaANF.logical_relations_cc LambdaANF.algebra LambdaANF.inline_letapp LambdaANF.lambda_lifting_correct.
Require Import LambdaANF.closure_conversion_correct ctx.

Require Import micromega.Lia.

Import ListNotations.

Open Scope alg_scope.

Section Bounds.

  (* ***** Fuel ***** *)

  Global Program Instance fuel_res_pre : @resource fin nat :=
    { zero := 0;
      one_i fin := 1;
      plus x y  := x + y; }.
  Solve Obligations with (simpl; lia).

  Global Program Instance fuel_res_ordered : @ordered fin nat fuel_res_pre :=
    { lt := Peano.lt }.
  Solve Obligations with (try (intro; intros; simpl; lia)).
  Solve Obligations with (try (simpl; lia)).
  Next Obligation.
    destruct (Compare_dec.lt_dec x y); auto. right. eexists (x - y). lia.
  Qed.

  Global Program Instance fuel_res_ones : @resource_ones fin nat fuel_res_pre.

  Global Program Instance fuel_res_hom : @nat_hom fin nat fuel_res_pre :=
    { to_nat y := y }.

  Global Program Instance fuel_res_exp : @exp_resource nat :=
    { HRes := fuel_res_pre }.

  Global Instance fuel_res : @fuel_resource nat.
  Proof.
    econstructor.
    eapply fuel_res_ordered.
    eapply fuel_res_ones.
    eapply fuel_res_hom.
  Defined.

  (* ***** Trace ***** *)

  Global Program Instance trace_res_pre : @resource fin (nat * nat) :=
    { zero := (0, 0);
      one_i fin :=
        match fin with
        | Four => (0, 1)
        | Six => (0, 1)
        | _ => (1, 0)
        end;
      plus x y := (fst x + fst y, snd x + snd y) }.
  Solve Obligations with (try (simpl; lia)).
  Solve Obligations with (try (split; congruence)).
  Next Obligation. simpl. f_equal; lia. Qed.
  Next Obligation. simpl. f_equal; lia. Qed.
  Next Obligation. simpl. f_equal; lia. Qed.

  Global Program Instance trace_res_exp : @exp_resource (nat * nat) :=
    { HRes := trace_res_pre }.

  Global Instance trace_res : @trace_resource (nat * nat).
  Proof.
    econstructor. eapply trace_res_exp.
  Defined.

  Ltac unfold_all :=
    try unfold zero in *;
    try unfold one_ctx in *;
    try unfold one in *;
    try unfold one_i in *;
    try unfold HRes in *;
    try unfold HRexp_f in *; try unfold fuel_res in *; try unfold fuel_res_exp in *; try unfold fuel_res_pre in *;
    try unfold HRexp_t in *; try unfold trace_res in *; try unfold trace_res_exp in *; try unfold trace_res_pre in *.

  Section Inline_bound.

    (* bound for inlining *)
    Definition inline_bound (L G : nat) : PostT :=
      fun '(e1, rho1, c1, (t1, tapp1)) '(e2, rho2, c2, (t2, tapp2)) =>
        c1 <= c2 + 2 * G * tapp1 + 2 * L /\
        tapp1 <= tapp2 + 2 * G * tapp2 + L /\
        t2 + tapp2 = c2.

    Context (cenv : ctor_env).

    Instance inline_bound_compat L G (Hi : L <= G) :
      Post_properties cenv (inline_bound L G) (inline_bound L G) (inline_bound G G).
    Proof.
      constructor; (try (intro; intros; intro; intros; destruct cout1; destruct cout2;
                         unfold inline_bound in *; unfold_all; simpl; split; [| split ]; lia)).
      - intro; intros. intro; intros. destruct cout1; destruct cout2. destruct cout1'; destruct cout2'.
        unfold inline_bound in *; unfold_all; simpl. destructAll. split. lia. split; lia.

      - intro; intros. intro; intros.
        unfold inline_bound in *; unfold_all; simpl.
        assert (c = 0). eapply NPeano.Nat.lt_1_r. eassumption. subst. lia.
      - intro; intros. unfold post_base'.
        unfold inline_bound in *; unfold_all; simpl. lia.
      - intro; intros; unfold inline_bound in *.
        destruct x as [[[? ?] ?] [? ?]]; destruct y as [[[? ?] ?] [? ?]]. split; [| split ]; lia.
    Qed.

    Lemma inline_bound_post_Eapp_l i G v t l rho1 x rho2 :
      post_Eapp_l (inline_bound i G) (inline_bound (S i) G) v t l rho1 x rho2.
    Proof.
      intro; intros. unfold inline_bound in *. unfold_all. simpl in *.
      destruct cout1; destruct cout2. simpl in *. destructAll.
      split; [| split ]; try lia.
    Qed.

    Lemma inline_bound_remove_steps_letapp_OOT i j G :
      remove_steps_letapp_OOT cenv (inline_bound j G) (inline_bound (S (i + j)) G).
    Proof.
      intro; intros. unfold inline_bound in *. unfold_all. simpl in *.
      destruct cout1; destruct cout2. simpl in *.
      split; [| split ]; lia.
    Qed.

    Lemma inline_bound_remove_steps_letapp i j G :
      remove_steps_letapp cenv (inline_bound i G) (inline_bound j G) (inline_bound (S (i + j)) G).
    Proof.
      intro; intros. unfold inline_bound in *. unfold_all; simpl in *.
      destruct cout1; destruct cout2. destruct cout1'; destruct cout2'. simpl in *. lia.
    Qed.

    (* This allows us to prove divergence preservation *)
    Lemma inline_bound_post_upper_bound L G :
      post_upper_bound (inline_bound L G).
    Proof.
      intro; intros. unfold inline_bound in *. unfold_all.
      eexists (fun x => (1 + 2 * G + 2 * G * 2 * G) * x + 2 * L * 2 * G + 2 * L).
      intros.
      destruct cout1 as [t1 tapp1]; destruct cout2 as [t2 tapp2].

      destruct H. destruct H0.
      assert (Hleq : tapp1 <= cin2 + 2 * G * cin2 + L) by lia. clear H0 H1.

      assert (Hleq' : (1 + 2 * G + 2 * G * 2 * G) * cin1 + 2 * L * 2 * G + 2 * L <=
                      (1 + 2 * G + 2 * G * 2 * G) * cin2 + 2 * L * 2 * G + 2 * L).
      { eapply Le.le_trans. eassumption. eapply Le.le_trans.
        eapply plus_le_compat_r. eapply plus_le_compat_l. eapply mult_le_compat_l. eassumption.
        lia. }

      assert (Hleq'' : cin1 <= cin2).
      { eapply Nat.add_le_mono_r in Hleq'. eapply Nat.add_le_mono_r in Hleq'.
        eapply NPeano.Nat.mul_le_mono_pos_l in Hleq'. eassumption. lia. }

      eexists (cin2 - cin1). simpl. lia.
    Qed.

    (* bound for inlining, toplevel *)
    Definition inline_bound_top (G : nat) : @PostT nat (nat * nat) :=
      fun '(e1, rho1, c1, (t1, tapp1)) '(e2, rho2, c2, (t2, tapp2)) =>
        let A := 1 + 2 * G + 2 * G * 2 * G in
        c1 <= A * c2 + A.

    Lemma inline_bound_top_impl (G : nat) :
      inclusion _ (inline_bound G G) (inline_bound_top G).
    Proof.
      intros [[[? ?] ?] [? ?]] [[[? ?] ?] [? ?]]. unfold inline_bound, inline_bound_top in *. unfold_all.
      intros. destructAll.
      eapply le_trans. eassumption.
      eapply le_trans. eapply plus_le_compat_r. eapply plus_le_compat_l. eapply mult_le_compat_l. eassumption.
      lia.
    Qed.

    (* For shrink reduction *)
    Open Scope ctx_scope.

    Lemma inline_bound_ctx1 :
      forall (C : exp_ctx) (e1 : exp) (rho1 rho1' : env) (e2 : exp) (rho2 : env) (cin1 cin2 : nat)
             (cout1 cout2 : nat * nat),
        ctx_to_rho C rho1 rho1' ->
        len_exp_ctx C = 1%nat ->
        inline_bound 0 1 (e1, rho1', cin1, cout1) (e2, rho2, cin2, cout2) ->
        inline_bound 1 1 (C |[ e1 ]|, rho1, cin1 <+> one (C |[ e1 ]|), cout1 <+> one (C |[ e1 ]|))
                     (e2, rho2, cin2, cout2).
    Proof.
      intro; intros. unfold inline_bound in *. unfold_all; simpl in *.
      destruct cout1; destruct cout2. simpl in *. destructAll.
      destruct (C |[ e1 ]|); simpl; try lia.
    Qed.

    Lemma inline_bound_Ecase :
      forall x cl t e n rho1 rho2 cin1 cout1 cin2 cout2,
        cps_util.find_tag_nth cl t e n ->
        inline_bound 0 1 (e, rho1, cin1, cout1) (e, rho2, cin2, cout2) ->
        inline_bound 1 1 (Ecase x cl, rho1, cin1 <+> one (Ecase x cl), cout1 <+> one (Ecase x cl)) (e, rho2, cin2, cout2).
    Proof.
      intro; intros. unfold inline_bound in *. unfold_all; simpl in *.
      destruct cout1; destruct cout2. simpl in *. destructAll. lia.
    Qed.

  End Inline_bound.

  Section SimpleBound.

    Context (cenv : ctor_env).

    (* Simple bound for transformations that don't decrease steps *)
    Definition simple_bound (L : nat) : @PostT nat (nat * nat) :=
      fun '(e1, rho1, c1, (t1, tapp1)) '(e2, rho2, c2, (t2, tapp2)) =>
        c1 <= c2 + L.

    Instance simple_bound_compat k :
      Post_properties cenv (simple_bound 0) (simple_bound k) (simple_bound 0).
    Proof.
      constructor; (try (intro; intros; intro; intros; destruct cout1; destruct cout2;
                         unfold simple_bound  in *; unfold_all; simpl; lia)).
      - intro; intros. intro; intros. destruct cout1; destruct cout2. destruct cout1'; destruct cout2'.
        unfold simple_bound in *; unfold_all; simpl. destructAll. lia.
      - intro; intros. intro; intros.
        unfold simple_bound in *; unfold_all; simpl. lia.
      - intro; intros. unfold post_base'.
        unfold simple_bound in *; unfold_all; simpl. lia.
      - intro; intros; unfold simple_bound in *.
        destruct x as [[[? ?] ?] [? ?]]; destruct y as [[[? ?] ?] [? ?]]. lia.
    Qed.

    (* CC bound properties *)

    Lemma Hpost_locals_r :
      forall (n : nat) (rho1 rho2  rho2' : env)(e1 : exp) (e2 : exp)
             (cin1 : nat) (cout1 : nat * nat)
             (cin2 : nat) (cout2 : nat * nat) (C : exp_ctx),
        ctx_to_rho C rho2 rho2' ->
        simple_bound (n + to_nat (one_ctx C)) (e1, rho1, cin1, cout1)
                     (e2, rho2', cin2, cout2) ->
        simple_bound n (e1, rho1, cin1, cout1)
                     (C |[ e2 ]|, rho2, cin2 <+> (one_ctx C), cout2 <+> (one_ctx C)).
    Proof.
      intros. destruct cout1; destruct cout2. unfold simple_bound in *. unfold_all. simpl in *.
      lia.
    Qed.

    Lemma Hpost_locals_l :
      forall (n : nat) (rho1 rho2  rho2' : env)(e1 : exp) (e2 : exp)
             (cin1 : nat) (cout1 : nat * nat)
             (cin2 : nat) (cout2 : nat * nat) (C : exp_ctx),
        ctx_to_rho C rho2 rho2' ->
        simple_bound n (e1, rho1, cin1, cout1)
                     (C |[ e2 ]|, rho2, cin2 <+> (one_ctx C), cout2 <+> (one_ctx C)) ->
        simple_bound (n + to_nat (one_ctx C)) (e1, rho1, cin1, cout1)
                     (e2, rho2', cin2, cout2).
    Proof.
      intros. destruct cout1; destruct cout2. unfold simple_bound in *. unfold_all. simpl in *.
      lia.
    Qed.

    Lemma Hpost_locals_l0 :
      forall (n : nat) (rho1 rho2  rho2' : env)(e1 : exp) (e2 : exp)
             (cin1 : nat) (cout1 : nat * nat)
             (cin2 : nat) (cout2 : nat * nat) (C : exp_ctx),
        ctx_to_rho C rho2 rho2' ->
        simple_bound n (e1, rho1, cin1, cout1)
                     (C |[ e2 ]|, rho2, cin2, cout2) ->
        simple_bound (n + to_nat (one_ctx C)) (e1, rho1, cin1, cout1)
                     (e2, rho2', cin2, cout2).
    Proof.
      intros. destruct cout1; destruct cout2. unfold simple_bound in *. unfold_all. simpl in *.
      lia.
    Qed.

    Lemma HOOT : forall j, post_OOT (simple_bound j).
    Proof.
      intros. intro; intros. intro; intros.
      unfold simple_bound in *. unfold_all. simpl in *.
      lia.
    Qed.

    Lemma Hbase : forall j, post_base (simple_bound j).
    Proof.
      intros. intro; intros. unfold post_base'.
      unfold simple_bound in *. unfold_all. simpl in *.
      lia.
    Qed.

    Context (clo_tag : ctor_tag).

    Lemma HPost_letapp_cc :
      forall f x t xs e1 rho1 n k,
        k <= 4 + 4 * length xs  ->
        post_letapp_compat_cc' cenv clo_tag f x t xs e1 rho1 (simple_bound n) (simple_bound (n + k)) (simple_bound 0).
    Proof.
      intro; intros. intro; intros. destruct cout1; destruct cout2. destruct cout1'; destruct cout2'.
      unfold simple_bound in *; unfold_all; simpl. destructAll. lia.
    Qed.

    Lemma HPost_letapp_OOT_cc :
      forall f x t xs e1 rho1 n k,
        k <= 4 + 4 * length xs ->
        post_letapp_compat_cc_OOT' clo_tag f x t xs e1 rho1 (simple_bound (n + k)) (simple_bound 0).
    Proof.
      intro; intros. intro; intros. destruct cout1; destruct cout2.
      unfold simple_bound in *; unfold_all; simpl. destructAll. lia.
    Qed.

    Lemma HPost_app :
      forall k v t l rho1,
        k <= 4 + 4 * length l -> post_app_compat_cc' clo_tag v t l rho1 (simple_bound k) (simple_bound 0).
    Proof.
      intro; intros. intro; intros. destruct cout1; destruct cout2.
      unfold simple_bound in *; unfold_all; simpl. destructAll. lia.
    Qed.

    (* This allows us to prove divergence preservation *)
    Lemma simple_bound_post_upper_bound L :
      post_upper_bound (simple_bound L).
    Proof.
      intro; intros. unfold simple_bound in *. unfold_all.
      eexists (fun x => x +  L).
      intros.
      destruct cout1 as [t1 tapp1]; destruct cout2 as [t2 tapp2].
      eapply Nat.add_le_mono_r in H.

      eexists (cin2 - cin1). simpl. lia.
    Qed.

  End SimpleBound.

  Section HoistingBound.

    Context (cenv : ctor_env).

    Definition hoisting_bound (L G : nat) : @PostT nat (nat * nat) :=
      fun '(e1, rho1, c1, (t1, tapp1)) '(e2, rho2, c2, (t2, tapp2)) =>
        c1 <= c2 + G * c2 + L.

    Instance hoisting_bound_compat L G (Hi : L <= G) :
      Post_properties cenv (hoisting_bound L G) (hoisting_bound L G) (hoisting_bound G G).
    Proof.
      constructor; (try (intro; intros; intro; intros; destruct cout1; destruct cout2;
                         unfold hoisting_bound in *; unfold_all; simpl; lia)).
      - intro; intros. intro; intros. destruct cout1; destruct cout2. destruct cout1'; destruct cout2'.
        unfold hoisting_bound in *; unfold_all; simpl. destructAll. lia.
      - intro; intros. intro; intros.
        unfold hoisting_bound in *; unfold_all; simpl. lia.
      - intro; intros. unfold post_base'.
        unfold hoisting_bound in *; unfold_all; simpl. lia.
      - intro; intros; unfold hoisting_bound in *.
        destruct x as [[[? ?] ?] [? ?]]; destruct y as [[[? ?] ?] [? ?]]. lia.
    Qed.

    Lemma hoisting_bound_mon n m G :
      n <= m -> inclusion _ (hoisting_bound n G) (hoisting_bound m G).
    Proof.
      intros Hleq.
      intro; intros; unfold hoisting_bound in *.
      destruct x as [[[? ?] ?] [? ?]]; destruct y as [[[? ?] ?] [? ?]]. lia.
    Qed.

    Lemma hoisting_bound_post_Efun_l n G :
      post_Efun_l (hoisting_bound n G) (hoisting_bound (S n) G).
    Proof.
      intro; intros. unfold hoisting_bound in *. unfold_all. simpl in *.
      destruct cout1; destruct cout2. lia.
    Qed.

    Lemma hoisting_bound_post_Efun_r n m :
      (n <= m)%nat -> post_Efun_r (hoisting_bound n m) (hoisting_bound m m).
    Proof.
      intros Hleq.
      intro; intros. unfold hoisting_bound in *. unfold_all. simpl in *.
      destruct cout1; destruct cout2. lia.
    Qed.

    Lemma hoisting_bound_post_upper_bound n G :
      post_upper_bound (hoisting_bound n G).
    Proof.
      intro; intros. unfold hoisting_bound in *. unfold_all.
      eexists (fun x => G * x + x + n).
      intros.
      destruct cout1 as [t1 tapp1]; destruct cout2 as [t2 tapp2].
      eapply Nat.add_le_mono_r in H.
      replace (cin2 + G * cin2) with ((1 + G) * cin2) in H by lia.
      replace (G * cin1 + cin1) with ((1 + G) * cin1) in H by lia.
      eapply NPeano.Nat.mul_le_mono_pos_l in H.
      eexists (cin2 - cin1). simpl. lia.
      lia.
    Qed.

  End HoistingBound.

  Section LambdaLiftingBound.

    Definition ll_bound (l : nat) := simple_bound 0.

    Context (cenv : ctor_env).

    Instance ll_bound_compat k m n :
      Post_properties cenv (ll_bound k) (ll_bound m) (ll_bound n).
    Proof. unfold ll_bound in *. eapply simple_bound_compat. Qed.

    Lemma ll_bound_local_steps :
      forall {A} e1 rho1 c1 t1 e2 rho2 c2 t2 fvs f B1 rhoc x t xs1 l,
        M.get f rho1 = Some (Vfun rhoc B1 x) ->
        find_def x B1 = Some (t, xs1, e1) ->
        ll_bound l (e1, rho1, c1, t1) (e2, rho2, c2, t2) ->
        l <= 1 + length xs1 + @length A fvs + 1 ->
        ll_bound 0 (e1, rho1, c1, t1) (e2, rho2, c2, t2).
    Proof.
      intros. destruct t1, t2.
      unfold simple_bound  in *; unfold_all; simpl in *. lia.
    Qed.

    Lemma ll_bound_mon :
      forall l l', l <= l' -> inclusion _ (ll_bound l) (ll_bound l').
    Proof.
      intros. intro; intros. eassumption.
    Qed.

   Lemma ll_bound_local_app :
     forall (e1 : exp) (rho1 : env) (f : var) (ft : fun_tag) (ys : list var) (rho2 : env),
       post_Eapp_r (ll_bound 0) (ll_bound (1 + Datatypes.length ys)) e1 rho1 f ft ys rho2.
   Proof.
     intros. intro; intros. destruct cout1, cout2.
     unfold simple_bound  in *; unfold_all; simpl in *. lia.
   Qed.

   Lemma ll_bound_local_app' :
     forall (e1 : exp) (rho1 : env) (f : var) (ft : fun_tag) (ys : list var) (rho2 : env),
       post_Eapp_r (ll_bound 1) (ll_bound (1 + Datatypes.length ys + 1)) e1 rho1 f ft ys rho2.
   Proof.
     intros. intro; intros. destruct cout1, cout2.
     unfold simple_bound  in *; unfold_all; simpl in *. lia.
   Qed.

   Lemma ll_bound_local_steps_let_app :
      forall e1 rho1 c1 t1 c1' t1' e2 rho2 e2' rho2' e2'' rho2'' c2  t2 c2' t2'
             f B1 e1' rhoc rhoc' x ft ys ys' xs1 vs1 v fvs ft' f',
        M.get f rho1 = Some (Vfun rhoc B1 f') ->
        find_def f' B1 = Some (ft, xs1, e1') ->
        set_lists xs1 vs1 (def_funs B1 B1 rhoc rhoc) = Some rhoc' ->
        (* maybe bstep is needed but ignore for now *)
        ll_bound 1 (e1', rhoc', c1, t1) (e2', rho2', c2, t2) ->
        ll_bound 0 (e1, M.set x v rho1, c1', t1') (e2'', rho2'', c2', t2') ->
        ll_bound 0 (Eletapp x f ft ys e1, rho1, c1 <+> c1' <+> one (Eletapp x f ft ys e1), t1 <+> t1' <+> one (Eletapp x f ft ys e1))
                 (e2, rho2, c2 <+> c2' <+> one (Eletapp x f' ft' (ys' ++ fvs) e2''),
                  t2 <+> t2' <+> one (Eletapp x f' ft' (ys' ++ fvs) e2'')).
   Proof.
     intros. destruct t1, t2, t1', t2'.
     unfold simple_bound  in *; unfold_all; simpl in *. lia.
   Qed.

   Lemma ll_bound_local_steps_let_app_OOT :
     forall e1 rho1 c1 t1  e2 rho2 e2' rho2' e2'' c2  t2
            f B1 e1' rhoc rhoc' x ft ys ys' xs1 vs1 fvs ft' f' f'',
       M.get f rho1 = Some (Vfun rhoc B1 f'') ->
       find_def f'' B1 = Some (ft, xs1, e1') ->
       set_lists xs1 vs1 (def_funs B1 B1 rhoc rhoc) = Some rhoc' ->
       (* maybe bstep is needed but ignore for now *)
       ll_bound 1 (e1', rhoc', c1, t1) (e2', rho2', c2, t2) ->
       ll_bound 0 (Eletapp x f ft ys e1, rho1, c1 <+> one (Eletapp x f ft ys e1), t1 <+> one (Eletapp x f ft ys e1))
                (e2, rho2, c2 <+> one (Eletapp x f' ft' (ys' ++ fvs) e2''),
                 t2 <+> one (Eletapp x f' ft' (ys' ++ fvs) e2'')).
   Proof.
     intros. destruct t1, t2.
     unfold simple_bound  in *; unfold_all; simpl in *. lia.
   Qed.

   Lemma ll_bound_local_steps_app :
     forall rho1 c1 t1 e2 rho2 e2' rho2' c2 t2
            f B1 e1' rhoc rhoc' f' ft ys xs1 vs1 f'' ft' ys' fvs,
       M.get f rho1 = Some (Vfun rhoc B1 f') ->
       find_def f' B1 = Some (ft, xs1, e1') ->
       set_lists xs1 vs1 (def_funs B1 B1 rhoc rhoc) = Some rhoc' ->
       (* maybe bstep is needed but ignore for now *)
       ll_bound 1 (e1', rhoc', c1, t1) (e2', rho2', c2, t2) ->
       ll_bound 0 (Eapp f ft ys, rho1, c1 <+> one (Eapp f ft ys), t1 <+> one (Eapp f ft ys))
                (e2, rho2, c2 <+> one (Eapp f'' ft' (ys' ++ fvs)), t2 <+> one (Eapp f' ft' (ys' ++ fvs))).
   Proof.
     intros. destruct t1, t2.
     unfold simple_bound  in *; unfold_all; simpl in *. lia.
   Qed.

   Lemma ll_bound_ctx_r :
     forall (n : nat) (e1 e2 : exp) (C : exp_ctx) (rho1 rho2 rho2' : env)
            (C0 : exp_ctx) c1 c2 cout1 cout2,
       ctx_to_rho C rho2 rho2' ->
       ll_bound n (e1, rho1, c1, cout1) (e2, rho2', c2, cout2) ->
       ll_bound (n + to_nat (one_ctx C0)) (e1, rho1, c1, cout1)
                (C |[ e2 ]|, rho2, plus c2 (one_ctx C), plus cout2 (one_ctx C)).
   Proof.
     intros. destruct cout1, cout2.
     unfold simple_bound  in *; unfold_all; simpl in *. lia.
   Qed.

  End LambdaLiftingBound.

  Section UncurryBound.

    Lemma Hpost_curry :
      forall e rho rho' rho'' c1 c2 cout1 cout2 f1 ft1 fv1 gv1,
        simple_bound 0 (e, rho, c1, cout1) (e, rho'', c2, cout2) ->
        simple_bound 0 (e, rho, c1, cout1) (Eapp f1 ft1 (gv1 ++ fv1), rho', plus c2 (one (Eapp f1 ft1 (gv1 ++ fv1))), plus cout2 (one (Eapp f1 ft1 (gv1 ++ fv1)))).
    Proof.
      intros. destruct cout1; destruct cout2. unfold simple_bound in *. unfold_all. simpl in *.
      lia.
    Qed.

    Lemma Hpost_idemp : inclusion _ (comp (simple_bound 0) (simple_bound 0)) (simple_bound 0).
    Proof.
      intro; intros.
      destruct x as [[[? ?] ?] [? ?]]; destruct y as [[[? ?] ?] [? ?]].
      unfold comp, simple_bound in *. unfold_all. destructAll.
      destruct x as [[[? ?] ?] [? ?]]. simpl in *. lia.
    Qed.

  End UncurryBound.
End Bounds.