(*  Title:      JinjaDCI/J/Expr.thy
    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   2003 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory J/Expr.thy by Tobias Nipkow
*)

section \<open> Expressions \<close>

theory Expr
imports "../Common/Exceptions"
begin

datatype bop = Eq | Add     \<comment> \<open>names of binary operations\<close>

datatype 'a exp
  = new cname      \<comment> \<open>class instance creation\<close>
  | Cast cname "('a exp)"      \<comment> \<open>type cast\<close>
  | Val val      \<comment> \<open>value\<close>
  | BinOp "('a exp)" bop "('a exp)"     ("_ \<guillemotleft>_\<guillemotright> _" [80,0,81] 80)      \<comment> \<open>binary operation\<close>
  | Var 'a                                               \<comment> \<open>local variable (incl. parameter)\<close>
  | LAss 'a "('a exp)"     ("_:=_" [90,90]90)                    \<comment> \<open>local assignment\<close>
  | FAcc "('a exp)" vname cname     ("_\<bullet>_{_}" [10,90,99]90)      \<comment> \<open>field access\<close>
  | SFAcc cname vname cname     ("_\<bullet>\<^sub>s_{_}" [10,90,99]90)      \<comment> \<open>static field access\<close>
  | FAss "('a exp)" vname cname "('a exp)"     ("_\<bullet>_{_} := _" [10,90,99,90]90)      \<comment> \<open>field assignment\<close>
  | SFAss cname vname cname "('a exp)"     ("_\<bullet>\<^sub>s_{_} := _" [10,90,99,90]90)      \<comment> \<open>static field assignment\<close>
  | Call "('a exp)" mname "('a exp list)"     ("_\<bullet>_'(_')" [90,99,0] 90)            \<comment> \<open>method call\<close>
  | SCall cname mname "('a exp list)"     ("_\<bullet>\<^sub>s_'(_')" [90,99,0] 90)            \<comment> \<open>static method call\<close>
  | Block 'a ty "('a exp)"     ("'{_:_; _}")
  | Seq "('a exp)" "('a exp)"     ("_;;/ _"             [61,60]60)
  | Cond "('a exp)" "('a exp)" "('a exp)"     ("if '(_') _/ else _" [80,79,79]70)
  | While "('a exp)" "('a exp)"     ("while '(_') _"     [80,79]70)
  | throw "('a exp)"
  | TryCatch "('a exp)" cname 'a "('a exp)"     ("try _/ catch'(_ _') _"  [0,99,80,79] 70)
  | INIT cname "cname list" bool "('a exp)" ("INIT _ '(_,_') \<leftarrow> _" [60,60,60,60] 60) \<comment> \<open>internal initialization command: class, list of superclasses to initialize, preparation flag; command on hold\<close>
  | RI cname "('a exp)" "cname list" "('a exp)" ("RI '(_,_') ; _ \<leftarrow> _" [60,60,60,60] 60) \<comment> \<open>running of the initialization procedure for class with expression, classes still to initialize command on hold\<close>

type_synonym
  expr = "vname exp"            \<comment> \<open>Jinja expression\<close>
type_synonym
  J_mb = "vname list \<times> expr"    \<comment> \<open>Jinja method body: parameter names and expression\<close>
type_synonym
  J_prog = "J_mb prog"          \<comment> \<open>Jinja program\<close>

type_synonym
  init_stack = "expr list \<times> bool"  \<comment> \<open>Stack of expressions waiting on initialization in small step; indicator boolean True if current expression has been init checked\<close>

text\<open>The semantics of binary operators: \<close>

fun binop :: "bop \<times> val \<times> val \<Rightarrow> val option" where
  "binop(Eq,v\<^sub>1,v\<^sub>2) = Some(Bool (v\<^sub>1 = v\<^sub>2))"
| "binop(Add,Intg i\<^sub>1,Intg i\<^sub>2) = Some(Intg(i\<^sub>1+i\<^sub>2))"
| "binop(bop,v\<^sub>1,v\<^sub>2) = None"

lemma map_Val_throw_eq:
 "map Val vs @ throw ex # es = map Val vs' @ throw ex' # es' \<Longrightarrow> ex = ex'"
(*<*)by(induct vs arbitrary: vs'; case_tac vs') auto(*>*)

lemma map_Val_nthrow_neq:
 "map Val vs = map Val vs' @ throw ex' # es' \<Longrightarrow> False"
(*<*)by(induct vs arbitrary: vs'; case_tac vs') auto(*>*)

lemma map_Val_eq:
 "map Val vs = map Val vs' \<Longrightarrow> vs = vs'"
(*<*)by(induct vs arbitrary: vs'; case_tac vs') auto(*>*)

lemma init_rhs_neq [simp]: "e \<noteq> INIT C (Cs,b) \<leftarrow> e"
proof -
  have "size e \<noteq> size (INIT C (Cs,b) \<leftarrow> e)" by auto
  then show ?thesis by fastforce
qed

lemma init_rhs_neq' [simp]: "INIT C (Cs,b) \<leftarrow> e \<noteq> e"
proof -
  have "size e \<noteq> size (INIT C (Cs,b) \<leftarrow> e)" by auto
  then show ?thesis by fastforce
qed

lemma ri_rhs_neq [simp]: "e \<noteq> RI(C,e');Cs \<leftarrow> e"
proof -
  have "size e \<noteq> size (RI(C,e');Cs \<leftarrow> e)" by auto
  then show ?thesis by fastforce
qed

lemma ri_rhs_neq' [simp]: "RI(C,e');Cs \<leftarrow> e \<noteq> e"
proof -
  have "size e \<noteq> size (RI(C,e');Cs \<leftarrow> e)" by auto
  then show ?thesis by fastforce
qed

subsection "Syntactic sugar"

abbreviation (input)
  InitBlock:: "'a \<Rightarrow> ty \<Rightarrow> 'a exp \<Rightarrow> 'a exp \<Rightarrow> 'a exp"   ("(1'{_:_ := _;/ _})") where
  "InitBlock V T e1 e2 == {V:T; V := e1;; e2}"

abbreviation unit where "unit == Val Unit"
abbreviation null where "null == Val Null"
abbreviation "addr a == Val(Addr a)"
abbreviation "true == Val(Bool True)"
abbreviation "false == Val(Bool False)"

abbreviation
  Throw :: "addr \<Rightarrow> 'a exp" where
  "Throw a == throw(Val(Addr a))"

abbreviation
  THROW :: "cname \<Rightarrow> 'a exp" where
  "THROW xc == Throw(addr_of_sys_xcpt xc)"

subsection\<open>Free Variables\<close>

primrec fv :: "expr \<Rightarrow> vname set" and fvs :: "expr list \<Rightarrow> vname set" where
  "fv(new C) = {}"
| "fv(Cast C e) = fv e"
| "fv(Val v) = {}"
| "fv(e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = fv e\<^sub>1 \<union> fv e\<^sub>2"
| "fv(Var V) = {V}"
| "fv(LAss V e) = {V} \<union> fv e"
| "fv(e\<bullet>F{D}) = fv e"
| "fv(C\<bullet>\<^sub>sF{D}) = {}"
| "fv(e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = fv e\<^sub>1 \<union> fv e\<^sub>2"
| "fv(C\<bullet>\<^sub>sF{D}:=e\<^sub>2) = fv e\<^sub>2"
| "fv(e\<bullet>M(es)) = fv e \<union> fvs es"
| "fv(C\<bullet>\<^sub>sM(es)) = fvs es"
| "fv({V:T; e}) = fv e - {V}"
| "fv(e\<^sub>1;;e\<^sub>2) = fv e\<^sub>1 \<union> fv e\<^sub>2"
| "fv(if (b) e\<^sub>1 else e\<^sub>2) = fv b \<union> fv e\<^sub>1 \<union> fv e\<^sub>2"
| "fv(while (b) e) = fv b \<union> fv e"
| "fv(throw e) = fv e"
| "fv(try e\<^sub>1 catch(C V) e\<^sub>2) = fv e\<^sub>1 \<union> (fv e\<^sub>2 - {V})"
| "fv(INIT C (Cs,b) \<leftarrow> e) = fv e"
| "fv(RI (C,e);Cs \<leftarrow> e') = fv e \<union> fv e'"
| "fvs([]) = {}"
| "fvs(e#es) = fv e \<union> fvs es"

lemma [simp]: "fvs(es\<^sub>1 @ es\<^sub>2) = fvs es\<^sub>1 \<union> fvs es\<^sub>2"
(*<*)by (induct es\<^sub>1 type:list) auto(*>*)

lemma [simp]: "fvs(map Val vs) = {}"
(*<*)by (induct vs) auto(*>*)

subsection\<open>Accessing expression constructor arguments\<close>

fun val_of :: "'a exp \<Rightarrow> val option" where
"val_of (Val v) = Some v" |
"val_of _ = None"

lemma val_of_spec: "val_of e = Some v \<Longrightarrow> e = Val v"
proof(cases e) qed(auto)

fun lass_val_of :: "'a exp \<Rightarrow> ('a \<times> val) option" where
"lass_val_of (V:=Val v) = Some (V, v)" |
"lass_val_of _ = None"

lemma lass_val_of_spec:
assumes "lass_val_of e = \<lfloor>a\<rfloor>"
shows "e = (fst a:=Val (snd a))"
using assms proof(cases e)
  case (LAss V e') then show ?thesis using assms proof(cases e')qed(auto)
qed(auto)

fun map_vals_of :: "'a exp list \<Rightarrow> val list option" where
"map_vals_of (e#es) = (case val_of e of Some v \<Rightarrow> (case map_vals_of es of Some vs \<Rightarrow> Some (v#vs)
                                                                        | _ \<Rightarrow> None)
                                      | _ \<Rightarrow> None)" |
"map_vals_of [] = Some []"

lemma map_vals_of_spec: "map_vals_of es = Some vs \<Longrightarrow> es = map Val vs"
proof(induct es arbitrary: vs) qed(auto simp: val_of_spec)

lemma map_vals_of_Vals[simp]: "map_vals_of (map Val vs) = \<lfloor>vs\<rfloor>" by(induct vs, auto)

lemma map_vals_of_throw[simp]:
 "map_vals_of (map Val vs @ throw e # es') = None"
 by(induct vs, auto)

fun bool_of :: "'a exp \<Rightarrow> bool option" where
"bool_of true = Some True" |
"bool_of false = Some False" |
"bool_of _ = None"

lemma bool_of_specT:
assumes "bool_of e = Some True" shows "e = true"
proof -
  have "bool_of e = Some True" by fact
  then show ?thesis
  proof(cases e)
    case (Val x3) with assms show ?thesis
    proof(cases x3)
      case (Bool x) with assms Val show ?thesis
      proof(cases x)qed(auto)
    qed(simp_all)
  qed(auto)
qed

lemma bool_of_specF:
assumes "bool_of e = Some False" shows "e = false"
proof -
  have "bool_of e = Some False" by fact
  then show ?thesis
  proof(cases e)
    case (Val x3) with assms show ?thesis
    proof(cases x3)
      case (Bool x) with assms Val show ?thesis
      proof(cases x)qed(auto)
    qed(simp_all)
  qed(auto)
qed

fun throw_of :: "'a exp \<Rightarrow> 'a exp option" where
"throw_of (throw e') = Some e'" |
"throw_of _ = None"

lemma throw_of_spec: "throw_of e = Some e' \<Longrightarrow> e = throw e'"
proof(cases e) qed(auto)

fun init_exp_of :: "'a exp \<Rightarrow> 'a exp option" where
"init_exp_of (INIT C (Cs,b) \<leftarrow> e) = Some e" |
"init_exp_of (RI(C,e');Cs \<leftarrow> e) = Some e" |
"init_exp_of _ = None"

lemma init_exp_of_neq [simp]: "init_exp_of e = \<lfloor>e'\<rfloor> \<Longrightarrow> e' \<noteq> e" by(cases e, auto)
lemma init_exp_of_neq'[simp]: "init_exp_of e = \<lfloor>e'\<rfloor> \<Longrightarrow> e \<noteq> e'" by(cases e, auto)

subsection\<open>Class initialization\<close>

text \<open> This section defines a few functions that return information
 about an expression's current initialization status. \<close>

 \<comment> \<open> True if expression contains @{text INIT}, @{text RI}, or a call to a static method @{term clinit} \<close>
primrec sub_RI :: "'a exp \<Rightarrow> bool" and sub_RIs :: "'a exp list \<Rightarrow> bool" where
  "sub_RI(new C) = False"
| "sub_RI(Cast C e) = sub_RI e"
| "sub_RI(Val v) = False"
| "sub_RI(e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = (sub_RI e\<^sub>1 \<or> sub_RI e\<^sub>2)"
| "sub_RI(Var V) = False"
| "sub_RI(LAss V e) = sub_RI e"
| "sub_RI(e\<bullet>F{D}) = sub_RI e"
| "sub_RI(C\<bullet>\<^sub>sF{D}) = False"
| "sub_RI(e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = (sub_RI e\<^sub>1 \<or> sub_RI e\<^sub>2)"
| "sub_RI(C\<bullet>\<^sub>sF{D}:=e\<^sub>2) = sub_RI e\<^sub>2"
| "sub_RI(e\<bullet>M(es)) = (sub_RI e \<or> sub_RIs es)"
| "sub_RI(C\<bullet>\<^sub>sM(es)) = (M = clinit \<or> sub_RIs es)"
| "sub_RI({V:T; e}) = sub_RI e"
| "sub_RI(e\<^sub>1;;e\<^sub>2) = (sub_RI e\<^sub>1 \<or> sub_RI e\<^sub>2)"
| "sub_RI(if (b) e\<^sub>1 else e\<^sub>2) = (sub_RI b \<or> sub_RI e\<^sub>1 \<or> sub_RI e\<^sub>2)"
| "sub_RI(while (b) e) = (sub_RI b \<or> sub_RI e)"
| "sub_RI(throw e) = sub_RI e"
| "sub_RI(try e\<^sub>1 catch(C V) e\<^sub>2) = (sub_RI e\<^sub>1 \<or> sub_RI e\<^sub>2)"
| "sub_RI(INIT C (Cs,b) \<leftarrow> e) = True"
| "sub_RI(RI (C,e);Cs \<leftarrow> e') = True"
| "sub_RIs([]) = False"
| "sub_RIs(e#es) = (sub_RI e \<or> sub_RIs es)"

lemmas sub_RI_sub_RIs_induct = sub_RI.induct sub_RIs.induct

lemma nsub_RIs_def[simp]:
 "\<not>sub_RIs es \<Longrightarrow> \<forall>e \<in> set es. \<not>sub_RI e"
 by(induct es, auto)

lemma sub_RI_base:
 "e = INIT C (Cs, b) \<leftarrow> e' \<or> e = RI(C,e\<^sub>0);Cs \<leftarrow> e' \<Longrightarrow> sub_RI e"
 by(cases e, auto)

lemma nsub_RI_Vals[simp]: "\<not>sub_RIs (map Val vs)"
 by(induct vs, auto)

lemma lass_val_of_nsub_RI: "lass_val_of e = \<lfloor>a\<rfloor> \<Longrightarrow> \<not>sub_RI e"
 by(drule lass_val_of_spec, simp)

 \<comment> \<open> is not currently initializing class @{text C'} (point past checking flag) \<close>
primrec not_init :: "cname \<Rightarrow> 'a exp \<Rightarrow> bool" and not_inits :: "cname \<Rightarrow> 'a exp list \<Rightarrow> bool" where
  "not_init C' (new C) = True"
| "not_init C' (Cast C e) = not_init C' e"
| "not_init C' (Val v) = True"
| "not_init C' (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = (not_init C' e\<^sub>1 \<and> not_init C' e\<^sub>2)"
| "not_init C' (Var V) = True"
| "not_init C' (LAss V e) = not_init C' e"
| "not_init C' (e\<bullet>F{D}) = not_init C' e"
| "not_init C' (C\<bullet>\<^sub>sF{D}) = True"
| "not_init C' (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = (not_init C' e\<^sub>1 \<and> not_init C' e\<^sub>2)"
| "not_init C' (C\<bullet>\<^sub>sF{D}:=e\<^sub>2) = not_init C' e\<^sub>2"
| "not_init C' (e\<bullet>M(es)) = (not_init C' e \<and> not_inits C' es)"
| "not_init C' (C\<bullet>\<^sub>sM(es)) = not_inits C' es"
| "not_init C' ({V:T; e}) = not_init C' e"
| "not_init C' (e\<^sub>1;;e\<^sub>2) = (not_init C' e\<^sub>1 \<and> not_init C' e\<^sub>2)"
| "not_init C' (if (b) e\<^sub>1 else e\<^sub>2) = (not_init C' b \<and> not_init C' e\<^sub>1 \<and> not_init C' e\<^sub>2)"
| "not_init C' (while (b) e) = (not_init C' b \<and> not_init C' e)"
| "not_init C' (throw e) = not_init C' e"
| "not_init C' (try e\<^sub>1 catch(C V) e\<^sub>2) = (not_init C' e\<^sub>1 \<and> not_init C' e\<^sub>2)"
| "not_init C' (INIT C (Cs,b) \<leftarrow> e) = ((b \<longrightarrow> Cs = Nil \<or> C' \<noteq> hd Cs) \<and> C' \<notin> set(tl Cs) \<and> not_init C' e)"
| "not_init C' (RI (C,e);Cs \<leftarrow> e') = (C' \<notin> set (C#Cs) \<and> not_init C' e \<and> not_init C' e')"
| "not_inits C' ([]) = True"
| "not_inits C' (e#es) = (not_init C' e \<and> not_inits C' es)"

lemma not_inits_def'[simp]:
 "not_inits C es \<Longrightarrow> \<forall>e \<in> set es. not_init C e"
 by(induct es, auto)

lemma nsub_RIs_not_inits_aux: "\<forall>e \<in> set es. \<not>sub_RI e \<longrightarrow> not_init C e
  \<Longrightarrow> \<not>sub_RIs es \<Longrightarrow> not_inits C es"
 by(induct es, auto)

lemma nsub_RI_not_init: "\<not>sub_RI e \<Longrightarrow> not_init C e"
proof(induct e) qed(auto intro: nsub_RIs_not_inits_aux)

lemma nsub_RIs_not_inits: "\<not>sub_RIs es \<Longrightarrow> not_inits C es"
by(rule nsub_RIs_not_inits_aux) (simp_all add: nsub_RI_not_init)

subsection\<open>Subexpressions\<close>

 \<comment> \<open> all strictly smaller subexpressions; does not include self \<close>
 primrec subexp :: "'a exp \<Rightarrow> 'a exp set" and subexps :: "'a exp list \<Rightarrow> 'a exp set" where
  "subexp(new C) = {}"
| "subexp(Cast C e) = {e} \<union> subexp e"
| "subexp(Val v) = {}"
| "subexp(e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = {e\<^sub>1, e\<^sub>2} \<union> subexp e\<^sub>1 \<union> subexp e\<^sub>2"
| "subexp(Var V) = {}"
| "subexp(LAss V e) = {e} \<union> subexp e"
| "subexp(e\<bullet>F{D}) = {e} \<union> subexp e"
| "subexp(C\<bullet>\<^sub>sF{D}) = {}"
| "subexp(e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = {e\<^sub>1, e\<^sub>2} \<union> subexp e\<^sub>1 \<union> subexp e\<^sub>2"
| "subexp(C\<bullet>\<^sub>sF{D}:=e\<^sub>2) = {e\<^sub>2} \<union>subexp e\<^sub>2"
| "subexp(e\<bullet>M(es)) = {e} \<union> set es \<union> subexp e \<union> subexps es"
| "subexp(C\<bullet>\<^sub>sM(es)) = set es \<union> subexps es"
| "subexp({V:T; e}) = {e} \<union> subexp e"
| "subexp(e\<^sub>1;;e\<^sub>2) = {e\<^sub>1, e\<^sub>2} \<union> subexp e\<^sub>1 \<union> subexp e\<^sub>2"
| "subexp(if (b) e\<^sub>1 else e\<^sub>2) = {b, e\<^sub>1, e\<^sub>2} \<union> subexp b \<union> subexp e\<^sub>1 \<union> subexp e\<^sub>2"
| "subexp(while (b) e) = {b, e} \<union> subexp b \<union> subexp e"
| "subexp(throw e) = {e} \<union> subexp e"
| "subexp(try e\<^sub>1 catch(C V) e\<^sub>2) = {e\<^sub>1, e\<^sub>2} \<union> subexp e\<^sub>1 \<union> subexp e\<^sub>2"
| "subexp(INIT C (Cs,b) \<leftarrow> e) = {e} \<union> subexp e"
| "subexp(RI (C,e);Cs \<leftarrow> e') = {e, e'} \<union> subexp e \<union> subexp e'"
| "subexps([]) = {}"
| "subexps(e#es) = {e} \<union> subexp e \<union> subexps es"

lemmas subexp_subexps_induct = subexp.induct subexps.induct

abbreviation subexp_of :: "'a exp \<Rightarrow> 'a exp \<Rightarrow> bool" where
 "subexp_of e e' \<equiv> e \<in> subexp e'"

lemma subexp_size_le:
 "(e' \<in> subexp e \<longrightarrow> size e' < size e) \<and> (e' \<in> subexps es \<longrightarrow> size e' < size_list size es)"
proof(induct rule: subexp_subexps.induct)
  case Call:11 then show ?case using not_less_eq size_list_estimation by fastforce
next
  case SCall:12 then show ?case using not_less_eq size_list_estimation by fastforce
qed(auto)

lemma subexps_def2: "subexps es = set es \<union> (\<Union>e \<in> set es. subexp e)" by(induct es, auto)

 \<comment> \<open> strong induction \<close>
lemma shows subexp_induct[consumes 1]:
"(\<And>e. subexp e = {} \<Longrightarrow> R e) \<Longrightarrow> (\<And>e. (\<And>e'. e' \<in> subexp e \<Longrightarrow> R e') \<Longrightarrow> R e)
   \<Longrightarrow> (\<And>es. (\<And>e'. e' \<in> subexps es \<Longrightarrow> R e') \<Longrightarrow> Rs es) \<Longrightarrow> (\<forall>e'. e' \<in> subexp e \<longrightarrow> R e') \<and> R e"
and subexps_induct[consumes 1]:
 "(\<And>es. subexps es = {} \<Longrightarrow> Rs es) \<Longrightarrow> (\<And>e. (\<And>e'. e' \<in> subexp e \<Longrightarrow> R e') \<Longrightarrow> R e)
   \<Longrightarrow> (\<And>es. (\<And>e'. e' \<in> subexps es \<Longrightarrow> R e') \<Longrightarrow> Rs es) \<Longrightarrow> (\<forall>e'. e' \<in> subexps es \<longrightarrow> R e') \<and> Rs es"
proof(induct rule: subexp_subexps_induct)
  case (Cast x1 x2)
  then have "(\<forall>e'. subexp_of e' x2 \<longrightarrow> R e') \<and> R x2" by fast
  then have "(\<forall>e'. subexp_of e' (Cast x1 x2) \<longrightarrow> R e')" by auto
  then show ?case using Cast.prems(2) by fast
next
  case (BinOp x1 x2 x3)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. subexp_of e' x3 \<longrightarrow> R e') \<and> R x3"
   by fast+
  then have "(\<forall>e'. subexp_of e' (x1 \<guillemotleft>x2\<guillemotright> x3) \<longrightarrow> R e')" by auto
  then show ?case using BinOp.prems(2) by fast
next
  case (LAss x1 x2)
  then have "(\<forall>e'. subexp_of e' x2 \<longrightarrow> R e') \<and> R x2" by fast
  then have "(\<forall>e'. subexp_of e' (LAss x1 x2) \<longrightarrow> R e')" by auto
  then show ?case using LAss.prems(2) by fast
next
  case (FAcc x1 x2 x3)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" by fast
  then have "(\<forall>e'. subexp_of e' (x1\<bullet>x2{x3}) \<longrightarrow> R e')" by auto
  then show ?case using FAcc.prems(2) by fast
next
  case (FAss x1 x2 x3 x4)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. subexp_of e' x4 \<longrightarrow> R e') \<and> R x4"
   by fast+
  then have "(\<forall>e'. subexp_of e' (x1\<bullet>x2{x3} := x4) \<longrightarrow> R e')" by auto
  then show ?case using FAss.prems(2) by fast
next
  case (SFAss x1 x2 x3 x4)
  then have "(\<forall>e'. subexp_of e' x4 \<longrightarrow> R e') \<and> R x4" by fast
  then have "(\<forall>e'. subexp_of e' (x1\<bullet>\<^sub>sx2{x3} := x4) \<longrightarrow> R e')" by auto
  then show ?case using SFAss.prems(2) by fast
next
  case (Call x1 x2 x3)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. e' \<in> subexps x3 \<longrightarrow> R e') \<and> Rs x3"
   by fast+
  then have "(\<forall>e'. subexp_of e' (x1\<bullet>x2(x3)) \<longrightarrow> R e')" using subexps_def2 by auto
  then show ?case using Call.prems(2) by fast
next
  case (SCall x1 x2 x3)
  then have "(\<forall>e'. e' \<in> subexps x3 \<longrightarrow> R e') \<and> Rs x3" by fast
  then have "(\<forall>e'. subexp_of e' (x1\<bullet>\<^sub>sx2(x3)) \<longrightarrow> R e')" using subexps_def2 by auto
  then show ?case using SCall.prems(2) by fast
next
  case (Block x1 x2 x3)
  then have "(\<forall>e'. subexp_of e' x3 \<longrightarrow> R e') \<and> R x3" by fast
  then have "(\<forall>e'. subexp_of e' {x1:x2; x3} \<longrightarrow> R e')" by auto
  then show ?case using Block.prems(2) by fast
next
  case (Seq x1 x2)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. subexp_of e' x2 \<longrightarrow> R e') \<and> R x2"
   by fast+
  then have "(\<forall>e'. subexp_of e' (x1;; x2) \<longrightarrow> R e')" by auto
  then show ?case using Seq.prems(2) by fast
next
  case (Cond x1 x2 x3)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. subexp_of e' x2 \<longrightarrow> R e') \<and> R x2"
    and "(\<forall>e'. subexp_of e' x3 \<longrightarrow> R e') \<and> R x3" by fast+
  then have "(\<forall>e'. subexp_of e' (if (x1) x2 else x3) \<longrightarrow> R e')" by auto
  then show ?case using Cond.prems(2) by fast
next
  case (While x1 x2)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. subexp_of e' x2 \<longrightarrow> R e') \<and> R x2"
   by fast+
  then have "(\<forall>e'. subexp_of e' (while (x1) x2) \<longrightarrow> R e')" by auto
  then show ?case using While.prems(2) by fast
next
  case (throw x)
  then have "(\<forall>e'. subexp_of e' x \<longrightarrow> R e') \<and> R x" by fast
  then have "(\<forall>e'. subexp_of e' (throw x) \<longrightarrow> R e')" by auto
  then show ?case using throw.prems(2) by fast
next
  case (TryCatch x1 x2 x3 x4)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. subexp_of e' x4 \<longrightarrow> R e') \<and> R x4"
   by fast+
  then have "(\<forall>e'. subexp_of e' (try x1 catch(x2 x3) x4) \<longrightarrow> R e')" by auto
  then show ?case using TryCatch.prems(2) by fast
next
  case (INIT x1 x2 x3 x4)
  then have "(\<forall>e'. subexp_of e' x4 \<longrightarrow> R e') \<and> R x4" by fast
  then have "(\<forall>e'. subexp_of e' (INIT x1 (x2,x3) \<leftarrow> x4) \<longrightarrow> R e')" by auto
  then show ?case using INIT.prems(2) by fast
next
  case (RI x1 x2 x3 x4)
  then have "(\<forall>e'. subexp_of e' x2 \<longrightarrow> R e') \<and> R x2" and "(\<forall>e'. subexp_of e' x4 \<longrightarrow> R e') \<and> R x4"
   by fast+
  then have "(\<forall>e'. subexp_of e' (RI (x1,x2) ; x3 \<leftarrow> x4) \<longrightarrow> R e')" by auto
  then show ?case using RI.prems(2) by fast
next
  case (Cons_exp x1 x2)
  then have "(\<forall>e'. subexp_of e' x1 \<longrightarrow> R e') \<and> R x1" and "(\<forall>e'. e' \<in> subexps x2 \<longrightarrow> R e') \<and> Rs x2"
   by fast+
  then have "(\<forall>e'. e' \<in> subexps (x1 # x2) \<longrightarrow> R e')" using subexps_def2 by auto
  then show ?case using Cons_exp.prems(3) by fast
qed(auto)

subsection"Final expressions"
(* these definitions and most of the lemmas were in BigStep.thy in the original Jinja *)

definition final :: "'a exp \<Rightarrow> bool"
where
  "final e  \<equiv>  (\<exists>v. e = Val v) \<or> (\<exists>a. e = Throw a)"

definition finals:: "'a exp list \<Rightarrow> bool"
where
  "finals es  \<equiv>  (\<exists>vs. es = map Val vs) \<or> (\<exists>vs a es'. es = map Val vs @ Throw a # es')"

lemma [simp]: "final(Val v)"
(*<*)by(simp add:final_def)(*>*)

lemma [simp]: "final(throw e) = (\<exists>a. e = addr a)"
(*<*)by(simp add:final_def)(*>*)

lemma finalE: "\<lbrakk> final e;  \<And>v. e = Val v \<Longrightarrow> R;  \<And>a. e = Throw a \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:final_def)(*>*)

lemma final_fv[iff]: "final e \<Longrightarrow> fv e = {}"
 by (auto simp: final_def)

lemma finalsE:
 "\<lbrakk> finals es;  \<And>vs. es = map Val vs \<Longrightarrow> R;  \<And>vs a es'. es = map Val vs @ Throw a # es' \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:finals_def)(*>*)

lemma [iff]: "finals (Val v # es) = finals es"
(*<*)
proof(rule iffI)
  assume "finals (Val v # es)"
  moreover {
    fix vs a es'
    assume "\<forall>vs a es'. es \<noteq> map Val vs @ Throw a # es'"
      and "Val v # es = map Val vs @ Throw a # es'"
    then have "\<exists>vs. es = map Val vs" by(case_tac vs; simp)
  }
  ultimately show "finals es" by(clarsimp simp add: finals_def)
next
  assume "finals es"
  moreover {
    fix vs a es'
    assume "es = map Val vs @ Throw a # es'"
    then have "\<exists>vs' a' es''. Val v # map Val vs @ Throw a # es' = map Val vs' @ Throw a' # es''"
      by(rule_tac x = "v#vs" in exI) simp
  }
  ultimately show "finals (Val v # es)" by(clarsimp simp add: finals_def)
qed
(*>*)

lemma finals_app_map[iff]: "finals (map Val vs @ es) = finals es"
(*<*)by(induct_tac vs, auto)(*>*)

lemma [iff]: "finals (map Val vs)"
(*<*)using finals_app_map[of vs "[]"]by(simp)(*>*)

lemma [iff]: "finals (throw e # es) = (\<exists>a. e = addr a)"
(*<*)
proof(rule iffI)
  assume "finals (throw e # es)"
  moreover {
    fix vs a es'
    assume "throw e # es = map Val vs @ Throw a # es'"
    then have "\<exists>a. e = addr a" by(case_tac vs; simp)
  }
  ultimately show "\<exists>a. e = addr a" by(clarsimp simp add: finals_def)
next
  assume "\<exists>a. e = addr a"
  moreover {
    fix vs a es'
    assume "e = addr a"
    then have "\<exists>vs aa es'. Throw a # es = map Val vs @ Throw aa # es'"
      by(rule_tac x = "[]" in exI) simp
  }
  ultimately show "finals (throw e # es)" by(clarsimp simp add: finals_def)
qed
(*>*)

lemma not_finals_ConsI: "\<not> final e \<Longrightarrow> \<not> finals(e#es)"
(*<*)
proof -
  assume "\<not> final e"
  moreover {
    fix vs a es'
    assume "\<forall>v. e \<noteq> Val v" and "\<forall>a. e \<noteq> Throw a"
    then have "e # es \<noteq> map Val vs @ Throw a # es'" by(case_tac vs; simp)
  }
  ultimately show ?thesis by(clarsimp simp add:finals_def final_def)
qed
(*>*)

lemma not_finals_ConsI2: "e = Val v \<Longrightarrow> \<not> finals es \<Longrightarrow> \<not> finals(e#es)"
(*<*)
proof -
  assume [simp]: "e = Val v" and "\<not> finals es"
  moreover {
    fix vs a es'
    assume "\<forall>vs. es \<noteq> map Val vs" and "\<forall>vs a es'. es \<noteq> map Val vs @ Throw a # es'"
    then have "e # es \<noteq> map Val vs @ Throw a # es'" by(case_tac vs; simp)
  }
  ultimately show ?thesis by(clarsimp simp add:finals_def final_def)
qed
(*>*)

end


section \<open>Preprocessor and Code-Generator User Interface\<close>
theory LLVM_Codegen_Preproc
imports
  "../kernel/LLVM_Codegen"
  "Monadify"
  "../../lib/Definition_Utils"
  "../../lib/Named_Simpsets"
keywords "export_llvm" "llvm_deps" :: thy_decl
begin

  subsection \<open>Fixed-Point Unfolding Setup\<close>

  declaration \<open>fn _ => Definition_Utils.declare_extraction_group @{binding LLVM} #> snd\<close>

  declaration \<open>fn _ =>
    Definition_Utils.add_extraction (@{extraction_group LLVM},\<^here>) {
      pattern = Logic.varify_global @{term "REC (B::('a \<Rightarrow> 'b llM) \<Rightarrow> 'a \<Rightarrow> 'b llM)"},
      gen_thm = @{thm REC_unfold},
      gen_tac = Partial_Function.mono_tac
    }
  \<close>

  declaration \<open>fn _ =>
    Definition_Utils.add_extraction (@{extraction_group LLVM},\<^here>) {
      pattern = Logic.varify_global @{term "REC' (B::('a \<Rightarrow> 'b llM) \<Rightarrow> 'a \<Rightarrow> 'b llM)"},
      gen_thm = @{thm REC'_unfold},
      gen_tac = Partial_Function.mono_tac
    }
  \<close>

subsection \<open>Preprocessor\<close>
  text \<open>
    The actual code generator expects a set of monomorphic, well-shaped equations.
    The preprocessor processes user specified equations, monomorphizes them and
    brings them into the right shape.
  \<close>

  named_theorems llvm_code \<open>Isabelle-LLVM code theorems\<close>

  named_simpset llvm_inline = HOL_ss

  attribute_setup llvm_inline = \<open>
    Attrib.add_del
      (Named_Simpsets.add_attr @{named_simpset llvm_inline})
      (Named_Simpsets.del_attr @{named_simpset llvm_inline})
  \<close>

  lemma llvm_inline_bind_laws[llvm_inline]:
    "bind m return = m"
    "bind (bind m (\<lambda>x. f x)) g = bind m (\<lambda>x. bind (f x) g)"
    by auto

  lemma unit_meta_eq: "x \<equiv> ()" by simp

  lemma pull_lambda_case: "(case x of (a,b) \<Rightarrow> \<lambda>y. t a b y) = (\<lambda>y. case x of (a,b) \<Rightarrow> t a b y)"
    apply (rule ext) apply (cases x) by auto

  ML_val \<open>Term.Var\<close>

  ML \<open> structure LLC_Preprocessor =
    struct
      open LLC_Lib

      structure Monadify = struct
        structure BT = Gen_Monadify_Cong_Basis ()
        open BT

        fun mk_return x = @{mk_term "return ?x ::_ llM"}
        fun mk_bind m f = @{mk_term "bind ?m ?f ::_ llM"}

        fun dest_return @{mpat "return ?x ::_ llM"} = SOME x | dest_return _ = NONE
        fun dest_bind @{mpat "bind ?m ?f ::_ llM"} = SOME (m,f) | dest_bind _ = NONE

        fun dest_monadT (Type (@{type_name M},[T,@{typ unit},@{typ cost},@{typ llvm_memory},@{typ err}])) = SOME T | dest_monadT _ = NONE

        fun mk_ll_call t = @{mk_term \<open>ll_call ?t\<close>}

        fun strip_op ctxt @{mpat \<open>ll_call ?fxs\<close>} = let
            val (f,xs) = BT.strip_op ctxt fxs
            val vnames = Name.invent_list (Term.add_free_names f []) "x" (length xs)
            val vars = vnames ~~ map fastype_of xs |> map Free
            val f = betapplys (f,vars) |> mk_ll_call |> fold_rev lambda vars
          in (f,xs) end
        | strip_op ctxt t = BT.strip_op ctxt t

        val bind_return_thm = @{lemma "bind m return = m" by simp}
        val return_bind_thm = @{lemma "bind (return x) f = f x" by simp}
        val bind_bind_thm = @{lemma "bind (bind m (\<lambda>x. f x)) g = bind m (\<lambda>x. bind (f x) g)" by simp}

        structure T = Gen_Monadify (
          val mk_return = mk_return
          val mk_bind = mk_bind
          val dest_return = dest_return
          val dest_bind = dest_bind
          val dest_monadT = dest_monadT
          val strip_op = strip_op
          val bind_return_thm = bind_return_thm
          val return_bind_thm = return_bind_thm
          val bind_bind_thm = bind_bind_thm
        )
        open T

      end

      (********* Normalization of code theorems *)

      fun cthm_inline ctxt thm = let
        val ctxt = Named_Simpsets.put @{named_simpset llvm_inline} ctxt
      in
        (* TODO: Simplifier.rewrite may introduce beta redexes.
          Currently we eliminate them right away. Or is it OK to have beta-redexes? *)
        Conv.fconv_rule (rhs_conv (Simplifier.rewrite ctxt) then_conv Thm.beta_conversion true) thm
      end

      val cthm_monadify = Conv.fconv_rule o (rhs_conv o Monadify.monadify_conv)

      val inline_iteration_limit =
        Config.int (Config.declare ("inline_iteration_limit", \<^here>) (fn _ => Config.Int ~1));

      fun monadify_inline_cthm ctxt thm = let
        fun rpt 0 thm' = raise THM ("inline_iteration_limit exceeded",~1,[thm,thm'])
          | rpt n thm = let
          val thm' = thm |> cthm_monadify ctxt |> cthm_inline ctxt
        in
          if Thm.eq_thm_prop (thm,thm') then thm
          else rpt (n-1) thm'
        end

        val it_limit = Config.get ctxt inline_iteration_limit
      in
        thm
        |> cthm_inline ctxt
        |> rpt it_limit
      end

      (*
        Bring code theorem into parseable format. To be applied after inlining,
          immediately before parsing.

        Applies eta-expansion, return-expansion, and converts \<equiv> to =.
        Finally, it will replace unit-binds by () constants and anonymous bind.

        May fail on non-well-formed theorems.
      *)
      fun cthm_format ctxt thm = let
        fun normalize_bind1 @{mpat \<open>ll_call ?t\<close>} = normalize_bind1 t |> Monadify.mk_ll_call
        | normalize_bind1 t = let
          val (f,args) = strip_comb t
          val _ = check_valid_head f

          val args_is_M = fastype_of f |> binder_types |> map (is_llM o body_type)

          val _ = length args_is_M = length args orelse raise TYPE ("cthm_format: All arguments must be explicit", [fastype_of f], [t])

          val args = map2 (fn isM => isM?(normalize o expand_eta_all)) args_is_M args

        in
          list_comb (f, args)
        end

        and normalize @{mpat "bind ?m ?f"} = let
            val m = normalize_bind1 m
            val f = (*ensure_abs f*) expand_eta_all f |> normalize
          in @{mk_term "bind ?m ?f"} end
        | normalize (Abs (x,T,t)) = Abs (x,T,normalize t)
        | normalize (t as @{mpat "return _"}) = t
        | normalize t = let val t = normalize_bind1 t in @{mk_term "bind ?t (\<lambda>x. return x)"} end

        fun normalize_eq @{mpat "Trueprop (?a = ?b)"} = let val b = normalize b in @{mk_term "Trueprop (?a = ?b)"} end
          | normalize_eq @{mpat "?a \<equiv> ?b"} = let val b = normalize b in @{mk_term "?a \<equiv> ?b"} end
          | normalize_eq t = raise TERM ("format_code_thm: normalize_eq", [t])

        fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset HOL_ss ctxt addsimps @{thms bind_laws}))

        fun cthm_norm_lambda ctxt thm = let
          val thm = Local_Defs.unfold ctxt @{thms pull_lambda_case} thm

          (*fun r thm = case Thm.concl_of thm of
            @{mpat "Trueprop (_ = (\<lambda>_. _))"} => r (thm RS @{thm fun_cong})
          | @{mpat "_ \<equiv> (\<lambda>_. _)"} => r (thm RS @{thm meta_fun_cong})
          | _ => thm
          *)

          fun r thm = case try (fn () => (thm RS @{thm fun_cong})) () of
            NONE => thm
          | SOME thm => r thm

        in
          r thm
        end

      in
        thm
        |> (simplify (put_simpset HOL_ss ctxt addsimps @{thms Monad.bind_laws atomize_eq}))
        |> cthm_norm_lambda ctxt
        |> (Conv.fconv_rule (Refine_Util.f_tac_conv ctxt normalize_eq (norm_tac ctxt)))
        |> (Conv.fconv_rule (Conv.top_sweep_conv (K (Conv.rewr_conv @{thm unit_meta_eq})) ctxt))
      end

      (********* Gathering of code equations *)
      (* TODO: Use net *)

      fun dep_prep_code_thm thm = let
        val c = head_of_eqn_thm thm
        val _ = check_valid_head c
      in
        (c,thm)
      end

      fun dep_try_instantiate_code_thm c (l,thm) = let
        val thy = Thm.theory_of_thm thm
      in
        case SOME (Pattern.match thy (l,c) (Vartab.empty,Vartab.empty)) handle Pattern.MATCH => NONE of
          NONE => NONE
        | SOME m => SOME (instantiate_uc m thm)
      end

      fun dep_find_code_thm pthms c =
        case get_first (dep_try_instantiate_code_thm c) pthms of
          SOME eqn => eqn
        | NONE => raise TERM ("No code equation",[c])

      val cmd_name_prefix = Long_Name.qualify (Long_Name.qualifier @{const_name ll_add}) "ll_"
      val comb_name_prefix = Long_Name.qualify (Long_Name.qualifier @{const_name llc_while}) "llc_"

      fun dep_is_ll_comb_name name =
               name = @{const_name bind}
        orelse name = @{const_name return}
        orelse String.isPrefix cmd_name_prefix name
        orelse String.isPrefix comb_name_prefix name

      fun dep_is_call_const t = case try dest_head t of
        NONE => false
      | SOME (name,T) =>
                  not (dep_is_ll_comb_name name) (* Not an internal name *)
          andalso is_llM (body_type T)           (* Yields a monadic result *)
          andalso not (exists (exists_subtype is_llM) (binder_types T)) (* No monadic parameters *)

      fun calls_of_cthm thm = Term.fold_aterms
        (fn t => dep_is_call_const t?cons t)
        (rhs_of_eqn (Thm.prop_of thm))
        []

      fun default_extractions ctxt =
          Definition_Utils.get_extraction_group ctxt @{extraction_group LLVM}

      fun gather_code_thms roots lthy = let
        val thy = Proof_Context.theory_of lthy
        val pthms = Named_Theorems.get lthy @{named_theorems llvm_code}
          |> map dep_prep_code_thm
          |> Refine_Util.subsume_sort fst thy

        fun process_root c (ctab, lthy) = let
          val _ = check_valid_head c
          val basename = name_of_head c |> Long_Name.base_name
        in
          case Termtab.lookup ctab c of
            SOME _ => (ctab, lthy)
          | NONE => let
              val _ = assert_monomorphic_const c
              (* Get code theorem and inline it *)
              val teqn = dep_find_code_thm pthms c |> monadify_inline_cthm lthy

              (* Extract recursion equations *)
              val exs = default_extractions lthy

              val ((teqn,add_eqns,_),lthy) = Definition_Utils.extract_recursion_eqs exs basename teqn lthy

              val teqns = teqn::add_eqns

              (* Inline and format again *)
              val teqns = map (monadify_inline_cthm lthy #> cthm_format lthy) teqns

              (* Update table *)
              val ctab = fold Termtab.update_new (map dep_prep_code_thm teqns) ctab

              (* Find calls *)
              val calls = map calls_of_cthm teqns |> flat

              (* Recurse *)
              val (ctab,lthy) = fold process_root calls (ctab,lthy)
            in
              (ctab, lthy)
            end
        end

        val (ctab,lthy) = fold process_root roots (Termtab.empty,lthy)
        val thms = Termtab.dest ctab |> map snd

      in
        (thms,lthy)
      end

    end
  \<close>

  declaration \<open>K (LLC_Preprocessor.Monadify.prepare_add_const_decl @{term "numeral a"})\<close>

  (* Small regression test against ll-call aware strip-op *)
  ML_val \<open>
    fun test ctxt t =
      betapplys (LLC_Preprocessor.Monadify.strip_op ctxt t) aconv t
      orelse raise TERM("Monadify strip-op regression test",[t])

    val _ = let val t=test @{context} in
      t @{term \<open>f\<close>};
      t @{term \<open>f x\<close>};
      t @{term \<open>f x y z\<close>};

      t @{term \<open>ll_call f\<close>};
      t @{term \<open>ll_call (f x)\<close>};
      t @{term \<open>ll_call (f x y z)\<close>};

      ()
    end
  \<close>

  ML_val \<open>
    @{term \<open>doM { z\<leftarrow>ll_add a b; ll_call (f (x+y+a) z (b+1)) }\<close>}
    |> LLC_Preprocessor.Monadify.monadify @{context}
    |> Thm.cterm_of @{context}

  \<close>

subsection \<open>Code Generator Driver\<close>
  text \<open>
    The driver combines preeprocessing and code generation,
    and defines the user interface of the code generator, namely the commands
    @{command export_llvm} and @{command llvm_deps}.
  \<close>

  ML \<open> structure LLC_Driver
    = struct

      val cfg_llvm_debug = Attrib.setup_config_bool @{binding llvm_debug} (K false)
      val cfg_llvm_gen_header = Attrib.setup_config_bool @{binding llvm_gen_header} (K true)

      fun pretty_cthms ctxt cthms = let
        val ctxt = Config.put Syntax_Trans.eta_contract false ctxt
      in Pretty.big_list "Code Theorems" (map (Thm.pretty_thm ctxt) cthms) end

      fun pretty_ftab_entry ctxt (t,n) = Pretty.block [
        Syntax.pretty_term ctxt t, Pretty.brk 1, Pretty.str ":: ", Syntax.pretty_typ ctxt (fastype_of t),
        Pretty.brk 1,Pretty.str "\<rightarrow>",Pretty.brk 1, Pretty.str n
      ]

      fun pretty_ftab ctxt ftab = Pretty.big_list "Symbol table:"
        (map (pretty_ftab_entry ctxt) (Termtab.dest ftab))

      fun consts_to_llvm hfname cns tydefs lthy = let
        val dbg = Config.get lthy cfg_llvm_debug
        val gen_header = Config.get lthy cfg_llvm_gen_header
        fun trace s = if dbg then Pretty.string_of (s ()) |> tracing else ()

        val _ = trace (fn () => Pretty.str "Gathering code theorems")
        val (cthms,lthy) = LLC_Preprocessor.gather_code_thms (map fst cns) lthy
        val _ = trace (fn () => pretty_cthms lthy cthms)

        val _ = trace (fn () => Pretty.str "Computing symbol table")
        val fixes = map_filter (fn (_,NONE) => NONE | (cn,SOME sigspec) => SOME (cn,LLC_HeaderGen.name_of_sigspec sigspec)) cns
        val ftab = LLC_Compiler.compute_fun_names fixes cthms
        val _ = trace (fn () => pretty_ftab lthy ftab)

        val _ = trace (fn () => Pretty.str "Translating code theorems to IL")
        val (tys,eqns) = LLC_Compiler.parse_cthms ftab cthms lthy
        val _ = trace (fn () => LLC_Intermediate.pretty_llc (tys,eqns))

        val _ = trace (fn () => Pretty.str "Writing LLVM")
        val res = LLC_Backend.compile_to_llvm lthy (tys,eqns)

        val hdres = if gen_header then let
            val _ = trace (fn () => Pretty.str "Preparing Header")
            val sigspecs = map_filter snd cns
            val hdres = LLC_HeaderGen.make_header hfname tydefs sigspecs eqns
          in hdres end
          else NONE

      in
        ((cthms,res,hdres), lthy)
      end

      local
        val using_master_directory =
          File.full_path o Resources.master_directory o Proof_Context.theory_of;

        fun prepare_path ctxt (s,pos) = let
          val _ = Position.report pos Markup.language_path;
          val path = Path.explode s;
          val _ = Position.report pos (Markup.path (Path.smart_implode path));
          val path = using_master_directory ctxt path
        in path end

        fun remove_ext ext p = let val (p',ext') = Path.split_ext p in if ext=ext' then p' else p end
        fun remove_all_ext p = case Path.split_ext p of (p,"") => p | (p,_) => remove_all_ext p

        fun prepare_hpath _ NONE = ("HEADER_NAME",NONE)
          | prepare_hpath ctxt (SOME spos) = let
              val path = prepare_path ctxt spos
                |> remove_ext "ll"
                |> Path.ext "h"
              val hfname = remove_all_ext (Path.base path) |> Path.implode
            in
              (hfname,SOME path)
            end

        fun write_out NONE s = writeln s
          | write_out (SOME path) s = File.write path s

        (*
        (*
          Contains a name (used as name for generated LLVM function) and
          an optional signature (used for header file generation).

          Note that this information is redundant, the name in the signature must match
          the LLVM-name. This redundancy, however, reflects the split of LLVM code
          generator and Header file generator.
        *)
        datatype siginfo = SIGI of string * LLC_HeaderGen.raw_sig option

        fun sigi_of_sig (rsg as (LLC_HeaderGen.RSIG (_,name,_))) = SIGI (name,SOME rsg)
        fun sigi_of_name name = SIGI (name,NONE)

        fun sigi_name (SIGI (name,_)) = name
        fun sigi_has_sig (SIGI (_,NONE)) = false
          | sigi_has_sig (SIGI (_,SOME _)) = true

        fun sigi_the_sig (SIGI (_,SOME sg)) = sg
          | sigi_the_sig _ = raise Match

        val parse_sigi =
             (Parse.short_ident || Parse.string) >> sigi_of_name
          || xxx, string needs inner parser!

        *)

      in
        fun export_llvm cns tydefs path (hfname,hfpath) lthy = let
          val lthy = Config.put Syntax_Trans.eta_contract false lthy
          val ((cthms,llvm_code,hcode),lthy) = consts_to_llvm hfname cns tydefs lthy
          val _ = write_out path llvm_code
          val _ = case hcode of SOME c => write_out hfpath c | NONE => ()
        in
          (cthms,lthy)
        end

        val export_llvm_cmd = (
          Args.mode "debug"
          -- Args.mode "no_while"
          -- Args.mode "no_header"
          -- Parse_Spec.opt_thm_name ":"
          -- (Scan.repeat1 (Parse.term -- Scan.option (@{keyword "is"} |-- LLC_HeaderGen.parse_raw_sig ))
          -- Scan.option (@{keyword "defines"} |-- LLC_HeaderGen.parse_raw_tydefs)
          -- Scan.option ((@{keyword "file"} |-- Parse.position Parse.path))
          )
            >> (fn ((((dbg,nowhile),no_header),bnd),((cns,tydefs),path_spos)) => fn lthy => let

              val nowhile_declarations =
                Config.put LLC_Lib.llc_compile_while false
              #> Context.proof_map (Named_Simpsets.add_simp @{named_simpset llvm_inline} @{thm llc_while_def})

              val lthy = (dbg?Config.put cfg_llvm_debug true) lthy
              val lthy = (nowhile?nowhile_declarations) lthy
              val lthy = (no_header?Config.put cfg_llvm_gen_header false) lthy

              (*
                TODO: No idea what happens here, but any subsequent
                  open_target/close_target block will RESET the configuration options
                  just made! Unless, we open our own target here ... then options will
                  only be reset at corresponding close_target.

                  PROBLEM:
                    set_option; open_target; close_target; <No effect of set-option visible here!>

                  BUT:
                    set_option; open; open; close <effect still visible>; close <effect gone>

                  No chance to figure out what happens, given the 'ample' 1-paragraph
                  documentation available on the local target mechanism in Isabelle.
                  I'm not even sure at this point whether the local-target stuff is required
                  in extract_recursion_eqs in first place?
              *)
              val lthy = Local_Theory.open_target lthy |> snd

              val cns = map (apfst (Syntax.read_term lthy)) cns
              val cns = map (apsnd (map_option (LLC_HeaderGen.check_raw_sig lthy))) cns
              val tydefs = the_default [] (map_option (LLC_HeaderGen.check_raw_tydefs lthy) tydefs)

              val path = Option.map (prepare_path lthy) path_spos
              val hfnpath = prepare_hpath lthy path_spos

              val (cthms,lthy) = export_llvm cns tydefs path hfnpath lthy

              val (_,lthy) = Local_Theory.note (bnd,cthms) lthy

              val lthy = Local_Theory.close_target lthy

            in lthy end))

        val llvm_deps_cmd = Parse_Spec.opt_thm_name ":" -- Scan.repeat1 Parse.term
          >> (fn (bnd,cns) => fn lthy => let
              val cns = map (Syntax.read_term lthy) cns
              val _ = writeln "Gathering code theorems"

              val (cthms,lthy) = LLC_Preprocessor.gather_code_thms cns lthy
              val (_,lthy) = Local_Theory.note (bnd,cthms) lthy

              val _ = writeln "Done"

              val _ = pretty_cthms lthy cthms |> Pretty.string_of |> writeln

             in lthy end
          )

      end

      val _ = Outer_Syntax.local_theory @{command_keyword export_llvm} "generate LLVM code for constants" export_llvm_cmd
      val _ = Outer_Syntax.local_theory @{command_keyword llvm_deps} "Print LLVM code theorems for constants" llvm_deps_cmd
    end
  \<close>

  subsection \<open>Setup for Product Type\<close>
  text \<open>We prepare a setup to compile product types to anonymous 2-element structures\<close>

  lemma ll_prod_is_pair[ll_is_pair_type_thms]:
    "ll_is_pair_type True TYPE('a::llvm_rep \<times>'b::llvm_rep) TYPE('a) TYPE('b)"
    by (simp add: ll_is_pair_type_def)

  definition [llvm_inline]: "prod_insert_fst \<equiv> ll_insert_fst :: ('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a \<Rightarrow> ('a\<times>'b) llM"
  definition [llvm_inline]: "prod_insert_snd \<equiv> ll_insert_snd :: ('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b \<Rightarrow> ('a\<times>'b) llM"
  definition [llvm_inline]: "prod_extract_fst \<equiv> ll_extract_fst :: ('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a llM"
  definition [llvm_inline]: "prod_extract_snd \<equiv> ll_extract_snd :: ('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b llM"
  definition [llvm_inline]: "prod_gep_fst \<equiv> ll_gep_fst :: ('a::llvm_rep \<times> 'b::llvm_rep) ptr \<Rightarrow> 'a ptr llM"
  definition [llvm_inline]: "prod_gep_snd \<equiv> ll_gep_snd :: ('a::llvm_rep \<times> 'b::llvm_rep) ptr \<Rightarrow> 'b ptr llM"

  lemma prod_ops_simp:
    "prod_insert_fst = (\<lambda>(_,b) a. return (a,b))"
    "prod_insert_snd = (\<lambda>(a,_) b. return (a,b))"
    "prod_extract_fst = (\<lambda>(a,b). return a)"
    "prod_extract_snd = (\<lambda>(a,b). return b)"
    unfolding
      prod_insert_fst_def ll_insert_fst_def
      prod_insert_snd_def ll_insert_snd_def
      prod_extract_fst_def ll_extract_fst_def
      prod_extract_snd_def ll_extract_snd_def
    apply (all \<open>intro ext\<close>  )
    apply (auto
      simp: checked_split_pair_def to_val_prod_def from_val_prod_def checked_from_val_def
      split: prod.splits
      )
    done

  subsection \<open>Ad-Hoc Regression Tests\<close>

experiment begin

  definition exp :: "64 word \<Rightarrow> 64 word llM" where [llvm_code]: "exp i \<equiv> doM {
    s \<leftarrow> prod_insert_fst init 1;
    s \<leftarrow> prod_insert_snd s i;
    s \<leftarrow> llc_while
      (\<lambda>s. doM {
        i \<leftarrow> prod_extract_snd s;
        ll_icmp_ne i 0
      })
      (\<lambda>s. doM {
        c \<leftarrow> prod_extract_fst s;
        i \<leftarrow> prod_extract_snd s;

        c \<leftarrow> ll_mul c 2;
        i \<leftarrow> ll_sub i 1;

        s \<leftarrow> prod_insert_fst init c;
        s \<leftarrow> prod_insert_snd s i;

        return s
      })
      s;

    prod_extract_fst s
  }"

  definition streq :: "8 word ptr \<Rightarrow> 8 word ptr \<Rightarrow> 1 word llM" where [llvm_code]: "streq s\<^sub>1 s\<^sub>2 = doM {
      x \<leftarrow> ll_load s\<^sub>1;
      ll_load s\<^sub>2 \<bind> ll_icmp_eq x
    }"

  export_llvm streq

  definition [llvm_code]: "test2 (n::32 word) \<equiv> doM {
    n \<leftarrow> ll_add n 42;
    p \<leftarrow> ll_malloc TYPE(16 word) n;
    p \<leftarrow> ll_ofs_ptr p (5::32 word);
    ll_store 42 p;
    r \<leftarrow> ll_load p;
    return r
  }"

  definition [llvm_code]: "add_add (a::_ word) \<equiv> doM {
    x \<leftarrow> ll_add a a;
    x \<leftarrow> ll_add x x;
    return x
  }"

  definition [llvm_code]: "add_add_driver (a::32 word) (b::64 word) \<equiv> doM {
    a \<leftarrow> ll_call (add_add a);
    b \<leftarrow> ll_call (add_add b);
    a \<leftarrow> ll_zext a TYPE(64 word);
    b \<leftarrow> ll_add a b;
    return b
  }"

  export_llvm (debug) add_add_driver

  definition [llvm_code]: "main (argc::32 word) (argv::8 word ptr ptr) \<equiv> doM {
    r \<leftarrow> ll_call (test2 argc);
    r \<leftarrow> ll_zext r TYPE(32 word);
    return r
  }"

  definition [llvm_code]: "main_exp (argc::32 word) (argv::8 word ptr ptr) \<equiv> doM {
    argc \<leftarrow> ll_zext argc TYPE(64 word);
    r \<leftarrow> ll_call (exp argc);
    r \<leftarrow> ll_trunc r TYPE(32 word);
    return r
  }"

definition [llvm_code]: "testx (a::64 word) \<equiv> llc_while (\<lambda>a. ll_icmp_ult 0 a) (\<lambda>a. ll_sub a 1) a"

export_llvm (debug) testx
export_llvm (debug) exp_thms1: exp

export_llvm (debug) (no_while) exp_thms2: exp
export_llvm (debug) (no_while) exp_thms3: exp

thm exp_thms1
thm exp_thms2
thm exp_thms3

export_llvm (debug) foobar: main_exp is main
export_llvm (debug) main is main

definition [llvm_code]:
  "test_if_names (n::32 word) \<equiv> doM {
    tmp \<leftarrow> ll_icmp_eq n 0;
    a \<leftarrow> llc_if tmp (return null) (doM {
                                     x \<leftarrow> ll_malloc TYPE(8 word) n;
                                     return x
                                   });
    p \<leftarrow> ll_ofs_ptr a (1::32 word);
    ll_store 0x2A p;
    ll_free a;
    return ()
  }"

export_llvm test_if_names

definition fib :: "64 word \<Rightarrow> 64 word llM"
  where [llvm_code]: "fib n \<equiv> ll_call (REC' (\<lambda>fib n. doM {
    t\<leftarrow>ll_icmp_ule n 1;
    llc_if t
      (return n)
      (doM {
        n\<^sub>1 \<leftarrow> ll_sub n 1;
        a\<leftarrow>fib n\<^sub>1;
        n\<^sub>2 \<leftarrow> ll_sub n 2;
        b\<leftarrow>fib n\<^sub>2;
        c\<leftarrow>ll_add a b;
        return c })} ) n)"

export_llvm (debug) fib is fib

definition triple_sum :: "(64 word \<times> 64 word \<times> 64 word) \<Rightarrow> 64 word llM" where [llvm_code]:
  "triple_sum abc \<equiv> doM {
    a \<leftarrow> ll_extract_fst abc;
    bc::64 word \<times> 64 word \<leftarrow> ll_extract_snd abc;
    b \<leftarrow> ll_extract_fst bc;
    c \<leftarrow> ll_extract_snd bc;
    r \<leftarrow> ll_add a b;
    r \<leftarrow> ll_add r c;
    return r
   }"

export_llvm triple_sum is \<open>_ triple_sum(triple)\<close>
  defines \<open>typedef struct {int64_t a; struct {int64_t b; int64_t c;};} triple;\<close>

end

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Strings\<close>
theory Strings
  imports Ordinals
begin

text \<open>Alphanumeric characters are encoded as ordinals. Strings are ordered tuples of
characters.\<close>

subsection \<open>Characters\<close>

ML \<open>
(*Use unary encoding for now; this can be swapped out for something more
  efficient later.*)
fun von_neumann i = funpow i (fn t => \<^const>\<open>succ\<close> $ t) \<^term>\<open>{}\<close>

val chars =
  ["0","1","2","3","4","5","6","7","8","9",
  "a","b","c","d","e","f","g","h","i","j", "k","l","m",
  "n","o","p","q","r","s","t","u","v","w","x","y","z",
  "A","B","C","D","E","F","G","H","I","J","K","L","M",
  "N","O","P","Q","R","S","T","U","V","W","X","Y","Z",
  "_","'"] ~~ map_range von_neumann 64
\<close>

local_setup \<open>
  let val transforms = chars |> map (fn (char, tm) =>
    let
      val name = "char'" ^ char ^ "'"
      val mx = "'''" ^ char ^ "''"
    in
      snd o Local_Theory.define (
        (Binding.qualified_name name, Mixfix.mixfix mx),
        ((Binding.qualified_name (name ^ "_def"), []), tm)
      )
    end)
  in foldl1 (op o) transforms end
\<close>

subsection \<open>Strings\<close>

definition string :: \<open>set \<Rightarrow> set\<close>
  where "string s \<equiv> s" \<comment>\<open>Wraps tuples of characters into strings.\<close>

text \<open>Strings should be opaque to the type derivator.\<close>

opaque "string"

syntax "_string" :: \<open>pttrn \<Rightarrow> set\<close> ("@_")

ML \<open>
  fun term_of_char c = case c of
      #"0" => \<^term>\<open>'0'\<close> | #"1" => \<^term>\<open>'1'\<close> | #"2" => \<^term>\<open>'2'\<close> | #"3" => \<^term>\<open>'3'\<close>
    | #"4" => \<^term>\<open>'4'\<close> | #"5" => \<^term>\<open>'5'\<close> | #"6" => \<^term>\<open>'6'\<close> | #"7" => \<^term>\<open>'7'\<close>
    | #"8" => \<^term>\<open>'8'\<close> | #"9" => \<^term>\<open>'9'\<close> | #"a" => \<^term>\<open>'a'\<close> | #"b" => \<^term>\<open>'b'\<close>
    | #"c" => \<^term>\<open>'c'\<close> | #"d" => \<^term>\<open>'d'\<close> | #"e" => \<^term>\<open>'e'\<close> | #"f" => \<^term>\<open>'f'\<close>
    | #"g" => \<^term>\<open>'g'\<close> | #"h" => \<^term>\<open>'h'\<close> | #"i" => \<^term>\<open>'i'\<close> | #"j" => \<^term>\<open>'j'\<close>
    | #"k" => \<^term>\<open>'k'\<close> | #"l" => \<^term>\<open>'l'\<close> | #"m" => \<^term>\<open>'m'\<close> | #"n" => \<^term>\<open>'n'\<close>
    | #"o" => \<^term>\<open>'o'\<close> | #"p" => \<^term>\<open>'p'\<close> | #"q" => \<^term>\<open>'q'\<close> | #"r" => \<^term>\<open>'r'\<close>
    | #"s" => \<^term>\<open>'s'\<close> | #"t" => \<^term>\<open>'t'\<close> | #"u" => \<^term>\<open>'u'\<close> | #"v" => \<^term>\<open>'v'\<close>
    | #"w" => \<^term>\<open>'w'\<close> | #"x" => \<^term>\<open>'x'\<close> | #"y" => \<^term>\<open>'y'\<close> | #"z" => \<^term>\<open>'z'\<close>
    | #"A" => \<^term>\<open>'A'\<close> | #"B" => \<^term>\<open>'B'\<close> | #"C" => \<^term>\<open>'C'\<close> | #"D" => \<^term>\<open>'D'\<close>
    | #"E" => \<^term>\<open>'E'\<close> | #"F" => \<^term>\<open>'F'\<close> | #"G" => \<^term>\<open>'G'\<close> | #"H" => \<^term>\<open>'H'\<close>
    | #"I" => \<^term>\<open>'I'\<close> | #"J" => \<^term>\<open>'J'\<close> | #"K" => \<^term>\<open>'K'\<close> | #"L" => \<^term>\<open>'L'\<close>
    | #"M" => \<^term>\<open>'M'\<close> | #"N" => \<^term>\<open>'N'\<close> | #"O" => \<^term>\<open>'O'\<close> | #"P" => \<^term>\<open>'P'\<close>
    | #"Q" => \<^term>\<open>'Q'\<close> | #"R" => \<^term>\<open>'R'\<close> | #"S" => \<^term>\<open>'S'\<close> | #"T" => \<^term>\<open>'T'\<close>
    | #"U" => \<^term>\<open>'U'\<close> | #"V" => \<^term>\<open>'V'\<close> | #"W" => \<^term>\<open>'W'\<close> | #"X" => \<^term>\<open>'X'\<close>
    | #"Y" => \<^term>\<open>'Y'\<close> | #"Z" => \<^term>\<open>'Z'\<close> | #"_" => \<^term>\<open>'_'\<close> | #"'" => \<^term>\<open>'''\<close>
    | _ => raise Match

  fun pairify s =
    (foldr1 (fn (t1, t2) => \<^const>\<open>pair\<close> $ t1 $ t2) (map term_of_char (String.explode s)))

  fun str_tr [(c as Const (\<^syntax_const>\<open>_constrain\<close>, _)) $ t $ u] =
        c $ (\<^const>\<open>string\<close> $ str_tr [t]) $ u
    | str_tr [t] =
        (case t of
          Free (s, _) => pairify s
        | Const ("_idtdummy", _) => error "Cannot begin string with underscore"
        | Const (s, _) => pairify s
        | _ => raise TERM ("str_tr", [t]))
    | str_tr ts = raise TERM ("str_tr", ts)

  fun tuple_to_string t =
    let
      fun char (Const (s, _)) =
            let
              val base_name = nth (space_explode "." s) 1
            in
              nth_string base_name 5
            end
        | char _ = raise Match

      (*
        Josh: Some issue I can't figure out: at the stage at which
        print_translation is called, the scope of \<open>pair\<close> hasn't been resolved
        fully, so using \<^const_name>\<open>pair\<close> fails in the code below.
      *)
      fun tuple_to_string (_ $ t $ ts) = (*Underscore should be \<open>pair\<close>!*)
            char t :: tuple_to_string ts
        | tuple_to_string t = [char t]
    in
      implode (
        case t of
          (*Underscore should be \<open>pair\<close>!*)
          (_ $ t $ ts) => char t :: tuple_to_string ts
        | _ => [char t])
    end

  fun str_tr' [] = Syntax.const \<^syntax_const>\<open>_string\<close>
    | str_tr' [t] = Syntax.const \<^syntax_const>\<open>_string\<close> $ Syntax.free (tuple_to_string t)
    | str_tr' ts = raise TERM ("str_tr'", ts)
\<close>

parse_translation \<open>[(\<^syntax_const>\<open>_string\<close>, K str_tr)]\<close>
print_translation \<open>[(\<^const_syntax>\<open>string\<close>, K str_tr')]\<close>

lemmas char_simps =
  char'0'_def char'1'_def char'2'_def char'3'_def char'4'_def char'5'_def char'6'_def
  char'7'_def char'8'_def char'9'_def char'a'_def char'b'_def char'c'_def char'd'_def
  char'e'_def char'f'_def char'g'_def char'h'_def char'i'_def char'j'_def char'k'_def
  char'l'_def char'm'_def char'n'_def char'o'_def char'p'_def char'q'_def char'r'_def
  char's'_def char't'_def char'u'_def char'v'_def char'w'_def char'x'_def char'y'_def
  char'z'_def char'A'_def char'B'_def char'C'_def char'D'_def char'E'_def char'F'_def
  char'G'_def char'H'_def char'I'_def char'J'_def char'K'_def char'L'_def char'M'_def
  char'N'_def char'O'_def char'P'_def char'Q'_def char'R'_def char'S'_def char'T'_def
  char'U'_def char'V'_def char'W'_def char'X'_def char'Y'_def char'Z'_def char'_'_def

text \<open>The following lemma is used to prove distinctness of non-identical strings.\<close>

lemma pair_ne_succ: "\<langle>a, b\<rangle> \<noteq> succ n" \<comment>\<open>Very encoding-dependent!\<close>
unfolding pair_def succ_def
proof
  let
    ?pair = "{{a}, {a, b}}"
  assume
    asm: "?pair = n \<union> {n}"
  then have
    "n \<in> ?pair"
    by auto
  hence
    "n = {a} \<or> n = {a, b}"
    by auto
  hence
    "a \<in> ?pair"
    by (auto simp: asm)
  thus False by auto
qed

lemmas succ_ne_pair = pair_ne_succ[symmetric]

subsection \<open>String Disequality\<close>

lemma False_if_ne_if_eq: "a = b \<Longrightarrow> a \<noteq> b \<Longrightarrow> False" by auto

lemma string_conj_simp [simp]:
  "\<lbrakk>string a \<noteq> string b; P\<rbrakk> \<Longrightarrow> string a \<noteq> string b \<and> P" ..

ML \<open>
  fun string_ne_tac ctxt =
    let
      val char_ne_word_tac = SUBGOAL (fn (_, i) =>
        rewrite_goal_tac ctxt @{thms char_simps} i
        THEN HEADGOAL (eresolve0_tac @{thms succ_ne_pair pair_ne_succ}))

      fun word_ne_tac i =
        let
          val char_ne_tac = SUBGOAL (fn (_, i) =>
            rewrite_goal_tac ctxt @{thms char_simps} i
            THEN REPEAT (HEADGOAL (dresolve0_tac @{thms succ_inj}))
            THEN HEADGOAL (eresolve0_tac @{thms False_if_ne_if_eq})
            THEN HEADGOAL (resolve0_tac @{thms succ_ne_empty succ_ne_empty[symmetric]}))

          val first_char_ne_tac =
            TRY o dresolve0_tac @{thms eq_if_pair_eq_left} THEN' char_ne_tac
        in
          REPEAT (CHANGED
            ((char_ne_word_tac
            ORELSE' first_char_ne_tac
            ORELSE' dresolve0_tac @{thms eq_if_pair_eq_right}) i))
        end
    in
      resolve_tac ctxt @{thms notI}
      THEN' rewrite_goal_tac ctxt @{thms string_def}
      THEN' word_ne_tac
    end

  val string_simp_solver = map_theory_simpset
    (fn ctxt => ctxt addSolver (mk_solver "distinguish strings" string_ne_tac))
\<close>

setup \<open>string_simp_solver\<close>

method_setup string_ne =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (
    (TRY o eresolve_tac ctxt @{thms False_if_ne_if_eq})
    THEN' string_ne_tac ctxt))\<close>

(* Example *)
notepad
begin
  have
    "@Alex \<noteq> @Josh" and
    "@abcd \<noteq> @asdf" and
    "@abcd \<noteq> @asdf" and
    "@abcdefg \<noteq> @asdfghj" and
    "@a10 \<noteq> @b_"
    by auto
end

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Memset
imports "../../AutoCorres"
begin

install_C_file "memset.c"

autocorres [
  heap_abs_syntax,
  no_heap_abs=memset,
  no_signed_word_abs=memset,
  unsigned_word_abs=memset] "memset.c"

lemma c_guard_word8_ptr [simp]:
     "c_guard (x :: word8 ptr) = (x \<noteq> NULL)"
  apply (clarsimp simp: c_guard_def ptr_aligned_def c_null_guard_def)
  apply (metis Ptr_ptr_val first_in_intvl intvl_Suc not_less_eq ptr_val.ptr_val_def)
  done

lemma to_bytes_word8 [simp]: "to_bytes (a :: word8) x = [a]"
  by (clarsimp simp: to_bytes_def typ_info_word word_rsplit_same)

lemma heap_update_list_id [simp]:
    "heap_update_list x [] = (\<lambda>x. x)"
  apply (rule ext)
  apply simp
  done

lemma heap_update_heap_update_list:
   "\<lbrakk> ptr_val p = q + (of_nat (length l)); Suc (length l) < addr_card \<rbrakk> \<Longrightarrow>
      heap_update (p :: word8 ptr) v (heap_update_list q l s) = (heap_update_list q (l @ [v]) s)"
  apply (rule ext)
  apply (clarsimp simp: heap_update_def unat_of_nat32
    addr_card word_bits_def fun_upd_def)
  apply (subst heap_update_list_value, clarsimp simp: addr_card)
  apply safe
   apply (subst if_P)
    apply (fastforce intro: intvlI)
   apply (clarsimp simp: unat_of_nat32 word_bits_def)
  apply (subst (1 2)  heap_update_list_value,
    simp add: addr_card,
    simp add: addr_card)
  apply (case_tac "x \<in> {q..+length l}")
   apply (subst if_P, simp)
   apply (subst if_P)
    apply clarsimp
    apply (metis (full_types) intvlD intvlI less_SucI)
   apply (subst nth_append, clarsimp)
   apply (metis (hide_lams, no_types) add_diff_cancel2 intvlD le_unat_uoi less_or_eq_imp_le not_le)
  apply clarsimp
  apply (metis intvlD intvlI less_antisym)
  done

lemma (in memset) memset:
  "\<forall>s\<^sub>0. \<lbrace> \<lambda>s. s = s\<^sub>0 \<and> n < addr_card \<and> 0 \<notin> {ptr_val p ..+ n} \<rbrace>
      memset' p c n
      \<lbrace> \<lambda>rv s. s = t_hrs_'_update (hrs_mem_update (
          heap_update_list (ptr_val p) (replicate n (scast c)))) s\<^sub>0 \<rbrace>!"
proof -
  {
     fix s0
     have "\<lbrace> \<lambda>s. s = s0 \<and> n < addr_card \<and> 0 \<notin> {ptr_val p ..+ n} \<rbrace>
                memset' p c n
          \<lbrace> \<lambda>rv s. s = t_hrs_'_update (hrs_mem_update
              (heap_update_list (ptr_val p) (replicate n (scast c)))) s0 \<rbrace>!"
      apply (rule validNF_assume_pre)
      apply (unfold memset'_def)
      apply (subst whileLoop_add_inv [where M="\<lambda>((d', n'), _). n'"
                and I="\<lambda>(d', n') s.
                   n' \<le> n \<and>
                   (n' \<le> n \<longrightarrow> d' = ptr_coerce p +\<^sub>p int (n - n')) \<and>
                   (n' \<le> n \<longrightarrow> s = t_hrs_'_update
                  (hrs_mem_update (heap_update_list (ptr_val p) (replicate (n - n') (scast c)))) s0)"])
      apply wp
        apply (clarsimp simp:)
        apply (intro conjI impI)
           apply arith
          apply (clarsimp simp: ptr_add_def)
         apply (rule globals.fold_congs, simp, simp)
         apply (clarsimp simp: hrs_mem_update_def)
         apply (subst heap_update_heap_update_list)
           apply (clarsimp simp: ptr_add_def)
          apply (clarsimp)
          apply arith
         apply (metis diff_Suc_diff_eq2 diff_diff_left minus_nat.diff_0 replicate_Suc_append)
        apply (clarsimp simp: ptr_add_def)
        apply (metis (hide_lams, no_types) add_less_cancel_right add.left_neutral intvl_inter_le le0 le_add_diff_inverse of_nat_diff semiring_1_class.of_nat_0)
       apply clarsimp
      apply (clarsimp simp: hrs_mem_update_def)
      done
  }

  thus ?thesis
    by simp
qed

lemma word_rsplit_sword_0 [simp]:
  "word_rsplit (0 :: sword32) = [0, 0, 0, 0 :: word8]"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma heap_update_zero_node:
    "heap_update_list p [0, 0, 0, 0, 0, 0, 0, 0] = heap_update (Ptr p) (node_C NULL 0)"
  apply (rule ext)
  apply (clarsimp simp: heap_update_def to_bytes_def)
  apply (subst packed_type_access_ti)
  apply (clarsimp simp: access_ti\<^sub>0_def)
   apply clarsimp
  apply (clarsimp simp: to_bytes_def to_bytes_p_def node_C_tag_def node_C_typ_tag)
  apply (subst final_pad_def)
  apply (clarsimp simp: typ_info_word size_td_lt_ti_typ_pad_combine Let_def padup_def)
  apply (clarsimp simp: ti_typ_pad_combine_def)
  apply (clarsimp simp: ti_typ_combine_def empty_typ_info_def  typ_info_ptr typ_info_word word_rsplit_0)
  done

lemma (in memset) is_valid_node_C_non_NULL [simp]:
    "is_valid_node_C (lift_global_heap s) p \<Longrightarrow> 0 \<notin> {ptr_val p ..+ 8}"
  by (auto dest: simple_lift_c_guard simp:
        lift_global_heap_def c_guard_def c_null_guard_def)

lemma (in memset) zero_node:
  "\<forall>s\<^sub>0. \<lbrace> \<lambda>s. is_valid_node_C s p \<and> s = s\<^sub>0\<rbrace> zero_node' p \<lbrace> \<lambda>rv s. s = s\<^sub>0[p := (node_C NULL 0) ] \<rbrace>! "
  apply (clarsimp simp: zero_node'_def)
  apply (wp add: memset [THEN validNF_make_schematic_post, simplified])
  apply (fastforce dest: simple_lift_c_guard simp: addr_card lift_global_heap_def
          heap_update_zero_node memset.update_node_def typ_simple_heap_simps
          fun_upd_def)
  done

end


theory outFlashData

imports Data_inc
begin

typedef outFlash="{cout,cintern}"
  by auto

instance outFlash::finite
  apply (intro_classes)
  using type_definition.Abs_image type_definition_outFlash typedef_finite_UNIV by fastforce

instantiation outFlash::somechan
begin
definition Rep_outFlash_def: "Rep = Rep_outFlash"

lemma repand_range[simp]: "range (Rep::outFlash \<Rightarrow> channel) = {cout,cintern}"
  apply(subst Rep_outFlash_def)
  using type_definition.Rep_range type_definition_outFlash by fastforce

instance
  apply(intro_classes)
  apply clarsimp
  unfolding Rep_outFlash_def by (meson Rep_outFlash_inject injI)
end

lemma outFlash_chdom[simp]: "chDom TYPE (outFlash) = {cout,cintern}"
  by (simp add: somechandom)

section \<open>Constructors\<close>

definition "Flashout \<equiv> Abs_outFlash cout"
definition "Flashin2 \<equiv> Abs_outFlash cintern"

free_constructors outFlash for Flashout | Flashin2
  apply auto?  (* TODO: kann man das "auto" entfernen? *)
  unfolding Flashout_def Flashin2_def
  apply (metis Rep_outFlash Rep_outFlash_inverse empty_iff insert_iff)
  apply (simp add: Abs_outFlash_inject)?
  done

lemma flashout_rep [simp]: "Rep Flashout = cout"
  unfolding Rep_outFlash_def Flashout_def
  by (simp add: Abs_outFlash_inverse)

lemma flashin2_rep [simp]: "Rep Flashin2 = cintern"
  unfolding Rep_outFlash_def Flashin2_def
  by (simp add: Abs_outFlash_inverse)

section \<open>Preperation for locale instantiation\<close>

(* Tuple:
      1. Value should go to port c1. It is of type "bool"
      2. Value should go to port c2. It is of type "bool"
*)

(* The first parameter is the converter from user-type (here bool) to "M"

  for every type in the tuple such a function must be in the parameter. So if the tuple
  would consist of (nat\<times>bool) there are 2 converters required *)

fun outFlashChan::"('bool \<Rightarrow> 'a) \<Rightarrow> ('bool\<times>'bool) \<Rightarrow> outFlash \<Rightarrow> 'a" where
"outFlashChan boolConv  (port_c1,   _    ) Flashout = boolConv port_c1" |
"outFlashChan boolConv  (   _   , port_c2) Flashin2 = boolConv port_c2"

(* Helper Function for lemmata (mostly surj). Should be hidden from the user! *)
definition outFlashChan_inv::"('bool \<Rightarrow> 'a) \<Rightarrow> (outFlash \<Rightarrow> 'a) \<Rightarrow> ('bool\<times>'bool)" where
"outFlashChan_inv boolConv f = ((inv boolConv) (f Flashout), (inv boolConv) (f Flashin2))"

lemma outFlashChan_surj_helper:
    assumes "f Flashout \<in> range boolConv"
        and "f Flashin2 \<in> range boolConv"
  shows "outFlashChan boolConv (outFlashChan_inv boolConv f) = f"
  unfolding outFlashChan_inv_def
  apply(rule ext, rename_tac "c")
  apply(case_tac c; simp)
  by (auto simp add: assms f_inv_into_f)

lemma outFlashChan_surj:
    assumes "f Flashout \<in> range boolConv"
        and "f Flashin2 \<in> range boolConv"
      shows "f \<in> range (outFlashChan boolConv)"
  by (metis UNIV_I image_iff assms outFlashChan_surj_helper)

lemma outFlashChan_inj: assumes "inj boolConv"
  shows "inj (outFlashChan boolConv)"
  apply (auto simp add: inj_def)
   by (metis assms outFlashChan.simps injD)+

subsection \<open>SBE\<close>
(* Dieses Beispiel ist zeitsychron, daher das "Tsyn" *)
abbreviation "buildFlashOutSBE \<equiv> outFlashChan (Tsyn o map_option \<B>)"
(* Die Signatur lautet: "bool option \<times> bool option \<Rightarrow> outFlash \<Rightarrow> M"
    Das "option" kommt aus der Zeit. "None" = keine Nachricht *)

lemma buildflashout_ctype: "buildFlashOutSBE a c \<in> ctype (Rep c)"
  apply(cases c; cases a)
  by(auto simp add: ctype_def)

lemma buildflashout_inj: "inj buildFlashOutSBE"
  apply(rule outFlashChan_inj)
  by simp

lemma buildflashout_range: "range (\<lambda>a. buildFlashOutSBE a c) = ctype (Rep c)"
  apply(cases c)
  apply(auto simp add: image_iff ctype_def)
  by (metis option.simps(9))+

lemma buildflashout_surj: assumes "\<And>c. sbe c \<in> ctype (Rep c)"
  shows "sbe \<in> range buildFlashOutSBE"
  apply(rule outFlashChan_surj)
  apply (metis flashout_rep assms rangecout) (* Die metis-Sachen kann man bestimmt in einen 1-Zeiler umwandeln *)
  by (metis flashin2_rep assms rangecintern)

interpretation andInSBE: sbeGen "buildFlashOutSBE"
  apply(unfold_locales)
  apply(simp add: buildflashout_ctype)
  apply (simp add: buildflashout_inj)
  apply (simp add: buildflashout_surj)
  by simp

subsection \<open>SB\<close>

abbreviation "buildFlashOutSB \<equiv> outFlashChan (Rep_cfun (smap (Tsyn o map_option \<B>)))"

lemma buildflashoutsb_ctype: "sValues\<cdot>(buildFlashOutSB a c) \<subseteq> ctype (Rep c)"
  apply(cases c; cases a)
  by (auto simp add: ctype_def smap_sValues)

lemma buildflashoutsb_inj: "inj buildFlashOutSB"
  apply(rule outFlashChan_inj, rule smap_inj)
  by (simp)

lemma smap_rang2values: assumes "sValues\<cdot>s \<subseteq> range f"
    shows "s \<in> range (Rep_cfun (smap f))"
  using assms smap_well by force

lemma buildflashoutsb_surj: assumes "sb_well sb"
  shows "sb \<in> range buildFlashOutSB"
  apply(rule outFlashChan_surj; rule smap_rang2values; rule sbwellD)
  apply (simp_all add: assms)
  using rangecout apply simp
  using rangecintern apply simp
  done

interpretation andInSB: sbGen "buildFlashOutSB"
  apply(unfold_locales)
  apply (simp add: buildflashoutsb_ctype)
  apply (simp add: buildflashoutsb_inj)
  by (simp add: buildflashoutsb_surj)

end


(*  Title:      HOL/Auth/n_german_on_inis.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_on_inis imports n_german_on_ini
begin
lemma on_inis:
  assumes b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  shows "formEval f s"
  proof -
  have c1: "(f=inv__1  )\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__2  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__3  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__4  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__5  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__6  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__7  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__8  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__9  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__10  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__11  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__12  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__13  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__14  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__15  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__16  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__17  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__19  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__20  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__21  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__22  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__23  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__24  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__25  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__26  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__27  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__29  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__30  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__31  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__32  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__33  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__34  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__35  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__36  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__37  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__38  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__39  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__40  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__41  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__42  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__43  p__Inv2)\<or>
    (\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__44  p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__45  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__46  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__47  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__48  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__49  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__50  p__Inv1 p__Inv2)\<or>
    (\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
  apply (cut_tac b1, simp) done
    moreover {
      assume d1: "(f=inv__1  )"
      have "formEval f s"
      apply (rule iniImply_inv__1)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__2  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__2)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__3  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__3)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__4  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__4)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__5  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__5)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__6  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__6)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__7  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__7)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__8  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__8)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__9  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__9)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__10  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__10)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__11  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__11)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__12  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__12)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__13  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__13)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__14  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__14)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__15  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__15)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__16  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__16)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__17  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__17)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__18  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__18)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__19  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__19)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__20  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__20)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__21  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__21)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__22  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__22)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__23  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__23)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__24  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__24)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__25  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__25)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__26  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__26)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__27  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__27)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__28  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__28)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__29  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__29)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__30  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__30)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__31  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__31)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__32  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__32)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__33  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__33)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__34  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__34)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__35  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__35)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__36  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__36)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__37  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__37)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__38  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__38)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__39  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__39)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__40  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__40)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__41  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__41)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__42  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__42)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__43  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__43)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__44  p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__44)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__45  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__45)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__46  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__46)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__47  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__47)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__48  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__48)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__49  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__49)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__50  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__50)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__51  p__Inv1 p__Inv2)"
      have "formEval f s"
      apply (rule iniImply_inv__51)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

  ultimately show "formEval f s"
  by satx
qed

end