theory Blexer
  imports "Lexer"
begin

section \<open>Bit-Encodings\<close>

datatype bit = Z | S

fun code :: "val \<Rightarrow> bit list"
where
  "code Void = []"
| "code (Char c) = []"
| "code (Left v) = Z # (code v)"
| "code (Right v) = S # (code v)"
| "code (Seq v1 v2) = (code v1) @ (code v2)"
| "code (Stars []) = [S]"
| "code (Stars (v # vs)) =  (Z # code v) @ code (Stars vs)"

fun sz where
  "sz ZERO = 0"
| "sz ONE = 0"
| "sz (CH _) = 0"
| "sz (SEQ r1 r2) = 1 + sz r1 + sz r2"
| "sz (ALT r1 r2) = 1 + sz r1 + sz r2"
| "sz (STAR r) = 1 + sz r"
| "sz (NTIMES r n) = 1 + (n + 1) + sz r"

fun
  Stars_add :: "val \<Rightarrow> val \<Rightarrow> val"
where
  "Stars_add v (Stars vs) = Stars (v # vs)"

function (sequential)
  decode' :: "bit list \<Rightarrow> rexp \<Rightarrow> (val * bit list)"
where
  "decode' bs ZERO = (undefined, bs)"
| "decode' bs ONE = (Void, bs)"
| "decode' bs (CH d) = (Char d, bs)"
| "decode' [] (ALT r1 r2) = (Void, [])"
| "decode' (Z # bs) (ALT r1 r2) = (let (v, bs') = decode' bs r1 in (Left v, bs'))"
| "decode' (S # bs) (ALT r1 r2) = (let (v, bs') = decode' bs r2 in (Right v, bs'))"
| "decode' bs (SEQ r1 r2) = (let (v1, bs') = decode' bs r1 in
                             let (v2, bs'') = decode' bs' r2 in (Seq v1 v2, bs''))"
| "decode' [] (STAR r) = (Void, [])"
| "decode' (S # bs) (STAR r) = (Stars [], bs)"
| "decode' (Z # bs) (STAR r) = (let (v, bs') = decode' bs r in
                                    let (vs, bs'') = decode' bs' (STAR r)
                                    in (Stars_add v vs, bs''))"
| "decode' bs (NTIMES r n) = decode' bs (STAR r)"
by pat_completeness auto

lemma decode'_smaller:
  assumes "decode'_dom (bs, r)"
  shows "length (snd (decode' bs r)) \<le> length bs"
using assms
apply(induct bs r)
apply(auto simp add: decode'.psimps split: prod.split)
using dual_order.trans apply blast
apply (meson dual_order.trans le_SucI)
  done

termination "decode'"
apply(relation "inv_image (measure(%cs. sz cs) <*lex*> measure(%s. size s)) (%(ds,r). (r,ds))")
apply(auto dest!: decode'_smaller)
   apply (metis less_Suc_eq_le snd_conv)
  done

definition
  decode :: "bit list \<Rightarrow> rexp \<Rightarrow> val option"
where
  "decode ds r \<equiv> (let (v, ds') = decode' ds r
                  in (if ds' = [] then Some v else None))"

lemma decode'_code_Stars:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> (\<forall>x. decode' (code v @ x) r = (v, x)) \<and> flat v \<noteq> []"
  shows "decode' (code (Stars vs) @ ds) (STAR r) = (Stars vs, ds)"
  using assms
  apply(induct vs)
  apply(auto)
  done

lemma decode'_code_NTIMES:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> (\<forall>x. decode' (code v @ x) r = (v, x))"
  shows "decode' (code (Stars vs) @ ds) (NTIMES r n) = (Stars vs, ds)"
  using assms
  apply(induct vs arbitrary: n r ds)
   apply(auto)
  done

lemma decode'_code:
  assumes "\<Turnstile> v : r"
  shows "decode' ((code v) @ ds) r = (v, ds)"
using assms
  apply(induct v r arbitrary: ds rule: Prf.induct)
  apply(auto)[6]
  using decode'_code_Stars apply blast
  apply(rule decode'_code_NTIMES)
  apply(simp)
  apply(auto)
  done

lemma decode_code:
  assumes "\<Turnstile> v : r"
  shows "decode (code v) r = Some v"
  using assms unfolding decode_def
  by (smt append_Nil2 decode'_code old.prod.case)

section {* Annotated Regular Expressions *}

datatype arexp =
  AZERO
| AONE "bit list"
| ACHAR "bit list" char
| ASEQ "bit list" arexp arexp
| AALTs "bit list" "arexp list"
| ASTAR "bit list" arexp
| ANTIMES "bit list" arexp nat

abbreviation
  "AALT bs r1 r2 \<equiv> AALTs bs [r1, r2]"

fun asize :: "arexp \<Rightarrow> nat" where
  "asize AZERO = 1"
| "asize (AONE cs) = 1"
| "asize (ACHAR cs c) = 1"
| "asize (AALTs cs rs) = Suc (sum_list (map asize rs))"
| "asize (ASEQ cs r1 r2) = Suc (asize r1 + asize r2)"
| "asize (ASTAR cs r) = Suc (asize r)"
| "asize (ANTIMES cs r n) = Suc (asize r) + n"

fun az2 :: "arexp \<Rightarrow> nat" where
  "az2 AZERO = 1"
| "az2 (AONE cs) = 1"
| "az2 (ACHAR cs c) = 1"
| "az2 (AALTs cs rs) = Suc (sum_list (map az2 rs))"
| "az2 (ASEQ cs r1 r2) = Suc (az2 r1 + az2 r2)"
| "az2 (ASTAR cs r) = Suc (az2 r)"
| "az2 (ANTIMES cs r n) = Suc (az2 r) + n + 1"

fun
  erase :: "arexp \<Rightarrow> rexp"
where
  "erase AZERO = ZERO"
| "erase (AONE _) = ONE"
| "erase (ACHAR _ c) = CH c"
| "erase (AALTs _ []) = ZERO"
| "erase (AALTs _ [r]) = (erase r)"
| "erase (AALTs bs (r#rs)) = ALT (erase r) (erase (AALTs bs rs))"
| "erase (ASEQ _ r1 r2) = SEQ (erase r1) (erase r2)"
| "erase (ASTAR _ r) = STAR (erase r)"
| "erase (ANTIMES _ r n) = NTIMES (erase r) n"

fun fuse :: "bit list \<Rightarrow> arexp \<Rightarrow> arexp" where
  "fuse bs AZERO = AZERO"
| "fuse bs (AONE cs) = AONE (bs @ cs)"
| "fuse bs (ACHAR cs c) = ACHAR (bs @ cs) c"
| "fuse bs (AALTs cs rs) = AALTs (bs @ cs) rs"
| "fuse bs (ASEQ cs r1 r2) = ASEQ (bs @ cs) r1 r2"
| "fuse bs (ASTAR cs r) = ASTAR (bs @ cs) r"
| "fuse bs (ANTIMES cs r n) = ANTIMES (bs @ cs) r n"

lemma fuse_append:
  shows "fuse (bs1 @ bs2) r = fuse bs1 (fuse bs2 r)"
  apply(induct r)
  apply(auto)
  done

fun intern :: "rexp \<Rightarrow> arexp" where
  "intern ZERO = AZERO"
| "intern ONE = AONE []"
| "intern (CH c) = ACHAR [] c"
| "intern (ALT r1 r2) = AALT [] (fuse [Z] (intern r1))
                                (fuse [S]  (intern r2))"
| "intern (SEQ r1 r2) = ASEQ [] (intern r1) (intern r2)"
| "intern (STAR r) = ASTAR [] (intern r)"
| "intern (NTIMES r n) = ANTIMES [] (intern r) n"

function (sequential) retrieve  :: "arexp \<Rightarrow> val \<Rightarrow> bit list" where
  "retrieve (AONE bs) Void = bs"
| "retrieve (ACHAR bs c) (Char d) = bs"
| "retrieve (AALTs bs [r]) v = bs @ retrieve r v"
| "retrieve (AALTs bs (r#rs)) (Left v) = bs @ retrieve r v"
| "retrieve (AALTs bs (r#rs)) (Right v) = bs @ retrieve (AALTs [] rs) v"
| "retrieve (ASEQ bs r1 r2) (Seq v1 v2) = bs @ retrieve r1 v1 @ retrieve r2 v2"

| "retrieve (ASTAR bs r) (Stars []) = bs @ [S]"
| "retrieve (ASTAR bs r) (Stars (v#vs)) = bs @ [Z] @ retrieve r v @ retrieve (ASTAR [] r) (Stars vs)"

| "retrieve (ANTIMES bs r n) (Stars vs) = retrieve (ASTAR bs r) (Stars vs)"
| "retrieve _ _ = undefined"
     apply(pat_completeness)
apply(auto)
done

termination "retrieve"
apply(relation "inv_image (measure(%cs. size cs) <*lex*> measure(%s. az2 s)) (%(ds,r). (r,ds))")
  apply(auto)
done

fun
 bnullable :: "arexp \<Rightarrow> bool"
where
  "bnullable (AZERO) = False"
| "bnullable (AONE bs) = True"
| "bnullable (ACHAR bs c) = False"
| "bnullable (AALTs bs rs) = (\<exists>r \<in> set rs. bnullable r)"
| "bnullable (ASEQ bs r1 r2) = (bnullable r1 \<and> bnullable r2)"
| "bnullable (ASTAR bs r) = True"
| "bnullable (ANTIMES bs r n) = (if n  = 0 then True else bnullable r)"

abbreviation
  bnullables :: "arexp list \<Rightarrow> bool"
where
  "bnullables rs \<equiv> (\<exists>r \<in> set rs. bnullable r)"

function (sequential)
  bmkeps :: "arexp \<Rightarrow> bit list"
where
  "bmkeps(AONE bs) = bs"
| "bmkeps(ASEQ bs r1 r2) = bs @ (bmkeps r1) @ (bmkeps r2)"
| "bmkeps(AALTs bs (r#rs)) =
    (if bnullable(r) then (bs @ bmkeps r) else (bmkeps (AALTs bs rs)))"
| "bmkeps(ASTAR bs r) = bs @ [S]"
| "bmkeps(ANTIMES bs r n) =
    (if n = 0 then bs @ [S] else bs @ [Z] @ (bmkeps r) @ bmkeps(ANTIMES [] r (n - 1)))"
apply(pat_completeness)
apply(auto)
done

termination "bmkeps"
apply(relation "measure asize")
        apply(auto)
  using asize.elims by force

fun
   bmkepss :: "arexp list \<Rightarrow> bit list"
where
  "bmkepss (r # rs) = (if bnullable(r) then (bmkeps r) else (bmkepss rs))"

lemma bmkepss1:
  assumes "\<not> bnullables rs1"
  shows "bmkepss (rs1 @ rs2) = bmkepss rs2"
  using assms
  by(induct rs1) (auto)

lemma bmkepss2:
  assumes "bnullables rs1"
  shows "bmkepss (rs1 @ rs2) = bmkepss rs1"
  using assms
  by (induct rs1) (auto)

fun
 bder :: "char \<Rightarrow> arexp \<Rightarrow> arexp"
where
  "bder c (AZERO) = AZERO"
| "bder c (AONE bs) = AZERO"
| "bder c (ACHAR bs d) = (if c = d then AONE bs else AZERO)"
| "bder c (AALTs bs rs) = AALTs bs (map (bder c) rs)"
| "bder c (ASEQ bs r1 r2) =
     (if bnullable r1
      then AALT bs (ASEQ [] (bder c r1) r2) (fuse (bmkeps r1) (bder c r2))
      else ASEQ bs (bder c r1) r2)"
| "bder c (ASTAR bs r) = ASEQ (bs @ [Z]) (bder c r) (ASTAR [] r)"
| "bder c (ANTIMES bs r n) = (if n = 0 then AZERO else ASEQ (bs @ [Z]) (bder c r) (ANTIMES [] r (n - 1)))"

fun
  bders :: "arexp \<Rightarrow> string \<Rightarrow> arexp"
where
  "bders r [] = r"
| "bders r (c#s) = bders (bder c r) s"

lemma bders_append:
  "bders c (s1 @ s2) = bders (bders c s1) s2"
  apply(induct s1 arbitrary: c s2)
  apply(simp_all)
  done

lemma bnullable_correctness:
  shows "nullable (erase r) = bnullable r"
  apply(induct r rule: erase.induct)
  apply(simp_all)
  done

lemma erase_fuse:
  shows "erase (fuse bs r) = erase r"
  apply(induct r rule: erase.induct)
  apply(simp_all)
  done

lemma erase_intern [simp]:
  shows "erase (intern r) = r"
  apply(induct r)
  apply(simp_all add: erase_fuse)
  done

lemma erase_bder [simp]:
  shows "erase (bder a r) = der a (erase r)"
  apply(induct r rule: erase.induct)
  apply(simp_all add: erase_fuse bnullable_correctness)
  done

lemma erase_bders [simp]:
  shows "erase (bders r s) = ders s (erase r)"
  apply(induct s arbitrary: r )
  apply(simp_all)
  done

lemma bnullable_fuse:
  shows "bnullable (fuse bs r) = bnullable r"
  apply(induct r arbitrary: bs)
  apply(auto)
  done

lemma retrieve_encode_STARS:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> code v = retrieve (intern r) v"
  shows "code (Stars vs) = retrieve (ASTAR [] (intern r)) (Stars vs)"
  using assms
  apply(induct vs)
  apply(simp_all)
  done

lemma retrieve_encode_NTIMES:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> code v = retrieve (intern r) v"
  shows "code (Stars vs) = retrieve (ANTIMES [] (intern r) n) (Stars vs)"
  using assms
  using retrieve.simps(9) retrieve_encode_STARS by presburger

lemma retrieve_fuse2:
  assumes "\<Turnstile> v : (erase r)"
  shows "retrieve (fuse bs r) v = bs @ retrieve r v"
  using assms
  apply(induct r arbitrary: v bs)
  apply(auto elim: Prf_elims)[4]
  apply(case_tac x2a)
  apply(simp)
  using Prf_elims(1) apply blast
  apply(case_tac x2a)
  apply(simp)
  apply(simp)
  apply(case_tac list)
  apply(simp)
  apply(simp)
  apply (smt (verit, best) Prf_elims(3) append_assoc retrieve.simps(4) retrieve.simps(5))
  apply(simp)
  using retrieve_encode_STARS
  apply(auto elim!: Prf_elims)[1]
  apply(case_tac vs)
  apply(simp)
   apply(simp)
  (* NTIMES *)
  apply(auto elim!: Prf_elims)[1]
  apply(case_tac vs1)
   apply(simp_all)
  apply(case_tac vs2)
    apply(simp_all)
  done

lemma retrieve_fuse:
  assumes "\<Turnstile> v : r"
  shows "retrieve (fuse bs (intern r)) v = bs @ retrieve (intern r) v"
  using assms
  by (simp_all add: retrieve_fuse2)

lemma retrieve_code:
  assumes "\<Turnstile> v : r"
  shows "code v = retrieve (intern r) v"
  using assms
  apply(induct v r )
        apply(simp_all add: retrieve_fuse retrieve_encode_STARS)
  apply(subst retrieve_encode_NTIMES)
   apply(auto)
  done

lemma retrieve_AALTs_bnullable1:
  assumes "bnullable r"
  shows "retrieve (AALTs bs (r # rs)) (mkeps (erase (AALTs bs (r # rs))))
         = bs @ retrieve r (mkeps (erase r))"
  using assms
  apply(case_tac rs)
  apply(auto simp add: bnullable_correctness)
  done

lemma retrieve_AALTs_bnullable2:
  assumes "\<not>bnullable r" "bnullables rs"
  shows "retrieve (AALTs bs (r # rs)) (mkeps (erase (AALTs bs (r # rs))))
         = retrieve (AALTs bs rs) (mkeps (erase (AALTs bs rs)))"
  using assms
  apply(induct rs arbitrary: r bs)
  apply(auto)
  using bnullable_correctness apply blast
  apply(case_tac rs)
  apply(auto)
  using bnullable_correctness apply blast
  apply(case_tac rs)
  apply(auto)
  done

lemma bmkeps_retrieve_AALTs:
  assumes "\<forall>r \<in> set rs. bnullable r \<longrightarrow> bmkeps r = retrieve r (mkeps (erase r))"
          "bnullables rs"
  shows "bs @ bmkepss rs = retrieve (AALTs bs rs) (mkeps (erase (AALTs bs rs)))"
 using assms
  apply(induct rs arbitrary: bs)
  apply(auto)
  using retrieve_AALTs_bnullable1 apply presburger
  apply (metis retrieve_AALTs_bnullable2)
  apply (simp add: retrieve_AALTs_bnullable1)
  by (metis retrieve_AALTs_bnullable2)

lemma bmkeps_retrieve_ANTIMES:
  assumes "if n = 0 then True else bmkeps r = retrieve r (mkeps (erase r))"
  and     "bnullable (ANTIMES bs r n)"
  shows "bmkeps (ANTIMES bs r n) = retrieve (ANTIMES bs r n) (Stars (replicate n (mkeps (erase r))))"
 using assms
  apply(induct n arbitrary: r bs)
  apply(auto)[1]
  apply(simp)
  done

lemma bmkeps_retrieve:
  assumes "bnullable r"
  shows "bmkeps r = retrieve r (mkeps (erase r))"
  using assms
  apply(induct r rule: bmkeps.induct)
        apply(auto)
  apply (simp add: retrieve_AALTs_bnullable1)
  using retrieve_AALTs_bnullable1 apply force
    apply(metis retrieve_AALTs_bnullable2)
  apply (metis Cons_eq_appendI One_nat_def Suc_diff_1 append_Nil replicate_Suc retrieve.simps(8))
  done

lemma bder_retrieve:
  assumes "\<Turnstile> v : der c (erase r)"
  shows "retrieve (bder c r) v = retrieve r (injval (erase r) c v)"
  using assms
  apply(induct r arbitrary: v rule: erase.induct)
  using Prf_elims(1) apply auto[1]
  using Prf_elims(1) apply auto[1]
  apply(auto)[1]
  apply (metis Prf_elims(4) injval.simps(1) retrieve.simps(1) retrieve.simps(2))
  using Prf_elims(1) apply blast
  (* AALTs case *)
  apply(simp)
  apply simp
  apply(simp)
  defer
  (* ASEQ case *)
  apply(simp)
  apply(case_tac "nullable (erase r1)")
  apply(simp)
  apply(erule Prf_elims)
  using Prf_elims(2) bnullable_correctness apply force
  apply (simp add: bmkeps_retrieve bnullable_correctness retrieve_fuse2)
  apply (simp add: bmkeps_retrieve bnullable_correctness retrieve_fuse2)
  using Prf_elims(2) apply force
  (* ASTAR case *)
  apply(rename_tac bs r v)
  apply(simp)
  apply(erule Prf_elims)
  apply(clarify)
  apply(erule Prf_elims)
  apply(clarify)
   apply (simp add: retrieve_fuse2)
  (* ANTIMES case *)
  apply(simp)
  apply(auto)
  apply(erule Prf_elims)
  apply(erule Prf_elims)
  apply(clarify)
  apply(erule Prf_elims)
  apply(clarify)
  apply simp

  (* AALTS *)
  apply(rename_tac "r\<^sub>1" "r\<^sub>2" rs v)
   apply(erule Prf_elims)
   apply(simp)
  apply(simp)
  apply(case_tac rs)
  apply(simp)
  apply(simp)
  using Prf_elims(3) apply fastforce
  done

lemma MAIN_decode:
  assumes "\<Turnstile> v : ders s r"
  shows "Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r"
  using assms
proof (induct s arbitrary: v rule: rev_induct)
  case Nil
  have "\<Turnstile> v : ders [] r" by fact
  then have "\<Turnstile> v : r" by simp
  then have "Some v = decode (retrieve (intern r) v) r"
    using decode_code retrieve_code by auto
  then show "Some (flex r id [] v) = decode (retrieve (bders (intern r) []) v) r"
    by simp
next
  case (snoc c s v)
  have IH: "\<And>v. \<Turnstile> v : ders s r \<Longrightarrow>
     Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r" by fact
  have asm: "\<Turnstile> v : ders (s @ [c]) r" by fact
  then have asm2: "\<Turnstile> injval (ders s r) c v : ders s r"
    by (simp add: Prf_injval ders_append)
  have "Some (flex r id (s @ [c]) v) = Some (flex r id s (injval (ders s r) c v))"
    by (simp add: flex_append)
  also have "... = decode (retrieve (bders (intern r) s) (injval (ders s r) c v)) r"
    using asm2 IH by simp
  also have "... = decode (retrieve (bder c (bders (intern r) s)) v) r"
    using asm by (simp_all add: bder_retrieve ders_append)
  finally show "Some (flex r id (s @ [c]) v) =
                 decode (retrieve (bders (intern r) (s @ [c])) v) r" by (simp add: bders_append)
qed

definition blexer where
 "blexer r s \<equiv> if bnullable (bders (intern r) s) then
                decode (bmkeps (bders (intern r) s)) r else None"

lemma blexer_correctness:
  shows "blexer r s = lexer r s"
proof -
  { define bds where "bds \<equiv> bders (intern r) s"
    define ds  where "ds \<equiv> ders s r"
    assume asm: "nullable ds"
    have era: "erase bds = ds"
      unfolding ds_def bds_def by simp
    have mke: "\<Turnstile> mkeps ds : ds"
      using asm by (simp add: mkeps_nullable)
    have "decode (bmkeps bds) r = decode (retrieve bds (mkeps ds)) r"
      using bmkeps_retrieve
      using asm era
      using bnullable_correctness by force
    also have "... =  Some (flex r id s (mkeps ds))"
      using mke by (simp_all add: MAIN_decode ds_def bds_def)
    finally have "decode (bmkeps bds) r = Some (flex r id s (mkeps ds))"
      unfolding bds_def ds_def .
  }
  then show "blexer r s = lexer r s"
    unfolding blexer_def lexer_flex
    by (auto simp add: bnullable_correctness[symmetric])
qed

unused_thms

end


theory examples
imports Main   "quantum_hoare_logic" "lt"
begin
(*
lemma grover:  "valid I
               (((Init 2 0;Init 2 1;Init 2 2;Init 4 3;
               Utrans Delta 2;Utrans H 0;Utrans H 1;Utrans H 2);
              While M0 M1 (Utrans Or (10);Utrans H 0;Utrans H 1;Utrans Ph 10;
         Utrans H 0; Utrans H 1) Q);
           Cond [(N0,SKIP,P),(N1,SKIP,P),(N2,SKIP,P),(N3,SKIP,P)] )
               P"
apply(rule_tac Q="wlp P (Cond [(N0,SKIP,P),(N1,SKIP,P),(N2,SKIP,P),(N3,SKIP,P)]) " in Seq)
prefer 2
apply(rule_tac Q="mat_add (uu M0 (wlp P (Cond [(N0, SKIP, P), (N1, SKIP, P), (N2, SKIP, P), (N3, SKIP, P)]))) (uu M1 Q)"in Seq)
prefer 2
apply simp
apply vcg
prefer 5
apply simp
apply quantum_oracle
prefer 6
apply(rule While)
prefer 4
apply(rule ord_wlp1,auto)
apply quantum_oracle+
apply (metis fst_eqD fsts.cases snd_eqD snds.cases wellDefined.simps(1))+
apply vcg
prefer 5
apply(simp add:zero_add)
apply quantum_oracle+
done*)
(*
lemma shor:"valid P  (Init 2 0;Utrans H 0;Utrans U 1;Utrans (dag U) 1;Utrans (dag H) 0;
                    Cond [(M0,SKIP,Q),(M1,SKIP,Q)])   Q"
apply(rule ord_wlp,auto)
apply quantum_oracle+
apply (metis fst_conv fsts.cases snd_conv snds.cases wellDefined.simps(1))
apply (metis fst_conv fsts.cases snd_conv snds.cases wellDefined.simps(1))
apply quantum_oracle
done*)
end


subsection \<open>Data-flow Tree Theorems\<close>

theory IRTreeEvalThms
  imports
    Graph.ValueThms
    IRTreeEval
begin

subsubsection \<open>Deterministic Data-flow Evaluation\<close>

lemma evalDet:
  "[m,p] \<turnstile> e \<mapsto> v\<^sub>1 \<Longrightarrow>
   [m,p] \<turnstile> e \<mapsto> v\<^sub>2 \<Longrightarrow>
   v\<^sub>1 = v\<^sub>2"
  apply (induction arbitrary: v\<^sub>2 rule: "evaltree.induct")
  by (elim EvalTreeE; auto)+

lemma evalAllDet:
  "[m,p] \<turnstile> e \<mapsto>\<^sub>L v1 \<Longrightarrow>
   [m,p] \<turnstile> e \<mapsto>\<^sub>L v2 \<Longrightarrow>
   v1 = v2"
  apply (induction arbitrary: v2 rule: "evaltrees.induct")
   apply (elim EvalTreeE; auto)
  using evalDet by force

subsubsection \<open>Typing Properties for Integer Evaluation Functions\<close>

text \<open>We use three simple typing properties on integer values:
   $is_IntVal32, is_IntVal64$ and the more general $is_IntVal$.\<close>

lemma unary_eval_not_obj_ref:
  shows "unary_eval op x \<noteq> ObjRef v"
  by (cases op; cases x; auto)

lemma unary_eval_not_obj_str:
  shows "unary_eval op x \<noteq> ObjStr v"
  by (cases op; cases x; auto)

(* declare [[show_types = true]] *)

(* TODO: try proving some results about int_[un]signed_value? *)
(* TODO
lemma negative_iff_top_bit:
  fixes v :: "'a :: len word"
  assumes "b < LENGTH('a)"
  shows "(signed_take_bit b v <s 0) = bit v b"
  using signed_take_bit_negative_iff apply transfer

lemma signed_eq_unsigned:
  assumes "int_signed_value b v \<ge> 0"
  shows "int_signed_value b v = int_unsigned_value b v"
proof -
  thm signed_take_bit_negative_iff

  have "\<not> bit v b"
    using assms int_signed_value.simps
*)

(* Note: this will need qualifying once we have non-integer unary ops. *)
lemma unary_eval_int:
  assumes def: "unary_eval op x \<noteq> UndefVal"
  shows "is_IntVal (unary_eval op x)"
  unfolding is_IntVal_def using def
  apply (cases "unary_eval op x"; auto)
  using unary_eval_not_obj_ref unary_eval_not_obj_str by simp+

lemma bin_eval_int:
  assumes def: "bin_eval op x y \<noteq> UndefVal"
  shows "is_IntVal (bin_eval op x y)"
  apply (cases op; cases x; cases y)  (* 192 cases! *)
  unfolding is_IntVal_def using def apply auto (* leaves 14 cases*)
                 apply presburger+ (* prove 6 more easy cases *)
           apply (meson bool_to_val.elims)
          apply (meson bool_to_val.elims)
         apply (smt (verit) new_int.simps)+
  by (meson bool_to_val.elims)+

lemma IntVal0:
  "(IntVal 32 0) = (new_int 32 0)"
  unfolding new_int.simps
  by auto

lemma IntVal1:
  "(IntVal 32 1) = (new_int 32 1)"
  unfolding new_int.simps
  by auto

(* ICK, a collection of relevant take_bit_x lemmas would help *)
lemma bin_eval_new_int:
  assumes def: "bin_eval op x y \<noteq> UndefVal"
  shows "\<exists>b v. (bin_eval op x y) = new_int b v \<and>
               b = (if op \<in> binary_fixed_32_ops then 32 else intval_bits x)"
  apply (cases op; cases x; cases y)
  unfolding is_IntVal_def using def apply auto
  apply presburger+
  apply (metis take_bit_and)
  apply presburger
  apply (metis take_bit_or)
  apply presburger
  apply (metis take_bit_xor)
  apply presburger
  using IntVal0 IntVal1
  apply (metis bool_to_val.elims new_int.simps)
  apply presburger
  apply (smt (verit) new_int.elims)
  apply (smt (verit, best) new_int.elims)
  apply (metis IntVal0 IntVal1 bool_to_val.elims new_int.simps)
  apply presburger
  apply (metis IntVal0 IntVal1 bool_to_val.elims new_int.simps)
  apply presburger
  apply (metis IntVal0 IntVal1 bool_to_val.elims new_int.simps)
  by meson

lemma int_stamp:
  assumes i: "is_IntVal v"
  shows "is_IntegerStamp (constantAsStamp v)"
  using i unfolding is_IntegerStamp_def is_IntVal_def by auto

lemma validStampIntConst:
  assumes "v = IntVal b ival"
  assumes "0 < b \<and> b \<le> 64"
  shows "valid_stamp (constantAsStamp v)"
proof -
  have bnds: "fst (bit_bounds b) \<le> int_signed_value b ival \<and> int_signed_value b ival \<le> snd (bit_bounds b)"
    using assms int_signed_value_bounds
    by presburger
  have s: "constantAsStamp v = IntegerStamp b (int_signed_value b ival) (int_signed_value b ival)"
    using assms(1) constantAsStamp.simps(1) by blast
  then show ?thesis
    unfolding s valid_stamp.simps
    using assms(2) assms bnds by linarith
qed

lemma validDefIntConst:
  assumes v: "v = IntVal b ival"
  assumes "0 < b \<and> b \<le> 64"
  assumes "take_bit b ival = ival"
  shows "valid_value v (constantAsStamp v)"
proof -
  have bnds: "fst (bit_bounds b) \<le> int_signed_value b ival \<and> int_signed_value b ival \<le> snd (bit_bounds b)"
    using assms int_signed_value_bounds
    by presburger
  have s: "constantAsStamp v = IntegerStamp b (int_signed_value b ival) (int_signed_value b ival)"
    using assms(1) constantAsStamp.simps(1) by blast
  then show ?thesis
    unfolding s unfolding v unfolding valid_value.simps
    using assms validStampIntConst
    by simp
qed

(* is it useful to have a new_int version of the above?
lemma validIntConst:
  assumes i: "v = new_int b ival"
  assumes "0 < b \<and> b \<le> 64"
  shows "valid_value v (constantAsStamp v)"
proof -
  have bnds: "fst (bit_bounds b) \<le> int_signed_value b ival \<and> int_signed_value b ival \<le> snd (bit_bounds b)"
    using assms int_signed_value_bounds
    by presburger
  have s: "constantAsStamp v = IntegerStamp b (int_signed_value b ival) (int_signed_value b ival)"
    using assms new_int.simps constantAsStamp.simps
  then show ?thesis
  using i new_int.simps validDefIntConst
*)

subsubsection \<open>Evaluation Results are Valid\<close>

text \<open>A valid value cannot be $UndefVal$.\<close>
lemma valid_not_undef:
  assumes a1: "valid_value val s"
  assumes a2: "s \<noteq> VoidStamp"
  shows "val \<noteq> UndefVal"
  apply (rule valid_value.elims(1)[of val s True])
  using a1 a2 by auto

(* Elimination rules for valid_value, for each kind of stamp. *)
lemma valid_VoidStamp[elim]:
  shows "valid_value val VoidStamp \<Longrightarrow>
      val = UndefVal"
  using valid_value.simps by metis

lemma valid_ObjStamp[elim]:
  shows "valid_value val (ObjectStamp klass exact nonNull alwaysNull) \<Longrightarrow>
      (\<exists>v. val = ObjRef v)"
  using valid_value.simps by (metis val_to_bool.cases)

lemma valid_int[elim]:
  shows "valid_value val (IntegerStamp b lo hi) \<Longrightarrow>
      (\<exists>v. val = IntVal b v)"
  using valid_value.elims(2) by fastforce

lemmas valid_value_elims =
  valid_VoidStamp
  valid_ObjStamp
  valid_int

lemma evaltree_not_undef:
  fixes m p e v
  shows "([m,p] \<turnstile> e \<mapsto> v) \<Longrightarrow> v \<noteq> UndefVal"
  apply (induction rule: "evaltree.induct")
  using valid_not_undef wf_value_def by auto

lemma leafint:
  assumes ev: "[m,p] \<turnstile> LeafExpr i (IntegerStamp b lo hi) \<mapsto> val"
  shows "\<exists>b v. val = (IntVal b v)"
(* Note: we could also add: ...\<and> lo \<le> sint v \<and> sint v \<le> hi *)
proof -
  have "valid_value val (IntegerStamp b lo hi)"
    using ev by (rule LeafExprE; simp)
  then show ?thesis by auto
qed

lemma default_stamp [simp]: "default_stamp = IntegerStamp 32 (-2147483648) 2147483647"
  using default_stamp_def by auto

lemma valid_value_signed_int_range [simp]:
  assumes "valid_value val (IntegerStamp b lo hi)"
  assumes "lo < 0"
  shows "\<exists>v. (val = IntVal b v \<and>
             lo \<le> int_signed_value b v \<and>
             int_signed_value b v \<le> hi)"
  using assms valid_int
  by (metis valid_value.simps(1))

(* If we want to support unsigned values:
lemma valid_value_unsigned_int_range [simp]:
  assumes "valid_value val (IntegerStamp b lo hi)"
  assumes "0 \<le> lo"
  shows "\<exists>v. (val = IntVal b v \<and>
             lo \<le> int_unsigned_value b v \<and>
             int_unsigned_value b v \<le> hi)"
  using assms valid_int
  by fastforce
*)

subsubsection \<open>Example Data-flow Optimisations\<close>

(* TODO: need to know that valid_values fit within b bits!
   This requires that the bounds also fit within b bits!
lemma valid_value_fits:
  assumes "valid_value (IntVal b v) (IntegerStamp b lo hi)"
  assumes "0 \<le> lo"
  shows "take_bit b v = v"
  using assms valid_value_unsigned_int_range
*)

(* An example refinement: a + 0 = a *)
(*
lemma a0a_helper [simp]:
  assumes a: "valid_value v (IntegerStamp b lo hi)"
  shows "intval_add v (IntVal b 0) = v"
proof -
  obtain v64 :: int64 where "v = (IntVal b v64)" using a valid_int by blast
  then have "v64+0=v64" by simp
  then have "intval_add (IntVal b v64) (IntVal b 0) = IntVal b (take_bit b v64)"
    by auto
  then show ?thesis
qed

lemma a0a: "(BinaryExpr BinAdd (LeafExpr 1 default_stamp) (ConstantExpr (IntVal32 0)))
              \<ge> (LeafExpr 1 default_stamp)"
  by (auto simp add: evaltree.LeafExpr)
*)

(* Another example refinement: x + (y - x) \<ge> y *)
(* TODO:
lemma xyx_y_helper [simp]:
  assumes "valid_value x (IntegerStamp 32 lox hix)"
  assumes "valid_value y (IntegerStamp 32 loy hiy)"
  shows "intval_add x (intval_sub y x) = y"
proof -
  obtain x32 :: int32 where x: "x = (IntVal32 x32)" using assms valid32 by blast
  obtain y32 :: int32 where y: "y = (IntVal32 y32)" using assms valid32 by blast
  show ?thesis using x y by simp
qed

lemma xyx_y:
  "(BinaryExpr BinAdd
     (LeafExpr x (IntegerStamp 32 lox hix))
     (BinaryExpr BinSub
       (LeafExpr y (IntegerStamp 32 loy hiy))
       (LeafExpr x (IntegerStamp 32 lox hix))))
   \<ge> (LeafExpr y (IntegerStamp 32 loy hiy))"
  by (auto simp add: LeafExpr)
*)

subsubsection \<open>Monotonicity of Expression Refinement\<close>

text \<open>We prove that each subexpression position is monotonic.
That is, optimizing a subexpression anywhere deep inside a top-level expression
also optimizes that top-level expression.

Note that we might also be able to do
this via reusing Isabelle's $mono$ operator (HOL.Orderings theory), proving instantiations
like $mono (UnaryExpr op)$, but it is not obvious how to do this for both arguments
of the binary expressions.\<close>

lemma mono_unary:
  assumes "x \<ge> x'"
  shows "(UnaryExpr op x) \<ge> (UnaryExpr op x')"
  using UnaryExpr assms by auto

lemma mono_binary:
  assumes "x \<ge> x'"
  assumes "y \<ge> y'"
  shows "(BinaryExpr op x y) \<ge> (BinaryExpr op x' y')"
  using BinaryExpr assms by auto

lemma never_void:
  assumes "[m, p] \<turnstile> x \<mapsto> xv"
  assumes "valid_value xv (stamp_expr xe)"
  shows "stamp_expr xe \<noteq> VoidStamp"
  using valid_value.simps
  using assms(2) by force

(* These were trivially true, due to operator precedence errors.
lemma stamp32:
  "\<exists>v . ((xv = IntVal32 v) \<longleftrightarrow> valid_value xv (IntegerStamp 32 lo hi))"
  using valid_int32
  by (metis (full_types) Value.inject(1) zero_neq_one)

lemma stamp64:
  "\<exists>v . xv = IntVal64 v \<longleftrightarrow> valid_value xv (IntegerStamp 64 lo hi)"
  using valid_int64
  by (metis (full_types) Value.inject(2) zero_neq_one)
*)

(* This lemma is no longer true once we allow some non-integer values.
lemma stamprange:
  "valid_value v s \<longrightarrow> (\<exists>b lo hi. (s = IntegerStamp b lo hi) \<and> (b=8 \<or> b=16 \<or> b=32 \<or> b=64))"
  using valid_value.elims
*)

lemma compatible_trans:
  "compatible x y \<and> compatible y z \<Longrightarrow> compatible x z"
  by (cases x; cases y; cases z; simp del: valid_stamp.simps)

lemma compatible_refl:
  "compatible x y \<Longrightarrow> compatible y x"
  using compatible.elims(2) by fastforce

(*
lemma tmp:
  assumes "[m, p] \<turnstile> xe \<mapsto> xv"
  shows "valid_value xv (stamp_expr xe)"
  sorry (* proved later *)

lemma helping:
  assumes "[m, p] \<turnstile> xe \<mapsto> xv"
  assumes "\<forall>m p v. ([m,p] \<turnstile> xe \<mapsto> v) \<longrightarrow> [m,p] \<turnstile> ye \<mapsto> v"
  shows "compatible (stamp_expr xe) (stamp_expr ye)"
proof -
  have "[m, p] \<turnstile> ye \<mapsto> xv"
    using assms(1,2)
    by blast
  then have "valid_value xv (stamp_expr ye)"
    using tmp by simp
  then show ?thesis using stamprange
      apply (cases "\<exists>v. xv = IntVal32 v")
    using assms(2) valid_value.elims(2)
    using assms(1) tmp apply fastforce
    by (smt (verit, del_insts) assms(1) compatible.simps(1) tmp valid_value.elims(2))
qed
*)

lemma mono_conditional:
  assumes "c \<ge> c'"
  assumes "t \<ge> t'"
  assumes "f \<ge> f'"
  shows "(ConditionalExpr c t f) \<ge> (ConditionalExpr c' t' f')"
proof (simp only: le_expr_def; (rule allI)+; rule impI)
  fix m p v
  assume a: "[m,p] \<turnstile> ConditionalExpr c t f \<mapsto> v"
  then obtain cond where c: "[m,p] \<turnstile> c \<mapsto> cond" by auto
  then have c': "[m,p] \<turnstile> c' \<mapsto> cond" using assms by auto
  (*have co: "compatible (stamp_expr t) (stamp_expr f)"
    using a by auto*)
  define branch  where b:  "branch  = (if val_to_bool cond then t else f)"
  define branch' where b': "branch' = (if val_to_bool cond then t' else f')"
  then have beval: "[m,p] \<turnstile> branch \<mapsto> v" using a b c evalDet by blast
  (*then have "compatible (stamp_expr branch) (stamp_expr branch')"
      using helping
      using assms(2) assms(3) b b' by force
  then have compatible: "compatible (stamp_expr te') (stamp_expr fe')"
    using compatible_trans co compatible_refl
    proof (cases "val_to_bool cond")
      case True
      then have "branch = te"
        using b by simp
      from True have "branch' = te'"
        using b' by simp
      then have "compatible (stamp_expr te) (stamp_expr te')"
        using \<open>branch = te\<close> \<open>compatible (stamp_expr branch) (stamp_expr branch')\<close> by blast
      then have "compatible (stamp_expr fe) (stamp_expr fe')"
        using co compatible_trans compatible_refl sorry
      then show ?thesis
        using \<open>compatible (stamp_expr te) (stamp_expr te')\<close> co compatible_refl compatible_trans by blast
    next
      case False
      then show ?thesis sorry
    qed*)
  from beval have "[m,p] \<turnstile> branch' \<mapsto> v" using assms b b' by auto
  then show "[m,p] \<turnstile> ConditionalExpr c' t' f' \<mapsto> v"
    using ConditionalExpr c' b'
    by (simp add: evaltree_not_undef)
qed

(*
Step 3: if e1 isrefby e2 then g[e1] isREFby g[e2]
   Note: This needs to go after IRStepObj.thy.

lemma graph_refined:
  assumes "e1 \<ge> e2"
  assumes "g \<triangleleft> e1 \<leadsto> (g1, x1)"
  assumes "g \<triangleleft> e2 \<leadsto> (g2, x2)"
  shows "\<forall> m m' h h'. (g \<turnstile> (x1, m, h) \<rightarrow> (nid, m', h'))
                  \<longrightarrow> (g \<turnstile> (x2, m, h) \<rightarrow> (nid, m', h'))"
*)

subsection \<open>Unfolding rules for evaltree quadruples down to bin-eval level\<close>

text \<open>These rewrite rules can be useful when proving optimizations.
  They support top-down rewriting of each level of the tree into the
  lower-level $bin_eval$ / $unary_eval$ level, simply by saying
  $unfolding unfold_evaltree$.\<close>

(* TODO:
lemma unfold_valid32 [simp]:
  "valid_value y (constantAsStamp (IntVal b v)) = (y = IntVal b v)"
  by (induction y; auto dest: signed_word_eqI)

lemma unfold_valid64 [simp]:
  "valid_value y (constantAsStamp (IntVal64 v)) = (y = IntVal64 v)"
  by (induction y; auto dest: signed_word_eqI)
*)

(* the general case, for all constants *)
lemma unfold_const:
  shows "([m,p] \<turnstile> ConstantExpr c \<mapsto> v) = (wf_value v \<and> v = c)"
  by blast

(* TODO:
corollary unfold_const32:
  shows "([m,p] \<turnstile> ConstantExpr (IntVal 32 c) \<mapsto> v) = (v = IntVal 32 c)"
  using unfold_valid32 by blast

corollary unfold_const64:
  shows "([m,p] \<turnstile> ConstantExpr (IntVal64 c) \<mapsto> v) = (v = IntVal64 c)"
  using unfold_valid64 by blast
*)

lemma unfold_binary:
  shows "([m,p] \<turnstile> BinaryExpr op xe ye \<mapsto> val) = (\<exists> x y.
          (([m,p] \<turnstile> xe \<mapsto> x) \<and>
           ([m,p] \<turnstile> ye \<mapsto> y) \<and>
           (val = bin_eval op x y) \<and>
           (val \<noteq> UndefVal)
        ))" (is "?L = ?R")  (* (\<exists> x y. (?R1 \<and> ?R2 \<and> ?R3))" *)
proof (intro iffI)
  assume 3: ?L
  show ?R by (rule evaltree.cases[OF 3]; blast+)
next
  assume ?R
  then obtain x y where "[m,p] \<turnstile> xe \<mapsto> x"
        and "[m,p] \<turnstile> ye \<mapsto> y"
        and "val = bin_eval op x y"
        and "val \<noteq> UndefVal"
    by auto
  then show ?L
     by (rule BinaryExpr)
 qed

lemma unfold_unary:
  shows "([m,p] \<turnstile> UnaryExpr op xe \<mapsto> val)
         = (\<exists> x.
             (([m,p] \<turnstile> xe \<mapsto> x) \<and>
              (val = unary_eval op x) \<and>
              (val \<noteq> UndefVal)
             ))" (is "?L = ?R")
  by auto

(* TODO: conditional *)

lemmas unfold_evaltree =
  unfold_binary
  unfold_unary
(*
  unfold_const32
  unfold_const64
  unfold_valid32
  unfold_valid64
*)

(* we could add this more general rule too, for completeness:
  unfold_const
  but we want the more specific unfold_const32/64 rules to have priority.
  This does not seem possible with 'lemmas' - order is ignored.
*)

subsection \<open>Lemmas about $new\_int$ and integer eval results.\<close>

lemma unary_eval_new_int:
  assumes def: "unary_eval op x \<noteq> UndefVal"
  shows "\<exists>b v. unary_eval op x = new_int b v \<and>
               b = (if op \<in> normal_unary then intval_bits x else ir_resultBits op)"
proof (cases "op \<in> normal_unary")
  case True
  then show ?thesis
    by (metis def empty_iff insert_iff intval_abs.elims intval_bits.simps intval_logic_negation.elims intval_negate.elims intval_not.elims unary_eval.simps(1) unary_eval.simps(2) unary_eval.simps(3) unary_eval.simps(4))
next
  case False
  consider ib ob where "op = UnaryNarrow ib ob" |
           ib ob where "op = UnaryZeroExtend ib ob" |
           ib ob where "op = UnarySignExtend ib ob"
    by (metis False IRUnaryOp.exhaust insert_iff)
  then show ?thesis
  proof (cases)
    case 1
    then show ?thesis
      by (metis False IRUnaryOp.sel(4) def intval_narrow.elims unary_eval.simps(5))
  next
    case 2
    then show ?thesis
      by (metis False IRUnaryOp.sel(6) def intval_zero_extend.elims unary_eval.simps(7))
  next
    case 3
    then show ?thesis
      by (metis False IRUnaryOp.sel(5) def intval_sign_extend.elims unary_eval.simps(6))
  qed
qed

lemma new_int_unused_bits_zero:
  assumes "IntVal b ival = new_int b ival0"
  shows "take_bit b ival = ival"
  using assms(1) new_int_take_bits by blast

lemma unary_eval_unused_bits_zero:
  assumes "unary_eval op x = IntVal b ival"
  shows "take_bit b ival = ival"
  using assms unary_eval_new_int
  by (metis Value.inject(1) Value.simps(5) new_int.elims new_int_unused_bits_zero)

lemma bin_eval_unused_bits_zero:
  assumes "bin_eval op x y = (IntVal b ival)"
  shows "take_bit b ival = ival"
  using assms bin_eval_new_int
  by (metis Value.distinct(1) Value.inject(1) new_int.elims new_int_take_bits)

lemma eval_unused_bits_zero:
  "[m,p] \<turnstile> xe \<mapsto> (IntVal b ix) \<Longrightarrow> take_bit b ix = ix"
proof (induction xe)
  case (UnaryExpr x1 xe)
  then show ?case
    using unary_eval_unused_bits_zero by force
next
  case (BinaryExpr x1 xe1 xe2)
  then show ?case
    using bin_eval_unused_bits_zero by force
next
  case (ConditionalExpr xe1 xe2 xe3)
  then show ?case
    by (metis (full_types) EvalTreeE(3))
next
  case (ParameterExpr i s)
  then have "valid_value (p!i) s"
    by fastforce
  then show ?case
    by (metis ParameterExprE Value.distinct(7) intval_bits.simps intval_word.simps local.ParameterExpr valid_value.elims(2))
next
  case (LeafExpr x1 x2)
  then show ?case
    by (smt (z3) EvalTreeE(6) Value.simps(11) valid_value.elims(1) valid_value.simps(1))
next
  case (ConstantExpr x)
  then show ?case using wf_value_def
    by (metis EvalTreeE(1) constantAsStamp.simps(1) valid_value.simps(1))
next
  case (ConstantVar x)
  then show ?case
    by fastforce
next
  case (VariableExpr x1 x2)
  then show ?case
    by fastforce
qed

lemma unary_normal_bitsize:
  assumes "unary_eval op x = IntVal b ival"
  assumes "op \<in> normal_unary"
  shows "\<exists> ix. x = IntVal b ix"
  apply (cases op)
        prefer 7 using assms apply blast
       prefer 6 using assms apply blast
      prefer 5 using assms apply blast
  using Value.distinct(1) Value.sel(1) assms(1) new_int.simps unary_eval.simps
      intval_abs.elims intval_negate.elims intval_not.elims intval_logic_negation.elims
     apply metis+
  done

lemma unary_not_normal_bitsize:
  assumes "unary_eval op x = IntVal b ival"
  assumes "op \<notin> normal_unary"
  shows "b = ir_resultBits op \<and> 0 < b \<and> b \<le> 64"
  apply (cases op)
  using assms apply blast+  (* the normal_unary cases *)
  apply (metis IRUnaryOp.sel(4) Value.distinct(1) Value.sel(1) assms(1) intval_narrow.elims intval_narrow_ok new_int.simps unary_eval.simps(5))
   apply (smt (verit) IRUnaryOp.sel(5) Value.distinct(1) Value.sel(1) assms(1) intval_sign_extend.elims new_int.simps order_less_le_trans unary_eval.simps(6))
  apply (metis IRUnaryOp.sel(6) Value.distinct(1) assms(1) intval_bits.simps intval_zero_extend.elims linorder_not_less neq0_conv new_int.simps unary_eval.simps(7))
  done

lemma unary_eval_bitsize:
  assumes "unary_eval op x = IntVal b ival"
  assumes 2: "x = IntVal bx ix"
  assumes "0 < bx \<and> bx \<le> 64"
  shows "0 < b \<and> b \<le> 64"
proof (cases "op \<in> normal_unary")
  case True
  then obtain tmp where "unary_eval op x = new_int bx tmp"
    by (cases op; simp; auto simp: 2)
  then show ?thesis
    using assms by simp
next
  case False
  then obtain tmp where "unary_eval op x = new_int b tmp \<and> 0 < b \<and> b \<le> 64"
    apply (cases op; simp; auto simp: 2)
    apply (metis "2" Value.inject(1) Value.simps(5) assms(1) intval_narrow.simps(1) intval_narrow_ok new_int.simps unary_eval.simps(5))
    apply (metis "2" Value.distinct(1) Value.inject(1) assms(1) bot_nat_0.not_eq_extremum diff_is_0_eq intval_sign_extend.elims new_int.simps unary_eval.simps(6) zero_less_diff)
    by (smt (verit, del_insts) "2" Value.simps(5) assms(1) intval_bits.simps intval_zero_extend.simps(1) new_int.simps order_less_le_trans unary_eval.simps(7))
  then show ?thesis
    by blast
qed

(*
lemma unary2:
  assumes "[m,p] \<turnstile> xe \<mapsto> IntVal b ix \<Longrightarrow> 0 < b \<and> b \<le> 64"
  assumes "[m,p] \<turnstile> UnaryExpr op xe \<mapsto> IntVal b ix"
  shows "0 < b \<and> b \<le> 64"
*)

lemma bin_eval_inputs_are_ints:
  assumes "bin_eval op x y = IntVal b ix"
  obtains xb yb xi yi where "x = IntVal xb xi \<and> y = IntVal yb yi"
proof -
  have "bin_eval op x y \<noteq> UndefVal"
    by (simp add: assms)
  then show ?thesis
    using assms apply (cases op; cases x; cases y; simp)
    using that by blast+
qed

lemma eval_bits_1_64:
  "[m,p] \<turnstile> xe \<mapsto> (IntVal b ix) \<Longrightarrow> 0 < b \<and> b \<le> 64"
proof (induction xe arbitrary: "b" "ix")
  case (UnaryExpr op x2)
  then obtain xv where
       xv: "([m,p] \<turnstile> x2 \<mapsto> xv) \<and>
            IntVal b ix = unary_eval op xv"
    using unfold_binary by auto
  then have "b = (if op \<in> normal_unary then intval_bits xv else ir_resultBits op)"
    using unary_eval_new_int
    by (metis Value.disc(1) Value.discI(1) Value.sel(1) new_int.simps)
  then show ?case
    by (metis xv UnaryExpr.IH unary_normal_bitsize unary_not_normal_bitsize)
next
  case (BinaryExpr op x y)
  then obtain xv yv where
       xy: "([m,p] \<turnstile> x \<mapsto> xv) \<and>
            ([m,p] \<turnstile> y \<mapsto> yv) \<and>
            IntVal b ix = bin_eval op xv yv"
    using unfold_binary by auto
  then have def: "bin_eval op xv yv \<noteq> UndefVal" and xv: "xv \<noteq> UndefVal" and "yv \<noteq> UndefVal"
    using evaltree_not_undef xy by (force, blast, blast)
  then have "b = (if op \<in> binary_fixed_32_ops then 32 else intval_bits xv)"
    by (metis xy intval_bits.simps new_int.simps bin_eval_new_int)
  then show ?case
    by (metis BinaryExpr.IH(1) Value.distinct(7) Value.distinct(9) xv bin_eval_inputs_are_ints intval_bits.elims le_add_same_cancel1 less_or_eq_imp_le numeral_Bit0 xy zero_less_numeral)
next
  case (ConditionalExpr xe1 xe2 xe3)
  then show ?case
    by (metis (full_types) EvalTreeE(3))
next
  case (ParameterExpr x1 x2)
  then show ?case
    using ParameterExprE intval_bits.simps valid_stamp.simps(1) valid_value.elims(2) valid_value.simps(17)
    by (metis (no_types, lifting))
next
  case (LeafExpr x1 x2)
  then show ?case
    by (smt (z3) EvalTreeE(6) Value.distinct(7) Value.inject(1) valid_stamp.simps(1) valid_value.elims(1))
next
  case (ConstantExpr x)
  then show ?case using wf_value_def
    by (metis EvalTreeE(1) constantAsStamp.simps(1) valid_stamp.simps(1) valid_value.simps(1))
next
  case (ConstantVar x)
  then show ?case
    by blast
next
  case (VariableExpr x1 x2)
  then show ?case
    by blast
qed

lemma unfold_binary_width:
  assumes "op \<notin> binary_fixed_32_ops \<and> op \<notin> binary_shift_ops"
  shows "([m,p] \<turnstile> BinaryExpr op xe ye \<mapsto> IntVal b val) = (\<exists> x y.
          (([m,p] \<turnstile> xe \<mapsto> IntVal b x) \<and>
           ([m,p] \<turnstile> ye \<mapsto> IntVal b y) \<and>
           (IntVal b val = bin_eval op (IntVal b x) (IntVal b y)) \<and>
           (IntVal b val \<noteq> UndefVal)
        ))" (is "?L = ?R")
proof (intro iffI)
  assume 3: ?L
  show ?R apply (rule evaltree.cases[OF 3])
         apply force+ apply auto[1]
    using assms apply (cases op; auto)
          apply (smt (verit) intval_add.elims Value.inject(1))
    using intval_mul.elims Value.inject(1)
         apply (smt (verit) new_int.simps new_int_bin.simps)
    using intval_sub.elims Value.inject(1)
        apply (smt (verit) new_int.simps new_int_bin.simps)
    using intval_and.elims Value.inject(1)
       apply (smt (verit) new_int.simps new_int_bin.simps take_bit_and)
    using intval_or.elims Value.inject(1)
      apply (smt (verit) new_int.simps new_int_bin.simps take_bit_or)
    using intval_xor.elims Value.inject(1)
     apply (smt (verit) new_int.simps new_int_bin.simps take_bit_xor)
  by blast

next
  assume R: ?R
  then obtain x y where "[m,p] \<turnstile> xe \<mapsto> IntVal b x"
        and "[m,p] \<turnstile> ye \<mapsto> IntVal b y"
        and "new_int b val = bin_eval op (IntVal b x) (IntVal b y)"
        and "new_int b val \<noteq> UndefVal"
    using bin_eval_unused_bits_zero by force
  then show ?L
    using R by blast
qed

end