Require Import MetaCoq.Template.All.
Require Import List String.
Import ListNotations MonadNotation.
Require Import MetaCoq.Template.Pretty.

Load de_bruijn_print.
Load non_uniform.

Require Import Even.
Require Import Recdef.

Scheme Equality for sort_family.

Definition canElim (s : sort_family) (xs:list sort_family) : bool.
Proof.
  induction xs as [|x xs].
  - exact false.
  - destruct (sort_family_eq_dec s x).
    + exact true.
    + exact IHxs.
Defined.

Goal forall x xs, canElim x xs = true <-> In x xs.
Proof.
  induction xs;simpl canElim;simpl In.
  - split;auto.
  - split.
    + destruct sort_family_eq_dec  as [->|];auto.
      now intros H%IHxs.
    + intros [-> | H%IHxs];destruct sort_family_eq_dec;congruence.
Qed.

Unset Strict Unquote Universe Mode. (* for universe errors todo: should be done properly *)
Definition getMaxElim (xs:list sort_family) :=
  if canElim InType xs then <% Type %> else (* todo: is this always the correct Level? *)
    if canElim InSet xs then <% Set %> else
      <% Prop %>.

Fixpoint remove_lambdas (t:term) : term :=
  match t with
  | tLambda _ _ t2 => remove_lambdas t2
  | _ => t
  end.
Fixpoint remove_prods (t:term) : term :=
  match t with
  | tProd _ _ t2 => remove_prods t2
  | _ => t
  end.

Fixpoint collect_prods (t:term) : list (context_decl) :=
  match t with
  | tProd n t1 t2 => (vass n t1)::collect_prods t2
  | _ => []
  end.
Fixpoint collect_lambdas (t:term) : list (context_decl) :=
  match t with
  | tLambda n t1 t2 => (vass n t1)::collect_lambdas t2
  | _ => []
  end.

Definition count_prods (t : term) : nat := #|collect_prods t|.

Fixpoint replaceLastOffset (f:nat -> term -> term) (off:nat) (u:term) :=
  match u with
  | tProd n h t => tProd n h (replaceLastOffset f (S off) t)
  | tLambda na T M => tLambda na T (replaceLastOffset f (S off) M)
  | tLetIn na b ty b' =>
      tLetIn na b ty (replaceLastOffset f (S off) b')
  | _ => (f off u)
  end.

Definition replaceLastLambda (t:term) (u:term) := it_mkLambda_or_LetIn (rev(collect_lambdas u)) t.
Definition replaceLastProd (t:term) (u:term) := it_mkProd_or_LetIn (rev(collect_prods u)) t.
Definition replaceLastLambda' (t:term) (u:term) := replaceLastLambda u t.
Definition replaceLastProd' (t:term) (u:term) := replaceLastProd u t.

Definition mapProdToLambda (u:term) : term :=
  let prods := collect_prods u in
  it_mkLambda_or_LetIn (rev prods) (remove_arity #|prods| u).

Definition createAppChainOff (o:nat) (t:term) (count:nat) :=
              (mkApps t
                (nat_rec
                    _
                    []
                    (fun n a => cons (tRel (o+n)) a)
                    count
                )
              ).

Definition createAppChain := createAppChainOff 0.

Definition id {X:Type} := fun (x:X) => x.

Definition hasSat (xs:list bool) := fold_left orb xs false.

Fixpoint findRel (k:nat) (u:term) :=
  match u with
  | tRel n => n =? k
  | tEvar ev args => hasSat(map (findRel k) args)
  | tCast c kind ty => orb (findRel k c) (findRel k ty)
  | tProd na A B => orb (findRel k A) (findRel (S k) B)
  | tLambda na T M => orb (findRel k T) (findRel (S k) M)
  | tLetIn na b ty b' => orb (orb (findRel k b) (findRel k ty)) (findRel (S k) b')
  | tApp u0 v => findRel k u0
  | tCase ind p c brs => orb (orb (findRel k p) (findRel k c)) (hasSat (map (fun p => findRel k p.2) brs))
  | tProj p c => (findRel k c)
  | tFix mfix idx =>
      let k' := #|mfix| + k in
      let k' := #|mfix| + k in let mfix' := map (fun a => orb a.(dtype) a.(dbody)) (map (map_def (findRel k) (findRel k')) mfix) in hasSat mfix'
  | tCoFix mfix idx =>
      let k' := #|mfix| + k in
      let k' := #|mfix| + k in let mfix' := map (fun a => orb a.(dtype) a.(dbody)) (map (map_def (findRel k) (findRel k')) mfix) in hasSat mfix'
  | _ => false
  end.

Fixpoint substApp (s : term) (a:list term) (k : nat) (off:nat) (u : term) {struct u} : term :=
  match u with
  | tRel n =>
    if k =? n then (lift0 k) (tApp s a)
    else tRel n
  | tEvar ev args => tEvar ev (map (substApp s a k off) args)
  | tCast c kind ty => tCast (substApp s a k off c) kind (substApp s a k off ty)
  | tProd na A B => tProd na (substApp s a k off A) (substApp s a (S k) (S off) B)
  | tLambda na T M => tLambda na (substApp s a k off T) (substApp s a (S k) (S off) M)
  | tLetIn na b ty b' => tLetIn na (substApp s a k off b) (substApp s a k off ty) (substApp s a (S k) (S off) b')
  | tApp (tRel n) v => if k=? n then tApp (lift0 k s) ((map (substApp s a k off) v)++map (lift0 k) a) else mkApps (tRel n) (map (substApp s a k off) v)
  | tApp u0 v => mkApps (substApp s a k off u0) (map (substApp s a k off) v)
  | tCase ind p c brs => let brs' := map (on_snd (substApp s a k off)) brs in tCase ind (substApp s a k off p) (substApp s a k off c) brs'
  | tProj p c => tProj p (substApp s a k off c)
  | tFix mfix idx =>
    let off' := #|mfix| + off in
      let k' := #|mfix| + k in let mfix' := map (map_def (substApp s a k off) (substApp s a k' off')) mfix in tFix mfix' idx
  | tCoFix mfix idx =>
    let off' := #|mfix| + off in
      let k' := #|mfix| + k in let mfix' := map (map_def (substApp s a k off) (substApp s a k' off')) mfix in tFix mfix' idx
  | _ => u
  end.

Definition addHelper (repl:nat) (dest:term) (rest:term) (n:name) (h:term) (f:name->term->term->term) :=
  let newName :=
      match n with
        nAnon => "IH"
      | nNamed s => "IH_"+s s
      end
  in
  if findRel repl h then
    tProd
      (nNamed newName)
      (substApp dest [tRel 0] repl 0 h)
      rest
  else rest.

Fixpoint substAdd (repl:nat) (dest:term) (u:term) :=
  match u with
  | tProd n h t => tProd n h (addHelper repl dest (substAdd (S repl) dest t) n h tProd)
  | tLambda n h t => tLambda n h (addHelper repl dest (substAdd (S repl) dest t) n h tLambda)

  | tEvar ev args => tEvar ev (map (substAdd repl dest) args)
  | tCast c kind ty => tCast c kind (substAdd repl dest ty)
  | tLetIn na b ty b' =>
      tLetIn na b ty (substAdd (S repl) dest b')
  | tCase ind p c brs =>
      let brs' := map (on_snd (substAdd repl dest)) brs in
      tCase ind p c brs'
  | tProj p c => tProj p (substAdd repl dest c)
  | tFix mfix idx =>
      let k' := #|mfix| + repl in
      let mfix' := map (map_def (substAdd k' dest) (substAdd k' dest)) mfix in
      tFix mfix' idx
  | tCoFix mfix idx =>
      let k' := #|mfix| + repl in
      let mfix' := map (map_def (substAdd k' dest) (substAdd k' dest)) mfix in
      tCoFix mfix' idx
  | _ => u
  end.

Definition constrMapping (type:term) (paramCount:nat) (cons: (ident × term) × nat) (paramOffset:nat) (last:term->term) :=
          let (y,count) := cons in (* count=arguments of constructor case *)
          let (name,a) := y in
          replaceLastOffset (* replace tpye construction with call of p *)
            (fun _ => last)
            0
            (
              lift0 paramOffset (* lift parameter call over other cases *)
              (subst1 type paramCount (* tRel => inductive type *)
              (
              (remove_arity (* remove param quantification in constructor *)
                  paramCount
                  a
              )))
            ).

(* todo: split in enumerate and filteri *)
Fixpoint filteri {A} (f:nat->A->bool) (s0:nat) (l:list A) : list (nat×A) :=
  match l with
  | [] => []
  | x :: l0 => if f s0 x then (s0,x) :: filteri f (S s0) l0 else filteri f (S s0) l0
  end.

Definition addInductiveHypothesis (a:term) (tyLift:nat) (argCount:nat) (paramCount:nat) (lCount:nat) (rest:term) :=
  let recArgs :=
      (filteri
          (fun n t => findRel (n+paramCount+tyLift) (decl_type t))
          0
          (collect_prods (lift0 tyLift (remove_arity paramCount a)))
       ) in
  it_mkProd_or_LetIn
    (rev (mapi
       (fun k (y:(nat × context_decl)) =>
          let (a,t) := y in
          let name := decl_name t in
          let ty := decl_type t in
          let argDiff := k+argCount-a in
          {|
            decl_body := None;
            decl_name := nNamed (match name with nAnon => "IH" | nNamed n => "IH_" +s n end);
            decl_type :=
              replaceLastOffset
              (fun n t =>
                tApp
                  (tRel (n+argCount+k+lCount)) (* p *)
                  (match t with
                    | tApp _ a => skipn paramCount a (* indices *)
                    | _ => []
                    end ++
                        [
                          createAppChain
                            (* k inductive hypothesis before, n recursion guards, ath argument in chain *)
                            (tRel (n+argDiff-1)) (* the corresponding argument *)
                            n
                        ]
                  )
              )
              0
              (lift0 argDiff ty)
          |}
       )
       recArgs
    ))
    (lift0 #|recArgs| rest).

Definition quantifyCases (isInductive:bool) (ctors : list ((ident×term)×nat)) (paramCount:nat) (ind:inductive) (univ:universe_instance) :=
  let ctorCount := #|ctors| in
  let type := tInd ind univ in
      (* fold over constructors for cases *)
  (* can be omitted with type inference *)
        mapi
        (fun n (x:(ident × term) × nat) =>
          let (y,count) := x in (* count=arguments of constructor case *)
          let (name,a) := y in
          let lcount := n in (* how many cases before this *)
           vass
             (nNamed ("H_" +s name))
             (
               constrMapping type paramCount x (S lcount)
               (* replace tpye construction with call of p *)
               (fun type_app =>
                  let rest :=
                   tApp
                     (tRel (count+lcount)) (* p (after cases and arguments) *)
                      (match type_app with
                      | tApp _ xs => skipn paramCount xs (* transfer indices from type call to call of p *)
                      | _ => []
                      end
                      ++
                      [ (* last argument is instance *)
                        (* todo: empty apply *)
                        (* get constructor of type *)
                        createAppChain
                          (* apply with parameter *)
                          (* parameter is before p, arguments, cases and other parameter *)
                          (lift0
                             (1+count+lcount)
                             (createAppChain
                                (tConstruct ind lcount univ)
                                paramCount
                             )
                          )
                          (* apply with arguments *)
                          count
                      ])
                  in
                  if isInductive then
                    addInductiveHypothesis a (S lcount) count paramCount lcount rest
                  else rest
               )
             )
        ) ctors.

Definition getInductiveCalls (ctor:(ident×term)×nat) (paramExtraLift nuParamLift:nat) (trueParamCount nonUniformArgCount:nat) (fOff:nat) (argCount:nat) : list term :=
    let (y,count) := ctor in (* count=arguments of constructor case *)
    let (_,a) := y in
    let recArgs :=
        (filteri
              (fun n t => findRel (n+trueParamCount+nonUniformArgCount+paramExtraLift+nuParamLift) (decl_type t))
            0
            (collect_prods
               (lift0 nuParamLift
               (lift paramExtraLift nonUniformArgCount
                      (remove_arity (trueParamCount+nonUniformArgCount) a)
               )
               )
            )
            (* (collect_prods (remove_arity paramCount a)) *)
        ) in
    map
      (fun (y:(nat × context_decl)) =>
         let (a,t) := y in
         let name := decl_name t in
         let ty := decl_type t in
            replaceLastOffset
            (fun n t =>
              tApp
                (tRel (n+fOff)) (* f *)
                (match t with
                  | tApp _ a => skipn trueParamCount a (* indices *)
                  | _ => []
                  end ++
                      [
                        createAppChain
                          (tRel (n+(argCount-a-1))) (* the corresponding argument *)
                          n
                      ]
                )
            )
            0
            (mapProdToLambda (lift0 (argCount-a) ty))
            (* (mapProdToLambda (lift0 tyLift (remove_arity paramCount ty))) *)
      ) recArgs.

Print one_inductive_body.

Definition createElim (isInductive:bool) (ind:inductive) (univ:universe_instance) (ind_body:mutual_inductive_body) (returnType:option term) (nameFun:name->term->name) :=
  (* take params *)
    (* p *)
  (* var for cases *)
  (* f *)
  (* indices *)
  (* instance *)
  match nth_error ind_body.(ind_bodies) ind.(inductive_ind) with
  | None => None
  | Some one_body => Some(
  (* let paramCount := ind_body.(ind_npars) in *)
  let allParamCount := ind_body.(ind_npars) in
  let trueParamCount := getParamCount one_body ind_body.(ind_npars) in
  let nonUniformArgCount := ind_body.(ind_npars) - trueParamCount in

  let allParams := ind_body.(ind_params) in
  let nonUniformParams := firstn nonUniformArgCount allParams in
  let trueParams := skipn nonUniformArgCount allParams in

  let trueParamCtors := one_body.(ind_ctors) in
  let allParamCtors := map (on_snd (plus nonUniformArgCount)) one_body.(ind_ctors) in

  let type := tInd ind univ in
  let ind_applied := (* typ applied with params *)
      mkApps type (mapi (fun i _ => tRel (trueParamCount-i-1)) trueParams)
  in
  let nuIndex_type := remove_arity trueParamCount one_body.(ind_type) in
  let trueIndex_type := remove_arity allParamCount one_body.(ind_type) in
  let allIndCount := (* count of indices and non Uniform *)
      count_prods nuIndex_type
  in
  let trueIndCount := (* count of indices *)
      count_prods trueIndex_type
  in
  let ctorCount := #|trueParamCtors| in
  let predType :=
       replaceLastProd
         (
            (* add ∀ for instance *)
            (tProd (nNamed "inst")
                   (createAppChain (lift0 allIndCount ind_applied) allIndCount)
                 (* if prop => elim over prop *)
                 (* if type => elim over type *)
               (match returnType with None => getMaxElim one_body.(ind_kelim) | Some t => t end)
          )
         )
         (* quantify over indices but not over params *)
         nuIndex_type in
  (* quantify over all params *)
  it_mkLambda_or_LetIn trueParams
  (tLambda
     (* predicate *)
     (nNamed "p")
     (* the type of p is a transformation of the type
      todo: fold indices for type of p or use the type in index construction below
      for consistency*)
     predType
     (
       it_mkLambda_or_LetIn (rev (quantifyCases isInductive allParamCtors trueParamCount ind univ))
        (*
          theoretically recursive fix after cases
         *)
         (
              tFix
            [{|
             dname := nNamed "f"%string;
             dtype := (* could be omitted using type inference *)
               (* lift over cases for constructor and p *)
               replaceLastProd'
               (lift0 (S ctorCount) predType)
               (createAppChain (tRel (allIndCount + S ctorCount)) (S allIndCount))
              (* return p of instace *)
              (* p is after indices and cases *)
              ;
              dbody := (* take all indicies *)
              (* lift over cases for constructor and p and f? *)
                replaceLastLambda'
                  (mapProdToLambda (lift0 (2+ctorCount) predType))
                  (
                    (* match on instance *)
                    (* todo: handle non uniform matches *)
                    (* use change match return type, case application and access to non uniform *)
                        (tCase (ind, allParamCount)
                            (* return type of match *)
                            (
                              (lift0 (S trueIndCount)
                              (replaceLastLambda'
                                (mapProdToLambda
                              (lift (2+ctorCount) nonUniformArgCount
                                          (remove_arity nonUniformArgCount predType)
                                ))
                                (* apply p with indices and instace *)
                                (* p is after instance, indices, f, arguments (indices and instance) and cases *)
                                (* trueInd from above, nonUniformArgCount, f,  *)
                                (createAppChain (tRel (1+allIndCount+1+ctorCount) (* 1+trueIndCount *)
                                (* (createAppChain (tRel (1+trueIndCount+allIndCount+1+ctorCount) *)
                                                      (* (ctorCount+1+nonUniformArgCount+1+nonUniformArgCount) *)
                                                ) (S allIndCount))
                              ))
                            )
                           (* on instance *)
                            (tRel 0)
                            (* [(0,tRel 42)] *)
                            (* map case for each constructor *)

  (*  currently here   *)
                           (mapi
                              (fun i (x:(ident × term) × nat) =>
                                 let (y,count) := x in (* count for arguments of constructor *)
                                 let (_,a) := y in
                                 (count,
                                  (* constrMapping type allParamCount mapProdToLambda x (1+trueIndCount+2+ctorCount) *)
                                  replaceLastLambda'
                                  (
                                    (lift0 (S trueIndCount)
                                    (lift (2+ctorCount) nonUniformArgCount
                                      (subst1 type allParamCount (* tRel => inductive type *)
                                        (mapProdToLambda
                                          (remove_arity allParamCount a)
                                        )
                                      )
                                    )
                                    )
                                  )
                                  (* case for constructor is after f, indices, constructor arguments and other cases *)
                                  (* apply all arguments of constructor to case *)
                                  (
                                     let callChain :=
                                        (createAppChain (
                                             createAppChainOff
                                               (S trueIndCount+count)
                                               (tRel (1+allIndCount+count+(ctorCount -i)))
                                               nonUniformArgCount
                                        ) count) in
                                     if isInductive then
                                      mkApps callChain
                                              (getInductiveCalls x (2+ctorCount) (1+trueIndCount) trueParamCount nonUniformArgCount (count+1+allIndCount) count)
                                      else callChain
                                  )
                                 )
                              )
                              trueParamCtors
                           )
                        )
                )
             ;
             (* recursion over instance (last argument) *)
             rarg := allIndCount |}] 0)
    ))
  , one_body.(ind_name) +s (if isInductive then "_ind_MC" else "_case_MC") ) end.

(* POLYMORPHIC *)
Definition runElim {A:Type} (indTm : A) (isInductive:bool) (create:bool) (nameOpt:option ident) (returnType:option term)
  : TemplateMonad unit
  := p <- tmQuoteRec indTm;;
     let (env,tm) := (p:program) in
     match tm with
     | tInd ind0 univ =>
       decl <- tmQuoteInductive (inductive_mind ind0) ;;
            let lemma := createElim isInductive ind0 univ decl returnType (fresh_name (empty_ext env) []) in
            evaluated <- tmEval lazy lemma;;
            if create then
              match evaluated with
                None => tmFail "invalid inductive"
              | Some (x,name') =>
                let name := match nameOpt with None => name' | Some s => s end
                in
                         y <- tmUnquote x;;
                         z <- tmEval lazy (y.(my_projT2));;
                        tmPrint y;;
                        tmPrint "";;
                        tmPrint z;;
                        tmDefinitionRed name (Some lazy) z;;(* simplified type *)
                        tmPrint "";;
                        tmPrint x
              end
            else
              match evaluated with
                None => tmPrint "failed"
                | Some (x,_) =>
                  tmPrint x;;
                  bruijn_print x
              end
     | _ => tmPrint tm ;; tmFail " is not an inductive"
     end.

Definition create {A:Type} (tm:A) (isInductive:bool) (create:bool) :=
  runElim tm isInductive create None None.

Definition getName (x : nat -> nat) :=
  x <- tmEval cbv x;;
  t <- tmQuote x ;; match t with tLambda (nNamed na) _ _ => ret na | _ => ret "" end.

Notation name_of n := (ltac:(let k x := exact x in run_template_program (getName (fun n : nat => 0)) k)).

Notation "'Scheme' 'Elimination' 'for' T" := (runElim T false true None None)(at level 8).
Notation "'Scheme' 'Elimination' 'for' T 'Sort' 'Type'" := (runElim T false true None (Some <% Type %>))(at level 8).
Notation "'Scheme' n ':=' 'Elimination' 'for' T 'Sort' 'Type'" := (runElim T false true (Some (name_of n)) (Some <% Type %>))(at level 8).
Notation "'Scheme' n ':=' 'Elimination' 'for' T 'Sort' 'Type'" := (runElim T false true (Some "nat_caset2") (Some <% Type %>))(at level 8).


(*
Copyright © 2007-2008 Russell O’Connor

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

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

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Export CoRN.algebra.RSetoid.
Require Export CoRN.metric2.StepFunction.
Require Import CoRN.model.structures.OpenUnit.
Require Import CoRN.tactics.CornTac.
Require Import CoRN.tactics.Qauto.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.algebra.COrdFields.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.
Set Automatic Introduction.

Local Open Scope Q_scope.

(**
** Step Functions over setoids

In this section we redevelop step functions over a setoid X.
The applicative functor StepF lifts equivalence relations (setoids).
When type X has an equivalence relation eqX, then StepF X inherits
an equivalence relation StepF_eq, by checking that the leaf values in X
are equivalent for each rational argument. Moreover, a morphism f : X --> Y
lifts to a morphism map StepF f : StepF X --> StepF Y.
In other words, StepF is an endofunctor of the category of setoids.

*)

Local Open Scope setoid_scope.

(** We lift ap to the setoid version.  Map is a notation calling ap so
that all lemmas about ap automatically apply to Map. *)
Definition Ap (X Y : RSetoid) : (StepF (X --> Y))->(StepF X)->(StepF Y)
  := fun f x => (@Ap X Y (StepFunction.Map (@evalMorphism X Y) f) x).
Notation "f <@> x" := (Ap f x) (at level 15, left associativity) : sfstscope.
Notation "f ^@> x" := (Ap (constStepF f) x) (at level 15, left associativity) : sfstscope.
Notation "f <@^ x" := (Ap f (constStepF x)) (at level 15, left associativity) : sfstscope.

Local Open Scope sfstscope.

(** We lift lemmas about map, ap, mirror, and glue *)
Lemma MirrorGlue : forall (X : RSetoid) (o : OpenUnit) (al ar : StepF X),
       Mirror (glue o al ar) = glue (OpenUnitDual o) (Mirror ar) (Mirror al).
Proof.
 reflexivity.
Qed.

Lemma MapGlue : forall (X Y : RSetoid) (f : (X --> Y))
         (o : OpenUnit) (al ar : StepF X),
       f ^@> (glue o al ar) = glue o (f ^@> al) (f ^@> ar).
Proof.
 reflexivity.
Qed.

Lemma ApGlue : forall (X Y : RSetoid) (fl fr : StepF (X --> Y))
         (o : OpenUnit) (b : StepF X),
       (glue o fl fr) <@> b = glue o (fl <@> (SplitL b o)) (fr <@> (SplitR b o)).
Proof.
 intros X Y fl fr o b.
 unfold Ap.
 simpl (StepFunction.Map (@evalMorphism X Y) (glue o fl fr)).
 rewrite ApGlue.
 reflexivity.
Qed.

Lemma ApGlueGlue : forall (X Y : RSetoid) (fl fr : StepF (X --> Y)) (o : OpenUnit) (l r : StepF X),
       (glue o fl fr) <@> (glue o l r) = glue o (fl <@> l) (fr <@> r).
Proof.
 intros X Y fl fr o l r.
 unfold Ap.
 simpl (StepFunction.Map (@evalMorphism X Y) (glue o fl fr)).
 rewrite ApGlueGlue.
 reflexivity.
Qed.

Lemma SplitLMap : forall (X Y : RSetoid) (x : StepF X) (a : OpenUnit) (f : X --> Y),
       SplitL (f ^@> x) a = f ^@> (SplitL x a).
Proof.
 intros X Y x a f.
 unfold Ap.
 simpl.
 rewrite SplitLMap.
 reflexivity.
Qed.

Lemma SplitRMap : forall (X Y : RSetoid) (x : StepF X) (a : OpenUnit) (f : X --> Y),
       SplitR (f ^@> x) a = f ^@> (SplitR x a).
Proof.
 intros X Y x a f.
 unfold Ap.
 simpl.
 rewrite SplitRMap.
 reflexivity.
Qed.

Section EquivalenceA.
(** A step function over [Prop], a characteristic function, can be
folded into [Prop], which holds for the always true characteristic
function *)
Definition StepFfoldProp : StepF iffSetoid -> Prop := (StepFfold (X:=iffSetoid) (fun x => x ) (fun _ a b => a /\ b )).

Definition st_eqS0 {X : RSetoid} : X -> X --> iffSetoid.
Proof.
 intros x.
 exists (st_eq x).
 abstract ( intros x1 x2 Hx; simpl; rewrite -> Hx; reflexivity).
Defined.

Definition st_eqS {X : RSetoid} : X --> X --> iffSetoid.
Proof.
 exists (st_eqS0).
 abstract ( intros x1 x2 Hx y; simpl; rewrite -> Hx; reflexivity).
Defined.
(**
** Equivalence
An equivalence relation on step functions is implemented by lifiting
the equivalence relation on the underlying setoid to step functions.
The results is a characteristic function saying where two step functions
are equivalent.  The step functions are considered equivalent if this
characteristic function says they are equivalent everywhere.
*)
Definition StepF_eq {X : RSetoid} (f g:StepF X):Prop:=
(StepFfoldProp (st_eqS ^@> f <@> g)).

Notation "x === y" := (StepF_eq x y) (at level 70).

(** With equality defined we can complete the proof that split is the
opposite of glue *)
Lemma glue_StepF_eq :
  forall {X : RSetoid} (s:StepF X) (s1 s2:StepF X),
  forall a, s1 === (SplitL s a) -> s2 === (SplitR s a) -> (glue a s1 s2) === s.
Proof.
 intros X s s1 s2 a H0 H1.
 unfold StepF_eq.
 rewrite MapGlue.
 rewrite ApGlue.
 split; assumption.
Qed.

Lemma glue_eq_ind : forall {X : RSetoid} (s1 s2 s:StepF X) a (P:Prop),
    (s1 === SplitL s a -> s2 === SplitR s a -> P) -> (glue a s1 s2 === s) -> P.
Proof.
 intros X s1 s2 s a P H H0.
 unfold StepF_eq in *.
 rewrite -> MapGlue in *.
 rewrite ApGlue in H0.
 destruct H0.
 auto.
Qed.
(** The equivalence relation is reflexive *)
Lemma StepF_eq_refl : forall {X : RSetoid} (x : StepF X), x === x.
Proof.
 intro X. induction x.
  change (st_eq x x).
  reflexivity.
 apply glue_StepF_eq.
  simpl; rewrite SplitLGlue; assumption.
 simpl; rewrite SplitRGlue; assumption.
Qed.
(* begin hide *)
Hint Resolve StepF_eq_refl.
(* end hide *)
(** StepF_Qeq is a refinement of any setoid equality *)
Lemma StepF_Qeq_eq : forall {X : RSetoid} (s t:StepF X), (StepF_Qeq s t) -> s === t.
Proof.
  intro X.
  induction s; induction t; try contradiction; simpl.
  intros H.
  rewrite H.
  auto with *.
 intros [H [H0 H1]].
 apply glue_StepF_eq.
  apply IHs1.
  apply SplitL_glue_ind; intros H2; try (elim (Qlt_not_le _ _ H2); rewrite -> H); auto with *.
 apply IHs2.
 apply SplitR_glue_ind; intros H2; try (elim (Qlt_not_le _ _ H2); rewrite -> H); auto with *.
Qed.

Lemma glueSplit : forall {X : RSetoid} (s : StepF X),
    forall a, (glue a (SplitL s a) (SplitR s a)) === s.
Proof.
 intros X s a.
 apply glue_StepF_eq; auto with *.
Qed.

End EquivalenceA.
(* begin hide *)
#[global]
Hint Resolve StepF_eq_refl : sfarith.
(* end hide *)
Notation "x == y" := (StepF_eq x y) (at level 70) : sfstscope.

Section EquivalenceB.
Variable X Y : RSetoid.

Lemma Map_resp_StepF_eq: forall f:X-->Y,
    (forall x y, (st_eq x y)-> (st_eq (f x) (f y))) ->
    forall s t:(StepF X), s == t -> (f ^@> s) == (f ^@> t).
Proof.
 intros f H.
 induction s. induction t.
  unfold StepF_eq, Map2, StepFfoldProp ;simpl;auto with *.
  unfold StepF_eq, Map2, StepFfoldProp. simpl;  intuition.
  intros t H0.
 unfold StepF_eq, Map2 in H0.
 rewrite MapGlue in H0.
 rewrite ApGlue in H0.
 unfold StepF_eq, Map2.
 repeat rewrite MapGlue.
 rewrite ApGlue.
 rewrite SplitLMap.
 rewrite SplitRMap.
 destruct H0 as [H0l H0R].
 split.
  apply IHs1; auto.
 apply IHs2; auto.
Qed.

End EquivalenceB.

Lemma StepFfoldPropglue:forall (y:StepF iffSetoid) o,
 StepFfoldProp (glue o (SplitL y o) (SplitR y o)) <-> StepFfoldProp y.
Proof.
 induction y.
  unfold StepF_eq, StepFfoldProp.
  simpl; tauto.
 simpl.
 intro o0.
 apply SplitLR_glue_ind; intros H.
   generalize (IHy1 (OpenUnitDiv o0 o H)).
   unfold StepFfoldProp; simpl; tauto.
  generalize (IHy2 (OpenUnitDualDiv o0 o H)).
  unfold StepFfoldProp; simpl; tauto.
 simpl.
 reflexivity.
Qed.

Lemma StepFfoldProp_morphism:forall x y:(StepF iffSetoid),
  (StepF_eq x y) ->
  ((StepFfoldProp x)<->(StepFfoldProp y)).
Proof.
 induction x. induction y.
  auto with *.
  unfold StepF_eq. simpl. unfold StepFfoldProp;simpl;intuition.
  intros y H0.
 unfold StepF_eq, Map2 in H0.
 rewrite MapGlue in H0.
 rewrite ApGlue in H0.
 destruct H0 as [H0l H0r].
 change ((StepFfoldProp x1 /\ StepFfoldProp x2) <-> StepFfoldProp y).
 rewrite -> (IHx1 (SplitL y o)); auto with *.
 rewrite -> (IHx2 (SplitR y o)); auto with *.
 apply: StepFfoldPropglue.
Qed.

Lemma StepFfoldPropSplitR
     : forall (s : StepF iffSetoid) (a : OpenUnit),
       StepFfoldProp s -> StepFfoldProp (SplitR s a).
Proof.
 intros s a H.
 rewrite <- (StepFfoldPropglue s a) in H.
 destruct H; auto.
Qed.

Lemma StepFfoldPropSplitL
     : forall (s : StepF iffSetoid) (a : OpenUnit),
       StepFfoldProp s -> StepFfoldProp (SplitL s a).
Proof.
 intros s a H.
 rewrite <- (StepFfoldPropglue s a) in H.
 destruct H; auto.
Qed.

Section EquivalenceC.

Variable X : RSetoid.
(* begin hide *)
Hint Resolve StepF_Qeq_eq StepF_Qeq_refl SplitL_resp_Qeq SplitR_resp_Qeq.
(* end hide *)
Lemma StepF_eq_resp_Qeq : forall (s t : StepF X) u v, (StepF_Qeq s t) -> (StepF_Qeq u v) -> s == u -> t == v.
Proof.
 induction s; induction t; try contradiction.
  intros u v Hst Huv Hsu.
  simpl in Hst.
  unfold StepF_eq in *.
  rewrite <- Hst.
  rewrite <- (StepFfoldProp_morphism ((st_eqS) ^@> constStepF x <@> u)); auto.
  apply: (Map_resp_StepF_eq); auto with *.
  intros a b Hab.
  simpl.
  rewrite -> Hab.
  reflexivity.
 intros u v [H [Hst0 Hst1]] Huv Hsu.
 destruct Hsu as [Hsu1 Hsu2] using (glue_eq_ind s1).
 apply glue_StepF_eq.
  eapply IHs1.
    assumption.
   unfold SplitL; apply SplitL_resp_Qeq.
    apply H.
   apply Huv.
  assumption.
 eapply IHs2.
   assumption.
  unfold SplitR; apply SplitR_resp_Qeq.
   apply H.
  apply Huv.
 assumption.
Qed.

Lemma Mirror_eq_Mirror : forall (s t : StepF X), Mirror s == Mirror t <-> s == t.
Proof.
 induction s.
  induction t; simpl.
   reflexivity.
  change (constStepF x == (Mirror t2) /\ constStepF x == (Mirror t1) <-> constStepF x == t1 /\ constStepF x == t2).
  tauto.
 intros t.
 rewrite MirrorGlue.
 split; apply (@glue_eq_ind X); intros H0 H1.
  apply glue_StepF_eq.
   rewrite <- IHs1.
   eapply StepF_eq_resp_Qeq;[| |apply H1]; auto with *.
   apply StepF_Qeq_sym.
   apply MirrorSplitL_Qeq; auto with *.
  rewrite <- IHs2.
  eapply StepF_eq_resp_Qeq;[| |apply H0]; auto with *.
  apply StepF_Qeq_sym.
  apply MirrorSplitR_Qeq; auto with *.
 apply glue_StepF_eq.
  apply StepF_eq_resp_Qeq with (Mirror s2) (Mirror (SplitR t o)); auto.
   apply MirrorSplitR_Qeq; apply Qeq_refl.
  rewrite -> IHs2.
  assumption.
 apply StepF_eq_resp_Qeq with (Mirror s1) (Mirror (SplitL t o)); auto.
  apply MirrorSplitL_Qeq; apply Qeq_refl.
 rewrite -> IHs1.
 assumption.
Qed.

Lemma SplitL_resp_Xeq : forall (s1 s2 : StepF X) a, s1 == s2 -> SplitL s1 a == SplitL s2 a.
Proof.
 induction s1.
  intros s2 a H.
  unfold StepF_eq in *.
  change (StepFfoldProp ((st_eqS x:X-->iffSetoid) ^@> SplitL s2 a)).
  rewrite <- SplitLMap.
  apply StepFfoldPropSplitL.
  assumption.
 intros s2 a H.
 destruct H using (glue_eq_ind s1_1).
 apply SplitL_glue_ind; intros Hao.
   apply StepF_eq_resp_Qeq with (SplitL s1_1 (OpenUnitDiv a o Hao)) (SplitL (SplitL s2 o) (OpenUnitDiv a o Hao)); auto.
   apply SplitLSplitL.
   simpl; field; auto with *.
  apply glue_StepF_eq.
   apply StepF_eq_resp_Qeq with s1_1 (SplitL s2 o); auto.
   apply StepF_Qeq_sym.
   apply SplitLSplitL.
   simpl; field; auto with *.
  apply StepF_eq_resp_Qeq with (SplitL s1_2 (OpenUnitDualDiv a o Hao)) (SplitL (SplitR s2 o) (OpenUnitDualDiv a o Hao)); auto.
  apply SplitLSplitR; simpl; field; auto with *.
 apply StepF_eq_resp_Qeq with s1_1 (SplitL s2 o); auto with *.
Qed.

Lemma SplitR_resp_Xeq : forall (s1 s2:StepF X) a, s1 == s2 -> SplitR s1 a == SplitR s2 a.
Proof.
 intros s1 s2 a H.
 pose (b:=OpenUnitDual a).
 apply StepF_eq_resp_Qeq with (Mirror (SplitL (Mirror s1) b)) (Mirror (SplitL (Mirror s2) b));
   try (unfold Mirror, SplitR, SplitL, b;eapply StepF_Qeq_trans;[apply Mirror_resp_Qeq; apply StepF_Qeq_sym; apply MirrorSplitR_Qeq; reflexivity|apply MirrorMirror]).
 rewrite -> Mirror_eq_Mirror.
 apply SplitL_resp_Xeq.
 rewrite -> Mirror_eq_Mirror.
 assumption.
Qed.

(** equalitiy is transitive *)
Lemma StepF_eq_trans:forall x y z : StepF X, x == y -> y == z -> x == z.
Proof.
 induction x. intros.
  unfold StepF_eq in *.
  set (A:=((st_eqS :X-->X-->iffSetoid) ^@> constStepF x)) in *.
  rewrite <- (StepFfoldProp_morphism (A <@> y)); auto with *.
  apply: (Map_resp_StepF_eq); auto with *.
  intros a b Hab.
  simpl.
  rewrite -> Hab.
  reflexivity.
 intros.
 destruct H using (glue_eq_ind x1).
 apply glue_StepF_eq.
  eapply IHx1.
   apply H.
  apply SplitL_resp_Xeq.
  assumption.
 eapply IHx2.
  apply H1.
 apply SplitR_resp_Xeq.
 assumption.
Qed.

Lemma glue_resp_StepF_eq:forall (x x' y y':StepF X) o,
  (x==x')->(y==y')->
  (glue o x y)==(glue o x' y').
Proof.
 intros.
 unfold StepF_eq.
 rewrite MapGlue.
 rewrite ApGlueGlue.
 split; assumption.
Qed.

(** equality is symmetric *)
Lemma StepF_eq_sym :forall x y: StepF X, x == y -> y == x.
Proof.
 intros x y.
 revert x.
 induction y.
  unfold StepF_eq. simpl. intro x0. induction x0.
  unfold StepFfoldProp. simpl. intros. symmetry; assumption.
   simpl. unfold StepFfoldProp; simpl; intuition; auto with *.
  intros x H.
 assert (H0:=(SplitL_resp_Xeq _ _ o H)).
 rewrite SplitLGlue in H0.
 assert (H1:=(SplitR_resp_Xeq _ _ o H)).
 rewrite SplitRGlue in H1.
 apply glue_StepF_eq;auto with *.
Qed.

End EquivalenceC.
(* begin hide *)
Add Parametric Relation (X : RSetoid) : (StepF X) (@StepF_eq X)
 reflexivity proved by (@StepF_eq_refl X)
 symmetry proved by (@StepF_eq_sym X)
 transitivity proved by (@StepF_eq_trans X)
 as StepF_SetoidTheory.

#[global]
Hint Resolve StepF_eq_sym StepF_eq_trans.

Add Morphism (StepFfoldProp)
  with signature (@StepF_eq iffSetoid) ==>  iff
 as StepFfoldProp_mor.
Proof.
 exact StepFfoldProp_morphism.
Qed.
(* end hide *)
Lemma StepF_Sth (X : RSetoid) : (Setoid_Theory (StepF X) (@StepF_eq X)).
 split; unfold Reflexive, Symmetric, Transitive; eauto with sfarith.
Qed.

(**
** Common subdivision view
This lemma allows to do induction over two step function as if the
functions had the same subdivisions.
*)
Lemma StepF_ind2 : forall (X Y : RSetoid) (P : StepF X -> StepF Y -> Prop),
       (forall (s s0 : StepF X) (t t0 : StepF Y),
        (s==s0) -> (t==t0) -> P s t -> P s0 t0) ->
       (forall (x:X) (y:Y), P (constStepF x) (constStepF y)) ->
       (forall (o : OpenUnit) (s s0 : StepF X) (t t0 : StepF Y),
        P s t -> P s0 t0 -> P (glue o s s0) (glue o t t0)) ->
       forall (s:StepF X) (t:StepF Y), P s t.
Proof.
 intros X Y P wd c0 c1.
 induction s.
  induction t.
   apply c0.
  apply wd with (s:=(glue o (constStepF x) (constStepF x))) (t:=glue o t1 t2); try reflexivity.
   apply (glueSplit (constStepF x) o).
  apply c1; assumption.
 intros t.
 eapply wd.
   reflexivity.
  apply glueSplit with (a:=o).
 apply c1; auto.
Qed.

Lemma glue_injl {X : RSetoid} :forall o (x y x1 y1:StepF X),
(glue o x y)==(glue o x1 y1) -> (x==x1).
Proof.
 intros.
 destruct H as [H _] using (glue_eq_ind x).
 rewrite SplitLGlue in H.
 assumption.
Qed.

Lemma glue_injr {X:RSetoid} :forall o (x y x1 y1:StepF X),
(glue o x y)==(glue o x1 y1) -> (y==y1).
Proof.
 intros.
 destruct H as [_ H] using (glue_eq_ind x).
 rewrite SplitRGlue in H.
 assumption.
Qed.

(** Decompose an equality over glue into two parts *)
Lemma eq_glue_ind {X : RSetoid} : forall (s1 s2 s : StepF X) (a : OpenUnit) (P : Prop),
       ((SplitL s a) == s1 -> (SplitR s a) == s2 -> P) ->
       s == (glue a s1 s2) -> P.
Proof.
 intros s1 s2 s a P H H0.
 symmetry in H0.
 destruct H0 as [H0l H0r] using (glue_eq_ind s1).
 symmetry in H0l, H0r.
 auto.
Qed.

Lemma MirrorSplitR {X : RSetoid} : forall (s : StepF X) (a b : OpenUnit),
  (b == OpenUnitDual a)%Q ->
  (Mirror (SplitR s a)) == (SplitL (Mirror s) b).
Proof.
 intros.
 apply StepF_Qeq_eq; auto with *.
 apply MirrorSplitR_Qeq; auto with *.
Qed.

Lemma MirrorSplitL {X : RSetoid} : forall (s : StepF X) (a b : OpenUnit),
  (b == OpenUnitDual a)%Q ->
  (Mirror (SplitL s a)) == (SplitR (Mirror s) b).
Proof.
 intros.
 apply StepF_Qeq_eq; auto with *.
 apply MirrorSplitL_Qeq; auto with *.
Qed.

(** Lift the distribution lemmas between ap and split to work over step
functions *)
Lemma SplitRAp :forall (X Y : RSetoid) (f : StepF (Y --> X)) (s : StepF Y) (o : OpenUnit),
  (SplitR (f <@> s) o) == (SplitR f o <@> SplitR s o).
Proof.
 intros X Y f s o.
 apply StepF_Qeq_eq; auto with *.
 unfold Ap.
 rewrite <- StepFunction.SplitRMap.
 apply SplitRAp_Qeq.
Qed.

Lemma SplitLAp :forall (X Y : RSetoid) (f : StepF (Y --> X)) (s : StepF Y) (o : OpenUnit),
  (SplitL (f <@> s) o) == (SplitL f o <@> SplitL s o).
Proof.
 intros X Y f s o.
 apply StepF_Qeq_eq; auto with *.
 unfold Ap.
 rewrite <- StepFunction.SplitLMap.
 apply SplitLAp_Qeq.
Qed.
(* begin hide *)
Add Parametric Morphism s : (@constStepF s) with signature (@st_eq s) ==> (@StepF_eq s) as constStepF_wd.
Proof.
 auto.
Qed.

Add Parametric Morphism s : (@glue s) with signature ou_eq ==> (@StepF_eq s) ==> (@StepF_eq s) ==> (@StepF_eq s) as glue_wd.
Proof.
 intros o1 o2 Ho x1 x2 Hx y1 y2 Hy.
 transitivity (glue o1 x2 y2).
  apply glue_resp_StepF_eq; auto.
 apply StepF_Qeq_eq.
 repeat split; auto; reflexivity.
Qed.

Add Parametric Morphism X : (@SplitL X) with signature (@StepF_eq X) ==> ou_eq ==> (@StepF_eq X) as SplitL_wd.
Proof.
 intros x1 x2 Hx o1 o2 Ho.
 transitivity (SplitL x2 o1).
  apply SplitL_resp_Xeq; auto.
 apply StepF_Qeq_eq.
 apply SplitL_resp_Qeq; auto; reflexivity.
Qed.

Add Parametric Morphism X : (@SplitR X) with signature (@StepF_eq X) ==> ou_eq ==> (@StepF_eq X) as SplitR_wd.
Proof.
 intros x1 x2 Hx o1 o2 Ho.
 transitivity (SplitR x2 o1).
  apply SplitR_resp_Xeq; auto.
 apply StepF_Qeq_eq.
 apply SplitR_resp_Qeq; auto; reflexivity.
Qed.

Add Parametric Morphism X Y : (@Ap X Y) with signature (@StepF_eq (extSetoid X Y)) ==> (@StepF_eq X) ==> (@StepF_eq Y) as Ap_wd.
Proof.
 intros f.
 induction f; intros g Hfg.
  induction g; intros x1.
   simpl.
   induction x1; intros x2.
    induction x2.
     intros H.
     transitivity (x ^@> (constStepF x2)).
      destruct x as [x Hx].
      clear Hfg. apply: Hx ; assumption.
      apply: Hfg.
    intros H.
    rewrite MapGlue.
    symmetry.
    symmetry in H.
    destruct H as [Hl Hr] using (glue_eq_ind x2_1).
    apply glue_StepF_eq.
     symmetry.
     symmetry in Hl.
     apply IHx2_1.
     assumption.
    symmetry.
    symmetry in Hr.
    apply IHx2_2.
    assumption.
   intros H.
   rewrite MapGlue.
   destruct H as [Hl Hr] using (glue_eq_ind x1_1).
   apply glue_StepF_eq.
    rewrite SplitLMap.
    apply IHx1_1; auto.
   rewrite SplitRMap.
   apply IHx1_2; auto.
  symmetry.
  rewrite ApGlue.
  destruct Hfg as [Hfg0 Hfg1] using (eq_glue_ind g1).
  apply glue_StepF_eq; symmetry.
   rewrite SplitLMap.
   apply IHg1; try rewrite -> H0; auto with *.
  rewrite SplitRMap.
  apply IHg2; try rewrite -> H0; auto with *.
 intros s s' Hs.
 destruct Hfg as [Hfg0 Hfg1] using (glue_eq_ind f1).
 rewrite ApGlue.
 apply glue_StepF_eq; auto with *.
  rewrite -> SplitLAp.
  apply IHf1; try rewrite -> Hs; auto with *.
 rewrite -> SplitRAp.
 apply IHf2; try rewrite -> Hs; auto with *.
Qed.
(* end hide *)
Lemma GlueAp : forall (X Y : RSetoid) (f : StepF (X --> Y)) (o : OpenUnit) (l r : StepF X),
       f <@> (glue o l r) == glue o ((SplitL f o) <@> l) ((SplitR f o) <@> r).
Proof.
 intros X Y f o l r.
 set (A:= ((SplitL f o)<@>l)).
 set (B:= ((SplitR f o)<@>r)).
 rewrite <- (glueSplit f o).
 rewrite ApGlueGlue.
 reflexivity.
Qed.
(**
** Applicative Functor
Here we prove the axioms of an applicative functor.
*)
Lemma Map_homomorphism (X Y : RSetoid) : forall (f:X-->Y) (a:X),
 (f ^@> constStepF a) == (constStepF (f a)).
Proof.
 reflexivity.
Qed.

Lemma Map_identity (X : RSetoid) : forall (a:StepF X),
 (@id X) ^@> a == a.
Proof.
 intros a.
 now rewrite <-(Map_identity a) at 2.
Qed.

Lemma Map_composition (X Y Z : RSetoid) : forall (a:StepF (Y-->Z)) (b:StepF (X-->Y)) (c:StepF X),
 ((@compose X Y Z) ^@> a <@> b <@> c) == (a <@> (b <@> c)).
Proof.
 induction a.
  simpl.
  apply (StepF_ind2 (X --> Y) X); auto with *.
   intros s s0 t t0 Hs Ht.
   rewrite -> Hs, Ht.
   auto.
  intros o s s0 t t0 H H0.
  rewrite -> Map_homomorphism.
  rewrite ApGlueGlue.
  do 2 rewrite MapGlue.
  rewrite ApGlueGlue.
  rewrite <- H.
  rewrite <- H0.
  reflexivity.
 intros b c.
 rewrite MapGlue.
 repeat rewrite ApGlue.
 apply glue_resp_StepF_eq.
  rewrite -> IHa1.
  rewrite -> SplitLAp.
  reflexivity.
 rewrite -> IHa2.
 rewrite -> SplitRAp.
 reflexivity.
Qed.

(** Here we show that the rest of the BCKW combinators lift to
step functions.  Hence all of the lambda calculus lifts to operate
over step functions.  Step functions form about a nice of an
applicative functor as is possible. *)
Lemma Map_discardable (X Y : RSetoid) : forall (a:StepF X) (b:StepF Y),
 ((@const _ _) ^@> a <@> b == a).
Proof.
 apply StepF_ind2; auto with *.
  intros s s0 t t0 Hs Ht.
  rewrite -> Hs, Ht; auto.
 intros o s s0 t t0 H0 H1.
 rewrite MapGlue.
 rewrite ApGlueGlue.
 rewrite -> H0, H1;reflexivity.
Qed.

Lemma Map_commutative W X Y : forall (f:StepF (W --> X --> Y)) (x:StepF X) (w:StepF W),
 ((@flip _ _ _) ^@> f <@> x <@> w) == (f <@> w <@> x).
Proof.
 induction f.
  simpl.
  apply StepF_ind2; auto with *.
   intros s s0 t t0 Hs Ht.
   rewrite -> Hs, Ht;auto.
  intros o s s0 t t0 H0 H1.
  rewrite -> Map_homomorphism.
  do 2 rewrite MapGlue.
  do 2 rewrite ApGlueGlue.
  rewrite -> H0, H1; reflexivity.
 intros x w.
 rewrite MapGlue.
 do 4 rewrite ApGlue.
 apply glue_resp_StepF_eq; auto.
Qed.

Lemma Map_copyable X Y : forall (f:StepF (X --> X --> Y)) (x:StepF X),
 ((@join _ _) ^@> f <@> x) == (f <@> x <@> x).
Proof.
 apply StepF_ind2; auto with *.
  intros s s0 t t0 Hs Ht.
  rewrite -> Hs, Ht; auto.
 intros o s s0 t t0 H0 H1.
 rewrite MapGlue.
 do 3 rewrite ApGlueGlue.
 rewrite -> H0, H1;reflexivity.
Qed.
(* begin hide *)
#[global]
Hint Rewrite
 ApGlueGlue ApGlue GlueAp SplitRAp SplitLAp SplitLGlue SplitRGlue
 Map_homomorphism : StepF_rew.

#[global]
Hint Rewrite
 Map_composition
 Map_discardable
 Map_commutative
 Map_identity
 Map_copyable : StepF_eval.
(* end hide *)
(** This tactic is usefully for symbolically evaluating functions written
in (BCKWI) combinator form that are ap'ed to step functions *)
Ltac evalStepF := progress
(repeat rewrite <- Map_homomorphism; autorewrite with StepF_eval).

Lemma Ap_interchange (X Y : RSetoid) : forall (f:StepF (X-->Y)) (a:X),
 (f <@^ a) == (flip id a) ^@> f.
Proof.
 intros f a.
 evalStepF.
 reflexivity.
Qed.

(** Map'ing the S combinator (which is also called ap) *)
Lemma Map_ap X Y Z : forall (f:StepF (X --> Y --> Z)) (x:StepF (X --> Y)) (a:StepF X),
 ((@ap _ _ _) ^@> f <@> x <@> a) == (f <@> a <@> (x <@> a)).
Proof.
 intros f x a.
 unfold ap.
 evalStepF.
 reflexivity.
Qed.
(* begin hide *)
#[global]
Hint Rewrite Map_ap : StepF_eval.
(* end hide *)
Ltac rewriteStepF := autorewrite with StepF_rew.

Lemma StepFfoldPropForall_Ap :
 forall X (f:StepF (X --> iffSetoid)) (x:StepF X), (forall y, StepFfoldProp (f <@> constStepF y)) -> StepFfoldProp (f <@> x).
Proof.
 intros X f x H.
 revert f H.
 induction x.
  intros f H.
  apply H.
 intros f H.
 rewrite <- (glueSplit f o).
 rewrite ApGlueGlue.
 split.
  apply IHx1.
  intros y.
  assert (H0:=H y).
  rewrite <- (glueSplit f o) in H0.
  rewrite ApGlue in H0.
  destruct H0 as [H0 _].
  assumption.
 apply IHx2.
 intros y.
 assert (H0:=H y).
 rewrite <- (glueSplit f o) in H0.
 rewrite ApGlue in H0.
 destruct H0 as [_ H0].
 assumption.
Qed.

(** A common case that we will encounter is that a predicate holds for
all step functions when it is define via map (or map2 or map3) and the
underlying function holds for all X. *)
Lemma StepFfoldPropForall_Map :
 forall X (f:X --> iffSetoid) (x:StepF X), (forall a, f a) -> StepFfoldProp (f ^@> x).
Proof.
 intros X f x H.
 apply StepFfoldPropForall_Ap.
 assumption.
Qed.

Lemma StepFfoldPropForall_Map2 :
 forall X Y (f:X --> Y --> iffSetoid) x y, (forall a b, f a b) -> StepFfoldProp (f ^@> x <@> y).
Proof.
 intros X Y f x y H.
 apply StepFfoldPropForall_Ap.
 intros b.
 rewrite <- (Map_commutative (constStepF f) (constStepF b)).
 rewriteStepF.
 apply StepFfoldPropForall_Map.
 intros a.
 apply: H.
Qed.

Lemma StepFfoldPropForall_Map3 :
 forall X Y Z (f:X --> Y --> Z --> iffSetoid) x y z, (forall a b c, f a b c) -> StepFfoldProp (f ^@> x <@> y <@> z).
Proof.
 intros X Y Z f x y z H.
 apply StepFfoldPropForall_Ap.
 intros c.
 rewrite <- (Map_commutative ((constStepF f) <@> x) (constStepF c)).
 rewrite <- Map_composition.
 rewriteStepF.
 rewrite <- (Map_commutative (constStepF (compose flip f)) (constStepF c)).
 rewriteStepF.
 apply StepFfoldPropForall_Map2.
 intros a b.
 apply: H.
Qed.

(** The implication operation can be lifted to work on characteristic
functions *)
Definition imp0:Prop->iffSetoid-->iffSetoid.
Proof.
 intro A.
 exists (fun B:Prop=>(A->B)).
 simpl. unfold canonical_names.equiv. intuition.
Defined.

Definition imp:iffSetoid-->iffSetoid-->iffSetoid.
Proof.
 exists imp0.
 simpl. unfold canonical_names.equiv, extEq. intuition.
 simpl. intuition.
Defined.

Definition StepF_imp (f g:StepF iffSetoid):Prop:=
(StepFfoldProp (imp ^@> f <@> g)).

Lemma StepFfoldPropglue_rew:(forall o x y, (StepFfoldProp (glue o x y))<->((StepFfoldProp x)/\StepFfoldProp y)).
Proof.
 auto with *.
Qed.
(* begin hide *)
#[global]
Hint Rewrite StepFfoldPropglue_rew:StepF_rew.
(* end hide *)
Lemma StepF_imp_imp:forall x y:(StepF iffSetoid),
  (StepF_imp x y) ->
  ((StepFfoldProp x)->(StepFfoldProp y)).
Proof.
 induction x. induction y.
  auto with *.
  unfold StepF_imp. unfold StepFfoldProp;simpl;intuition.
  intros y.
 unfold StepF_imp, Map2.
 rewriteStepF.
 intros.
 rewrite <- (StepFfoldPropglue y o).
 rewriteStepF.
 intuition.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition get_write_value_spec0 (rec: Pointer) (esr: Z64) (adt: RData) : option Z64 :=
    match rec, esr with
    | (_rec_base, _rec_ofst), VZ64 _esr =>
      rely is_int64 _esr;
      when _rt == esr_srt_spec (VZ64 _esr) adt;
      rely is_int _rt;
      if (_rt =? 31) then
        Some (VZ64 0)
      else
        when' _t'2 == get_rec_regs_spec (_rec_base, _rec_ofst) _rt adt;
        rely is_int64 _t'2;
        when' _t'3 == access_mask_spec (VZ64 _esr) adt;
        rely is_int64 _t'3;
        rely is_int64 (Z.land _t'2 _t'3);
        Some (VZ64 (Z.land _t'2 _t'3))
     end
    .

End SpecLow.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Require Import Label.

(* identifiers *)
Inductive id : Type :=
  | Id : string -> id.

(* class name *)
Inductive cn : Type :=
  | class_name : string -> cn.

Inductive ty : Type :=
  | classTy : cn -> ty
  | boolTy : ty
  | LabelTy : ty
  | LabelelTy : ty -> ty.

Inductive field : Type :=
  | fd : cn -> id -> field.

(* comparison of identifiers *)
Definition beq_id x y :=
  match x,y with
    | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

Inductive oid : Type :=
  | OID : nat -> oid.

Inductive tm : Type :=
  | Tvar : id -> tm
  | null : tm
  | EqCmp : tm -> tm -> tm
  | FieldAccess : tm -> id -> tm
  | MethodCall : tm -> id -> tm -> tm
  | NewExp : cn -> tm
(* boolean *)
  | B_true : tm
  | B_false : tm

(* label related *)
  | l : Label -> tm
  | labelData : tm -> tm -> tm
  | unlabel : tm -> tm
  | labelOf : tm -> tm
  | objectLabelOf : tm -> tm
  | raiseLabel : tm -> tm -> tm
  | toLabeled : tm -> tm -> tm
  | getCurrentLevel : tm

(* statement-like expressions *)
  | Assignment : id -> tm -> tm
  | FieldWrite : tm -> id -> tm -> tm
  | If : tm -> tm -> tm -> tm
  | Sequence : tm -> tm -> tm

(* special terms *)
  | ObjId: oid -> tm
  (* runtime labeled date*)
  | v_l : tm -> Label -> tm
  | v_opa_l : tm -> Label -> tm
  | hole : tm.

Inductive method_def : Type :=
  | m_def : ty -> id -> ty -> id -> tm -> method_def.

Inductive CLASS : Type :=
  | class_def : cn -> (list field) -> (list method_def) -> CLASS.

Inductive value : tm -> Prop :=
  (* contants are values or normal form *)
  | v_oid :
      forall o, value (ObjId o)
  | v_null :
      value null
  | v_label :
      forall lb, value (l lb)
  | v_labeled : forall v lb,
      value v ->
      value (v_l v lb)
  | v_opa_labeled : forall lb v,
      value v -> (forall v0 lb0, v <> v_opa_l v0 lb0) ->
      value (v_opa_l v lb)
  | v_true :
      value B_true
  | v_false :
      value B_false.

Hint Constructors value.

(* stack frame *)
Definition stack_frame : Type := id -> (option tm).

Definition sf_update (sf : stack_frame) (x : id) (v : tm) :=
  fun x' => if beq_id x x' then (Some v) else sf x'.

(*new definition for the code *)
Definition frame_stack  :Type := list tm.

Definition empty_stack_frame : stack_frame := fun _ => None.

(* Definitions for Heap related*)
Definition FieldMap : Type := id -> (option tm).

Definition fields_update (F : FieldMap) (x : id) (v : tm) :=
  fun x' => if beq_id x x' then (Some v) else F x'.

(* class definition -> Fields -> object label -> label of label*)
Inductive heapObj : Type :=
  | Heap_OBJ : CLASS -> FieldMap -> Label -> Label -> heapObj.

Inductive Heap_entry : Type :=
  | heap_entry : oid -> heapObj -> Heap_entry.

Notation "( oid , obj )" := (heap_entry oid obj).

Definition heap := list Heap_entry.

(* comparison of identifiers *)
Definition beq_oid x y :=
  match x,y with
    | OID n1, OID n2 => if beq_nat n1 n2 then true else false
  end.

Fixpoint update_heap_obj (h : heap) (o : oid) (ho : heapObj) :=
   match h with
      | nil => nil
      | head :: t => match head with
                            | ( o0 , heap_obj ) => if beq_oid o o0 then cons (o , ho) t
                                                                  else head :: update_heap_obj t o ho
                      end
   end.

Fixpoint lookup_heap_obj (h : heap) (o : oid) : option heapObj :=
   match h with
      | nil => None
      | h :: t => match h with
                            | ( o0 , ho ) => if beq_oid o o0 then Some ho
                                                                  else lookup_heap_obj t o
                      end
   end.

Definition get_fresh_oid (h:heap) :=
    match h with
     | nil => (OID 1)
     | h0 :: t0 => match h0 with
                        | ((OID n) , _) => (OID (n+1))
                          end
    end.

Definition add_heap_obj (h: heap) (o:oid) (ho : heapObj) :=
  cons (o, ho) h.

(* variable declaration *)
Inductive vd : Type :=
  | var_def : cn -> id -> vd.

Fixpoint find_method_body (methods : list method_def) (m : id) :=
  match methods with
    | nil => None
    | h :: t =>  match h with
                  | m_def cls m' cls_a arg_id body => if beq_id m m' then Some (m_def cls m' cls_a arg_id  body) else find_method_body t m
                 end
  end.

Definition find_method (cls : CLASS) (m : id) :=
  match cls with
    | class_def c_name fields methods => find_method_body methods m
  end.

Definition find_fields (cls : CLASS) :=
  match cls with
    | class_def c_name fields methods => fields
  end.

Fixpoint type_of_field (fields : list field) (f : id) : option cn :=
  match fields with
     | nil => None
     | (fd cls h) :: t => if beq_id h f then Some cls else (type_of_field t f)
  end.

Definition empty_field_map : FieldMap := fun _ => None.

Fixpoint init_field_map (fields : list field) (fm : FieldMap) :=
  match fields with
    | nil => fm
    | (fd cls h) :: t =>  (fun x' => if beq_id h x' then Some null else (init_field_map t fm) x')
  end.

Inductive container : Type :=
  | Container : tm -> frame_stack -> Label -> stack_frame -> container.

Definition Class_table := cn -> option CLASS.
Inductive config :=
  | Config : Class_table ->container -> list container -> heap -> config
  | Error_state : config
  | Terminal : config.
Hint Constructors config.

Reserved Notation "c '==>' c'"
  (at level 40, c' at level 39).

Fixpoint assignment_free (t : tm) :=
  match t with
    | Tvar x => true
    | null => true
    | EqCmp e1 e2  => if (assignment_free e1) then (assignment_free e2) else false
    | FieldAccess e f => (assignment_free e)
    | MethodCall e1 meth e2 => if (assignment_free e1) then (assignment_free e2) else false
    | NewExp cls => true
    | B_true => true
    | B_false => true
(* label related *)
    | l lb => true
    | labelData e1 e2 => if (assignment_free e1) then (assignment_free e2) else false
    | unlabel e => (assignment_free e)
    | labelOf e => (assignment_free e)
    | objectLabelOf e => (assignment_free e)
    | raiseLabel e1 e2 => if (assignment_free e1) then (assignment_free e2) else false
    | toLabeled e1 e2 => if (assignment_free e1) then (assignment_free e2) else false
    | getCurrentLevel => true

(* statements *)
    | Assignment x e => false
    | FieldWrite e1 f e2 =>  if (assignment_free e1) then (assignment_free e2) else false
    | If guard e1 e2 =>  if assignment_free guard then (if (assignment_free e1) then (assignment_free e2) else false )  else false
    | Sequence e1 e2 =>  if (assignment_free e1) then (assignment_free e2) else false

(* special terms *)
    | ObjId o =>  true
  (* runtime labeled date*)
    | v_l e lb => true
    | v_opa_l e lb => true
    | hole => true
  end.

Fixpoint surface_syntax (t : tm) :=
  match t with
    | Tvar x => true
    | null => true
    | EqCmp e1 e2  => if (surface_syntax e1) then (surface_syntax e2) else false
    | FieldAccess e f => (surface_syntax e)
    | MethodCall e1 meth e2 => if (surface_syntax e1) then (surface_syntax e2) else false
    | NewExp cls => true
    | B_true => true
    | B_false => true
(* label related *)
    | l lb => true
    | labelData e1 e2 => if (surface_syntax e1) then (surface_syntax e2) else false
    | unlabel e => (surface_syntax e)
    | labelOf e => (surface_syntax e)
    | objectLabelOf e => (surface_syntax e)
    | raiseLabel e1 e2 => if (surface_syntax e1) then (surface_syntax e2) else false
    | toLabeled e1 e2 => if ((surface_syntax e1) &&  (assignment_free e1))  then (surface_syntax e2) else false
    | getCurrentLevel => true

(* statements *)
    | Assignment x e => (surface_syntax e)
    | FieldWrite e1 f e2 =>  if (surface_syntax e1) then (surface_syntax e2) else false
    | If guard e1 e2 =>  if surface_syntax guard then (if (surface_syntax e1) then (surface_syntax e2) else false )  else false
    | Sequence e1 e2 =>  if (surface_syntax e1) then (surface_syntax e2) else false

(* special terms *)
    | ObjId o =>  false
  (* runtime labeled date*)
    | v_l e lb => false
    | v_opa_l e lb => false
    | hole => false
  end.

Inductive valid_syntax :  tm -> Prop :=
  (*variable *)
  | Valid_var : forall x,
      valid_syntax (Tvar x)
(* null *)
  | Valid_null :
      valid_syntax null

(* equal comparison *)
  | Valid_Eq1 : forall e1 e2,
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (EqCmp e1 e2)

  | Valid_Eq2 : forall  e2,
      surface_syntax e2 = true ->
      valid_syntax (EqCmp hole e2)

  | Valid_Eq3 : forall v e2,
      value v ->
      surface_syntax e2 = true ->
      valid_syntax (EqCmp v e2)

  | Valid_Eq4 : forall v,
      value v ->
      valid_syntax (EqCmp v hole)

  | Valid_Eq5 : forall v1 v2,
      value v1 -> value v2 ->
      valid_syntax (EqCmp v1 v2)

(* Field read *)
  | Valid_FieldAccess1 : forall e f,
      surface_syntax e = true ->
      valid_syntax (FieldAccess e f)

  | Valid_FieldAccess2 : forall f,
      valid_syntax (FieldAccess hole f)

  | Valid_FieldAccess3 : forall v f,
      value v ->
      valid_syntax (FieldAccess v f)

  | Valid_boolean_true :
      valid_syntax B_true
  | Valid_boolean_false :
      valid_syntax B_false

(* method call *)
  | Valid_MethodCall1 : forall e meth argu,
      surface_syntax e = true ->
      surface_syntax argu = true ->
      valid_syntax (MethodCall e meth argu)

  | Valid_MethodCall2 : forall meth argu,
      surface_syntax argu = true ->
      valid_syntax (MethodCall hole meth argu)

  | Valid_MethodCall3 : forall v meth argu,
      value v ->
      surface_syntax argu = true ->
      valid_syntax (MethodCall v meth argu)

  | Valid_MethodCall4 : forall v meth,
      value v ->
      valid_syntax (MethodCall v meth hole)

  | Valid_MethodCall5 : forall v1 v2 meth,
      value v1 -> value v2 ->
      valid_syntax (MethodCall v1 meth v2)

(* new exp *)
  | Valid_NewExp : forall cls_name,
      valid_syntax (NewExp cls_name)
(* label *)
  | Valid_label : forall lb,
      valid_syntax (l lb)

  (* label data *)
  | Valid_labelData1 : forall e1 e2,
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (labelData e1 e2)

  | Valid_labelData2 : forall e2,
       surface_syntax e2 = true ->
      valid_syntax (labelData hole e2)

  | Valid_labelData3 : forall v e2,
      value v ->
      surface_syntax e2 = true ->
      valid_syntax (labelData v e2)

  | Valid_labelData4 : forall v,
      value v ->
      valid_syntax (labelData v hole)

  | Valid_labelData5 : forall v1 v2,
      value v1 -> value v2 ->
      valid_syntax (labelData v1 v2)

(* unlabel *)
  | Valid_unlabel1 : forall e,
      surface_syntax e = true ->
      valid_syntax (unlabel e)

  | Valid_unlabel2 :
      valid_syntax (unlabel hole)

  | Valid_unlabel3 : forall v,
      value v ->
      valid_syntax (unlabel v)

(* labelOf *)
  | Valid_labelOf1 : forall e,
      surface_syntax e = true ->
      valid_syntax (labelOf e)

  | Valid_labelOf2 :
      valid_syntax (labelOf hole)

  | Valid_labelOf3 : forall v,
      value v ->
      valid_syntax (labelOf v)

(* objectLabelOf *)
  | Valid_objectLabelOf1 : forall e,
      surface_syntax e = true ->
      valid_syntax (objectLabelOf e)

  | Valid_objectLabelOf2 :
      valid_syntax (objectLabelOf hole)

  | Valid_objectLabelOf3 : forall v,
      value v ->
      valid_syntax (objectLabelOf v)

(* raise label *)
  | Valid_raiseLabel1 : forall e1 e2,
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (raiseLabel e1 e2)

  | Valid_raiseLabel2 : forall e2,
      surface_syntax e2 = true ->
      valid_syntax (raiseLabel hole e2)

  | Valid_raiseLabel3 : forall v e2,
      value v ->
      surface_syntax e2 = true ->
      valid_syntax (raiseLabel v e2)

  | Valid_raiseLabel4 : forall v,
      value v ->
      valid_syntax (raiseLabel v hole)

  | Valid_raiseLabel5 : forall v1 v2,
      value v1 -> value v2 ->
      valid_syntax (raiseLabel v1 v2)

(* toLabeled e1 e2 *)
  | Valid_toLabeled1 : forall e1 e2,
      surface_syntax e1 = true ->
      assignment_free e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (toLabeled e1 e2)

  | Valid_toLabeled2 : forall e1,
      surface_syntax e1 = true ->
      assignment_free e1 = true ->
      valid_syntax (toLabeled e1 hole)

  | Valid_toLabeled3 : forall e,
      surface_syntax e = true  ->
      assignment_free e = true ->
      valid_syntax (toLabeled e hole)

  | Valid_toLabeled4 : forall v e,
      value v ->
      surface_syntax e = true  ->
      assignment_free e = true ->
      valid_syntax (toLabeled e v)

  (*get current context level *)
  | Valid_getCurrentLevel :
      valid_syntax getCurrentLevel

(* assignment *)
  | Valid_assignment1 : forall e x,
      surface_syntax e = true ->
      valid_syntax (Assignment x e)

  | Valid_assignment2 : forall x,
      valid_syntax (Assignment x hole)

  | Valid_assignment3 : forall v x,
      value v ->
      valid_syntax (Assignment x v)

(* Field Write *)
  | Valid_FieldWrite1 : forall e1 f  e2,
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (FieldWrite e1 f e2)

  | Valid_FieldWrite2 : forall v f  e2,
      value v ->
      surface_syntax e2 = true ->
      valid_syntax (FieldWrite v f e2)

  | Valid_FieldWrite3 : forall e2 f,
      surface_syntax e2 = true ->
      valid_syntax (FieldWrite hole f e2)

  | Valid_FieldWrite4 : forall v1 v2 f,
      value v1 ->
      value v2 ->
      valid_syntax (FieldWrite v1 f v2)

  | Valid_FieldWrite5 : forall v f,
      value v ->
      valid_syntax hole ->
      valid_syntax (FieldWrite v f hole)

(* if *)
  | Valid_if1 : forall guard e1 e2,

      surface_syntax guard = true  ->
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (If guard e1 e2)

  | Valid_if2 : forall e1 e2,
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (If hole e1 e2)

  | Valid_if3 : forall guard e1 e2,
      value guard  ->
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (If guard e1 e2)

(* sequence *)
  | Valid_sequence1 : forall e1 e2,
      surface_syntax e1 = true ->
      surface_syntax e2 = true ->
      valid_syntax (Sequence e1 e2)

  (* sequence2 *)
  | Valid_sequence2 : forall e2,
      surface_syntax e2 = true ->
      valid_syntax (Sequence hole e2)

  | Valid_sequence3 : forall v e2,
      surface_syntax e2 = true ->
      value v ->
      valid_syntax (Sequence v e2)

(* ObjId *)
  | Valid_ObjId : forall o,
      valid_syntax (ObjId o)
(* runtime labeled data *)
  | Valid_v_l : forall lb v,
      value v ->
      valid_syntax (v_l v lb)
(* runtime labeled data *)
  | Valid_v_opa_l : forall lb v,
      value v ->
      (forall v0 lb0, v <> v_opa_l v0 lb0) ->
      valid_syntax (v_opa_l v lb)
(* hole *)
  | Valid_hole :
      valid_syntax hole.
Hint Constructors valid_syntax.

Fixpoint hole_free (t : tm) :=
  match t with
    | Tvar x => true
    | null => true
    | EqCmp e1 e2 => if (hole_free e1) then (hole_free e2) else false
    | FieldAccess e f => (hole_free e)
    | MethodCall e1 meth e2 => if (hole_free e1) then (hole_free e2) else false
    | NewExp cls => true
    | B_true => true
    | B_false => true

(* label related *)
    | l lb => true
    | labelData e1 e2 =>  if (hole_free e1) then (hole_free e2) else false
    | unlabel e => (hole_free e)
    | labelOf e => (hole_free e)
    | objectLabelOf e => hole_free e
    | raiseLabel e1 e2  => if (hole_free e1) then (hole_free e2) else false
    | toLabeled e1 e2 => if (hole_free e1) then (hole_free e2) else false
    | getCurrentLevel => true

(* statements *)
    | Assignment x e => (hole_free e)
    | FieldWrite e1 f e2 =>  if (hole_free e1) then (hole_free e2) else false
    | If guard e1 e2 =>  if (hole_free guard) then ( if (hole_free e1) then (hole_free e2) else false ) else false
    | Sequence e1 e2 =>  if (hole_free e1) then (hole_free e2) else false

(* special terms *)
    | ObjId o =>  true
  (* runtime labeled date*)
    | v_l e lb => (hole_free e)
    | v_opa_l e lb => (hole_free e)
    | hole => false
  end.

Fixpoint runtime_label (t : tm) :=
  match t with
  | v_opa_l v lb => lb
  | _ => L_Label
  end.

Fixpoint runtime_val (t : tm) : tm  :=
  match t with
    | v_opa_l v lb =>  v
    | _ => t
  end.

Fixpoint object_label (t : tm)  (h : heap) : Label :=
  match t with
  | ObjId o => match (lookup_heap_obj h o) with
                | Some (Heap_OBJ cls F lo ll) => ll
                | None => L_Label
               end
  | _ => L_Label
  end.

Fixpoint label_label (t : tm)  (h : heap) : Label :=
  match t with
  | ObjId o => match (lookup_heap_obj h o) with
                | Some (Heap_OBJ cls F lo ll) => ll
                | None => L_Label
               end
  | _ => L_Label
  end.

Inductive reduction : config -> config -> Prop :=
(* variabel access *)
  | ST_var : forall id h lb sf v ctns ct fs,
      Some v = sf(id) ->
      Config ct (Container (Tvar id) fs lb sf) ctns h ==> Config ct (Container v fs lb sf) ctns h

(* eq comparison *)
  (* context rule 1 *)
  | ST_EqCmp1 : forall h e1 e2 ct fs ctns sf lb,
      ~ value e1 ->
      Config ct (Container (EqCmp e1 e2) fs lb sf) ctns h ==> Config ct (Container e1 ((EqCmp hole e2) :: fs) lb sf) ctns h

  | ST_EqCmp2 : forall h e2 ct fs v ctns sf lb,
      value v ->
      Config ct (Container v ((EqCmp hole e2) :: fs) lb sf) ctns h ==> Config ct (Container (EqCmp v e2) fs lb sf ) ctns h

  | ST_EqCmp3 : forall h v e2 ct fs ctns sf lb,
      value v ->
      ~ value e2 ->
      Config ct (Container (EqCmp v e2) fs lb sf) ctns h ==> Config ct (Container e2 ((EqCmp v hole) :: fs) lb sf) ctns h

  | ST_EqCmp4 : forall h ct fs v1 v2 ctns sf lb,
      value v1 ->
      value v2 ->
      Config ct (Container v2 ((EqCmp v1 hole) :: fs) lb sf) ctns h ==> Config ct (Container (EqCmp v1 v2) fs lb sf ) ctns h

  | ST_EqCmp_result : forall h ct fs v1 v2 ctns sf lb result l' lb' lb'',
      value v1 ->
      value v2 ->
      ((runtime_val v1) = (runtime_val v2) -> result = B_true) ->
      ( (runtime_val v1) <> (runtime_val v2) -> result = B_false) ->
      l' = join_label (runtime_label v1) (runtime_label v2) ->
      lb' = join_label l' lb ->
      lb'' = join_label lb' (join_label (object_label (runtime_val v1) h)
                                        (object_label (runtime_val v2) h)) ->

      Config ct (Container (EqCmp v1 v2) fs lb sf ) ctns h
      ==> Config ct (Container result fs lb'' sf) ctns h

(* field read *)
  (* context rule *)
  | ST_fieldRead1 : forall sf h e f ct fs ctns lb,
      ~ value e ->
      Config ct (Container (FieldAccess e f) fs lb sf) ctns h ==> Config ct (Container e ((FieldAccess hole f) :: fs) lb sf) ctns h
  | ST_fieldRead2 : forall sf h f ct fs v ctns lb,
      value v ->
      Config ct (Container v ((FieldAccess hole f) :: fs) lb sf) ctns h ==> Config ct (Container (FieldAccess v f) fs lb sf) ctns h

  (* normal field access *)
  | ST_fieldRead3 : forall h o fname lo lb cls F v l'  ct fs ctns sf ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      Some v = F(fname) ->
      l' = join_label lo lb ->
      Config ct (Container (FieldAccess (ObjId o) fname) fs lb sf) ctns h ==>
             Config ct (Container v nil (join_label l' ll) sf) ((Container (FieldAccess (ObjId o) fname) fs lb sf ) :: ctns) h

  (* field access with opaque obj *)
  | ST_fieldRead4 : forall h o fname lo lb cls F v l'  ct fs ctns sf ell ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      Some v = F(fname) ->
      l' = join_label (join_label lo lb) ell ->
      Config ct (Container (FieldAccess (v_opa_l (ObjId o) ell) fname) fs lb sf) ctns h ==>
             Config ct (Container v nil (join_label l' ll) sf) ((Container (FieldAccess (v_opa_l (ObjId o) ell) fname) fs lb sf ) :: ctns) h

  (* null pointer exception for field access *)
  | ST_fieldReadException : forall h f ct fs sf ctns lb,
      Config ct (Container (FieldAccess null f) fs lb sf) ctns h ==> Error_state

  (* null pointer exception opaque for field access *)
  | ST_fieldReadExceptionOpaque : forall h f ct fs sf ctns lb ell,
      Config ct (Container (FieldAccess (v_opa_l null ell) f) fs lb sf) ctns h ==> Error_state

(* method call *)
  (* context rule: evaluate object target *)
  | ST_MethodCall1 : forall h e e2 id ct fs ctns sf lb,
      ~ value e ->
      Config ct (Container (MethodCall e id e2) fs lb sf) ctns h ==> Config ct (Container e ((MethodCall hole id e2) :: fs) lb sf) ctns h

  | ST_MethodCall2 : forall h e2 id ct fs v ctns sf lb,
      value v ->
      Config ct (Container v ((MethodCall hole id e2) :: fs) lb sf) ctns h ==> Config ct (Container (MethodCall v id e2) fs lb sf ) ctns h

  | ST_MethodCall3 : forall h e2 id ct fs v ctns sf lb,
      value v ->
      v <> null ->
      ~ value e2 ->
      Config ct (Container (MethodCall v id e2) fs lb sf) ctns h ==>
             Config ct (Container e2 ((MethodCall v id hole) :: fs) lb sf) ctns h

  | ST_MethodCall4 : forall h id ct fs v1 v2 ctns sf lb,
      value v1 ->
      value v2 ->
      Config ct (Container v2 ((MethodCall v1 id hole) :: fs) lb sf) ctns h ==> Config ct (Container (MethodCall v1 id v2) fs lb sf ) ctns h

  (* normal method call *)
  | ST_MethodCall_normal : forall o h cls fields v lo sf  arg_id cls_a body meth returnT ct fs ctns lb sf' ll,
      Some (Heap_OBJ cls fields lo ll) = lookup_heap_obj h o ->
      Some (m_def returnT meth cls_a arg_id body) = find_method cls meth ->
      value v ->
      sf' = sf_update empty_stack_frame arg_id v ->
      Config ct (Container (MethodCall (ObjId o) meth v) fs lb sf ) ctns h
      ==> Config ct (Container body nil (join_label lb ll) sf' ) ((Container (MethodCall (ObjId o) meth v) fs lb sf ) :: ctns) h

  (* normal method call opaque obj *)
  | ST_MethodCall_normal_opaque_obj : forall o h cls fields v lo sf  arg_id cls_a body meth returnT ct fs ctns lb sf' ell lb' ll,
      Some (Heap_OBJ cls fields lo ll) = lookup_heap_obj h o ->
      Some (m_def returnT meth cls_a arg_id body) = find_method cls meth ->
      value v ->
      sf' = sf_update empty_stack_frame arg_id v ->
      lb' = join_label lb ell ->
      Config ct (Container (MethodCall (v_opa_l (ObjId o) ell) meth v) fs lb sf ) ctns h
             ==> Config ct (Container body nil (join_label lb' ll) sf' ) ((Container (MethodCall (v_opa_l (ObjId o) ell) meth v) fs lb sf ) :: ctns) h

  (* null pointer exception for method call *)
  | ST_MethodCallException : forall h v meth ct fs lb sf  ctns,
      Config ct (Container (MethodCall null meth v) fs lb sf ) ctns h ==> Error_state

  (* null pointer exception opaque for method call *)
  | ST_MethodCallExceptionOpaque : forall h v meth ct fs lb sf ell ctns,
      value v ->
      Config ct (Container (MethodCall  (v_opa_l null ell) meth v) fs lb sf ) ctns h ==> Error_state

(* new expression *)
  | ST_NewExp : forall h h' o lb cls_name field_defs method_defs cls F ct fs ctns sf ,
      ct cls_name = Some cls ->
      o = get_fresh_oid h ->
      cls = (class_def cls_name field_defs method_defs) ->
      F =  (init_field_map (find_fields cls) empty_field_map) ->
      h' = add_heap_obj h o (Heap_OBJ cls F lb lb) ->
      Config ct (Container (NewExp cls_name) fs lb sf ) ctns h ==> Config ct (Container (ObjId o) fs lb sf ) ctns h'

(* label data express *)
  (* context rule *)
  | ST_LabelData1 : forall h e1 ct fs lb sf ctns e2,
      ~ value e1 ->
      Config ct (Container (labelData e1 e2) fs lb sf) ctns h ==> Config ct (Container e1 ((labelData hole e2) :: fs) lb sf) ctns h
  | ST_LabelData2 : forall h ct fs v lb e2 ctns sf,
      value v ->
      Config ct (Container v ((labelData hole e2) :: fs) lb sf) ctns h ==> Config ct (Container (labelData v e2) fs lb sf) ctns h

 | ST_LabelData3 : forall h v ct fs lb sf ctns e2,
     value v ->
     ~ value e2 ->
     Config ct (Container (labelData v e2) fs lb sf) ctns h ==> Config ct (Container e2 ((labelData v hole) :: fs) lb sf) ctns h

 | ST_LabelData4 : forall h ct fs v1 lb v2 ctns sf,
     value v1 ->
     value v2 ->
      Config ct (Container v2 ((labelData v1 hole) :: fs) lb sf) ctns h ==> Config ct (Container (labelData v1 v2) fs lb sf) ctns h

  | ST_LabelData5 : forall h v ct fs lb lo sf ctns,
      value v ->
      flow_to lb lo = true ->
      Config ct (Container (labelData v (l lo)) fs lb sf) ctns h ==>  Config ct (Container (v_l v lo) fs lb sf) ctns h

  | ST_LabelData6 : forall h v ct fs lb lo sf ctns ell,
      value v ->
      flow_to (join_label lb ell) lo = true ->
      Config ct (Container (labelData v (v_opa_l (l lo) ell)) fs lb sf) ctns h ==>  Config ct (Container (v_l v lo) fs  (join_label lb ell) sf) ctns h

  | ST_LabelDataLeak : forall h v ct fs lb lo ctns sf,
      value v ->
      flow_to lb lo = false ->
      Config ct (Container (labelData v (l lo)) fs lb sf) ctns h ==>  Error_state

  | ST_LabelDataLeak_opa : forall h v ct fs lb lo ctns sf ell,
      value v ->
      flow_to (join_label lb ell) lo = false ->
      Config ct (Container (labelData v (v_opa_l (l lo) ell)) fs lb sf) ctns h ==>  Error_state

(* unlabel *)
  (* context rule *)
  | ST_unlabel1 : forall h e ct fs lb sf ctns,
      ~ value e ->
      Config ct (Container (unlabel e) fs lb sf) ctns h ==> Config ct (Container e ((unlabel hole) :: fs) lb sf) ctns h
  | ST_unlabel2 : forall h ct fs v lb ctns sf,
      value v ->
      Config ct (Container v ((unlabel hole) :: fs) lb sf) ctns h ==> Config ct (Container (unlabel v) fs lb sf) ctns h

  (* unlabel *)
  | ST_unlabel3 : forall v lb lo l' h ct fs ctns sf,
      l' = join_label lb lo ->
      value v ->
      Config ct (Container (unlabel (v_l v lo)) fs lb sf) ctns h ==> Config ct (Container v fs l' sf) ctns h

  (* unlabel opaque *)
  | ST_unlabel4 : forall v lb l' h ct fs ctns sf ell,
      l' = join_label lb ell ->
      value (v_opa_l v ell) ->
      Config ct (Container (unlabel (v_opa_l v ell)) fs lb sf) ctns h ==>
             Config ct (Container (unlabel v) fs l' sf) ctns h
  (* unlabel data exception *)
  | ST_unlabelDataException : forall h ct fs ctns sf lb,
      Config ct (Container (unlabel null) fs lb sf) ctns h ==> Error_state

(* Label of *)
  (* context rule *)
  | ST_labelof1 : forall h e ct fs lb sf ctns,
      ~ value e ->
      Config ct (Container (labelOf e) fs lb sf) ctns h ==> Config ct (Container e ((labelOf hole) :: fs) lb sf) ctns h
  | ST_labelof2 : forall h ct fs v lb ctns sf,
      value v ->
      Config ct (Container v ((labelOf hole) :: fs) lb sf) ctns h ==> Config ct (Container (labelOf v) fs lb sf) ctns h

  | ST_labelof3 : forall v lb lo h ct fs ctns sf,
      value v ->
      Config ct (Container (labelOf (v_l v lo)) fs lb sf) ctns h ==> Config ct (Container (l lo) fs lb sf) ctns h

  | ST_labelof4 : forall v lb h ct fs ctns sf ell l',
      value (v_opa_l v ell) ->
      l' = join_label lb ell ->
      Config ct (Container (labelOf (v_opa_l v ell)) fs lb sf) ctns h ==>
             Config ct (Container (labelOf v) fs l' sf) ctns h
  (* unlabel data exception *)
  | ST_labelOfDataException : forall h ct fs ctns sf lb,
      Config ct (Container (labelOf null) fs lb sf) ctns h ==> Error_state

(* objectLabelOf *)
  (* context rule *)
  | ST_objectlabelof1 : forall h e ct fs lb sf ctns,
      ~ value e ->
      Config ct (Container (objectLabelOf e) fs lb sf) ctns h ==> Config ct (Container e ((objectLabelOf hole) :: fs) lb sf) ctns h
  | ST_objectlabelof2 : forall h ct fs v lb ctns sf,
      value v ->
      Config ct (Container v ((objectLabelOf hole) :: fs) lb sf) ctns h ==> Config ct (Container (objectLabelOf v) fs lb sf) ctns h

  | ST_objectlabelof3 : forall h ct fs sf ctns cls F lb lo o ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      Config ct (Container (objectLabelOf (ObjId o)) fs lb sf) ctns h ==>  Config ct (Container (l lo) fs (join_label ll lb) sf) ctns h

  | ST_objectlabelof4 : forall h ct fs sf ctns cls F lb lo o l' ell ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      l' = join_label lb ell ->
      Config ct (Container (objectLabelOf (v_opa_l (ObjId o) ell)) fs lb sf) ctns h ==>  Config ct (Container (l lo) fs (join_label ll l') sf) ctns h

  (* objectlabelof exception *)
  | ST_objectlabelofException1 : forall h ct fs ctns sf lb,
      Config ct (Container (objectLabelOf null) fs lb sf) ctns h ==> Error_state
  | ST_objectlabelofException2 : forall h ct fs ctns sf lb ell,
      Config ct (Container (objectLabelOf (v_opa_l null ell)) fs lb sf) ctns h ==> Error_state

(* raise label of an object *)
  (* context rule *)
  | ST_raiseLabel1 : forall h e1 ct fs lb sf ctns e2,
      ~ value e1 ->
      Config ct (Container (raiseLabel e1 e2) fs lb sf) ctns h ==> Config ct (Container e1 ((raiseLabel hole e2) :: fs) lb sf) ctns h
  | ST_raiseLabel2 : forall h ct fs v lb e2 ctns sf,
      value v ->
      Config ct (Container v ((raiseLabel hole e2) :: fs) lb sf) ctns h ==> Config ct (Container (raiseLabel v e2) fs lb sf) ctns h

| ST_raiseLabel21 : forall h e2 v ct fs lb sf ctns,
      value v -> ~ value e2 ->
      Config ct (Container (raiseLabel v e2) fs lb sf) ctns h ==> Config ct (Container e2 ((raiseLabel v hole) :: fs) lb sf) ctns h
  | ST_raiseLabel22 : forall h ct fs v1 lb v2 ctns sf,
      value v1 -> value v2 ->
      Config ct (Container v2 ((raiseLabel v1 hole) :: fs) lb sf) ctns h ==> Config ct (Container (raiseLabel v1 v2) fs lb sf) ctns h

  | ST_raiseLabel3 : forall h ct fs sf ctns cls F lb lo lo' o h' ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      flow_to lb ll = true  ->
      flow_to lo lo' = true ->
      h' = update_heap_obj h o (Heap_OBJ cls F lo' ll) ->
      Config ct (Container (raiseLabel (ObjId o) (l lo')) fs lb sf) ctns h ==>  Config ct (Container (ObjId o) fs lb sf) ctns h'

  | ST_raiseLabel3_opa : forall h ct fs sf ctns cls F lb lo lo' o h' ll ell,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      flow_to (join_label lb ell) ll = true  ->
      flow_to lo lo' = true ->
      h' = update_heap_obj h o (Heap_OBJ cls F lo' ll) ->
      Config ct (Container (raiseLabel (ObjId o) (v_opa_l (l lo') ell)) fs lb sf) ctns h ==>  Config ct (Container (ObjId o) fs (join_label lb ell) sf) ctns h'

  | ST_raiseLabel4 : forall h ct fs sf ctns cls F lb lo lo' o h' ell ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      flow_to (join_label lb ell) ll = true  ->
      flow_to lo lo' = true ->
      h' = update_heap_obj h o (Heap_OBJ cls F lo' ll) ->
      Config ct (Container (raiseLabel (v_opa_l (ObjId o) ell) (l lo')) fs lb sf) ctns h ==>  Config ct (Container ((ObjId o)) fs lb sf) ctns h'

  | ST_raiseLabel4_opa : forall h ct fs sf ctns cls F lb lo lo' o h' ell ll ell',
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      flow_to (join_label (join_label lb ell) ell') ll = true  ->
      flow_to lo lo' = true ->
      h' = update_heap_obj h o (Heap_OBJ cls F lo' ll) ->
      Config ct (Container (raiseLabel (v_opa_l (ObjId o) ell) (v_opa_l (l lo') ell')) fs lb sf) ctns h ==>  Config ct (Container ((ObjId o)) fs lb sf) ctns h'

  (*  raise label  exception *)
  | ST_raiseLabelException1 : forall h lb ct fs lo ctns sf,
      value lo ->
      Config ct (Container (raiseLabel null lo) fs lb sf) ctns h ==> Error_state

  | ST_raiseLabelException4 : forall h lb ct fs lo ctns sf ell,
      value lo ->
      Config ct (Container (raiseLabel (v_opa_l null ell) lo) fs lb sf) ctns h ==> Error_state
  | ST_raiseLabelException2 : forall h lb ct fs o ctns sf lo' cls F lo ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      (flow_to lb ll = false \/
      flow_to lo lo' = false ) ->
      Config ct (Container (raiseLabel (ObjId o) (l lo')) fs lb sf) ctns h ==>  Error_state
  | ST_raiseLabelException3 : forall h lb ct fs o ctns sf lo' cls F lo ell ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      (flow_to (join_label lb ell) ll = false \/
      flow_to lo lo' = false ) ->
      Config ct (Container (raiseLabel (v_opa_l (ObjId o) ell) (l lo')) fs lb sf) ctns h ==>  Error_state
| ST_raiseLabelException2_opa : forall h lb ct fs o ctns sf lo' cls F lo ll ell,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      (flow_to (join_label lb ell) ll = false \/
      flow_to lo lo' = false ) ->
      Config ct (Container (raiseLabel (ObjId o) (v_opa_l (l lo') ell)) fs lb sf) ctns h ==>  Error_state
  | ST_raiseLabelException3_opa : forall h lb ct fs o ctns sf lo' cls F lo ell ll ell',
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      (flow_to (join_label (join_label lb ell) ell') ll = false \/
      flow_to lo lo' = false ) ->
      Config ct (Container (raiseLabel (v_opa_l (ObjId o) ell) (v_opa_l (l lo') ell')) fs lb sf) ctns h ==>  Error_state

  (* toLabeled  *)
  | ST_toLabeled1 : forall h e1 e2 ct fs lb sf ctns,
      ~ value e2 ->
      Config ct (Container (toLabeled e1 e2) fs lb sf) ctns h ==> Config ct (Container e2 ((toLabeled e1 hole) :: fs) lb sf) ctns h
  | ST_toLabeled2 : forall h e1 v ct fs lb sf ctns,
      value v ->
     Config ct (Container v ((toLabeled e1 hole) :: fs) lb sf) ctns h ==> Config ct (Container (toLabeled e1 v) fs lb sf) ctns h
  | ST_toLabeled3 : forall h e1 lo ct fs lb sf ctns,
      Config ct (Container (toLabeled e1 (l lo)) fs lb sf) ctns h
             ==> Config ct (Container e1 ((labelData hole (l lo))::nil) lb sf) ((Container (toLabeled e1 (l lo)) fs lb sf ) :: ctns) h
  | ST_toLabeled4 : forall h e1 ct fs lb sf ctns ell v,
      value (v_opa_l v ell) ->
      Config ct (Container (toLabeled e1 (v_opa_l v ell)) fs lb sf) ctns h
             ==> Config ct (Container (toLabeled e1 v) fs (join_label lb ell) sf) ctns h
  |  ST_toLabeledException : forall h ct fs ctns sf lb e,
      Config ct (Container (toLabeled e null) fs lb sf) ctns h ==> Error_state

  (*getCurrentLevel *)
  |  ST_getCurrentLevel : forall h ct fs ctns sf lb,
      Config ct (Container getCurrentLevel fs lb sf) ctns h ==>  Config ct (Container (l lb) fs lb sf) ctns h

(* assignment *)
  (* context rule *)
  | ST_assignment1 : forall h e ct fs lb sf ctns id,
      ~ value e ->
      Config ct (Container (Assignment id e) fs lb sf) ctns h ==> Config ct (Container e ((Assignment id hole) :: fs) lb sf) ctns h
  | ST_assignment2 : forall h ct fs v lb ctns sf id,
      value v ->
      Config ct (Container v ((Assignment id hole) :: fs) lb sf) ctns h ==> Config ct (Container (Assignment id v) fs lb sf) ctns h

  | ST_assignment3 : forall v lb h ct fs ctns sf sf' id,
      value v ->
      sf' = sf_update sf id v ->
      Config ct (Container (Assignment id v) fs lb sf) ctns h ==> Config ct (Container v fs lb sf') ctns h

(* Field Write *)
  (* context rule 1 *)
   | ST_fieldWrite1 : forall h e e2 f ct fs ctns sf lb,
      ~ value e ->
      Config ct (Container (FieldWrite e f e2) fs lb sf) ctns h ==> Config ct (Container e ((FieldWrite hole f e2) :: fs) lb sf) ctns h

  | ST_fieldWrite2 : forall h e2 f ct fs v ctns sf lb,
      value v ->
      Config ct (Container v ((FieldWrite hole f e2) :: fs) lb sf) ctns h ==> Config ct (Container (FieldWrite v f e2) fs lb sf ) ctns h

  (* context rule: evaluate arguments *)
  | ST_fieldWrite3 : forall h v e2 f ct fs ctns sf lb,
      value v -> ~ value e2 ->
      v <> null ->
      Config ct (Container (FieldWrite v f e2) fs lb sf ) ctns h==> Config ct (Container e2 ((FieldWrite v f hole) :: fs) lb sf) ctns h
  | ST_fieldWrite4 : forall h v1 v2 f ct fs lb sf ctns,
      value v2 ->
      value v1 ->
      Config ct (Container v2 ((FieldWrite v1 f hole) :: fs) lb sf ) ctns h ==> Config ct (Container (FieldWrite v1 f v2) fs lb sf ) ctns h

  (* normal field write *)
  | ST_fieldWrite_normal : forall o h h' f lo lb cls F F' v ct fs ctns sf ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      F' = fields_update F f (runtime_val v) ->
      flow_to (join_label (runtime_label v) lb) (join_label lo ll) = true ->
      h' = update_heap_obj h o (Heap_OBJ cls F' lo ll) ->
      value v ->
    Config ct (Container (FieldWrite (ObjId o) f v) fs lb sf ) ctns h
           ==> Config ct (Container v fs lb sf ) ctns h'

  (* normal field write opaque obj *)
  | ST_fieldWrite_normal_opa_obj : forall o h h' f lo lb cls F F' v ct fs ctns sf ell ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      F' = fields_update F f (runtime_val v) ->
      flow_to (join_label (join_label (runtime_label v) lb) ell) (join_label lo ll) = true ->
      h' = update_heap_obj h o (Heap_OBJ cls F' lo ll) ->
      value v ->
    Config ct (Container (FieldWrite (v_opa_l (ObjId o) ell) f v) fs lb sf ) ctns h
           ==> Config ct (Container v fs lb sf ) ctns h'

  (* normal field information leak *)
  | ST_fieldWrite_leak1 : forall o h f lo lb cls F v ct fs ctns sf ll,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      flow_to (join_label (runtime_label v) lb) (join_label lo ll) = false ->
      value v ->
    Config ct (Container (FieldWrite (ObjId o) f v) fs lb sf ) ctns h
           ==>  Error_state

  | ST_fieldWrite_leak2 : forall o h f lo lb cls F v ct fs ctns sf ll ell,
      Some (Heap_OBJ cls F lo ll) = lookup_heap_obj h o ->
      flow_to (join_label (join_label (runtime_label v) lb) ell) (join_label lo ll) = false ->
      value v ->
    Config ct (Container (FieldWrite (v_opa_l (ObjId o) ell) f v) fs lb sf ) ctns h
           ==>  Error_state

  (* null pointer exception for field write *)
  | ST_FieldWrite_Exception : forall h v f ct fs lb sf  ctns,
      Config ct (Container (FieldWrite null f v) fs lb sf ) ctns h ==> Error_state

 (* null pointer exception opaque *)
  | ST_FieldWrite_ExceptionOpaque : forall h v f ct fs lb sf ell  ctns,
      value v ->
      Config ct (Container (FieldWrite (v_opa_l null ell) f v) fs lb sf ) ctns h ==> Error_state

  (* if statement *)
  | ST_if_guard : forall s1 s2 h lb guard ct fs ctns sf,
       ~ value guard ->
       Config ct (Container (If guard s1 s2) fs lb sf) ctns h ==> Config ct (Container guard ((If hole s1 s2) :: fs) lb sf) ctns h

  | ST_if_guard_return : forall s1 s2 h lb guard ct fs ctns sf,
       (value guard) ->
       Config ct (Container guard ((If hole s1 s2) :: fs) lb sf) ctns h ==>
              Config ct (Container (If guard s1 s2)  fs lb sf) ctns h
  | ST_if_guard_opa : forall s1 s2 h lb guard ct fs ctns sf ell,
       (value (v_opa_l guard ell)) ->
        Config ct (Container (If (v_opa_l guard ell) s1 s2) fs lb sf) ctns h ==>
           Config ct (Container (If guard s1 s2) fs (join_label lb ell) sf) ctns h
  | ST_if_b1 : forall s1 s2 h lb ct fs ctns sf,
       Config ct (Container (If B_true s1 s2) fs lb sf) ctns h ==> Config ct (Container s1 fs lb sf) ctns h
  | ST_if_b2 : forall s1 s2 h lb ct fs ctns sf,
      Config ct (Container (If B_false s1 s2) fs lb sf) ctns h ==> Config ct (Container s2 fs lb sf) ctns h
  | ST_if_exception : forall s1 s2 h lb ct fs ctns sf,
       Config ct (Container (If null s1 s2) fs lb sf) ctns h ==> Error_state
(* sequence *)
   (* context rule *)
  | ST_seq1 : forall h e1 e2 ct fs ctns lb sf,
      ~ value e1 ->
      Config ct (Container (Sequence e1 e2) fs lb sf) ctns h ==> Config ct (Container e1 ((Sequence hole e2) :: fs) lb sf) ctns h

  | ST_seq2 : forall h v e2 ct fs ctns lb sf,
      value v ->
      Config ct (Container v ((Sequence hole e2) :: fs) lb sf) ctns h ==> Config ct (Container (Sequence v e2)  fs lb sf) ctns h

  | ST_seq3 : forall h v e2 ct fs ctns lb sf,
      value v ->
    Config ct (Container  (Sequence v e2) fs lb sf) ctns h ==> Config ct (Container e2 fs lb sf) ctns h

  | ST_val_return_obj : forall h ct ctns sf lb' sf' fs' v lb e,
      (*ctn must have return_hole*)
      value v ->
      (forall v0 ell, value v0 -> v <> (v_opa_l v0 ell))  ->
    Config ct (Container v nil lb sf) ((Container e fs' lb' sf') :: ctns) h
           ==> Config ct (Container (v_opa_l v lb) fs' lb' sf') ctns h

  | ST_val_return_obj_ell : forall h ct ctns sf lb lb' sf' fs' ell v e,
    (*ctn must have return_hole*)
    Config ct (Container (v_opa_l v ell) nil lb sf) ((Container e fs' lb' sf') :: ctns) h
           ==> Config ct (Container (v_opa_l v (join_label ell lb)) fs' lb' sf') ctns h

where "c '==>' c'" := (reduction c c').
Hint Constructors reduction.

Hint Constructors valid_syntax.

Definition compare_oid (o1 : oid) (o2 : oid) :=
  match o1, o2 with
      | OID n1, OID n2 => if (gt_dec n1  n2) then true else false
  end.

Inductive wfe_heap : Class_table -> heap -> Prop :=
  | empty_heap_wfe : forall ct,
        wfe_heap ct  nil
  | heap_wfe : forall h h' o cls_def F ct cn ho lo method_defs field_defs ll,
        h' = (o , ho) :: h ->
        (h = nil \/ (exists o' ho' h'', h = (o' , ho') :: h'' /\ compare_oid o o' = true) ) ->
        wfe_heap ct h ->
        ho = (Heap_OBJ cls_def F lo ll) ->
        Some cls_def  = ct cn ->
        cls_def = class_def cn field_defs method_defs ->
        wfe_heap ct h'.

Inductive field_wfe_heap : Class_table -> heap -> Prop :=
  | heap_wfe_fields : forall h ct,
        (forall o cls_def F cls_name lo method_defs field_defs ll,
        lookup_heap_obj  h o = Some (Heap_OBJ cls_def F lo ll) ->
        Some cls_def  = ct cls_name ->
        cls_def = class_def cls_name field_defs method_defs ->
        (forall f cls', type_of_field field_defs f = Some cls' ->
                exists v, F(f) = Some v
                 /\ (v= null  \/
                          ( exists o' F' lx field_defs0 method_defs0 llx, v = ObjId o'
                                  /\ lookup_heap_obj  h o' = Some (Heap_OBJ (class_def cls' field_defs0 method_defs0) F' lx llx)
                                    /\ ct cls' = Some (class_def cls' field_defs0 method_defs0)
                          ) )
        ))->
        field_wfe_heap ct h.

Inductive wfe_stack_val : Class_table -> heap -> tm -> Prop :=
| stack_val_null : forall ct h,
    wfe_stack_val ct h null
| stack_val_object : forall ct h  o cls_name F lo field_defs method_defs ll,
      lookup_heap_obj h o =
      Some (Heap_OBJ (class_def cls_name field_defs method_defs) F lo ll) ->
      (ct cls_name = Some (class_def cls_name field_defs method_defs)) ->
      wfe_stack_val ct h (ObjId o)
| stack_val_labeled : forall ct h  v lb,
    wfe_stack_val ct h v ->
    wfe_stack_val ct h (v_l v lb)
| stack_val_opa_labeled : forall ct h  v lb,
    wfe_stack_val ct h v ->
    wfe_stack_val ct h (v_opa_l v lb)
| stack_val_label : forall ct h lb,
    wfe_stack_val ct h (l lb)
| stack_val_true : forall ct h,
    wfe_stack_val ct h (B_true)
| stack_val_false : forall ct h,
    wfe_stack_val ct h (B_false)
.
Hint Constructors wfe_stack_val.

(* be careful with this *)
Inductive wfe_stack_frame : Class_table -> heap -> stack_frame -> Prop :=
  | stack_frame_wfe : forall h sf ct,
      (forall x v,
          sf x = Some v  ->
          value v /\
          wfe_stack_val ct h v
      ) ->
        wfe_stack_frame ct h sf.
Hint Constructors wfe_stack_frame.

Inductive terminal_state : config -> Prop :=
  | Terminal_value : forall h v ct lb sf,
    value v ->
    terminal_state ( Config ct (Container v nil lb sf) nil h).

Hint Constructors terminal_state.
Hint Constructors value.

Hint Constructors reduction.
Hint Constructors container.

Inductive valid_fs : list tm -> Prop :=
  | valid_fs_nil : valid_fs nil
  | valid_fs_list : forall t fs,
      valid_syntax t ->
      (* all continuations have holes *)
      hole_free t = false ->
      valid_fs fs ->
      t <> hole ->
      valid_fs (t :: fs).
Hint Constructors valid_fs.

Inductive valid_ctn : Class_table ->container -> heap -> Prop:=
  | valid_container : forall t fs lb sf h ct,
     valid_fs fs ->
     valid_syntax t ->
     (forall fs', fs <> hole :: fs') ->
     wfe_stack_frame ct h sf ->
     valid_ctn ct (Container t fs lb sf) h.
Hint Constructors valid_ctn.

Inductive valid_ctns : Class_table ->  list container -> heap ->  Prop:=
| valid_ctns_nil : forall ct h,
    valid_ctns ct nil h
| valid_ctns_list : forall ct ctn ctns h,
    valid_ctn ct ctn h->
    valid_ctns ct ctns h ->
    valid_ctns ct (ctn :: ctns) h.
Hint Constructors valid_ctns.

Inductive valid_config : config -> Prop :=
  | valid_conf : forall ct t fs lb sf ctns h,
    valid_ctns ct ctns h ->
    valid_ctn ct (Container t fs lb sf) h ->
    hole_free t = true ->
    wfe_heap ct h -> field_wfe_heap ct h ->
    (*wfe_stack_frame CT h sf ->*)
    valid_config (Config ct (Container t fs lb sf) ctns h).
Hint Constructors valid_config.

Inductive multi_step_reduction : config -> config -> Prop :=
  | multi_reduction_refl : forall config , multi_step_reduction config config
  | multi_reduction_step : forall c1 c2 c3,
                    reduction c1 c2 ->
                    multi_step_reduction c2 c3 ->
                    multi_step_reduction c1 c3.

Notation "c1 '==>*' c2" := (multi_step_reduction c1 c2) (at level 40).