From mathcomp.ssreflect Require Import ssreflect ssrnat seq eqtype ssrbool.
From mathcomp.algebra Require Import ssrint ssralg.
From Coq.Strings Require Import Ascii String.
Require Import Coq.Program.Program.
Require Import Program.
Require Import UtilString.
Require Import ProofIrrelevance.
Import intZmod.
Require Import Common Types Memory Extraction.

Record var_descr := declare_var { var_name: string; var_type: ctype; location: nat }.
       Definition var_descr_beq (x y: var_descr) : bool :=
         (var_name x == var_name y)  && (var_type x == var_type y) && (location x == location y).
       Theorem var_descr_eq_dec: eq_dec var_descr.
         rewrite /eq_dec.
         decide equality.
         decide equality.
         apply ctype_eq_dec.
         apply string_eq_dec.
       Qed.

       Definition var_descr_eqP := reflect_from_dec var_descr_eq_dec.

       Canonical var_descr_eqMixin := EqMixin var_descr_eqP.
       Canonical var_descr_eqType := EqType var_descr var_descr_eqMixin.

Inductive binop : Set := | Add | Sub | Mul | Div | LAnd | LOr | Eq .
       Scheme Equality for binop.
       Definition binop_eqP := reflect_from_dec binop_eq_dec.
       Canonical binop_eqMixin := EqMixin binop_eqP.
       Canonical binop_eqType := EqType binop binop_eqMixin.

Inductive unop: Set := | Neg | Invert | Not | Convert (to:ctype) | Amp | Asterisk .
       Definition unop_beq (x y : unop) : bool :=
         match x, y with
           | Neg, Neg  |Invert, Invert | Not, Not | Amp, Amp | Asterisk, Asterisk => true
           | Convert t1, Convert t2 => t1 == t2
           | _, _ => false
         end.

       Lemma unop_eqP: Equality.axiom unop_beq.
         move=> x y.
         case Heq: (unop_beq _ _); move: Heq.
         case x; case y =>//=; try by constructor.
         move=> t0 t1. by move /eqP =>->; constructor.
         case x; case y => //=; try by constructor.
         move=> t0 t1  /eqP => Hneq. constructor. by case.
       Qed.
       Canonical unop_eqMixin := EqMixin unop_eqP.
       Canonical unop_eqType := EqType unop unop_eqMixin.
       Definition unop_eq_dec := dec_from_reflect unop_eqP.

Inductive expr :=
       | Lit   (t:ctype) (_:coq_type(t))
       | EDeallocated (t:ctype)
       | EGarbage (t:ctype)
       | Var   (_:string)
       | Binop (_:binop) (_ _: expr)
       | Unop  (_:unop)  (_: expr).

Inductive statement :=
       | Skip
       | Call : string -> seq expr -> statement (* return values do not exist *)
       | Assign: expr -> expr -> statement
       | Alloc: storage -> ctype -> option string -> nat -> statement
       | If: expr -> statement -> statement -> statement
       | While: expr -> statement -> statement
       | CodeBlock: seq statement -> statement
       | Debug
       | Enter
       | Leave .

Record function := mk_fun {
                       fun_id: nat;
                       fun_name: string;
                       args: seq (string * ctype);
                       body: statement;
                       fun_location: nat}. (* all functions are void; if they return smth it is written by pointer passed as arg *)

Record static_ctx : Set := mk_stat_ctx { functions: seq function; variables: seq ( seq var_descr ) }.
       Definition stat_ctx_empty:= mk_stat_ctx [::] [::].
       Definition stat_ctx_mod (s:static_ctx)
                  (mfuns: seq function -> seq function) (mvars: seq (seq var_descr)  -> seq (seq var_descr )) :=
         mk_stat_ctx (mfuns $ functions s) (mvars $ variables s).

Record dynamic_ctx : Set := mk_dyn_ctx { memory: seq block; call_stack: seq statement }.
       Definition dyn_ctx_mod (d:dynamic_ctx)
                  (mmem: seq block -> seq block) (mcs: seq statement -> seq statement) :=
         mk_dyn_ctx (mmem $ memory d) (mcs $ call_stack d).

       Definition dynamic_ctx_empty := mk_dyn_ctx [::] [::].
       Definition dyn_ctx_push (d:dynamic_ctx) (s:statement) : dynamic_ctx := mk_dyn_ctx (memory d) (s::call_stack d).
       Definition get_var (sc:static_ctx) (name:string) : option var_descr :=
         option_find (fun p: var_descr => var_name p == name) (flatten (variables sc)).
       Definition get_fun (sc:static_ctx) (name:string) : option function :=
         option_find (fun p: function => fun_name p == name) (functions sc).

Fixpoint type_solver {sc: static_ctx}  (e: expr) : ctype:=
  let slv := @type_solver sc  in
  match e with
    | Lit t _ => t
    | EDeallocated t => t
    | EGarbage t => t
    | Var name => match get_var sc name with
                    | Some v => Pointer $ var_type v
                    | None => ErrorType
                  end
    | Binop _ l r => eq_value_or_error_arith (slv l) (slv r) (fun t _ => t) ErrorType
    | Unop Asterisk op => match slv op with
                            | Pointer t => t
                            | _ => Bot
                          end
    | Unop _ o => slv o
  end.

Definition binop_interp (t:ctype) (op: binop) : int -> int -> value :=
  match t with
    | Int num => match op with
                   | Add => fun x y=> Value (Int num) $ addz x y
                   | Sub => fun x y=> Value (Int num) $ addz x (oppz y)
                   | Mul => fun x y => Value (Int num) $ intRing.mulz x y
                   | Eq  => fun x y=> Value (Int num) $ Posz $ if x == y then 1 else 0
                   | _ => fun _ _ => Error
                 end
    | _ => fun _ _ => Error
  end.

Definition unop_interp (t:ctype) (op:unop) : int -> value  :=
  match t with
    | Int kind =>
      match op with
        | Neg => fun x => Value (Int kind) $ oppz x
        | Not => fun x => Value (Int kind) $ Posz $ if sgz x == 0 then 1 else 0
        | _ => fun _ => Error
      end
    | _ => fun _ => Error
  end.

Definition find_block (m: dynamic_ctx) (i: nat)  : option block :=
  option_find (fun b=> block_id b == i) $ memory m.

Definition dereference (dyn:dynamic_ctx) (v:value) : value :=
  match v with
    | Value (Pointer pt) (Goodptr i o) =>
      match option_nth (memory dyn) i with
        | Some (mk_block lo _i sz block_type contents) =>
          if block_type == pt then nth Error contents o else Error
        | None => Error
      end
    | _ => Error
  end.

Fixpoint iexpr (stat:static_ctx) (dyn: dynamic_ctx) (e:expr) : value :=
  let interp := iexpr stat dyn in
  let type := @type_solver stat in
  let vars := flatten $ variables stat in
  let blocks := memory dyn in
  match e with
    | Lit t v => Value t v
    | EDeallocated t => Deallocated
    | EGarbage t => Garbage
    | Var name => match get_var stat name  with
                    | Some (declare_var n t loc) =>
                      match find_block dyn loc with
                        | Some b =>
                          if el_type b == t
                          then Value (Pointer t) (Goodptr t loc 0)
                          else Error
                        | None => Error
                      end
                    | None => Error
                  end
    | Binop opcode l r =>
      match interp l, interp r with
        | Value (Int kx) x, Value (Int ky) y =>
          eq_value_or_error_arith (Int kx) (Int ky) (fun tx ty => binop_interp (type e) opcode x y) Error
        | _, _ => Error
      end
    | Unop Asterisk op => match interp op with
                            | Value (Pointer pt) p => dereference dyn (interp op)
                            |_ => Error
                          end
    | Unop code op =>
      match interp op with
        | Value (Int kind) v => unop_interp (type e) code v
        |_ => Error
      end
  end.

      Definition alloc_block {dc: dynamic_ctx} (b:block) : dynamic_ctx := mk_dyn_ctx ( (memory dc) ++ [:: b] ) (call_stack dc).

      Definition next_block_id (s:dynamic_ctx) : nat := size $ memory $ s.

      Fixpoint garbage_values (sz: nat) : seq value :=
        match sz with | n .+1 => Garbage :: (garbage_values n) | 0 => [::] end.

      Definition bind_var (v:var_descr) (i:nat) (ctx:static_ctx) :=
        mk_stat_ctx (functions ctx) $ match variables ctx with
                                        | [::] => [:: [:: v] ]
                                        | cons x xs => cons (cons v x) xs
                                      end.

Inductive prog_state :=
      | Good: static_ctx -> dynamic_ctx -> prog_state
      | Bad : static_ctx -> dynamic_ctx -> statement -> prog_state.

      Definition stat_init := mk_stat_ctx nil [:: nil (*[:: declare_var "Unit" Unit 0 ] *) ].
      Definition get_stat p := match p with | Good s _ | Bad s _ _ => s end.
      Definition get_dyn p := match p with | Good _ d| Bad _ d _ => d end.

      Definition add_static_ctx (s:prog_state) :=
        match s with
          | Good stat dyn => Good (mk_stat_ctx (functions stat) ( [::] :: variables stat) ) dyn
          | Bad _ _ _ as s => s
        end.

      Definition remove_static_ctx (s:prog_state) :=
        match s with | Good stat dyn =>
                       match variables stat with
                         | [::] => s
                         | vs::vvs => Good (mk_stat_ctx (functions stat) vvs) dyn
                       end
                  | s => s
        end.

Definition block_mod (b: block) (idx: nat) (e: value) : block? :=
        if idx * ( SizeOf (el_type b)) >= block_size b then None else
          match e with
            | Value t v =>
              match el_type b == t with
                | true => Some $ mk_block
                               (region b)
                               (block_id b)
                               (block_size b)
                               (el_type b)
                               (set_nth Error (contents b) idx (Value t v))
                | false => None
              end
            | Garbage as e
            | Deallocated as e=>  Some $ mk_block
                               (region b)
                               (block_id b)
                               (block_size b)
                               (el_type b)
                               (set_nth Error (contents b) idx e)
            | Error => None
        end.

Definition ex_block := mk_block Stack 0 64 Int64 (garbage_values 8).
Eval compute in block_mod ex_block 1 (Value Int64 3).

Definition ErrorBlock := mk_block Data 0 0 ErrorType [::].

Definition mem_write (dyn: dynamic_ctx)  (bid:nat) (pos: nat) (val:value) : dynamic_ctx? :=
  let m := memory dyn in
  let oldblock := option_nth m bid in
  let can_write v tp := match v with
                          | Value t v => t == tp
                          | Garbage
                          | Deallocated => true
                          | Error => false
                        end in
  match oldblock with
    | Some oldblock =>
      if can_write val $ el_type oldblock then
        option_map (fun newblock=> dyn_ctx_mod dyn (fun _=> set_nth ErrorBlock m bid newblock) id) $  block_mod oldblock pos val
      else None
    | None => None
  end.

Definition add_var (vd:var_descr) (c: static_ctx):=
  mk_stat_ctx
    (functions c)
    match variables c with
      | [::] => [:: [:: vd ]]
      | cons x xs => cons (cons vd x) xs
    end
.

Definition is_value_true {c:static_ctx} (v: value) : option bool:=
  match v with
    | Value (Int kind) z => Some $ sgz z != 0
    | Value (Pointer _) Nullptr => Some false
    | Value (Pointer _) (Goodptr _ _) => Some true
    | _ => None
  end.

(*Lemma value_inj a  v1 v2: Value a v1 = Value a b c v2 -> v1 = v2.
  move=> H.
  inversion H.
  by depcomp H1.
Defined.  *)

Definition eval ps e: value :=
  iexpr (get_stat ps) (get_dyn ps) e.

Theorem carrier_eq_dec: forall t, eq_dec (coq_type t).
  rewrite /eq_dec.
  case; try by apply unit_eq_dec.
  - case; apply int_eq_dec.
  - apply ptr_eq_dec.
  - move=> *. apply (seq_eq_dec _ nat_eq_dec).
Qed.

     Theorem expr_eq_dec : eq_dec expr.
       have Hlst: forall (A:Type) (a:A) l,  a :: l = l -> False. by  move=> A a; elim =>//=; move=> a0 l0 IH [] =><-.
       rewrite /eq_dec.
       fix 1.
       move => x y.
       case x; case y; try by right.
       - move => t c t0 c0.
         case Ht:(t == t0).
         + move /eqP in Ht; subst.
           move: (carrier_eq_dec t0 c0 c).
           case; [by left; subst
                 | by right; move =>[]=> H; depcomp H].
         + by move /eqP in Ht; right; case; move=> He; symmetry in He.
       - move=> t0 t; move: (ctype_eq_dec t0 t) =>[].
         by move => ->; left.
         by move=> H; right; case=> H'; symmetry in H'.
       - move=> t0 t; move: (ctype_eq_dec t0 t) =>[].
           by move => ->; left.
           by move=> H; right; case=> H'; symmetry in H'.
       - by move=> s0 s; move: (string_eq_dec s s0) => []; by[left; subst| right; case].
       - move=> op2 x2 y2 op1 x1 y1.
         move: (binop_eq_dec op1 op2) => [Hop|Hop];
           move: (expr_eq_dec x1 x2) => [Hx|Hx];
           move: (expr_eq_dec y1 y2) => [Hy|Hy]; try by right;case.
           by rewrite Hx Hy Hop; left.
       - move=> op1 x1  op2 x2.
         move:(expr_eq_dec x2 x1) => [Hx|Hx]; move:(unop_eq_dec op2 op1) => [Hop|Hop]; subst; try by [right;case].
           by left.
     Qed.

     Definition expr_eqP := reflect_from_dec expr_eq_dec.

     Canonical expr_eqMixin := EqMixin expr_eqP.
     Canonical expr_eqType := EqType expr expr_eqMixin.

     Theorem statement_eq_dec: eq_dec statement.
       rewrite /eq_dec.
       fix 1.
       have option_eq_dec t: eq_dec t ->  eq_dec (option t). by rewrite /eq_dec =>H; decide equality.
       decide equality.
       apply ( seq_eq_dec _ expr_eq_dec).
       apply string_eq_dec.
       apply expr_eq_dec.
       apply expr_eq_dec.
       apply nat_eq_dec.
       apply (option_eq_dec _ string_eq_dec).
       apply ctype_eq_dec.
       apply storage_eq_dec.
       apply expr_eq_dec.
       apply expr_eq_dec.
       elim: l l0.
         by case; [left | right].
         move=> a l H l0.
         case l0. by right.
         move=> s l1.
         move: (H l1) => [H0|H0]; move: (statement_eq_dec a s) => [H1|H1]; subst;
           try by [left| right; case].
     Defined.

     Definition statement_eqP := reflect_from_dec statement_eq_dec.

     Canonical statement_eqMixin := EqMixin statement_eqP.
     Canonical statement_eqType := EqType statement statement_eqMixin.

     (* Todo: make the lists potentially infinite? *)

     (* Add:
* Check if expression types are corresponding to arguments;
* Throw in assignments
*)

Definition LitFromExpr (ps: prog_state) (e:expr): expr ?:=
  match eval ps e  with
    | Value t v => Some $ Lit t v
    | Garbage =>  None
    | Deallocate => None
  end .

Definition prologue_arg (ps: prog_state) (name:string) (t:ctype) (e:expr) :=
  option_map (fun l =>  [:: Alloc Stack t (Some name) 1; Assign (Var name) l] ) $ LitFromExpr ps e.

Definition prologue_args (ps:prog_state) (f:function) (es: seq expr) :=
  let vals :=  map (fun a => prologue_arg ps (fst (fst a)) (snd (fst a)) (snd a)) $ zip (args f) es in
  foldl cat_if_some (Some nil) vals.

Definition prologue_for (ps: prog_state) (f:function) (argvals: seq expr) : option ( seq statement)  :=
  option_map (cons Enter) $ prologue_args ps f argvals.
(*
Definition epilogue_arg (ps: prog_state) (name:string) (t:ctype) (e:expr) :=
  Some [:: Assign (Var name) (EDeallocated t)] .

Definition epilogue_args (ps:prog_state) (f:function) (es: seq expr) :=
  let vals :=  map (fun a => epilogue_arg ps (fst (fst a)) (snd (fst a)) (snd a)) $ zip (args f) es in
  foldl cat_if_some (Some nil) vals.
 *)

Definition epilogue_for (ps: prog_state) (f:function) (argvals: seq expr) : option ( seq statement)  := Some [:: Leave].
(*  option_map (fun x => x ++ [:: Leave]) $ epilogue_args ps f argvals. *)

Definition fun_by_address {t} (p: ptr t) (stat:static_ctx) (dyn:dynamic_ctx) : function? :=
  match p with
    | Goodptr b o => option_find (fun f=> fun_location f == b) $ functions stat
    | _ => None
  end.
Definition extract_some {T} (x:  T ? ? ) : T? :=
  match x with
    |Some x => x
    | None => None
  end.

Fixpoint interpreter_step (s: prog_state) : prog_state :=
  match s with
    | Good _ (mk_dyn_ctx _ nil) => s
    | Good ((mk_stat_ctx funs vars) as oldstat) ((mk_dyn_ctx mem (st::ss)) as olddyn) =>
      let dyn := mk_dyn_ctx mem ss in
      let bad := Bad oldstat olddyn st in
    match st with
      | Skip => Good oldstat dyn
      | Call fname fargs =>
        match get_fun oldstat fname with
          | Some f =>
            match prologue_for s f fargs, epilogue_for s f fargs with
              | Some prologue, Some epilogue =>
                Good oldstat $ dyn_ctx_mod dyn id (fun x => prologue ++ body f :: epilogue ++ x)
              | _, _ => bad
            end
          | None => bad
        end
      | Debug => s
      | Assign w val  =>
        match eval s w, eval s val with
          | Value (Pointer t)  (Goodptr to off), Value vtype v =>
            if vtype == t then
                match mem_write dyn to off  (Value _ v ) with
                      | Some d => Good oldstat d
                      | None => bad
                end
                  else bad
          | Value (Pointer t) (Goodptr to off) , Deallocated as v
          | Value (Pointer t) (Goodptr to off) , Garbage as v=>
                match mem_write dyn to off  v with
                      | Some d => Good oldstat d
                      | None => bad
                end

          | _, _ => bad
        end
      | Alloc loc type o_name sz =>
        let block_id := next_block_id dyn in
        let newdyn := dyn_ctx_mod dyn (fun m=> m ++ [:: mk_block loc block_id (sz* SizeOf type) type (garbage_values sz)]) id  in
        match o_name with
          | None => Good oldstat newdyn
          | Some name => Good (add_var (declare_var name type block_id) oldstat ) newdyn
        end
      | If cond _then _else => let cont := match @is_value_true oldstat $ eval s cond with
                                 | Some true => _then
                                 | _ => _else
                               end in
                                 Good oldstat $ dyn_ctx_mod dyn id (cons cont)
      | While cond body => match @is_value_true oldstat $ eval s cond with
                             | Some true => Good oldstat $ dyn_ctx_mod olddyn id (cons body)
                             | _ => Good oldstat dyn
                           end
      | CodeBlock sts => let bc := [:: Enter] ++ sts ++ [::Leave] in
                         let newdyn := dyn_ctx_mod dyn id (cat bc) in
                         Good oldstat newdyn
      | Enter => add_static_ctx $ Good oldstat dyn
      | Leave =>let newdyn :=
                    match variables $ oldstat with
                      | v::vv =>
                        @foldl  (var_descr) (option dynamic_ctx)
                               (fun sd v => extract_some $ option_map (fun sd=>mem_write sd (location v) 0 Deallocated) sd) (Some dyn) v
                      | nil => None
                    end in
                match newdyn with
                  | Some newdyn => remove_static_ctx $ Good oldstat newdyn
                  | None => bad
                end
    end
    | Bad stat dyn state => s
  end.

Definition init_state_for (s:statement) := Good (stat_ctx_mod stat_init (fun _=> [:: mk_fun 0 "main" nil s 0 ] ) id ) $
                                                mk_dyn_ctx  nil [:: s] .

Fixpoint interpret (steps:nat) (state: prog_state) :=
  match steps with | 0 => state
                | S steps => match state with
                               |Bad _ _ _ => state
                               |Good _ _ => interpret steps $ interpreter_step state
                             end
  end.

Definition statement_state (s:prog_state) (st:statement) := match s with
                                                              | Good x dc => Good x $ dyn_ctx_mod dc id (cons st)
                                                              | Bad x x0 x1 => s
                                                            end.
Definition isbad s := match s with | Bad _ _ _ => true | _ => false end.

Definition start_from_0th_fun (c:static_ctx): dynamic_ctx :=
  match ohead $ functions c with
    | None => dynamic_ctx_empty
    | Some main => dyn_ctx_push dynamic_ctx_empty (body main)
  end.
Definition init_state_for_prog (sc: static_ctx) := Good sc (start_from_0th_fun sc).

Definition LocVar t name := Alloc Stack t (Some name%string) 1.

Notation "{{  x1 ; .. ; xn }}" := (CodeBlock(  cons x1  .. (cons xn nil) ..) ) (at level 35, left associativity) : c.
Notation "'int8 x " := (LocVar Int8 x) (at level 200, no associativity) :c.
Notation "'uint8 x " := (LocVar UInt8 x) (at level 200, no associativity) :c.
Notation "'int16 x " := (LocVar Int16 x) (at level 200, no associativity) :c.
Notation "'uint16 x " := (LocVar UInt16 x) (at level 200, no associativity) :c.
Notation "'int32 x " := (LocVar Int32 x) (at level 200, no associativity) :c.
Notation "'uint32 x " := (LocVar UInt32 x) (at level 200, no associativity) :c.
Notation "'int64 x " := (LocVar Int64 x) (at level 200, no associativity) :c.
Notation "'uint64 x " := (LocVar UInt64 x) (at level 200, no associativity) :c.

Notation "' v := value" := (Assign v (value) ) (at level 200, no associativity) :c.
Notation " /* v " := (Unop Asterisk v) (at level 200, right associativity) :c.
Notation " /i n  " := (Lit Int64 n) (at level 210, no associativity) :c.
Delimit Scope c with c.
Open Scope string.
Open Scope c.

Definition GetVar s := ( Unop Asterisk ( Var s ) ).
Definition Arg := Var.
Definition AddrVar := Var.

Definition test_assign := {{
                           'int8 "x";
                           ' Var "x" := /i 4
                            }}.

Definition sample_call : static_ctx :=
  mk_stat_ctx [::
                 mk_fun 0 "main" [::] ({{
                                           'int64 "x";
                                           Call "f" [:: Var "x"]
                                         }}) 0;
                mk_fun 1 "f" [:: ("x", (Pointer Int64)) ]
                       ({{
                           ' Var "x"  := /i 2
                          }}) 1 ]
              nil.
(*
if (x == 1) res <- 1 else
{
alloc y;
y <- x;
y <- fact (x - 1)
res <- res * y
}
*)
Definition sample_fact : static_ctx :=
  mk_stat_ctx [::
                 mk_fun 0 "main" [::] ({{
                                           'int64 "x";
                                           ' Var "x" := /i 1;
                                           Call "f" [:: AddrVar "x"; /i 6 ];
                                           Debug
                                         }}) 0;

                mk_fun 1 "f" [:: ("res", (Pointer Int64)); ("x", Int64) ]
                       ({{
                            If (Binop Eq ( GetVar "x" ) ( /i 0 ) )
                               (' /* (Var "res") :=  /i 1 )
                               ({{
                                    'int64 "y";
                                    ' AddrVar "y" := GetVar "x";
                                   Call "f" [::AddrVar "y"; Binop Sub (GetVar "x") (/i (Posz 1)) ];

                                   Assign ( /* Var "res"  ) $ Binop Mul ( /* (GetVar "res") ) (GetVar "y")
                                          }})
                          }}) 1 ]
              nil.

Definition halts (ps: prog_state):= exists n:nat, call_stack ( get_dyn ( interpret n ps )) = nil.

Fixpoint unsome {T} (s:seq (option T) ) :=
  match s with
    | (Some s ):: ss => s :: unsome ss
    | None :: _=>  nil
    | nil => nil
  end.

Fixpoint unsome3 {T A B} (s:seq (A * B * (option T)) ) :=
  match s with
    | (x, y, Some s ):: ss => (x,y,s) :: unsome3 ss
    | _ => nil
  end.

Definition dumpvars (ps: prog_state) :=
  let stat := get_stat ps in
  let cntns (n:nat) := option_map contents $ find_block (get_dyn ps) n in
  let varinfo :=  get_var stat in
  let varnames := undup $ map var_name $  flatten (variables  stat) in
  let vards := map varinfo varnames in
unsome3 $  unsome $  map (option_map (fun vd => (var_name vd, var_type vd,  cntns $ location vd))) vards.
Definition is_good ps := match ps with | Good _ _  => true | _ => false end.

Let f := fun steps=>
        let state := interpret steps $ init_state_for_prog sample_fact in state.
(*        (is_good state, dumpvars state, get_dyn state).*)
Compute f  1 .
Compute f  2 .
Compute f  3 .
Compute f  4 .
Compute f  5 .
Compute f  6 .
Compute f  7 .
Compute f  8 .
Compute f  500.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal46.

From lfind Require Import LFind.
Require Import Arith.
Lemma lfind_state  (y:natural):@eq bool (orb (eqb y y) false) true.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal46_theorem0_61_eqb_refl/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
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  (y:natural) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


(* Celsius project *)
(* Clément Blaudeau - Lamp@EPFL & Inria 2020-2022 *)
(* ------------------------------------------------------------------------ *)
(* This files the core principles in their typing sense, along with lemmas and tactics *)

From Celsius Require Export Typing Wellformedness.
Implicit Type (σ: Store) (ρ ω: Env) (l: Loc) (L: LocSet) (Σ: StoreTyping) (T: Tpe) (μ: Mode) (Γ: EnvTyping).

(* ------------------------------------------------------------------------ *)
(** * Main definitions *)

(* ------------------------------------------------------------------------ *)
(** ** Monotonicity *)
Definition monotonicity Σ1 Σ2 :=
  forall l, l < dom Σ1 -> (exists T1 T2, getType Σ1 l = Some T1 /\ getType Σ2 l = Some T2 /\ T2 <: T1).
Notation "Σ1 ≼ Σ2" := (monotonicity Σ1 Σ2) (at level 60).

(* ------------------------------------------------------------------------ *)
(** ** Authority *)
Definition authority_st Σ1 Σ2 :=
  forall l C Ω, getType Σ1 l = Some (C, cool Ω) -> getType Σ2 l = Some (C, cool Ω).
Global Instance notation_stackability_store : notation_authority StoreTyping :=
  { authority_ := authority_st }.

(* ------------------------------------------------------------------------ *)
(** ** Value typing (with variants) *)
Inductive value_typing : StoreTyping -> Loc -> Tpe -> Prop :=
| vt_sub : forall Σ l T1 T2,
    getType Σ l = Some T1 ->
    (T1 <: T2) -> value_typing Σ l T2.
Global Instance notation_value_typing_Tpe : notation_dash_colon StoreTyping Loc Tpe :=
  { dash_colon_ := value_typing }.
Global Hint Unfold notation_value_typing_Tpe: notations.

Definition value_typing_mode Σ l μ :=
  exists C, Σ ⊨ l : (C, μ).
Global Instance notation_value_typing_Mode : notation_dash_colon StoreTyping Loc Mode :=
  { dash_colon_ := value_typing_mode }.
Global Hint Unfold notation_value_typing_Mode: notations.

Definition value_typing_cln Σ l C :=
  exists μ, Σ ⊨ l : (C, μ).
Global Instance notation_value_typing_ClN : notation_dash_colon StoreTyping Loc ClN :=
  { dash_colon_ := value_typing_cln }.
Global Hint Unfold notation_value_typing_ClN: notations.

Definition value_typing_mode_locset Σ L μ :=
  forall (l: Loc), (In Loc L l) -> Σ ⊨ l : μ.
Global Instance notation_value_typing_mode_LocSet : notation_dash_colon StoreTyping LocSet Mode :=
  { dash_colon_ := value_typing_mode_locset }.
Global Hint Unfold notation_value_typing_mode_LocSet: notations.

Definition value_typing_locset Σ (ll: list Loc) (vl: list Tpe) :=
  Forall2 (fun (l: Loc) (T:Tpe) => Σ ⊨ l : T) ll vl.
Global Instance notation_value_typing_LocSet : notation_dash_colon StoreTyping (list Loc) (list Tpe) :=
  { dash_colon_ := value_typing_locset }.
Global Hint Unfold notation_value_typing_LocSet: notations.

Lemma value_typing_dom : forall Σ l T,
    Σ ⊨ l : T -> l < dom Σ.
Proof with eauto using getType_dom.
  intros ...
  inverts H...
Qed.
Global Hint Resolve value_typing_dom: typ.

(* ------------------------------------------------------------------------ *)
(** ** Stackability *)
Definition stackability_st Σ1 Σ2 :=
  forall l, l < dom Σ2 -> (Σ2 ⊨ l : warm) \/ (l < dom Σ1).
Global Instance notation_stackability_StoreTyping : notation_stackability StoreTyping :=
  { stackability_ := stackability_st }.
Global Hint Unfold notation_stackability_StoreTyping : notations.

(* ------------------------------------------------------------------------ *)
(** ** Object typing **)
Inductive object_typing : StoreTyping -> Obj -> Tpe -> Prop :=

| ot_hot : forall Σ C ω Args Flds Mtds,
    ct C = class Args Flds Mtds ->
    (forall f,
        f < length Flds ->
        exists v D μ,
          fieldType C f = Some (D, μ) /\
          getVal ω f = Some v /\ (Σ ⊨ v : (D, hot))) ->
    object_typing Σ (C,ω) (C, hot)

| ot_warm : forall Σ C ω Args Flds Mtds,
    ct C = class Args Flds Mtds ->
    (forall f,
        f < length Flds ->
        exists v D μ,
          fieldType C f = Some (D, μ) /\
          getVal ω f = Some v /\ (Σ ⊨ v : (D, μ))) ->
    object_typing Σ (C,ω) (C, warm)

| ot_cool : forall Σ C ω n Args Flds Mtds,
    ct C = class Args Flds Mtds ->
    (forall f,
        f < n ->
        exists v D μ,
          fieldType C f = Some (D, μ) /\
          getVal ω f = Some v /\ (Σ ⊨ v : (D, μ))) ->
    object_typing Σ (C,ω) (C, cool n)

| ot_cold : forall Σ C ω,
    object_typing Σ (C,ω) (C, cold).

Global Instance notation_object_typing : notation_dash_colon StoreTyping Obj Tpe :=
  { dash_colon_ := object_typing }.
Global Hint Unfold notation_object_typing: notations.

(* ------------------------------------------------------------------------ *)
(** ** Store_typing *)
(** Here is the link between the abstract environment of types and the store used in execution *)

Definition store_typing Σ σ :=
  dom σ = dom Σ /\
  forall l, l < dom Σ ->
       exists C ω μ, getObj σ l = Some (C,ω) /\
                  getType Σ l = Some (C, μ) /\
                  Σ ⊨ (C, ω) : (C, μ).
Global Instance notation_store_typing: notation_dash StoreTyping Store :=
  { dash_ := store_typing }.
Global Hint Unfold notation_store_typing: notations.
Global Hint Unfold notation_store_typing store_typing: typ.

Lemma storeTyping_dom:
  forall Σ σ,
    Σ ⊨ σ -> dom σ = dom Σ.
Proof with (eauto with typ lia).
  intros ...
  inverts H...
Qed.
Global Hint Resolve storeTyping_dom: typ.

(* ------------------------------------------------------------------------ *)
(** ** Environment typing *)
Inductive env_typing : StoreTyping -> Env -> EnvTyping -> Prop :=
| et_nil : forall Σ, env_typing Σ nil nil
| et_cons : forall Σ ρ Γ l T,
    env_typing Σ ρ Γ ->
    (Σ ⊨ l : T) ->
    env_typing  Σ (l :: ρ) (T :: Γ).
Global Instance notation_env_typing: notation_dash_colon StoreTyping Env EnvTyping :=
  { dash_colon_ := env_typing }.
Global Hint Unfold notation_env_typing: notations.

(* ------------------------------------------------------------------------ *)
(** * Tactics *)
Ltac meta :=
  repeat
    match goal with
    (* Cross rewrites *)
    | H: getObj ?σ ?l = Some ?O,
        H': getObj ?σ ?l = Some ?O' |- _ => rewrite H' in H; inverts H
    | H: getType ?Σ ?l = Some ?T,
        H': getType ?Σ ?l = Some ?T' |- _ => rewrite H' in H; inverts H
    | H: getVal ?ρ ?f = Some ?l,
        H': getVal ?ρ ?f = Some ?l' |- _ => rewrite H' in H; inverts H

    (* Dom hypothesis *)
    | H: getType ?Σ ?l = Some ?T |- _ =>
        match goal with
        | H': Σ ⊨ ?σ, H'': l < dom ?σ' |- _ => fail 1
        | H': Σ ⊨ ?σ, H'': S l <= dom ?σ' |- _ => fail 1
        | _ =>
            let fresh := fresh "H__dom" in
            add_hypothesis fresh (getType_dom l T Σ H)
        end
    | H: getVal ?ρ ?f = Some ?l |- _ =>
        match goal with
        | H': S f <= dom ρ |- _ => fail 1
        | H': f < dom ρ |- _ => fail 1
        | _ => let fresh := fresh "H__dom" in
              add_hypothesis fresh (getVal_dom ρ f l H)
        end

    (* Destructs *)
    | H: ?Σ ⊨ ?l : ?x |- _ =>
        match type of l with
        | Loc => match type of x with
                | Mode => let C := fresh "C" in destruct H as [C H]
                | (ClN*Mode)%type =>
                    inverts H
                end
        end
    | o:Obj |- _ => let C := fresh "C" in
                  let ω := fresh "ω" in
                  destruct o as [C ω]
    | T:Tpe |- _ => let C := fresh "C" in
                  let μ := fresh "μ" in
                  destruct T as [C μ]
    | H: ?μ ⊑ hot |- _ =>
        let H__eq := fresh "H__eq" in
        assert (H__eq: μ = hot) by (invert H; steps); subst;
        clear H
    | H: hot ⊑ ?μ |- _ => clear H
    | H: ((?C, ?μ) <: (?C', ?μ')) |- _ => inverts H
    | H: ?Σ ⊨ ?σ |- context [ dom ?Σ ] => rewrite <- (proj1 H)
    | H: ?Σ ⊨ ?σ, H':context [ dom ?Σ ] |- _ => rewrite <- (proj1 H) in H'
    end ; sort; cross_rewrites;
  try lia.

Ltac meta_clean :=
  move_top StoreTyping;
  move_top EnvTyping;
  move_top Env;
  move_top Store;
  move_top (list Loc);
  move_top Loc;
  move_top (list Tpe);
  move_top Mode; move_top ClN; move_top Expr.

Ltac storeTyping_update :=
  repeat (match goal with
          | H1: ?Σ ⊨ ?σ,
              H2: getObj ?σ ?l = Some (?C, ?ω) |- _ =>
              match goal with
              | H3: getType Σ l = Some (C, ?μ) |- _ => fail 1
              | _ => let H_obj := fresh "H__getObj" in
                    let H_tpe := fresh "H__getType" in
                    let H_vt := fresh "H__vt" in
                    destruct ((proj2 H1) l (ltac:(rewrite <-(proj1 H1); apply (getObj_dom l _ σ H2)))) as
                      (?C & ?ω & ?μ & H_obj & H_tpe & H_vt);
                    symmetry in H_obj;
                    rewrite H2 in H_obj; inverts H_obj
              end
          | H1: ?Σ ⊨ ?σ,
              H2: getType ?Σ ?l = Some (?C, ?μ) |- _ =>
              match goal with
              | H3: getObj ?σ l = Some (C, ?ω) |- _ => fail 1
              | _ => let H_obj := fresh "H__getObj" in
                    let H_tpe := fresh "H__getType" in
                    let H_vt := fresh "H__vt" in
                    destruct ((proj2 H1) l (ltac:(rewrite <-(proj1 H1); apply (getObj_dom l _ σ H2)))) as
                      (?C & ?ω & ?μ & H_obj & H_tpe & H_vt);
                    symmetry in H_tpe;
                    rewrite H2 in H_tpe; inverts H_tpe
              end
          end; cross_rewrites).

(* ------------------------------------------------------------------------ *)
(** * Monotonicity results *)

Lemma monotonicity_dom : forall Σ1 Σ2,
    Σ1 ≼ Σ2 -> (dom Σ1 <= dom Σ2).
Proof with meta; eauto with lia updates .
  intros.
  destruct Σ1; steps...
  specialize (H (dom Σ1)) as (? & ? & ?); steps ...
Qed.
Global Hint Resolve monotonicity_dom: typ.

Lemma value_typing_monotonicity: forall Σ1 Σ2 l T,
    Σ1 ≼ Σ2 -> Σ1 ⊨ l : T -> Σ2 ⊨ l : T.
Proof with (meta; eauto with lia typ).
  intros ...
  specialize (H l H0) as [T1 [T2 [Hs1 [Hs2 H__sub]]]] ...
  eapply vt_sub ...
Qed.
Global Hint Resolve value_typing_monotonicity: typ.

Lemma env_typing_monotonicity: forall Σ1 Σ2 Γ ρ,
    Σ1 ≼ Σ2 -> Σ1 ⊨ ρ : Γ -> Σ2 ⊨ ρ : Γ.
Proof.
  intros.
  autounfold with notations in H0. simpl in H0.
  induction H0.
  - steps.
  - specialize (IHenv_typing H).
    apply et_cons; steps; eauto with typ.
Qed.
Global Hint Resolve env_typing_monotonicity: typ.

Lemma object_typing_monotonicity: forall Σ1 Σ2 (o: Obj) T,
    Σ1 ≼ Σ2 -> Σ1 ⊨ o : T -> Σ2 ⊨ o : T.
Proof with (meta; eauto 3 with lia typ).
  intros ...
  inversion H0; steps.

  - eapply ot_hot; intros...
    specialize (H7 f); steps.
    exists v D μ; splits => //.
    exists (D, hot)...
    lets ([ ] & [ ] & ? & ? & ?): H H6...

  - eapply ot_warm; intros...
    specialize (H7 f); steps.
    exists v, D, μ; splits ...
    lets ([ ] & [ ] & ? & ? & ?): H H6...
    eexists...

  - eapply ot_cool; intros...
    specialize (H7 f); steps.
    exists v, D, μ; steps ...
    lets ([ ] & [ ] & ? & ? & ?): H H6.
    eexists...
Qed.
Global Hint Resolve object_typing_monotonicity: typ.

Lemma mn_refl: forall Σ,
    Σ ≼ Σ.
Proof with (meta; eauto with ss typ).
  intros Σ l; steps ...
  lets [? ?]: getType_Some H...
Qed.
Global Hint Resolve mn_refl : typ.

Lemma mn_trans: forall Σ1 Σ2 Σ3,
    Σ1 ≼ Σ2 -> Σ2 ≼ Σ3 -> Σ1 ≼ Σ3.
Proof with (meta; eauto with lia typ).
  intros.
  intros l; steps.
  specialize (H l H1); steps.
  specialize (H0 l) as [ ]; steps...
  eexists; eexists...
Qed.
Global Hint Resolve mn_trans: typ.

Lemma mn_hot: forall Σ1 Σ2 l,
    Σ1 ≼ Σ2 ->
    (Σ1 ⊨ l : hot) ->
    (Σ2 ⊨ l : hot).
Proof.
  intros; meta.
  specialize (H l H0); steps; meta.
  exists C.
  eapply vt_sub; eauto with typ.
Qed.
Global Hint Resolve mn_hot: typ.

Lemma mn_hot_set: forall Σ1 Σ2 (L: LocSet),
    Σ1 ≼ Σ2 ->
    (Σ1 ⊨ L : hot) ->
    (Σ2 ⊨ L : hot).
Proof.
  intros; meta.
  intros l.
  specialize (H0  l); eauto with typ.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Inversion lemma for environment access *)
(* We define it here (and not in Typing.v) because it relies on typing of values *)

Lemma env_regularity: forall Γ Σ ρ x U T,
    Σ ⊨ ρ : Γ ->
    ((Γ, U) ⊢ (e_var x) : T) ->
    exists l, getVal ρ x = Some l /\ Σ ⊨ l : T.
Proof.
  intros ...
  remember (e_var x) as e.
  induction H0; try congruence.
  - specialize (IHexpr_typing H Heqe) as [l [H__val Ht]].
    exists l; steps.
    inverts Ht.
    eapply vt_sub; eauto with typ.
  - inverts Heqe.
    gen T x.
    autounfold with notations in H. simpl in *.
    induction H; intros; destruct x; steps; eauto.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Hot preservation results **)
(* Similar to the hot preservation result (in Localreasoning.v) but for typing *)

Lemma hot_transitivity : forall Σ σ l l',
    wf σ ->
    (Σ ⊨ l : hot) ->
    (Σ ⊨ σ) ->
    (σ ⊨ l ⇝ l') ->
    (Σ ⊨ l' : hot).
Proof with (storeTyping_update; meta; eauto 2 with lia typ).
  intros.
  gen Σ.
  induction H2; steps...
  inverts H__vt ...
  lets [? _]: H H1.
  lets: H3 H9.
  lets: getVal_dom H2...
  lets (?v & ?D & ?μ & ? & ? & ?): H10 f...
  exists D, (D, hot)...
Qed.

Lemma hot_transitivity_set : forall Σ σ L l,
    wf σ ->
    (Σ ⊨ L : hot) ->
    (Σ ⊨ σ) ->
    (σ ⊨ L ⇝ l) ->
    (Σ ⊨ l : hot).
Proof with (storeTyping_update; meta; eauto 2 with lia typ).
  intros. rch_set.
  eapply hot_transitivity...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Authority results *)

Lemma aty_st_refl: forall Σ, Σ ▷ Σ.
Proof with (meta; eauto with typ lia).
  intros Σ l H.
  destruct (getType Σ l) eqn:E; eauto.
Qed.
Global Hint Resolve aty_st_refl : typ.

Lemma aty_st_trans: forall Σ1 Σ2 Σ3,
    Σ1 ▷ Σ2 ->
    Σ2 ▷ Σ3 ->
    Σ1 ▷ Σ3.
Proof with steps.
  intros. intros l ...
Qed.
Global Hint Resolve aty_st_trans : typ.

(* ------------------------------------------------------------------------ *)
(** ** Stackability results *)

Lemma stk_st_refl: forall Σ, Σ ≪ Σ.
Proof.
  intros Σ l H. right => //.
Qed.
Global Hint Resolve stk_st_refl : typ.

Lemma stk_st_trans: forall Σ1 Σ2 Σ3,
    Σ1 ≪ Σ2 ->
    Σ2 ≪ Σ3 ->
    Σ2 ≼ Σ3 ->
    Σ1 ≪ Σ3.
Proof.
  intros.
  intros l ?.
  specialize (H0 l) as [ ]; eauto.
  specialize (H l H0) as [ ]; eauto.
  inverts H.
  inverts H3.
  left.
  specialize (H1 l) as [ ]; steps.
  rewrite H3 in H; steps.
  repeat eexists; eauto with typ.
Qed.
Global Hint Resolve stk_st_trans : typ.

(* ------------------------------------------------------------------------ *)
(** ** Selection result *)

Lemma cool_selection : forall Σ σ C l Ω ω f T,
    Σ ⊨ σ ->
    Σ ⊨ l : (C, cool Ω) ->
    getObj σ l = Some (C, ω) ->
    fieldType C f = Some T ->
    f < Ω ->
    exists v,
      getVal ω f = Some v /\
        Σ ⊨ v : T.
Proof with (meta; eauto 4 with typ lia).
  intros ...
  lets [ ]: (proj2 H) l ... steps ...
  inverts H7; inverts H9 ...
  - specialize (H11 f) as (v & D & ? & ? & ? & ?)...
    exists v; splits...
    eexists...
  - specialize (H10 f) as (v & D & ? & ? & ? & ?)...
    exists v; splits...
    eexists...
  - specialize (H10 f) as (v & D & ? & ? & ? & ?)...
    exists v; splits...
    eexists...
  - specialize (H12 f) as (v & D & ? & ? & ? & ?)...
    exists v; splits...
    eexists...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Upgrading lemmas *)
(* Those two crucial results allow the typing information to be upgraded during typing : - as every
mandatory field initializer is evaluated (cool n to cool (n+1)) - as the object finishes evaluation
(cool to warm)

 The last upgrading lemma is the local reasoning for typing, which upgrades objects to hot.
 *)

Lemma field_initialization: forall C I x σ ω T Σ v,
    wf σ ->
    Σ ⊨ σ ->
    getObj σ I = Some (C, ω) ->
    x <= dom ω ->
    getType Σ I = Some (C, cool x) ->
    fieldType C x = Some T ->
    (Σ ⊨ v : T) ->
    forall σ' Σ',
      assign_new I x v σ = Some σ' ->
      Σ' = [I ↦ (C, cool (S x))]Σ ->
      (Σ' ⊨ σ') /\ Σ ≼ Σ' /\ Σ ≪ Σ'.
Proof with (updates; meta; eauto 3 with typ lia).
  intros. subst.
  assert (H__fo: forall A B C : Prop , (B -> A) -> B -> C -> A /\ B /\ C) by firstorder.
  apply H__fo; clear H__fo; steps.
  - (* ⊨ *)
    split... { symmetry; eapply assign_new_dom... }
    intros l H__l.
    lets (?C & ?ω & ?μ & ? & ? & ?): (proj2 H0) l...
    rewrite /assign_new H1 in H6.
    destruct_eq (I = l); subst...
    + (* I = l *)
      destruct_if_eqb; inverts H6.
      * (* x = dom ω : a new field is added *)
        clear x.
        exists C, (ω++[v]), (cool (S (dom ω))); splits...
        ct_lookup C.
        lets: fieldType_some H4...
        eapply ot_cool ; [eassumption| updates; try lia].
        intros.
        assert (f = dom ω \/ f < dom ω) as [|] by lia; subst.
        -- exists v, c, m; splits...
           destruct_eq (l = v); subst...
           ++ exists (c, cool (S dom ω))...
              apply s_typ_mode, s_mode_trans with (cool (dom ω))...
           ++ exists (c, μ)...
        -- lets: fieldType_some H4...
           lets (?D & ?μ & ?): fieldType_exists f...
           lets (v0 & ?): getVal_Some H6.
           exists v0 D μ0; splits... rewrite getVal_last2...
           inverts H13.
           lets (?v1 & ?D & ?μ & ? & ? & ?): H22 H6...
           destruct_eq (l = v0); subst...
           ++ exists (C, cool (S dom ω))...
              apply s_typ_mode, s_mode_trans with (cool (dom ω))...
           ++ exists (D0, μ2)...
      * (* the field x is updated *)
        exists C, ([x ↦ v]ω), (cool (S x)); splits...
        inverts H13.
        lets [? _]: H l H10. lets : H1 H15...
        eapply ot_cool; try eassumption; try lia.
        intros.
        destruct_eq (x = f); subst...
        -- destruct_eq (l = v); subst;
             exists v, c, m; splits; eauto; eexists...
           apply s_typ_mode, s_mode_trans with (cool f)...
        -- lets (?v1 & ?D & ?μ & ? & ? & ?): H16 f...
           exists v1, D, μ0; splits...
           destruct_eq (l = v1); subst; eexists...
           apply s_typ_mode, s_mode_trans with (cool x)...

    + repeat eexists...
      destruct_if_eqb; inverts H6...

  - (* ≼ *)
    intros l H__l.
    rewrite /assign_new H1 in H6.
    destruct_eq (I = l); subst...
    + destruct_if_eqb; inverts H6.
      * clear x.
        exists (C, cool (dom ω)), (C, cool (S dom ω)); splits ...
      * lets [?T ?]: getType_Some Σ l...
        exists (C, cool x), (C, cool (S x)); splits...
    + lets [?T ?]: getType_Some Σ l...
      repeat eexists...

  - (* ≪ *)
    intros l H__l. right...
Qed.

Lemma promotion: forall Σ1 Σ2 C I σ2 Args Flds Mtds,
    Σ1 ▷ Σ2 ->
    Σ1 ≼ Σ2 ->
    Σ1 ≪ [I ↦ (C, warm)] Σ2 ->
    ct C = class Args Flds Mtds ->
    I >= dom Σ1 ->
    getType Σ2 I = Some (C, cool (dom Flds)) ->
    Σ2 ⊨ σ2 ->
    forall Σ3,
      Σ3 = [I ↦ (C, warm)]Σ2 ->
      Σ1 ▷ Σ3 /\
        Σ1 ≼ Σ3 /\
        Σ1 ≪ Σ3 /\
        Σ3 ⊨ σ2.
Proof with (updates; meta; eauto 3 with typ lia).
  intros. subst.
  apply proj2 with (Σ2 ≼ [I ↦ (C, warm)] (Σ2)).
  assert (H__fo: forall A B C D E: Prop, B -> (A -> C) -> (A -> C -> E) -> D -> A -> A /\ B /\ C /\ D /\ E) by firstorder.
  apply H__fo; clear H__fo; intros.

  - (* ▷ *)
    intros l H__l Ω ?.
    destruct_eq (I = l); subst...

  - (* ≼ *)
    intros l H__l.
    lets ([C0 μ] & ?): getType_Some H__l.
    lets ([C1 μ1] & ?): getType_Some Σ2 l...
    lets (?T & ?T & ? &? &?): H0 H__l...
    exists (C0, μ).
    destruct_eq (I = l); subst.
    + exists (C, warm); split...
    + exists (C0, μ1); split...

  - (* ⊨ *)
    split...
    intros l H__l.
    lets: monotonicity_dom H6...
    lets (C0 & ω & ?): getObj_Some H__l...
    lets (?C & ?ω & ?μ & ? & ? & ?) : (proj2 H5) l...
    destruct_eq (I = l); subst...
    + exists C, ω, warm; splits; auto.
      eapply ot_warm; [eassumption |].
      intros f ?.
      inverts H13.
      lets (?v & D & μ' & ? & ? & ?): H18 f H4...
      exists v D μ' ; splits...
      destruct_eq (l = v); subst; eexists...
    + exists C0, ω, μ; splits...

  - (* ≪ *)
    intros l H__l...
    destruct (H1 l)...

  - (* ≼ *)
    intros l H__l.
    lets ([C0 μ] & ?): getType_Some H__l.
    exists (C0, μ).
    destruct_eq (I = l); subst;
      eexists; split...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Object typing domains *)
(* The object typing imposes conditions on the size of local environments in the store *)

Lemma ot_cool_dom: forall Σ σ l C ω Ω,
    wf σ ->
    Σ ⊨ σ ->
    getObj σ l = Some (C, ω) ->
    Σ ⊨ (C, ω) : (C, cool Ω) ->
    Ω <= dom ω.
Proof with (meta; eauto with typ lia).
  intros.
  inverts H2.
  destruct Ω...
  lets: (proj1 (H l _ _ H1)) H7.
  lets [ ]: H8 Ω; steps...
  lets: getVal_dom H3...
Qed.

Lemma ot_warm_dom: forall Σ σ l C ω Args Flds Mtds,
    ct C = class Args Flds Mtds ->
    wf σ ->
    Σ ⊨ σ ->
    getObj σ l = Some (C, ω) ->
    Σ ⊨ (C, ω) : (C, warm)->
    dom ω = dom Flds.
Proof with (meta; eauto with typ lia).
  intros.
  inverts H2.
  inverts H3.
  lets: (proj1 (H0 l _ _ H5)) H7...
  destruct (dom Flds0)...
  lets [ ]: H8 n; steps...
  lets: getVal_dom H3...
Qed.

Lemma ot_hot_dom: forall Σ σ l C ω Args Flds Mtds,
    ct C = class Args Flds Mtds ->
    wf σ ->
    Σ ⊨ σ ->
    getObj σ l = Some (C, ω) ->
    Σ ⊨ (C, ω) : (C, hot) ->
    dom ω = dom Flds.
Proof with (meta; eauto with typ lia).
  intros.
  inverts H2.
  inverts H3.
  lets: (proj1 (H0 l _ _ H5)) H7...
  destruct (dom Flds0)...
  lets [ ]: H8 n; steps...
  lets: getVal_dom H3...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Other technical results *)

Lemma env_typing_subs: forall Γ1 Γ2 Σ vl,
    Σ ⊨ vl : Γ2 ->
    S_Typs Γ1 Γ2 ->
    Σ ⊨ vl : Γ2.
Proof.
  induction Γ1; intros.
  - inverts H0; eauto with typ.
  - inverts H0; meta.
    inverts H; simpl in *.
    eapply IHΓ1 in H6; eauto.
    eapply et_cons; simpl in *; eauto with typ.
Qed.
Global Hint Resolve env_typing_subs: typ.

Lemma storeTyping_assgn:
  forall Σ σ l f v0 v C D ω μ μ0 μ__f,
    Σ ⊨ σ ->
    getObj σ l = Some (C, ω) ->
    getVal ω f = Some v0 ->
    fieldType C f = Some (D, μ__f) ->
    getType Σ v0 = Some (D, μ0) ->
    getType Σ v = Some (D, μ) ->
    μ ⊑ μ0 ->
    wf σ ->
    Σ ⊨ ([l ↦ (C, [f ↦ v]ω)]σ).
Proof with (updates; meta; eauto 3 with typ updates).
  intros.
  split...
  intros l' H__l'.
  lets (C' & ω' & μ' & ? & ? & ?): (proj2 H) l'...
  destruct_eq (l = l'); subst...
  - exists C, [f ↦ v]ω, μ'; splits...
    destruct (ct C) as [Args Flds Mtds] eqn:H__ct.
    assert (f < dom Flds)...
    inverts H11.
    + eapply ot_hot; [eassumption|].
      intros.
      lets (?v & ?D & ?μ & ?&?&?): H17 f...
      lets (?v & ?D & ?μ & ?&?&?): H17 f0...
      destruct_eq (f = f0); subst...
      exists v, D0, μ; splits...
      eexists...
    + eapply ot_warm; [eassumption |].
      intros.
      lets (?v & ?D & ?μ & ?&?&?): H17 f...
      lets (?v & ?D & ?μ & ?&?&?): H17 f0...
      destruct_eq (f = f0); subst...
      exists v, D0, μ2; splits...
      eexists...
    + eapply ot_cool; updates; try reflexivity...
      intros.
      lets (?v & ?D & ?μ & ?&?&?): H17 f0...
      destruct_eq (f = f0); subst...
      exists v, D, μ1; splits...
      eexists...
    + apply ot_cold.
  - exists C', ω', μ'; splits...
Qed.

Lemma P_Hots_env:
  forall Args l args_val Σ1,
    P_hots Args ->
    Σ1 ⊨ args_val : Args ->
    l ∈ codom args_val ->
    Σ1 ⊨ l : hot.
Proof with (meta; eauto with typ).
  induction Args; intros; steps;
    inverts H0; inverts H1; simpl in * ...
  - inverts H.
    unfold P_hot in H6; steps ...
    exists c. eapply vt_sub ...
  - inverts H ...
Qed.
Global Hint Resolve P_Hots_env: typ.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2017   --   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.                           *)
(*                                                                  *)
(********************************************************************)

Require Import BuiltIn.

Definition func : forall (a:Type) (b:Type), Type.
intros a b.
exact (a -> b).
Defined.

Definition infix_at: forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, (a -> b) -> a -> b.
intros a aWT b bWT f x.
exact (f x).
Defined.

Definition pred (a: Type) := func a bool.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Axioms.

Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.
Require Import msl.Extensionality.

Require Import sepcomp.mem_lemmas.
Require Import sepcomp.semantics.

Require Import concurrency.machine_semantics.

Require Import msl.Coqlib2.

Section thread_stepN.
  Context {G TID SCH TR C M E:Type} (Sem:@ConcurSemantics G TID SCH TR C M) (ge:G).

  Fixpoint thread_stepN (n:nat) : SCH -> C -> M -> C -> M -> Prop :=
    match n with
      | O => fun U c m c' m' => (c,m) = ( c',m')
      | S k => fun U c1 m1 c3 m3 => exists c2, exists m2,
        @thread_step _ _ _ _ _ _ Sem ge U c1 m1 c2 m2 /\
        thread_stepN k U c2 m2 c3 m3
    end.

  Lemma thread_stepN_add : forall n m U c1 m1 c3 m3,
    thread_stepN (n+m) U c1 m1 c3 m3 <->
    exists c2, exists m2,
      thread_stepN n U c1 m1 c2 m2 /\
      thread_stepN m U c2 m2 c3 m3.
  Proof.
    induction n; simpl; intuition.
    firstorder. firstorder.
    inv H. auto.
    decompose [ex and] H. clear H.
    destruct (IHn m U x x0 c3 m3).
    apply H in H2.
    decompose [ex and] H2. clear H2.
    repeat econstructor; eauto.
    decompose [ex and] H. clear H.
    exists x1. exists x2; split; auto.
    destruct (IHn m U x1 x2 c3 m3).
    eauto.
  Qed.

  Definition thread_step_plus U c m c' m' :=
    exists n, thread_stepN (S n) U c m c' m'.

  Definition thread_step_star U c m c' m' :=
    exists n, thread_stepN n U c m c' m'.

  Lemma thread_step_plus_star : forall U c1 c2 m1 m2,
    thread_step_plus U c1 m1 c2 m2 -> thread_step_star U c1 m1 c2 m2.
  Proof. intros. destruct H as [n1 H1]. eexists. apply H1. Qed.

  Lemma thread_step_plus_trans : forall U c1 c2 c3 m1 m2 m3,
    thread_step_plus U c1 m1 c2 m2 -> thread_step_plus U c2 m2 c3 m3 ->
    thread_step_plus U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add (S n1) (S n2) U  c1 m1 c3 m3) as [_ H].
    eexists. apply H. exists c2. exists m2. split; assumption.
  Qed.

  Lemma thread_step_star_plus_trans : forall U c1 c2 c3 m1 m2 m3,
    thread_step_star U c1 m1 c2 m2 -> thread_step_plus U c2 m2 c3 m3 ->
    thread_step_plus U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add n1 (S n2) U  c1 m1 c3 m3) as [_ H].
    rewrite <- plus_n_Sm in H.
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma thread_step_plus_star_trans: forall U c1 c2 c3 m1 m2 m3,
    thread_step_plus U c1 m1 c2 m2 -> thread_step_star U c2 m2 c3 m3 ->
    thread_step_plus U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add (S n1) n2 U c1 m1 c3 m3) as [_ H].
    rewrite plus_Sn_m in H.
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma thread_step_star_trans: forall U c1 c2 c3 m1 m2 m3,
    thread_step_star U c1 m1 c2 m2 -> thread_step_star U c2 m2 c3 m3 ->
    thread_step_star U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add n1 n2 U c1 m1 c3 m3) as [_ H].
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma thread_step_plus_one: forall U c m c' m',
    thread_step  Sem ge U c m c' m' -> thread_step_plus U c m c' m'.
  Proof. intros. unfold thread_step_plus, thread_stepN. simpl.
    exists O. exists c'. exists m'. eauto.
  Qed.

  Lemma thread_step_plus_two: forall U c m c' m' c'' m'',
    thread_step  Sem ge U c m c' m' -> thread_step  Sem ge U c' m' c'' m'' ->
    thread_step_plus U c m c'' m''.
  Proof. intros.
    exists (S O). exists c'. exists m'. split; trivial.
    exists c''. exists m''. split; trivial. reflexivity.
  Qed.

  Lemma thread_step_star_zero: forall U c m, thread_step_star U c m c m.
  Proof. intros. exists O. reflexivity. Qed.

  Lemma thread_step_star_one: forall U c m c' m',
    thread_step  Sem ge U c m c' m' -> thread_step_star U c m c' m'.
  Proof. intros.
    exists (S O). exists c'. exists m'. split; trivial. reflexivity.
  Qed.

  Lemma thread_step_plus_split: forall U c m c' m',
    thread_step_plus U c m c' m' ->
    exists c'', exists m'', thread_step  Sem ge U c m c'' m'' /\
      thread_step_star U  c'' m'' c' m'.
  Proof. intros.
    destruct H as [n [c2 [m2 [Hstep Hstar]]]]. simpl in*.
    exists c2. exists m2. split. assumption. exists n. assumption.
  Qed.

End thread_stepN.