(* simple_language.thy *)
(* William Mansky *)
(* A simple concurrent language. *)

theory simple_language
imports trans_flowgraph
begin

(* Syntax *)
datatype 'var expr = Num int | Var 'var | Plus "'var expr" "'var expr" (infixl "+L" 104)
 | Eq "'var expr" "'var expr" (infix "===" 103)
(* Do we need wait for anything? *)
datatype ('var, 'expr) instr = assign 'var 'expr (infixr "\<leftarrow>" 101) | wait 'expr | branchifz 'expr
 | branch | lock 'var | unlock 'var

(* Free variables *)
primrec expr_fv where
"expr_fv (Num i) = {}" |
"expr_fv (Var x) = {x}" |
"expr_fv (e +L e') = expr_fv e \<union> expr_fv e'" |
"expr_fv (e === e') = expr_fv e \<union> expr_fv e'"
lemma finite_expr_fv [simp]: "finite (expr_fv e)"
by (induct e, auto)
corollary finite_expr_pattern_fv [simp]: "finite (expr_pattern_fv expr_fv e)"
by (case_tac e, auto)

primrec instr_fv where
"instr_fv (x \<leftarrow> e) = insert x (expr_fv e)" |
"instr_fv (wait e) = expr_fv e" |
"instr_fv (branchifz e) = expr_fv e" |
"instr_fv branch = {}" |
"instr_fv (lock x) = {x}" |
"instr_fv (unlock x) = {x}"

(* Instruction patterns for use in specifications. *)
type_synonym 'mvar pattern = "(('mvar, ('mvar, 'mvar expr) expr_pattern) instr, 'mvar) literal"

primrec instr_pattern_fv where
"instr_pattern_fv (x \<leftarrow> e) = insert x (expr_pattern_fv expr_fv e)" |
"instr_pattern_fv (wait e) = expr_pattern_fv expr_fv e" |
"instr_pattern_fv (branchifz e) = expr_pattern_fv expr_fv e" |
"instr_pattern_fv branch = {}" |
"instr_pattern_fv (lock x) = {x}" |
"instr_pattern_fv (unlock x) = {x}"
lemma finite_instr_pattern_fv [simp]: "finite (instr_pattern_fv i)"
by (induct i, auto)

abbreviation pattern_fv::"'mvar pattern \<Rightarrow> 'mvar set" where
"pattern_fv p \<equiv> lit_fv instr_pattern_fv p"

lemma finite_pattern_fv [simp]: "finite (pattern_fv p)"
by (case_tac p, auto)

(* Applying a valuation of metavariables to an expression pattern yields a concrete expression. *)
primrec expr_subst where
"expr_subst \<sigma> (Num i) = Some (Num i)" |
"expr_subst \<sigma> (Var x) = (case \<sigma> x of OExpr e \<Rightarrow> Some e | _ \<Rightarrow> None)" |
"expr_subst \<sigma> (a +L b) = (case (expr_subst \<sigma> a, expr_subst \<sigma> b) of
  (Some a', Some b') \<Rightarrow> Some (a' +L b') | _ \<Rightarrow> None)" |
"expr_subst \<sigma> (a === b) = (case (expr_subst \<sigma> a, expr_subst \<sigma> b) of
 (Some a', Some b') \<Rightarrow> Some (a' === b') | _ \<Rightarrow> None)"

lemma expr_fv_finite [simp]: "finite (expr_fv e)"
by (induct e, auto)

lemma expr_same_subst: "\<forall>v\<in>expr_fv e. \<sigma> v = \<sigma>' v \<Longrightarrow>
 expr_subst \<sigma> e = expr_subst \<sigma>' e"
by (induct e, auto)

lemma self_subst: "expr_subst (\<lambda>y. OExpr (Var y)) e = Some e"
by (induct e, auto)

corollary subst_out: "\<forall>v\<in>expr_fv e. \<sigma> v = OExpr (Var v) \<Longrightarrow> expr_subst \<sigma> e = Some e"
by (rule trans, rule expr_same_subst, auto simp add: self_subst)

lemma sub_out: "\<lbrakk>v \<in> expr_fv e; v' \<notin> expr_fv e\<rbrakk> \<Longrightarrow> \<exists>e'.
 expr_subst ((\<lambda>y. OExpr (Var y))(v := OExpr (Var v'))) e = Some e' \<and>
 expr_subst ((\<lambda>y. OExpr (Var y))(v' := OExpr (Var v))) e' = Some e"
apply (induct e, simp+)
apply (case_tac "v \<in> expr_fv e1", clarsimp)
apply (case_tac "v \<in> expr_fv e2", clarsimp+)
apply (cut_tac e=e2 and \<sigma>="(\<lambda>y. OExpr (Var y))(v := OExpr (Var v'))" in subst_out, simp+)
apply (cut_tac e=e2 and \<sigma>="(\<lambda>y. OExpr (Var y))(v' := OExpr (Var v))" in subst_out, simp+)
apply (rule_tac x="e' +L e2" in exI, simp)
apply (rule conjI)
apply (rule trans, erule option.weak_case_cong, simp+)+
apply clarsimp
apply (cut_tac e=e1 and \<sigma>="(\<lambda>y. OExpr (Var y))(v := OExpr (Var v'))" in subst_out, simp+)
apply (cut_tac e=e1 and \<sigma>="(\<lambda>y. OExpr (Var y))(v' := OExpr (Var v))" in subst_out, simp+)
apply (rule_tac x="e1 +L e'" in exI, simp)
apply (rule conjI)
apply (rule trans, erule option.weak_case_cong, simp+)+
apply clarsimp
apply (case_tac "v \<in> expr_fv e1", clarsimp)
apply (case_tac "v \<in> expr_fv e2", clarsimp+)
apply (cut_tac e=e2 and \<sigma>="(\<lambda>y. OExpr (Var y))(v := OExpr (Var v'))" in subst_out, simp+)
apply (cut_tac e=e2 and \<sigma>="(\<lambda>y. OExpr (Var y))(v' := OExpr (Var v))" in subst_out, simp+)
apply (rule_tac x="e' === e2" in exI, simp)
apply (rule conjI)
apply (rule trans, erule option.weak_case_cong, simp+)+
apply clarsimp
apply (cut_tac e=e1 and \<sigma>="(\<lambda>y. OExpr (Var y))(v := OExpr (Var v'))" in subst_out, simp+)
apply (cut_tac e=e1 and \<sigma>="(\<lambda>y. OExpr (Var y))(v' := OExpr (Var v))" in subst_out, simp+)
apply (rule_tac x="e1 === e'" in exI, simp)
apply (rule conjI)
apply (rule trans, erule option.weak_case_cong, simp+)+
done

primrec expr_pattern_subst :: "('mvar \<Rightarrow> ('thread, 'node, 'var expr, 'instr) object) \<Rightarrow>
 ('mvar, 'mvar expr) expr_pattern \<Rightarrow> 'var expr option"  where
"expr_pattern_subst \<sigma> (EPInj e) = expr_subst \<sigma> e" |
"expr_pattern_subst \<sigma> (x<e>) = (case (\<sigma> x, expr_subst \<sigma> e) of
 (OSynFunc (Var x) e, Some e') \<Rightarrow> expr_subst ((\<lambda>y. OExpr (Var y))
 (x := (OExpr e')::('thread, 'node, 'var expr, 'instr) object)) e | _ \<Rightarrow> None)"
(* Isabelle note: this lengthy type annotation is necessary because OExpr e', in itself,
   is of type (?, ?, expr, ?) object.  We need to identify the missing types with existing
   type variables, or they'll be introduced as separate variables. *)

lemma expr_pattern_fv_finite [simp]: "finite (expr_pattern_fv expr_fv e)"
by (induct e, auto)

lemma expr_pattern_same_subst: "\<forall>v\<in>expr_pattern_fv expr_fv e. \<sigma> v = \<sigma>' v \<Longrightarrow>
 expr_pattern_subst \<sigma> e = expr_pattern_subst \<sigma>' e"
apply (induct e, auto simp add: expr_same_subst)
apply (case_tac "\<sigma>' mvar", simp_all)
apply (case_tac expr1, simp_all)
apply (drule expr_same_subst, simp)
done

(* Similarly, applying a valuation of metavariables to an instruction pattern yields a concrete instruction. *)
primrec instr_subst where
"instr_subst \<sigma> (x \<leftarrow> e) = (case (\<sigma> x, expr_pattern_subst \<sigma> e) of
  (OExpr (Var y), Some e') \<Rightarrow> Some (y \<leftarrow> e') | _ \<Rightarrow> None)" |
"instr_subst \<sigma> (wait e) = (case expr_pattern_subst \<sigma> e of
  Some e' \<Rightarrow> Some (wait e') | _ \<Rightarrow> None)" |
"instr_subst \<sigma> (branchifz e) = (case expr_pattern_subst \<sigma> e of
  Some e' \<Rightarrow> Some (branchifz e') | _ \<Rightarrow> None)" |
"instr_subst _ branch = Some branch" |
"instr_subst \<sigma> (lock x) = (case \<sigma> x of OExpr (Var y) \<Rightarrow> Some (lock y) | _ \<Rightarrow> None)" |
"instr_subst \<sigma> (unlock x) = (case \<sigma> x of OExpr (Var y) \<Rightarrow> Some (unlock y) | _ \<Rightarrow> None)"

primrec subst where
"subst \<sigma> (Inj i) = instr_subst \<sigma> i" |
"subst \<sigma> (MVar x) = (case \<sigma> x of OInstr i \<Rightarrow> Some i)"

(* Utility functions for analysis of expressions. *)

primrec is_const where
"is_const (Num _) = True" |
"is_const (_ +L _) = False" |
"is_const (Var _) = False" |
"is_const (_ === _) = False"

primrec is_var where
"is_var (Num _) = False" |
"is_var (_ +L _) = False" |
"is_var (Var _) = True" |
"is_var (_ === _) = False"

(* Semantics on CFGs *)
primrec instr_edges where
"instr_edges (x \<leftarrow> e) = {\<lambda>t. case t of Seq \<Rightarrow> 1 | Branch \<Rightarrow> 0}" |
"instr_edges (wait e) = {\<lambda>t. case t of Seq \<Rightarrow> 1 | Branch \<Rightarrow> 0}" |
"instr_edges (branchifz e) = {\<lambda>t. case t of Seq \<Rightarrow> 1 | Branch \<Rightarrow> 1}" |
"instr_edges branch = {\<lambda>t. case t of Seq \<Rightarrow> 0 | Branch \<Rightarrow> 1}" |
"instr_edges (lock x) = {\<lambda>t. case t of Seq \<Rightarrow> 1 | Branch \<Rightarrow> 0}" |
"instr_edges (unlock x) = {\<lambda>t. case t of Seq \<Rightarrow> 1 | Branch \<Rightarrow> 0}"

definition "empty_env \<equiv> \<lambda>x. 0"

primrec eval where
"eval env (Num i) = i" |
"eval env (Var x) = env x" |
"eval env (e +L e') = eval env e + eval env e'" |
"eval env (e === e') = (if eval env e = eval env e' then 1 else 0)"

lemma eval_same: "\<forall>x\<in>expr_fv e. env x = env' x \<Longrightarrow> eval env e = eval env' e"
by (induct e, auto)

lemma eval_subst: "\<lbrakk>eval env y = eval env' y'; expr_subst (\<sigma>(x := OExpr (Var x))) e = Some e';
 \<forall>x\<in>expr_fv e'. env x = env' x;
 expr_subst (\<sigma>(x := OExpr y)) e = Some a; expr_subst (\<sigma>(x := OExpr y')) e = Some a'\<rbrakk> \<Longrightarrow>
 eval env a = eval env' a'"
apply (induct e arbitrary: e' a a', auto)
apply (case_tac "var = x", simp_all)
apply (case_tac "\<sigma> var", simp_all, erule eval_same)
apply (case_tac "expr_subst (\<sigma>(x := OExpr (Var x))) e1", simp+, case_tac "expr_subst (\<sigma>(x := OExpr (Var x))) e2", simp+)
apply (case_tac "expr_subst (\<sigma>(x := OExpr y)) e1", simp+, case_tac "expr_subst (\<sigma>(x := OExpr y)) e2", simp+)
apply (case_tac "expr_subst (\<sigma>(x := OExpr y')) e1", simp+, case_tac "expr_subst (\<sigma>(x := OExpr y')) e2", simp+)
apply clarsimp
apply (case_tac "expr_subst (\<sigma>(x := OExpr (Var x))) e1", simp+, case_tac "expr_subst (\<sigma>(x := OExpr (Var x))) e2", simp+)
apply (case_tac "expr_subst (\<sigma>(x := OExpr y)) e1", simp+, case_tac "expr_subst (\<sigma>(x := OExpr y)) e2", simp+)
apply (case_tac "expr_subst (\<sigma>(x := OExpr y')) e1", simp+, case_tac "expr_subst (\<sigma>(x := OExpr y')) e2", simp+)
apply clarsimp
done

locale simple_flowgraph = flowgraph where
 instr_edges="instr_edges::(string, string expr) instr \<Rightarrow> (edge_type \<Rightarrow> nat) set"
begin

definition "next_seq p \<equiv> SOME p'. p' \<in> out_by_t Edges Seq p"
definition "next_branch p \<equiv> SOME p'. p' \<in> out_by_t Edges Branch p"

lemma start_seq_correct: "(Start, next_seq Start, Seq) \<in> Edges"
apply (simp add: next_seq_def, cut_tac P="\<lambda>p'. p' \<in> out_by_t Edges Seq Start" in someI_ex,
 auto simp add: out_by_t_def)
apply (rule has_start)
done

lemma next_seq_correct: "\<lbrakk>p \<in> Nodes; p \<noteq> Exit; L p \<noteq> branch\<rbrakk> \<Longrightarrow> (p, next_seq p, Seq) \<in> Edges"
apply (simp add: next_seq_def, cut_tac P="\<lambda>p'. p' \<in> out_by_t Edges Seq p" in someI_ex,
 auto simp add: out_by_t_def)
apply (case_tac "p = Start", simp add: has_start)
apply (drule instr_edges_ok, simp+)
apply (case_tac "L p", simp_all)
apply (simp add: unique_seq, simp add: out_edges_def, force)+
apply (simp add: unique_pair, simp add: out_edges_def, force)
apply (simp add: unique_seq, simp add: out_edges_def, force)+
done

lemma next_seq_out: "\<lbrakk>p \<in> Nodes; p \<noteq> Exit; L p \<noteq> branch\<rbrakk> \<Longrightarrow> (next_seq p, Seq) \<in> out_edges Edges p"
by (simp add: out_edges_def next_seq_correct)

lemma next_branch_correct: "\<lbrakk>p \<in> Nodes; p \<noteq> Start; p \<noteq> Exit; L p = branch \<or> (\<exists>e. L p = branchifz e)\<rbrakk> \<Longrightarrow>
 (p, next_branch p, Branch) \<in> Edges"
apply (simp add: next_branch_def, cut_tac P="\<lambda>p'. p' \<in> out_by_t Edges Branch p" in someI_ex,
 auto simp add: out_by_t_def)
apply (drule instr_edges_ok, simp+, simp add: unique_branch, simp add: out_edges_def, force)
apply (drule instr_edges_ok, simp+, simp add: unique_pair, simp add: out_edges_def, force)
done

lemma next_branch_out: "\<lbrakk>p \<in> Nodes; p \<noteq> Start; p \<noteq> Exit; L p = branch \<or> (\<exists>e. L p = branchifz e)\<rbrakk> \<Longrightarrow>
 (next_branch p, Branch) \<in> out_edges Edges p"
by (simp add: out_edges_def next_branch_correct)

(* At first pass, all vars are global. *)
(* Semantics of a single thread *)
fun step_one_thread where
"step_one_thread p env =
 (if p = Start then (next_seq p, []) else
  if p = Exit then (p, []) (* unless we want to terminate? *) else case L p of
    x \<leftarrow> e \<Rightarrow> (next_seq p, [(x, eval env e)])
  | wait e \<Rightarrow> if eval env e = 0 then (p, []) else (next_seq p, [])
  | branchifz e \<Rightarrow> if eval env e = 0 then (next_branch p, []) else (next_seq p, [])
  | branch \<Rightarrow> (next_branch p, [])
  | lock x \<Rightarrow> if env x = 0 then (next_seq p, [(x, 1)]) else (p, [])
  | unlock x \<Rightarrow> if env x = 1 then (next_seq p, [(x, 0)]) else (p, []))"

end

term simple_flowgraph.step_one_thread
abbreviation "step_one_thread G \<equiv>
 simple_flowgraph.step_one_thread (Edges G) (Start G) (Exit G) (Label G)"
lemmas step_one_thread_simps = simple_flowgraph.step_one_thread.simps

lemma is_simple_flowgraph [simp]: "is_flowgraph G instr_edges =
 simple_flowgraph (Nodes G) (Edges G) (Start G) (Exit G) (Label G)"
by (auto simp add: is_flowgraph_def simple_flowgraph_def flowgraph_def is_doubly_pointed_graph_def)

lemma step_same_step: "\<lbrakk>\<forall>x. env x = env' x \<or> (\<forall>n \<in> Nodes G. x \<notin> instr_fv (Label G n));
 is_flowgraph G instr_edges; p \<in> Nodes G\<rbrakk> \<Longrightarrow> step_one_thread G p env = step_one_thread G p env'"
apply (clarsimp simp add: simple_flowgraph.step_one_thread.simps)
apply (case_tac "Label G p", simp_all)
apply (rule eval_same, force)
apply (cut_tac e=expr and env=env and env'=env' in eval_same, force, simp)
apply (cut_tac e=expr and env=env and env'=env' in eval_same, force, simp)
apply force+
done

(* Semantics of an entire tCFG, with true concurrency. *)
definition "update_map env changes \<equiv> \<lambda>x. case changes x of Some v \<Rightarrow> v | None \<Rightarrow> env x"

lemma update_map_in [simp]: "change_map x = Some v \<Longrightarrow> update_map env change_map x = v"
by (simp add: update_map_def)

lemma update_map_out [simp]: "change_map x = None \<Longrightarrow> update_map env change_map x = env x"
by (simp add: update_map_def)

lemma update_map_change [dest!]: "update_map env change_map x \<noteq> update_map env' change_map x \<Longrightarrow>
 change_map x = None \<and> env x \<noteq> env' x"
by (simp add: update_map_def split: option.splits)

lemma update_case1 [simp]: "P x \<Longrightarrow>
 update_map m (\<lambda>x. if P x then m1 x else m2 x) x = update_map m m1 x"
by (simp add: update_map_def)

lemma update_case2 [simp]: "\<not>P x \<Longrightarrow>
 update_map m (\<lambda>x. if P x then m1 x else m2 x) x = update_map m m2 x"
by (simp add: update_map_def)

lemma update_same: "\<lbrakk>update_map m m1 = update_map m m2; m x = m' x\<rbrakk> \<Longrightarrow>
 update_map m' m1 x = update_map m m2 x"
apply (drule_tac x=x in fun_cong)
apply (case_tac "m1 x", simp+)
done

lemma update_same_x: "\<lbrakk>update_map m m1 x = update_map m m2 x; m x = m' x\<rbrakk> \<Longrightarrow>
 update_map m' m1 x = update_map m m2 x"
by (case_tac "m1 x", simp+)

inductive step where
step [intro]: "\<lbrakk>\<forall>t\<in>ts. \<exists>G n. CFGs t = Some G \<and> ps t = Some n \<and>
 (\<exists>n' change. step_one_thread G n env = (n', change) \<and> changes t = change \<and> ps' t = Some n' \<and>
  (\<forall>x. Label G n = lock x \<and> n' \<noteq> n \<longrightarrow> locker x = t));
 \<forall>t. t \<notin> ts \<longrightarrow> ps' t = ps t \<and> changes t = [];
(* If a change is added, it was taken from some thread's step. *)
 \<forall>x v. change_map x = Some v \<longrightarrow> (\<exists>t. (x, v) \<in> set (changes t));
(* If a variable was changed by some thread, it will be changed in the environment
   (but not necessarily by that thread). *)
 \<forall>x v t. (x, v) \<in> set (changes t) \<longrightarrow> (\<exists>v'. change_map x = Some v');
 env' = update_map env change_map\<rbrakk> \<Longrightarrow>
 step CFGs (env, ps) (env', ps')"

(* We can eliminate the set ts. *)
inductive step' where
step' [intro]: "\<lbrakk>\<forall>t. (\<exists>G n. CFGs t = Some G \<and> ps t = Some n \<and>
 (\<exists>n' change. step_one_thread G n env = (n', change) \<and> changes t = change \<and> ps' t = Some n' \<and>
  (\<forall>x. Label G n = lock x \<and> n' \<noteq> n \<longrightarrow> locker x = t))) \<or> (ps' t = ps t \<and> changes t = []);
(* If a change is added, it was taken from some thread's step. *)
 \<forall>x v. change_map x = Some v \<longrightarrow> (\<exists>t. (x, v) \<in> set (changes t));
(* If a variable was changed by some thread, it will be changed in the environment
   (but not necessarily by that thread). *)
 \<forall>x v t. (x, v) \<in> set (changes t) \<longrightarrow> (\<exists>v'. change_map x = Some v');
 env' = update_map env change_map\<rbrakk> \<Longrightarrow>
 step' CFGs (env, ps) (env', ps')"

lemma step_step': "step = step'"
apply (rule ext)+
apply (rule iffI)
apply (erule step.cases, clarsimp, rule_tac locker=locker in step', simp_all, clarsimp)
apply (erule_tac x=t in ballE, clarsimp+)
apply (erule step'.cases, clarsimp, rule_tac locker=locker and ts="{t. ps' t \<noteq> ps t \<or> changes t \<noteq> []}" in step,
 simp_all, clarsimp)
apply (erule_tac x=t in allE, clarsimp)
done

inductive step_star where
step_star_refl [simp]: "step_star CFGs C C" |
step_star_trans: "\<lbrakk>step CFGs C C'; step_star CFGs C' C''\<rbrakk> \<Longrightarrow> step_star CFGs C C''"

lemma step_star_trans_gen: "\<lbrakk>step_star CFGs C C'; step_star CFGs C' C''\<rbrakk> \<Longrightarrow>
 step_star CFGs C C''"
apply (induct rule: step_star.induct, auto)
apply (rule step_star_trans, simp+)
done

lemma step_star_write [rule_format]: "\<lbrakk>step_star CFGs C C'\<rbrakk> \<Longrightarrow>
 fst C x \<noteq> fst C' x \<longrightarrow> (\<exists>env'' ps'' t G n. step_star CFGs C (env'', ps'') \<and> step_star CFGs (env'', ps'') C' \<and>
 CFGs t = Some G \<and> ps'' t = Some n \<and> (x, fst C' x) \<in> set (snd (step_one_thread G n env'')))"
apply (induct rule: step_star.induct, simp, clarsimp)
apply (case_tac "aa x \<noteq> ab x", clarsimp)
apply (rule_tac x=env'' in exI, rule_tac x=ps'' in exI, simp, rule conjI)
apply (rule step_star_trans, simp+)
apply force
apply (rule step.cases, simp, clarsimp)
apply (case_tac "change_map x", simp+)
apply (erule_tac x=x and P="\<lambda>x. \<forall>v. change_map x = Some v \<longrightarrow> (\<exists>t. (x, v) \<in> set (changes t))" in allE,
 clarsimp)
apply (erule_tac x=t in ballE, clarsimp)
apply (rule_tac x=env in exI, rule_tac x=ps in exI, simp)
apply (rule conjI, rule step_star_trans, simp+)
apply (rule_tac x=t in exI, simp+)
done

lemma same_safe [simp]: "\<lbrakk>CFGs t = Some G; Nodes G' = Nodes G\<rbrakk> \<Longrightarrow> safe_points (CFGs(t \<mapsto> G')) = safe_points CFGs"
apply (rule ext, simp add: safe_points_def, rule iffI, clarsimp)
apply (erule_tac x=ta in allE, clarsimp+)
apply force
done

lemma step_along_edge: "\<lbrakk>is_flowgraph G instr_edges; n \<in> Nodes G;
 step_one_thread G n env = (n', change); n' \<noteq> n\<rbrakk> \<Longrightarrow>  \<exists>e. (n, n', e) \<in> Edges G"
apply (simp add: step_one_thread_simps)
(* Start *)
apply (case_tac "n = Start G", auto simp add: flowgraph_def flowgraph_axioms_def)
apply (cut_tac Edges="Edges G" in simple_flowgraph.start_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Exit *)
apply (case_tac "n = Exit G", auto)
apply (case_tac "Label G n", auto)
(* Assign *)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Wait *)
apply (case_tac "eval env expr = 0", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Branchifz *)
apply (case_tac "eval env expr = 0", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_branch_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Branch *)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_branch_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Lock *)
apply (case_tac "env var = 0", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Unlock *)
apply (case_tac "env var = 1", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
done

lemma step_along_edge2: "\<lbrakk>is_flowgraph G instr_edges; n \<in> Nodes G;
 step_one_thread G n env = (n', change); change \<noteq> []\<rbrakk> \<Longrightarrow>  \<exists>e. (n, n', e) \<in> Edges G"
apply (simp add: step_one_thread_simps)
(* Start *)
apply (case_tac "n = Start G", auto simp add: flowgraph_def flowgraph_axioms_def)
apply (cut_tac Edges="Edges G" in simple_flowgraph.start_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Exit *)
apply (case_tac "n = Exit G", auto)
apply (case_tac "Label G n", auto)
(* Assign *)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Wait *)
apply (case_tac "eval env expr = 0", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Branchifz *)
apply (case_tac "eval env expr = 0", auto)
(* Lock *)
apply (case_tac "env var = 0", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* Unlock *)
apply (case_tac "env var = 1", auto)
apply (cut_tac Edges="Edges G" and Start="Start G" and Exit="Exit G" in simple_flowgraph.next_seq_correct,
 auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
done

locale simple_tCFG = tCFG where
 instr_edges="instr_edges::(string, string expr) instr \<Rightarrow> (edge_type \<Rightarrow> nat) set" begin

lemma safe_step: "\<lbrakk>safe_points CFGs ps; step CFGs (env, ps) (env', ps')\<rbrakk> \<Longrightarrow>
 safe_points CFGs ps'"
apply (clarsimp simp add: safe_points_def)
apply (erule step.cases, auto)
apply ((erule_tac x=t in allE)+, clarsimp)
apply (erule_tac x=t in ballE, auto)
apply (cut_tac t=t in CFGs, simp, frule step_along_edge, simp+, clarsimp+)
apply (clarsimp simp add: simple_flowgraph_def flowgraph_def, drule pointed_graph.edges_ok, simp+)
done

lemma safe_step_star: "\<lbrakk>safe_points CFGs ps; step_star CFGs (env, ps) (env', ps')\<rbrakk> \<Longrightarrow>
 safe_points CFGs ps'"
apply (drule_tac P="\<lambda>CFGs' C C'. CFGs' = CFGs \<and> safe_points CFGs (snd C) \<longrightarrow>
 safe_points CFGs (snd C')" in step_star.induct, simp_all, clarsimp)
apply (drule safe_step, simp+)
done

lemma step_increment_path: "\<lbrakk>step CFGs (env, ps) (env', ps'); l \<in> Paths ps'; safe_points CFGs ps\<rbrakk> \<Longrightarrow>
 [ps] \<frown> l \<in> Paths ps"
apply (rule path_incremental_gen, simp, clarsimp)
apply (erule step.cases, clarsimp)
apply (erule_tac x=t in ballE, clarsimp)
apply (rule ccontr, frule CFGs, drule_tac n=n in step_along_edge)
apply (simp add: safe_points_def, erule_tac x=t in allE, simp+)
done

lemma step_star_path_gen: "\<lbrakk>safe_points CFGs ps; step_star CFGs (env, ps) (env', ps')\<rbrakk> \<Longrightarrow>
 \<exists>l\<in>Paths ps. \<exists>i. l i = ps' \<and>
 (\<forall>j<i. \<exists>env''. step_star CFGs (env, ps) (env'', l j) \<and> step_star CFGs (env'', l j) (env', ps'))"
apply (drule_tac P="\<lambda>CFGs' C C'. CFGs' = CFGs \<and> safe_points CFGs (snd C) \<longrightarrow>
 (\<exists>l\<in>tCFG.Paths CFGs (snd C). \<exists>i. l i = snd C' \<and>
 (\<forall>j<i. \<exists>env''. step_star CFGs C (env'', l j) \<and> step_star CFGs (env'', l j) C'))" in step_star.induct, auto)
apply (cut_tac q=b in exists_path, clarsimp, rule_tac x=l in bexI, auto)
apply (rule_tac x=0 in exI, simp)
apply (drule safe_step, simp+)
apply (frule step_increment_path, simp+)
apply (rule_tac x="[b] \<frown> l" in bexI, simp_all)
apply (rule_tac x="Suc i" in exI, clarsimp)
apply (case_tac j, simp+)
apply (rule_tac x=a in exI, simp)
apply (rule step_star_trans, simp+)
apply (erule_tac x=nat in allE, clarsimp)
apply (rule_tac x=env'' in exI, simp)
apply (rule step_star_trans, simp+)
done

lemma step_star_path: "\<lbrakk>safe_points CFGs ps; step_star CFGs (env, ps) (env', ps')\<rbrakk> \<Longrightarrow>
 \<exists>l\<in>Paths ps. \<exists>i. l i = ps'"
by (drule step_star_path_gen, simp+, force)

lemma specify_rpath_step: "\<lbrakk>\<forall>l\<in>RPaths ps. P l; step_star CFGs (env0, start_points CFGs) (env, ps)\<rbrakk> \<Longrightarrow>
 \<exists>l\<in>RPaths ps. (\<forall>i. \<exists>env'. step_star CFGs (env0, start_points CFGs) (env', l i) \<and>
 step_star CFGs (env', l i) (env, ps)) \<and> P l"
apply (cut_tac ps="start_points CFGs" in step_star_path_gen, simp+, clarsimp)
apply (drule specify_rpath, simp+, clarsimp)
apply (rule_tac x=l' in bexI, simp_all, clarsimp)
apply (case_tac "ia \<le> i", erule_tac x=ia and P="\<lambda>j. j\<le>i \<longrightarrow> l' j = l (i - j)" in allE, simp)
apply (case_tac "ia = 0", force, simp+)
apply (erule_tac x=i and P="\<lambda>j. j\<le>i \<longrightarrow> l' j = l (i - j)" in allE, simp)
apply (drule_tac j=ia in before_start, simp+, force)
done

lemma specify_rpath_break: "\<lbrakk>\<forall>l\<in>RPaths ps'. P l; step_star CFGs (env0, start_points CFGs) (env, ps);
 step CFGs (env, ps) (env', ps')\<rbrakk> \<Longrightarrow> \<exists>l\<in>RPaths ps'. l 1 = ps \<and> P l"
apply (cut_tac ps="start_points CFGs" in step_star_path_gen, simp+, clarsimp)
apply (frule_tac i=i in reverse_path, clarsimp)
apply (cut_tac q=ps' in rpath_incremental_gen, simp+)
apply (erule step.cases, clarsimp)
apply (erule_tac x=t in ballE, clarsimp)
apply (rule ccontr, frule CFGs, drule_tac n=n in step_along_edge, simp_all)
apply (cut_tac ps="start_points CFGs" in safe_step_star, simp+, simp add: safe_points_def)
apply ((erule_tac x=t in allE)+, simp+)
apply (rule_tac x="[ps'] \<frown> l'" in bexI, simp+)
done

end

(* Later, we should extend this to a program containing these fragments,
   with possibly more code in P and C as well as other threads. *)
fun sample_program where
"sample_program ''P'' = Some \<lparr>Nodes = {0::nat, 1, 2, 3, 4, 5, 6},
 Edges = {(0, 1, Seq), (1, 2, Seq), (1, 6, Branch), (2, 3, Seq), (3, 4, Seq), (4, 5, Seq), (5, 1, Branch)},
 Start = 0, Exit = 6, Label = \<lambda>n. if n = 1 then branchifz (Num 1) else if n = 2 then wait (Var ''s'' === Num 0)
           else if n = 3 then ''y'' \<leftarrow> Var ''x'' else if n = 4 then ''s'' \<leftarrow> Num 1 else branch\<rparr>" |
"sample_program ''C'' = Some \<lparr>Nodes = {7, 8, 9, 10, 11, 12, 13},
 Edges = {(7, 8, Seq), (8, 9, Seq), (8, 13, Branch), (9, 10, Seq), (10, 11, Seq), (11, 12, Seq), (12, 8, Branch)},
 Start = 7, Exit = 13, Label = \<lambda>n. if n = 8 then branchifz (Num 1) else if n = 9 then wait (Var ''s'' === Num 1)
           else if n = 10 then ''z'' \<leftarrow> Var ''z'' +L Var ''y'' else if n = 11 then ''s'' \<leftarrow> Num 0 else branch\<rparr>" |
"sample_program _ = None"

lemma sample [simp]: "\<lbrakk>t \<noteq> ''C''; t \<noteq> ''P''\<rbrakk> \<Longrightarrow> sample_program t = None"
apply (case_tac t, simp)
apply (case_tac list, auto)
apply (case_tac a, simp_all)
apply (case_tac nibble1, simp_all, (case_tac nibble2, simp_all)+)
done

lemma sample_program_E [elim]: "\<lbrakk>P (sample_program ''P''); P (sample_program ''C''); P None\<rbrakk> \<Longrightarrow>
 P (sample_program t)"
by (case_tac "t = ''C''", simp, case_tac "t = ''P''", simp+)

interpretation sample_program: simple_tCFG sample_program
apply (auto simp add: simple_tCFG_def tCFG_def)
apply (subgoal_tac "pointed_graph (Nodes g) (Edges g) (Start g) (Exit g)", auto simp add: simple_flowgraph_def flowgraph_def flowgraph_axioms_def)
(* edge types *)
apply (case_tac "t = ''C''", auto simp add: out_edges_def edge_types_def intro!: ext
 split: edge_type.split)
apply (case_tac "t = ''P''", auto simp add: out_edges_def edge_types_def intro!: ext
 split: edge_type.split)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (case_tac "t = ''C''", auto, case_tac "t = ''P''", auto)
apply unfold_locales
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (case_tac "t = ''C''", force, case_tac "t = ''P''", force, simp)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (simp add: in_edges_def)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (simp add: out_edges_def)
apply (case_tac "t = ''C''", clarsimp, case_tac "t = ''P''", auto)
apply (case_tac "t = ''C''", clarsimp, case_tac "t' = ''P''", auto)
apply (case_tac "t = ''P''", clarsimp, case_tac "t' = ''C''", auto)
apply (simp add: dom_def)
apply (rule_tac n=2 and f="\<lambda>n. if n = 0 then ''C'' else ''P''" in nat_seg_image_imp_finite,
 auto)
apply (rule ccontr, case_tac "x = ''P''", auto)
apply force
done

end


section \<open> Collections from Z Toolkit \<close>

theory Collections_Z
  imports "Shallow-Expressions.Collections" "Z_Toolkit.Relation_Lib"
begin

subsection \<open> Partial Function Collection Lens \<close>

definition pfun_collection_lens :: "'a \<Rightarrow> 'b \<Longrightarrow> 'a \<Zpfun> 'b" where
[lens_defs]: "pfun_collection_lens = pfun_lens"

adhoc_overloading collection_lens pfun_collection_lens

lemma pfun_collection_lens_mwb [simp]: "mwb_lens (pfun_collection_lens e)"
  by (simp add: pfun_collection_lens_def)

lemma source_pfun_collection_lens: "\<S>\<^bsub>pfun_collection_lens i\<^esub> = {f. i \<in> pdom(f)}"
  by (auto simp add: lens_defs lens_source_def, metis pfun_upd_ext)

lemma defined_pfun_collection_lens [simp, code_unfold]:
  "\<lbrakk> vwb_lens x; $x \<sharp> (e)\<^sub>e \<rbrakk> \<Longrightarrow> \<^bold>D(x[e]) = (e \<in> pdom($x))\<^sub>e"
  by (simp add: lens_defined_def src_dyn_lens unrest source_ns_alpha source_pfun_collection_lens)
     (simp add: lens_defs wb_lens.source_UNIV)

subsection \<open> Finite Function Collection Lens \<close>

definition ffun_collection_lens :: "'a \<Rightarrow> 'b \<Longrightarrow> 'a \<Zffun> 'b" where
[lens_defs]: "ffun_collection_lens = ffun_lens"

adhoc_overloading collection_lens ffun_collection_lens

lemma ffun_collection_lens_mwb [simp]: "mwb_lens (ffun_collection_lens e)"
  by (simp add: ffun_collection_lens_def)

lemma source_ffun_collection_lens: "\<S>\<^bsub>ffun_collection_lens i\<^esub> = {f. i \<in> fdom(f)}"
  by (auto simp add: lens_defs lens_source_def, metis ffun_upd_ext)

lemma defined_ffun_collection_lens [simp, code_unfold]:
  "\<lbrakk> vwb_lens x; $x \<sharp> (e)\<^sub>e \<rbrakk> \<Longrightarrow> \<^bold>D(x[e]) = (e \<in> fdom($x))\<^sub>e"
  by (simp add: lens_defined_def src_dyn_lens unrest source_ns_alpha source_ffun_collection_lens)
     (simp add: lens_defs wb_lens.source_UNIV)

end


(*<*)
theory AOT_BasicLogicalObjects
  imports AOT_PLM
begin
(*>*)

section\<open>Basic Logical Objects\<close>
(* Note: so far only the parts required for possible world theory are implemented *)

AOT_define TruthValueOf :: \<open>\<tau> \<Rightarrow> \<phi> \<Rightarrow> \<phi>\<close> (\<open>TruthValueOf'(_,_')\<close>)
  "tv-p": \<open>TruthValueOf(x,p) \<equiv>\<^sub>d\<^sub>f A!x & \<forall>F (x[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q]))\<close>

AOT_theorem "p-has-!tv:1": \<open>\<exists>x TruthValueOf(x,p)\<close>
  using  "tv-p"[THEN "\<equiv>Df"]
  by (AOT_subst \<open>TruthValueOf(x,p)\<close>
                \<open>A!x & \<forall>F (x[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q]))\<close> for: x)
     (simp add: "A-objects"[axiom_inst])

AOT_theorem "p-has-!tv:2": \<open>\<exists>!x TruthValueOf(x,p)\<close>
  using  "tv-p"[THEN "\<equiv>Df"]
  by (AOT_subst \<open>TruthValueOf(x,p)\<close>
                \<open>A!x & \<forall>F (x[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q]))\<close> for: x)
     (simp add: "A-objects!")

AOT_theorem "uni-tv": \<open>\<^bold>\<iota>x TruthValueOf(x,p)\<down>\<close>
  using "A-Exists:2" "RA[2]" "\<equiv>E"(2) "p-has-!tv:2" by blast

AOT_define TheTruthValueOf :: \<open>\<phi> \<Rightarrow> \<kappa>\<^sub>s\<close> (\<open>\<circ>_\<close> [100] 100)
  "the-tv-p": \<open>\<circ>p =\<^sub>d\<^sub>f \<^bold>\<iota>x TruthValueOf(x,p)\<close>

AOT_define PropEnc :: \<open>\<tau> \<Rightarrow> \<phi> \<Rightarrow> \<phi>\<close> (infixl \<open>\<^bold>\<Sigma>\<close> 40)
  "prop-enc": \<open>x\<^bold>\<Sigma>p \<equiv>\<^sub>d\<^sub>f x\<down> & x[\<lambda>y p]\<close>

AOT_theorem "tv-id:1": \<open>\<circ>p = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q])))\<close>
proof -
  AOT_have \<open>\<box>\<forall>x(TruthValueOf(x,p)  \<equiv> A!x & \<forall>F (x[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q])))\<close>
    by (rule RN; rule GEN; rule "tv-p"[THEN "\<equiv>Df"])
  AOT_hence \<open>\<^bold>\<iota>x TruthValueOf(x,p) = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q])))\<close>
    using "equiv-desc-eq:3"[THEN "\<rightarrow>E", OF "&I", OF "uni-tv"] by simp
  thus ?thesis
    using "=\<^sub>d\<^sub>fI"(1)[OF "the-tv-p", OF "uni-tv"] by fast
qed

AOT_theorem "tv-id:2": \<open>\<circ>p\<^bold>\<Sigma>p\<close>
proof -
  AOT_modally_strict {
    AOT_have \<open>(p \<equiv> p) & [\<lambda>y p] = [\<lambda>y p]\<close>
      by (auto simp: "prop-prop2:2" "rule=I:1" intro!: "\<equiv>I" "\<rightarrow>I" "&I")
    AOT_hence \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y p] = [\<lambda>y q])\<close>
      using "\<exists>I" by fast
  }
  AOT_hence \<open>\<^bold>\<A>\<exists>q ((q \<equiv> p) & [\<lambda>y p] = [\<lambda>y q])\<close>
    using "RA[2]" by blast
  AOT_hence \<open>\<^bold>\<iota>x(A!x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q])))[\<lambda>y p]\<close>
    by (safe intro!: "desc-nec-encode:1"[unvarify F, THEN "\<equiv>E"(2)] "cqt:2")
  AOT_hence \<open>\<^bold>\<iota>x(A!x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q])))\<^bold>\<Sigma>p\<close>
    by (safe intro!: "prop-enc"[THEN "\<equiv>\<^sub>d\<^sub>fI"] "&I" "A-descriptions")
  AOT_thus \<open>\<circ>p\<^bold>\<Sigma>p\<close>
    by (rule "rule=E"[rotated, OF "tv-id:1"[symmetric]])
qed

(* TODO more theorems *)

AOT_theorem "TV-lem1:1":
  \<open>p \<equiv> \<forall>F(\<exists>q (q & F = [\<lambda>y q]) \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q]))\<close>
proof(safe intro!: "\<equiv>I" "\<rightarrow>I" GEN)
  fix F
  AOT_assume \<open>\<exists>q (q & F = [\<lambda>y q])\<close>
  then AOT_obtain q where \<open>q & F = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  moreover AOT_assume p
  ultimately AOT_have \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close>
    by (metis "&I" "&E"(1) "&E"(2) "deduction-theorem" "\<equiv>I")
  AOT_thus \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close> by (rule "\<exists>I")
next
  fix F
  AOT_assume \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close>
  then AOT_obtain q where \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  moreover AOT_assume p
  ultimately AOT_have \<open>q & F = [\<lambda>y q]\<close>
    by (metis "&I" "&E"(1) "&E"(2) "\<equiv>E"(2))
  AOT_thus \<open>\<exists>q (q & F = [\<lambda>y q])\<close> by (rule "\<exists>I")
next
  AOT_assume \<open>\<forall>F (\<exists>q (q & F = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  AOT_hence \<open>\<exists>q (q & [\<lambda>y p] = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & [\<lambda>y p] = [\<lambda>y q])\<close>
    using "\<forall>E"(1)[rotated, OF "prop-prop2:2"] by blast
  moreover AOT_have \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y p] = [\<lambda>y q])\<close>
    by (rule "\<exists>I"(2)[where \<beta>=p])
       (simp add: "rule=I:1" "&I" "oth-class-taut:3:a" "prop-prop2:2")
  ultimately AOT_have \<open>\<exists>q (q & [\<lambda>y p] = [\<lambda>y q])\<close> using "\<equiv>E"(2) by blast
  then AOT_obtain q where \<open>q & [\<lambda>y p] = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  AOT_thus \<open>p\<close>
    using "rule=E" "&E"(1) "&E"(2) id_sym "\<equiv>E"(2) "p-identity-thm2:3" by fast
qed

AOT_theorem "TV-lem1:2":
  \<open>\<not>p \<equiv> \<forall>F(\<exists>q (\<not>q & F = [\<lambda>y q]) \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q]))\<close>
proof(safe intro!: "\<equiv>I" "\<rightarrow>I" GEN)
  fix F
  AOT_assume \<open>\<exists>q (\<not>q & F = [\<lambda>y q])\<close>
  then AOT_obtain q where \<open>\<not>q & F = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  moreover AOT_assume \<open>\<not>p\<close>
  ultimately AOT_have \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close>
    by (metis "&I" "&E"(1) "&E"(2) "deduction-theorem" "\<equiv>I" "raa-cor:3")
  AOT_thus \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close> by (rule "\<exists>I")
next
  fix F
  AOT_assume \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close>
  then AOT_obtain q where \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  moreover AOT_assume \<open>\<not>p\<close>
  ultimately AOT_have \<open>\<not>q & F = [\<lambda>y q]\<close>
    by (metis "&I" "&E"(1) "&E"(2) "\<equiv>E"(1) "raa-cor:3")
  AOT_thus \<open>\<exists>q (\<not>q & F = [\<lambda>y q])\<close> by (rule "\<exists>I")
next
  AOT_assume \<open>\<forall>F (\<exists>q (\<not>q & F = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  AOT_hence \<open>\<exists>q (\<not>q & [\<lambda>y p] = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & [\<lambda>y p] = [\<lambda>y q])\<close>
    using "\<forall>E"(1)[rotated, OF "prop-prop2:2"] by blast
  moreover AOT_have \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y p] = [\<lambda>y q])\<close>
    by (rule "\<exists>I"(2)[where \<beta>=p])
       (simp add: "rule=I:1" "&I" "oth-class-taut:3:a" "prop-prop2:2")
  ultimately AOT_have \<open>\<exists>q (\<not>q & [\<lambda>y p] = [\<lambda>y q])\<close> using "\<equiv>E"(2) by blast
  then AOT_obtain q where \<open>\<not>q & [\<lambda>y p] = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  AOT_thus \<open>\<not>p\<close>
    using "rule=E" "&E"(1) "&E"(2) id_sym "\<equiv>E"(2) "p-identity-thm2:3" by fast
qed

AOT_define TruthValue :: \<open>\<tau> \<Rightarrow> \<phi>\<close> (\<open>TruthValue'(_')\<close>)
  "T-value": \<open>TruthValue(x) \<equiv>\<^sub>d\<^sub>f \<exists>p (TruthValueOf(x,p))\<close>

(* TODO more theorems *)

AOT_act_theorem "T-lem:1": \<open>TruthValueOf(\<circ>p, p)\<close>
proof -
  AOT_have \<theta>: \<open>\<circ>p = \<^bold>\<iota>x TruthValueOf(x, p)\<close>
    using "rule-id-df:1" "the-tv-p" "uni-tv" by blast
  moreover AOT_have \<open>\<circ>p\<down>\<close>
    using "t=t-proper:1" calculation "vdash-properties:10" by blast
  ultimately show ?thesis by (metis "rule=E" id_sym "vdash-properties:10" "y-in:3")
qed

AOT_act_theorem "T-lem:2": \<open>\<forall>F (\<circ>p[F] \<equiv> \<exists>q((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  using "T-lem:1"[THEN "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fE"], THEN "&E"(2)].

AOT_act_theorem "T-lem:3": \<open>\<circ>p\<^bold>\<Sigma>r \<equiv> (r \<equiv> p)\<close>
proof -
  AOT_have \<theta>: \<open>\<circ>p[\<lambda>y r] \<equiv> \<exists>q ((q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q])\<close>
    using "T-lem:2"[THEN "\<forall>E"(1), OF "prop-prop2:2"].
  show ?thesis
  proof(rule "\<equiv>I"; rule "\<rightarrow>I")
    AOT_assume \<open>\<circ>p\<^bold>\<Sigma>r\<close>
    AOT_hence \<open>\<circ>p[\<lambda>y r]\<close> by (metis "\<equiv>\<^sub>d\<^sub>fE" "&E"(2) "prop-enc")
    AOT_hence \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q])\<close> using \<theta> "\<equiv>E"(1) by blast
    then AOT_obtain q where \<open>(q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
    moreover AOT_have \<open>r = q\<close> using calculation
      using "&E"(2) "\<equiv>E"(2) "p-identity-thm2:3" by blast
    ultimately AOT_show \<open>r \<equiv> p\<close>
      by (metis "rule=E" "&E"(1) "\<equiv>E"(6) "oth-class-taut:3:a")
  next
    AOT_assume \<open>r \<equiv> p\<close>
    moreover AOT_have \<open>[\<lambda>y r] = [\<lambda>y r]\<close>
      by (simp add: "rule=I:1" "prop-prop2:2")
    ultimately AOT_have \<open>(r \<equiv> p) & [\<lambda>y r] = [\<lambda>y r]\<close> using "&I" by blast
    AOT_hence \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q])\<close> by (rule "\<exists>I"(2)[where \<beta>=r])
    AOT_hence \<open>\<circ>p[\<lambda>y r]\<close> using \<theta> "\<equiv>E"(2) by blast
    AOT_thus \<open>\<circ>p\<^bold>\<Sigma>r\<close>
      by (metis "\<equiv>\<^sub>d\<^sub>fI" "&I" "prop-enc" "russell-axiom[enc,1].\<psi>_denotes_asm")
  qed
qed

AOT_act_theorem "T-lem:4": \<open>TruthValueOf(x, p) \<equiv> x = \<circ>p\<close>
proof -
  AOT_have \<open>\<forall>x (x = \<^bold>\<iota>x TruthValueOf(x, p) \<equiv> \<forall>z (TruthValueOf(z, p) \<equiv> z = x))\<close>
    by (simp add: "fund-cont-desc" GEN)
  moreover AOT_have \<open>\<circ>p\<down>\<close>
    using "\<equiv>\<^sub>d\<^sub>fE" "tv-id:2" "&E"(1) "prop-enc" by blast
  ultimately AOT_have
    \<open>(\<circ>p = \<^bold>\<iota>x TruthValueOf(x, p)) \<equiv> \<forall>z (TruthValueOf(z, p) \<equiv> z = \<circ>p)\<close>
    using "\<forall>E"(1) by blast
  AOT_hence \<open>\<forall>z (TruthValueOf(z, p) \<equiv> z = \<circ>p)\<close>
    using "\<equiv>E"(1) "rule-id-df:1" "the-tv-p" "uni-tv" by blast
  AOT_thus \<open>TruthValueOf(x, p) \<equiv> x = \<circ>p\<close> using "\<forall>E"(2) by blast
qed

(* TODO more theorems *)

AOT_theorem "TV-lem2:1":
  \<open>(A!x & \<forall>F (x[F] \<equiv> \<exists>q (q & F = [\<lambda>y q]))) \<rightarrow> TruthValue(x)\<close>
proof(safe intro!: "\<rightarrow>I" "T-value"[THEN "\<equiv>\<^sub>d\<^sub>fI"] "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fI"]
                   "\<exists>I"(1)[rotated, OF "log-prop-prop:2"])
  AOT_assume \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q (q & F = [\<lambda>y q]))\<close>
  AOT_thus \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> (\<forall>p (p \<rightarrow> p))) & F = [\<lambda>y q]))\<close>
    apply (AOT_subst \<open>\<exists>q ((q \<equiv> (\<forall>p (p \<rightarrow> p))) & F = [\<lambda>y q])\<close>
                     \<open>\<exists>q (q & F = [\<lambda>y q])\<close> for: F :: \<open><\<kappa>>\<close>)
     apply (AOT_subst \<open>q \<equiv> \<forall>p (p \<rightarrow>p)\<close> \<open>q\<close> for: q)
    apply (metis (no_types, lifting) "\<rightarrow>I" "\<equiv>I" "\<equiv>E"(2) GEN)
    by (auto simp: "cqt-further:7")
qed

AOT_theorem "TV-lem2:2":
  \<open>(A!x & \<forall>F (x[F] \<equiv> \<exists>q (\<not>q & F = [\<lambda>y q]))) \<rightarrow> TruthValue(x)\<close>
proof(safe intro!: "\<rightarrow>I" "T-value"[THEN "\<equiv>\<^sub>d\<^sub>fI"] "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fI"]
                   "\<exists>I"(1)[rotated, OF "log-prop-prop:2"])
  AOT_assume \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q (\<not>q & F = [\<lambda>y q]))\<close>
  AOT_thus \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> (\<exists>p (p & \<not>p))) & F = [\<lambda>y q]))\<close>
    apply (AOT_subst \<open>\<exists>q ((q \<equiv> (\<exists>p (p & \<not>p))) & F = [\<lambda>y q])\<close>
                     \<open>\<exists>q (\<not>q & F = [\<lambda>y q])\<close> for: F :: \<open><\<kappa>>\<close>)
     apply (AOT_subst \<open>q \<equiv> \<exists>p (p & \<not>p)\<close> \<open>\<not>q\<close> for: q)
      apply (metis (no_types, lifting)
        "\<rightarrow>I" "\<exists>E" "\<equiv>E"(1) "\<equiv>I" "raa-cor:1" "raa-cor:3")
    by (auto simp add: "cqt-further:7")
qed

AOT_define TheTrue :: \<kappa>\<^sub>s (\<open>\<top>\<close>)
  "the-true:1": \<open>\<top> =\<^sub>d\<^sub>f \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(p & F = [\<lambda>y p])))\<close>
AOT_define TheFalse :: \<kappa>\<^sub>s (\<open>\<bottom>\<close>)
  "the-true:2": \<open>\<bottom> =\<^sub>d\<^sub>f \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p])))\<close>

AOT_theorem "the-true:3": \<open>\<top> \<noteq> \<bottom>\<close>
proof(safe intro!: "ab-obey:2"[unvarify x y, THEN "\<rightarrow>E", rotated 2, OF "\<or>I"(1)]
                   "\<exists>I"(1)[where \<tau>=\<open>\<guillemotleft>[\<lambda>x \<forall>q(q \<rightarrow> q)]\<guillemotright>\<close>] "&I" "prop-prop2:2")
  AOT_have false_def: \<open>\<bottom> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:2")
  moreover AOT_show false_den: \<open>\<bottom>\<down>\<close>
    by (meson "\<rightarrow>E" "t=t-proper:1" "A-descriptions"
              "rule-id-df:1[zero]" "the-true:2")
  ultimately AOT_have false_prop: \<open>\<^bold>\<A>(A!\<bottom> & \<forall>F (\<bottom>[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p])))\<close>
    using "nec-hintikka-scheme"[unvarify x, THEN "\<equiv>E"(1), THEN "&E"(1)] by blast
  AOT_hence \<open>\<^bold>\<A>\<forall>F (\<bottom>[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p]))\<close>
    using "Act-Basic:2" "&E"(2) "\<equiv>E"(1) by blast
  AOT_hence \<open>\<forall>F \<^bold>\<A>(\<bottom>[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p]))\<close>
    using "\<equiv>E"(1) "logic-actual-nec:3"[axiom_inst] by blast
  AOT_hence false_enc_cond:
    \<open>\<^bold>\<A>(\<bottom>[\<lambda>x \<forall>q(q \<rightarrow> q)] \<equiv> \<exists>p(\<not>p & [\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p]))\<close>
    using "\<forall>E"(1)[rotated, OF "prop-prop2:2"] by blast

  AOT_have true_def: \<open>\<top> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:1")
  moreover AOT_show true_den: \<open>\<top>\<down>\<close>
    by (meson "t=t-proper:1" "A-descriptions" "rule-id-df:1[zero]" "the-true:1" "\<rightarrow>E")
  ultimately AOT_have true_prop: \<open>\<^bold>\<A>(A!\<top> & \<forall>F (\<top>[F] \<equiv> \<exists>p(p & F = [\<lambda>y p])))\<close>
    using "nec-hintikka-scheme"[unvarify x, THEN "\<equiv>E"(1), THEN "&E"(1)]  by blast
  AOT_hence \<open>\<^bold>\<A>\<forall>F (\<top>[F] \<equiv> \<exists>p(p & F = [\<lambda>y p]))\<close>
    using "Act-Basic:2" "&E"(2) "\<equiv>E"(1) by blast
  AOT_hence \<open>\<forall>F \<^bold>\<A>(\<top>[F] \<equiv> \<exists>p(p & F = [\<lambda>y p]))\<close>
    using "\<equiv>E"(1) "logic-actual-nec:3"[axiom_inst] by blast
  AOT_hence \<open>\<^bold>\<A>(\<top>[\<lambda>x \<forall>q(q \<rightarrow> q)] \<equiv> \<exists>p(p & [\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p]))\<close>
    using "\<forall>E"(1)[rotated, OF "prop-prop2:2"] by blast
  moreover AOT_have \<open>\<^bold>\<A>\<exists>p(p & [\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p])\<close>
    by (safe intro!: "nec-imp-act"[THEN "\<rightarrow>E"] RN "\<exists>I"(1)[where \<tau>="\<guillemotleft>\<forall>q(q \<rightarrow> q)\<guillemotright>"] "&I"
                     GEN "\<rightarrow>I" "log-prop-prop:2" "rule=I:1" "prop-prop2:2")
  ultimately AOT_have \<open>\<^bold>\<A>(\<top>[\<lambda>x \<forall>q(q \<rightarrow> q)])\<close>
    using "Act-Basic:5" "\<equiv>E"(1,2) by blast
  AOT_thus \<open>\<top>[\<lambda>x \<forall>q(q \<rightarrow> q)]\<close>
    using "en-eq:10[1]"[unvarify x\<^sub>1 F, THEN "\<equiv>E"(1)] true_den "prop-prop2:2" by blast

  AOT_show \<open>\<not>\<bottom>[\<lambda>x \<forall>q(q \<rightarrow> q)]\<close>
  proof(rule "raa-cor:2")
    AOT_assume \<open>\<bottom>[\<lambda>x \<forall>q(q \<rightarrow> q)]\<close>
    AOT_hence \<open>\<^bold>\<A>\<bottom>[\<lambda>x \<forall>q(q \<rightarrow> q)]\<close>
      using "en-eq:10[1]"[unvarify x\<^sub>1 F, THEN "\<equiv>E"(2)]
            false_den "prop-prop2:2" by blast
    AOT_hence \<open>\<^bold>\<A>\<exists>p(\<not>p & [\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p])\<close>
      using false_enc_cond "Act-Basic:5" "\<equiv>E"(1) by blast
    AOT_hence \<open>\<exists>p \<^bold>\<A>(\<not>p & [\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p])\<close>
      using "Act-Basic:10" "\<equiv>E"(1) by blast
    then AOT_obtain p where p_prop: \<open>\<^bold>\<A>(\<not>p & [\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p])\<close>
      using "\<exists>E"[rotated] by blast
    AOT_hence \<open>\<^bold>\<A>[\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p]\<close>
      by (metis "Act-Basic:2" "&E"(2) "\<equiv>E"(1))
    AOT_hence \<open>[\<lambda>x \<forall>q(q \<rightarrow> q)] = [\<lambda>y p]\<close>
      using "id-act:1"[unvarify \<alpha> \<beta>, THEN "\<equiv>E"(2)] "prop-prop2:2" by blast
    AOT_hence \<open>(\<forall>q(q \<rightarrow> q)) = p\<close>
      using "p-identity-thm2:3"[unvarify p, THEN "\<equiv>E"(2)]
            "log-prop-prop:2" by blast
    moreover AOT_have \<open>\<^bold>\<A>\<not>p\<close> using p_prop
      using "Act-Basic:2" "&E"(1) "\<equiv>E"(1) by blast
    ultimately AOT_have \<open>\<^bold>\<A>\<not>\<forall>q(q \<rightarrow> q)\<close>
      by (metis "Act-Sub:1" "\<equiv>E"(1,2) "raa-cor:3" "rule=E")
    moreover AOT_have \<open>\<not>\<^bold>\<A>\<not>\<forall>q(q \<rightarrow> q)\<close>
      by (meson "Act-Sub:1" "RA[2]" "if-p-then-p" "\<equiv>E"(1) "universal-cor")
    ultimately AOT_show \<open>\<^bold>\<A>\<not>\<forall>q(q \<rightarrow> q) & \<not>\<^bold>\<A>\<not>\<forall>q(q \<rightarrow> q)\<close>
      using "&I" by blast
  qed
qed

AOT_act_theorem "T-T-value:1": \<open>TruthValue(\<top>)\<close>
proof -
  AOT_have true_def: \<open>\<top> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:1")
  AOT_hence true_den: \<open>\<top>\<down>\<close>
    using "t=t-proper:1" "vdash-properties:6" by blast
  AOT_show \<open>TruthValue(\<top>)\<close>
    using "y-in:2"[unvarify z, OF true_den, THEN "\<rightarrow>E", OF true_def]
          "TV-lem2:1"[unvarify x, OF true_den, THEN "\<rightarrow>E"] by blast
qed

AOT_act_theorem "T-T-value:2": \<open>TruthValue(\<bottom>)\<close>
proof -
  AOT_have false_def: \<open>\<bottom> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:2")
  AOT_hence false_den: \<open>\<bottom>\<down>\<close>
    using "t=t-proper:1" "vdash-properties:6" by blast
  AOT_show \<open>TruthValue(\<bottom>)\<close>
    using "y-in:2"[unvarify z, OF false_den, THEN "\<rightarrow>E", OF false_def]
          "TV-lem2:2"[unvarify x, OF false_den, THEN "\<rightarrow>E"] by blast
qed

AOT_theorem "two-T": \<open>\<exists>x\<exists>y(TruthValue(x) & TruthValue(y) & x \<noteq> y &
                           \<forall>z (TruthValue(z) \<rightarrow> z = x \<or> z = y))\<close>
proof -
  AOT_obtain a where a_prop: \<open>A!a & \<forall>F (a[F] \<equiv> \<exists>p (p & F = [\<lambda>y p]))\<close>
    using "A-objects"[axiom_inst] "\<exists>E"[rotated] by fast
  AOT_obtain b where b_prop: \<open>A!b & \<forall>F (b[F] \<equiv> \<exists>p (\<not>p & F = [\<lambda>y p]))\<close>
    using "A-objects"[axiom_inst] "\<exists>E"[rotated] by fast
  AOT_obtain p where p: p
    by (metis "log-prop-prop:2" "raa-cor:3" "rule-ui:1" "universal-cor")
  show ?thesis
  proof(rule "\<exists>I"(2)[where \<beta>=a]; rule "\<exists>I"(2)[where \<beta>=b];
        safe intro!: "&I" GEN "\<rightarrow>I")
    AOT_show \<open>TruthValue(a)\<close>
      using "TV-lem2:1" a_prop "vdash-properties:10" by blast
  next
    AOT_show \<open>TruthValue(b)\<close>
      using "TV-lem2:2" b_prop "vdash-properties:10" by blast
  next
    AOT_show \<open>a \<noteq> b\<close>
    proof(rule "ab-obey:2"[THEN "\<rightarrow>E", OF "\<or>I"(1)])
      AOT_show \<open>\<exists>F (a[F] & \<not>b[F])\<close>
      proof(rule "\<exists>I"(1)[where \<tau>="\<guillemotleft>[\<lambda>y p]\<guillemotright>"]; rule "&I" "prop-prop2:2")
        AOT_show \<open>a[\<lambda>y p]\<close>
          by(safe intro!: "\<exists>I"(2)[where \<beta>=p] "&I" p "rule=I:1"[OF "prop-prop2:2"]
              a_prop[THEN "&E"(2), THEN "\<forall>E"(1), THEN "\<equiv>E"(2), OF "prop-prop2:2"])
      next
        AOT_show \<open>\<not>b[\<lambda>y p]\<close>
        proof (rule "raa-cor:2")
          AOT_assume \<open>b[\<lambda>y p]\<close>
          AOT_hence \<open>\<exists>q (\<not>q & [\<lambda>y p] = [\<lambda>y q])\<close>
            using "\<forall>E"(1)[rotated, OF "prop-prop2:2", THEN "\<equiv>E"(1)]
                  b_prop[THEN "&E"(2)] by fast
          then AOT_obtain q where \<open>\<not>q & [\<lambda>y p] = [\<lambda>y q]\<close>
            using "\<exists>E"[rotated] by blast
          AOT_hence \<open>\<not>p\<close>
            by (metis "rule=E" "&E"(1) "&E"(2) "deduction-theorem" "\<equiv>I"
                      "\<equiv>E"(2) "p-identity-thm2:3" "raa-cor:3")
          AOT_thus \<open>p & \<not>p\<close> using p "&I" by blast
        qed
      qed
    qed
  next
    fix z
    AOT_assume \<open>TruthValue(z)\<close>
    AOT_hence \<open>\<exists>p (TruthValueOf(z, p))\<close>
      by (metis "\<equiv>\<^sub>d\<^sub>fE" "T-value")
    then AOT_obtain p where \<open>TruthValueOf(z, p)\<close> using "\<exists>E"[rotated] by blast
    AOT_hence z_prop: \<open>A!z & \<forall>F (z[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "\<equiv>\<^sub>d\<^sub>fE" "tv-p" by blast
    {
      AOT_assume p: \<open>p\<close>
      AOT_have \<open>z = a\<close>
      proof(rule "ab-obey:1"[THEN "\<rightarrow>E", THEN "\<rightarrow>E", OF "&I",
                             OF z_prop[THEN "&E"(1)], OF a_prop[THEN "&E"(1)]];
            rule GEN)
        fix G
        AOT_have \<open>z[G] \<equiv> \<exists>q ((q \<equiv> p) & G = [\<lambda>y q])\<close>
          using z_prop[THEN "&E"(2)] "\<forall>E"(2) by blast
        also AOT_have \<open>\<exists>q ((q \<equiv> p) & G = [\<lambda>y q]) \<equiv> \<exists>q (q & G = [\<lambda>y q])\<close>
          using "TV-lem1:1"[THEN "\<equiv>E"(1), OF p, THEN "\<forall>E"(2)[where \<beta>=G], symmetric].
        also AOT_have \<open>\<dots> \<equiv> a[G]\<close>
          using a_prop[THEN "&E"(2), THEN "\<forall>E"(2)[where \<beta>=G], symmetric].
        finally AOT_show \<open>z[G] \<equiv> a[G]\<close>.
      qed
      AOT_hence \<open>z = a \<or> z = b\<close> by (rule "\<or>I")
    }
    moreover {
      AOT_assume notp: \<open>\<not>p\<close>
      AOT_have \<open>z = b\<close>
      proof(rule "ab-obey:1"[THEN "\<rightarrow>E", THEN "\<rightarrow>E", OF "&I",
                             OF z_prop[THEN "&E"(1)], OF b_prop[THEN "&E"(1)]];
            rule GEN)
        fix G
        AOT_have \<open>z[G] \<equiv> \<exists>q ((q \<equiv> p) & G = [\<lambda>y q])\<close>
          using z_prop[THEN "&E"(2)] "\<forall>E"(2) by blast
        also AOT_have \<open>\<exists>q ((q \<equiv> p) & G = [\<lambda>y q]) \<equiv> \<exists>q (\<not>q & G = [\<lambda>y q])\<close>
          using "TV-lem1:2"[THEN "\<equiv>E"(1), OF notp, THEN "\<forall>E"(2), symmetric].
        also AOT_have \<open>\<dots> \<equiv> b[G]\<close>
          using b_prop[THEN "&E"(2), THEN "\<forall>E"(2), symmetric].
        finally AOT_show \<open>z[G] \<equiv> b[G]\<close>.
      qed
      AOT_hence \<open>z = a \<or> z = b\<close> by (rule "\<or>I")
    }
    ultimately AOT_show \<open>z = a \<or> z = b\<close>
      by (metis "reductio-aa:1")
  qed
qed

AOT_act_theorem "valueof-facts:1": \<open>TruthValueOf(x, p) \<rightarrow> (p \<equiv> x = \<top>)\<close>
proof(safe intro!: "\<rightarrow>I" dest!: "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fE"])
  AOT_assume \<theta>: \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  AOT_have a: \<open>A!\<top>\<close>
    using "\<exists>E" "T-T-value:1" "T-value" "&E"(1) "\<equiv>\<^sub>d\<^sub>fE" "tv-p" by blast
  AOT_have true_def: \<open>\<top> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:1")
  AOT_hence true_den: \<open>\<top>\<down>\<close>
    using "t=t-proper:1" "vdash-properties:6" by blast
  AOT_have b: \<open>\<forall>F (\<top>[F] \<equiv> \<exists>q (q & F = [\<lambda>y q]))\<close>
    using "y-in:2"[unvarify z, OF true_den, THEN "\<rightarrow>E", OF true_def] "&E" by blast
  AOT_show \<open>p \<equiv> x = \<top>\<close>
  proof(safe intro!: "\<equiv>I" "\<rightarrow>I")
    AOT_assume p
    AOT_hence \<open>\<forall>F (\<exists>q (q & F = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "TV-lem1:1"[THEN "\<equiv>E"(1)] by blast
    AOT_hence \<open>\<forall>F(\<top>[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using b "cqt-basic:10"[THEN "\<rightarrow>E", OF "&I", OF b] by fast
    AOT_hence c: \<open>\<forall>F(\<exists>q((q \<equiv> p) & F = [\<lambda>y q]) \<equiv> \<top>[F])\<close>
      using "cqt-basic:11"[THEN "\<equiv>E"(1)] by fast
    AOT_hence \<open>\<forall>F (x[F] \<equiv> \<top>[F])\<close>
      using "cqt-basic:10"[THEN "\<rightarrow>E", OF "&I", OF \<theta>[THEN "&E"(2)]] by fast
    AOT_thus \<open>x = \<top>\<close>
      by (rule "ab-obey:1"[unvarify y, OF true_den, THEN "\<rightarrow>E", THEN "\<rightarrow>E",
                           OF "&I", OF \<theta>[THEN "&E"(1)], OF a])
  next
    AOT_assume \<open>x = \<top>\<close>
    AOT_hence d: \<open>\<forall>F (\<top>[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "rule=E" \<theta>[THEN "&E"(2)] by fast
    AOT_have \<open>\<forall>F (\<exists>q (q & F = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "cqt-basic:10"[THEN "\<rightarrow>E", OF "&I",
              OF b[THEN "cqt-basic:11"[THEN "\<equiv>E"(1)]], OF d].
    AOT_thus p using "TV-lem1:1"[THEN "\<equiv>E"(2)] by blast
  qed
qed

AOT_act_theorem "valueof-facts:2": \<open>TruthValueOf(x, p) \<rightarrow> (\<not>p \<equiv> x = \<bottom>)\<close>
proof(safe intro!: "\<rightarrow>I" dest!: "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fE"])
  AOT_assume \<theta>: \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  AOT_have a: \<open>A!\<bottom>\<close>
    using "\<exists>E" "T-T-value:2" "T-value" "&E"(1) "\<equiv>\<^sub>d\<^sub>fE" "tv-p" by blast
  AOT_have false_def: \<open>\<bottom> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:2")
  AOT_hence false_den: \<open>\<bottom>\<down>\<close>
    using "t=t-proper:1" "vdash-properties:6" by blast
  AOT_have b: \<open>\<forall>F (\<bottom>[F] \<equiv> \<exists>q (\<not>q & F = [\<lambda>y q]))\<close>
    using "y-in:2"[unvarify z, OF false_den, THEN "\<rightarrow>E", OF false_def] "&E" by blast
  AOT_show \<open>\<not>p \<equiv> x = \<bottom>\<close>
  proof(safe intro!: "\<equiv>I" "\<rightarrow>I")
    AOT_assume \<open>\<not>p\<close>
    AOT_hence \<open>\<forall>F (\<exists>q (\<not>q & F = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "TV-lem1:2"[THEN "\<equiv>E"(1)] by blast
    AOT_hence \<open>\<forall>F(\<bottom>[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using b "cqt-basic:10"[THEN "\<rightarrow>E", OF "&I", OF b] by fast
    AOT_hence c: \<open>\<forall>F(\<exists>q((q \<equiv> p) & F = [\<lambda>y q]) \<equiv> \<bottom>[F])\<close>
      using "cqt-basic:11"[THEN "\<equiv>E"(1)] by fast
    AOT_hence \<open>\<forall>F (x[F] \<equiv> \<bottom>[F])\<close>
      using "cqt-basic:10"[THEN "\<rightarrow>E", OF "&I", OF \<theta>[THEN "&E"(2)]] by fast
    AOT_thus \<open>x = \<bottom>\<close>
      by (rule "ab-obey:1"[unvarify y, OF false_den, THEN "\<rightarrow>E", THEN "\<rightarrow>E",
                           OF "&I", OF \<theta>[THEN "&E"(1)], OF a])
  next
    AOT_assume \<open>x = \<bottom>\<close>
    AOT_hence d: \<open>\<forall>F (\<bottom>[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "rule=E" \<theta>[THEN "&E"(2)] by fast
    AOT_have \<open>\<forall>F (\<exists>q (\<not>q & F = [\<lambda>y q]) \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
      using "cqt-basic:10"[THEN "\<rightarrow>E", OF "&I",
                OF b[THEN "cqt-basic:11"[THEN "\<equiv>E"(1)]], OF d].
    AOT_thus \<open>\<not>p\<close> using "TV-lem1:2"[THEN "\<equiv>E"(2)] by blast
  qed
qed

AOT_act_theorem "q-True:1": \<open>p \<equiv> (\<circ>p = \<top>)\<close>
  apply (rule "valueof-facts:1"[unvarify x, THEN "\<rightarrow>E", rotated, OF "T-lem:1"])
  using "\<equiv>\<^sub>d\<^sub>fE" "tv-id:2" "&E"(1) "prop-enc" by blast

AOT_act_theorem "q-True:2": \<open>\<not>p \<equiv> (\<circ>p = \<bottom>)\<close>
  apply (rule "valueof-facts:2"[unvarify x, THEN "\<rightarrow>E", rotated, OF "T-lem:1"])
  using "\<equiv>\<^sub>d\<^sub>fE" "tv-id:2" "&E"(1) "prop-enc" by blast

AOT_act_theorem "q-True:3": \<open>p \<equiv> \<top>\<^bold>\<Sigma>p\<close>
proof(safe intro!: "\<equiv>I" "\<rightarrow>I")
  AOT_assume p
  AOT_hence \<open>\<circ>p = \<top>\<close> by (metis "\<equiv>E"(1) "q-True:1")
  moreover AOT_have \<open>\<circ>p\<^bold>\<Sigma>p\<close>
    by (simp add: "tv-id:2")
  ultimately AOT_show \<open>\<top>\<^bold>\<Sigma>p\<close>
    using "rule=E" "T-lem:4" by fast
next
  AOT_have true_def: \<open>\<top> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:1")
  AOT_hence true_den: \<open>\<top>\<down>\<close>
    using "t=t-proper:1" "vdash-properties:6" by blast
  AOT_have b: \<open>\<forall>F (\<top>[F] \<equiv> \<exists>q (q & F = [\<lambda>y q]))\<close>
    using "y-in:2"[unvarify z, OF true_den, THEN "\<rightarrow>E", OF true_def] "&E" by blast

  AOT_assume \<open>\<top>\<^bold>\<Sigma>p\<close>
  AOT_hence \<open>\<top>[\<lambda>y p]\<close> by (metis "\<equiv>\<^sub>d\<^sub>fE" "&E"(2) "prop-enc")
  AOT_hence \<open>\<exists>q (q & [\<lambda>y p] = [\<lambda>y q])\<close>
    using b[THEN "\<forall>E"(1), OF "prop-prop2:2", THEN "\<equiv>E"(1)] by blast
  then AOT_obtain q where \<open>q & [\<lambda>y p] = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  AOT_thus \<open>p\<close>
    using "rule=E" "&E"(1) "&E"(2) id_sym "\<equiv>E"(2) "p-identity-thm2:3" by fast
qed

AOT_act_theorem "q-True:5": \<open>\<not>p \<equiv> \<bottom>\<^bold>\<Sigma>p\<close>
proof(safe intro!: "\<equiv>I" "\<rightarrow>I")
  AOT_assume \<open>\<not>p\<close>
  AOT_hence \<open>\<circ>p = \<bottom>\<close> by (metis "\<equiv>E"(1) "q-True:2")
  moreover AOT_have \<open>\<circ>p\<^bold>\<Sigma>p\<close>
    by (simp add: "tv-id:2")
  ultimately AOT_show \<open>\<bottom>\<^bold>\<Sigma>p\<close>
    using "rule=E" "T-lem:4" by fast
next
  AOT_have false_def: \<open>\<bottom> = \<^bold>\<iota>x (A!x & \<forall>F (x[F] \<equiv> \<exists>p(\<not>p & F = [\<lambda>y p])))\<close>
    by (simp add: "A-descriptions" "rule-id-df:1[zero]" "the-true:2")
  AOT_hence false_den: \<open>\<bottom>\<down>\<close>
    using "t=t-proper:1" "vdash-properties:6" by blast
  AOT_have b: \<open>\<forall>F (\<bottom>[F] \<equiv> \<exists>q (\<not>q & F = [\<lambda>y q]))\<close>
    using "y-in:2"[unvarify z, OF false_den, THEN "\<rightarrow>E", OF false_def] "&E" by blast

  AOT_assume \<open>\<bottom>\<^bold>\<Sigma>p\<close>
  AOT_hence \<open>\<bottom>[\<lambda>y p]\<close> by (metis "\<equiv>\<^sub>d\<^sub>fE" "&E"(2) "prop-enc")
  AOT_hence \<open>\<exists>q (\<not>q & [\<lambda>y p] = [\<lambda>y q])\<close>
    using b[THEN "\<forall>E"(1), OF "prop-prop2:2", THEN "\<equiv>E"(1)] by blast
  then AOT_obtain q where \<open>\<not>q & [\<lambda>y p] = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
  AOT_thus \<open>\<not>p\<close>
    using "rule=E" "&E"(1) "&E"(2) id_sym "\<equiv>E"(2) "p-identity-thm2:3" by fast
qed

AOT_act_theorem "q-True:4": \<open>p \<equiv> \<not>(\<bottom>\<^bold>\<Sigma>p)\<close>
  using "q-True:5"
  by (metis "deduction-theorem" "\<equiv>I" "\<equiv>E"(2) "\<equiv>E"(4) "raa-cor:3")

AOT_act_theorem "q-True:6": \<open>\<not>p \<equiv> \<not>(\<top>\<^bold>\<Sigma>p)\<close>
  using "\<equiv>E"(1) "oth-class-taut:4:b" "q-True:3" by blast

AOT_define ExtensionOf :: \<open>\<tau> \<Rightarrow> \<phi> \<Rightarrow> \<phi>\<close> (\<open>ExtensionOf'(_,_')\<close>)
  "exten-p": \<open>ExtensionOf(x,p) \<equiv>\<^sub>d\<^sub>f A!x &
                                   \<forall>F (x[F] \<rightarrow> Propositional([F])) &
                                   \<forall>q ((x\<^bold>\<Sigma>q) \<equiv> (q \<equiv> p))\<close>

AOT_theorem "extof-e": \<open>ExtensionOf(x, p) \<equiv> TruthValueOf(x, p)\<close>
proof (safe intro!: "\<equiv>I" "\<rightarrow>I" "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fI"] "exten-p"[THEN "\<equiv>\<^sub>d\<^sub>fI"]
            dest!: "tv-p"[THEN "\<equiv>\<^sub>d\<^sub>fE"] "exten-p"[THEN "\<equiv>\<^sub>d\<^sub>fE"])
  AOT_assume 1: \<open>[A!]x & \<forall>F (x[F] \<rightarrow> Propositional([F])) & \<forall>q (x \<^bold>\<Sigma> q \<equiv> (q \<equiv> p))\<close>
  AOT_hence \<theta>: \<open>[A!]x & \<forall>F (x[F] \<rightarrow> \<exists>q(F = [\<lambda>y q])) & \<forall>q (x \<^bold>\<Sigma> q \<equiv> (q \<equiv> p))\<close>
    by (AOT_subst \<open>\<exists>q(F = [\<lambda>y q])\<close> \<open>Propositional([F])\<close> for: F :: \<open><\<kappa>>\<close>)
       (auto simp add: "df-rules-formulas[3]" "df-rules-formulas[4]"
                       "\<equiv>I" "prop-prop1")
  AOT_show \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  proof(safe intro!: "&I" GEN 1[THEN "&E"(1), THEN "&E"(1)] "\<equiv>I" "\<rightarrow>I")
    fix F
    AOT_assume 0: \<open>x[F]\<close>
    AOT_hence \<open>\<exists>q (F = [\<lambda>y q])\<close>
      using \<theta>[THEN "&E"(1), THEN "&E"(2)] "\<forall>E"(2) "\<rightarrow>E" by blast
    then AOT_obtain q where q_prop: \<open>F = [\<lambda>y q]\<close> using "\<exists>E"[rotated] by blast
    AOT_hence \<open>x[\<lambda>y q]\<close> using 0 "rule=E" by blast
    AOT_hence \<open>x\<^bold>\<Sigma>q\<close> by (metis "\<equiv>\<^sub>d\<^sub>fI" "&I" "ex:1:a" "prop-enc" "rule-ui:3")
    AOT_hence \<open>q \<equiv> p\<close> using \<theta>[THEN "&E"(2)] "\<forall>E"(2) "\<equiv>E"(1) by blast
    AOT_hence \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close> using q_prop "&I" by blast
    AOT_thus \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close> by (rule "\<exists>I")
  next
    fix F
    AOT_assume \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close>
    then AOT_obtain q where q_prop: \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close>
      using "\<exists>E"[rotated] by blast
    AOT_hence \<open>x\<^bold>\<Sigma>q\<close> using \<theta>[THEN "&E"(2)] "\<forall>E"(2) "&E" "\<equiv>E"(2) by blast
    AOT_hence \<open>x[\<lambda>y q]\<close> by (metis "\<equiv>\<^sub>d\<^sub>fE" "&E"(2) "prop-enc")
    AOT_thus \<open>x[F]\<close> using q_prop[THEN "&E"(2), symmetric] "rule=E" by blast
  qed
next
  AOT_assume 0: \<open>[A!]x & \<forall>F (x[F] \<equiv> \<exists>q ((q \<equiv> p) & F = [\<lambda>y q]))\<close>
  AOT_show \<open>[A!]x & \<forall>F (x[F] \<rightarrow> Propositional([F])) & \<forall>q (x \<^bold>\<Sigma> q \<equiv> (q \<equiv> p))\<close>
  proof(safe intro!: "&I" 0[THEN "&E"(1)] GEN "\<rightarrow>I")
    fix F
    AOT_assume \<open>x[F]\<close>
    AOT_hence \<open>\<exists>q ((q \<equiv> p) & F = [\<lambda>y q])\<close>
      using 0[THEN "&E"(2)] "\<forall>E"(2) "\<equiv>E"(1) by blast
    then AOT_obtain q where \<open>(q \<equiv> p) & F = [\<lambda>y q]\<close>
      using "\<exists>E"[rotated] by blast
    AOT_hence \<open>F = [\<lambda>y q]\<close> using "&E"(2) by blast
    AOT_hence \<open>\<exists>q F = [\<lambda>y q]\<close> by (rule "\<exists>I")
    AOT_thus \<open>Propositional([F])\<close> by (metis "\<equiv>\<^sub>d\<^sub>fI" "prop-prop1")
  next
    AOT_show \<open>x\<^bold>\<Sigma>r \<equiv> (r \<equiv> p)\<close> for r
    proof(rule "\<equiv>I"; rule "\<rightarrow>I")
      AOT_assume \<open>x\<^bold>\<Sigma>r\<close>
      AOT_hence \<open>x[\<lambda>y r]\<close> by (metis "\<equiv>\<^sub>d\<^sub>fE" "&E"(2) "prop-enc")
      AOT_hence \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q])\<close>
        using 0[THEN "&E"(2), THEN "\<forall>E"(1), OF "prop-prop2:2", THEN "\<equiv>E"(1)] by blast
      then AOT_obtain q where \<open>(q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q]\<close>
        using "\<exists>E"[rotated] by blast
      AOT_thus \<open>r \<equiv> p\<close>
        by (metis "rule=E" "&E"(1,2) id_sym "\<equiv>E"(2) "Commutativity of \<equiv>"
                  "p-identity-thm2:3")
    next
      AOT_assume \<open>r \<equiv> p\<close>
      AOT_hence \<open>(r \<equiv> p) & [\<lambda>y r] = [\<lambda>y r]\<close>
        by (metis "rule=I:1" "\<equiv>S"(1) "\<equiv>E"(2) "Commutativity of &" "prop-prop2:2")
      AOT_hence \<open>\<exists>q ((q \<equiv> p) & [\<lambda>y r] = [\<lambda>y q])\<close> by (rule "\<exists>I")
      AOT_hence \<open>x[\<lambda>y r]\<close>
        using 0[THEN "&E"(2), THEN "\<forall>E"(1), OF "prop-prop2:2", THEN "\<equiv>E"(2)] by blast
      AOT_thus \<open>x\<^bold>\<Sigma>r\<close> by (metis "\<equiv>\<^sub>d\<^sub>fI" "&I" "ex:1:a" "prop-enc" "rule-ui:3")
    qed
  qed
qed

AOT_theorem "ext-p-tv:1": \<open>\<exists>!x ExtensionOf(x, p)\<close>
  by (AOT_subst \<open>ExtensionOf(x, p)\<close> \<open>TruthValueOf(x, p)\<close> for: x)
     (auto simp: "extof-e" "p-has-!tv:2")

AOT_theorem "ext-p-tv:2": \<open>\<^bold>\<iota>x(ExtensionOf(x, p))\<down>\<close>
  using "A-Exists:2" "RA[2]" "ext-p-tv:1" "\<equiv>E"(2) by blast

AOT_theorem "ext-p-tv:3": \<open>\<^bold>\<iota>x(ExtensionOf(x, p)) = \<circ>p\<close>
proof -
  AOT_have 0: \<open>\<^bold>\<A>\<forall>x(ExtensionOf(x, p) \<equiv> TruthValueOf(x,p))\<close>
    by (rule "RA[2]"; rule GEN; rule "extof-e")
  AOT_have 1: \<open>\<circ>p = \<^bold>\<iota>x TruthValueOf(x,p)\<close>
    using "rule-id-df:1" "the-tv-p" "uni-tv" by blast
  show ?thesis
    apply (rule "equiv-desc-eq:1"[THEN "\<rightarrow>E", OF 0, THEN "\<forall>E"(1)[where \<tau>=\<open>\<guillemotleft>\<circ>p\<guillemotright>\<close>],
                                  THEN "\<equiv>E"(2), symmetric])
    using "1" "t=t-proper:1" "vdash-properties:10" apply blast
    by (fact 1)
qed
(*<*)end(*>*)


header {* Maybe monad *}

theory Maybe_Monad
imports Monad_Zero_Plus
begin

subsection {* Type definition *}

tycondef 'a\<cdot>maybe = Nothing | Just (lazy "'a")

lemma coerce_maybe_abs [simp]: "coerce\<cdot>(maybe_abs\<cdot>x) = maybe_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: maybe_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_maybe)
done

lemma coerce_Nothing [simp]: "coerce\<cdot>Nothing = Nothing"
unfolding Nothing_def by simp

lemma coerce_Just [simp]: "coerce\<cdot>(Just\<cdot>x) = Just\<cdot>(coerce\<cdot>x)"
unfolding Just_def by simp

lemma fmapU_maybe_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>maybe) = \<bottom>"
  "fmapU\<cdot>f\<cdot>Nothing = Nothing"
  "fmapU\<cdot>f\<cdot>(Just\<cdot>x) = Just\<cdot>(f\<cdot>x)"
unfolding fmapU_maybe_def maybe_map_def fix_const
apply simp
apply (simp add: Nothing_def)
apply (simp add: Just_def)
done

subsection {* Class instance proofs *}

instance maybe :: "functor"
apply default
apply (induct_tac xs rule: maybe.induct, simp_all)
done

instantiation maybe :: "{functor_zero_plus, monad_zero}"
begin

fixrec plusU_maybe :: "udom\<cdot>maybe \<rightarrow> udom\<cdot>maybe \<rightarrow> udom\<cdot>maybe"
  where "plusU_maybe\<cdot>Nothing\<cdot>ys = ys"
  | "plusU_maybe\<cdot>(Just\<cdot>x)\<cdot>ys = Just\<cdot>x"

lemma plusU_maybe_strict [simp]: "plusU\<cdot>\<bottom>\<cdot>ys = (\<bottom>::udom\<cdot>maybe)"
by fixrec_simp

fixrec bindU_maybe :: "udom\<cdot>maybe \<rightarrow> (udom \<rightarrow> udom\<cdot>maybe) \<rightarrow> udom\<cdot>maybe"
  where "bindU_maybe\<cdot>Nothing\<cdot>k = Nothing"
  | "bindU_maybe\<cdot>(Just\<cdot>x)\<cdot>k = k\<cdot>x"

lemma bindU_maybe_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>maybe)"
by fixrec_simp

definition zeroU_maybe_def:
  "zeroU = Nothing"

definition returnU_maybe_def:
  "returnU = Just"

lemma plusU_Nothing_right: "plusU\<cdot>xs\<cdot>Nothing = xs"
by (induct xs rule: maybe.induct) simp_all

lemma bindU_plusU_maybe:
  fixes xs ys :: "udom\<cdot>maybe" shows
  "bindU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>f = plusU\<cdot>(bindU\<cdot>xs\<cdot>f)\<cdot>(bindU\<cdot>ys\<cdot>f)"
apply (induct xs rule: maybe.induct)
apply simp_all
oops

instance proof
  fix x :: "udom"
  fix f :: "udom \<rightarrow> udom"
  fix h k :: "udom \<rightarrow> udom\<cdot>maybe"
  fix xs ys zs :: "udom\<cdot>maybe"
  show "fmapU\<cdot>f\<cdot>xs = bindU\<cdot>xs\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct xs rule: maybe.induct, simp_all add: returnU_maybe_def)
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>k = k\<cdot>x"
    by (simp add: returnU_maybe_def plusU_Nothing_right)
  show "bindU\<cdot>(bindU\<cdot>xs\<cdot>h)\<cdot>k = bindU\<cdot>xs\<cdot>(\<Lambda> x. bindU\<cdot>(h\<cdot>x)\<cdot>k)"
    by (induct xs rule: maybe.induct) simp_all
  show "plusU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>zs = plusU\<cdot>xs\<cdot>(plusU\<cdot>ys\<cdot>zs)"
    by (induct xs rule: maybe.induct) simp_all
  show "bindU\<cdot>zeroU\<cdot>k = zeroU"
    by (simp add: zeroU_maybe_def)
  show "fmapU\<cdot>f\<cdot>(plusU\<cdot>xs\<cdot>ys) = plusU\<cdot>(fmapU\<cdot>f\<cdot>xs)\<cdot>(fmapU\<cdot>f\<cdot>ys)"
    by (induct xs rule: maybe.induct) simp_all
  show "fmapU\<cdot>f\<cdot>zeroU = (zeroU :: udom\<cdot>maybe)"
    by (simp add: zeroU_maybe_def)
  show "plusU\<cdot>zeroU\<cdot>xs = xs"
    by (simp add: zeroU_maybe_def)
  show "plusU\<cdot>xs\<cdot>zeroU = xs"
    by (simp add: zeroU_maybe_def plusU_Nothing_right)
qed

end

subsection {* Transfer properties to polymorphic versions *}

lemma fmap_maybe_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>maybe) = \<bottom>"
  "fmap\<cdot>f\<cdot>Nothing = Nothing"
  "fmap\<cdot>f\<cdot>(Just\<cdot>x) = Just\<cdot>(f\<cdot>x)"
unfolding fmap_def by simp_all

lemma fplus_maybe_simps [simp]:
  "fplus\<cdot>(\<bottom>::'a\<cdot>maybe)\<cdot>ys = \<bottom>"
  "fplus\<cdot>Nothing\<cdot>ys = ys"
  "fplus\<cdot>(Just\<cdot>x)\<cdot>ys = Just\<cdot>x"
unfolding fplus_def by simp_all

lemma fplus_Nothing_right [simp]:
  "fplus\<cdot>m\<cdot>Nothing = m"
by (simp add: fplus_def plusU_Nothing_right)

lemma bind_maybe_simps [simp]:
  "bind\<cdot>(\<bottom>::'a\<cdot>maybe)\<cdot>f = \<bottom>"
  "bind\<cdot>Nothing\<cdot>f = Nothing"
  "bind\<cdot>(Just\<cdot>x)\<cdot>f = f\<cdot>x"
unfolding bind_def fplus_def by simp_all

lemma return_maybe_def: "return = Just"
unfolding return_def returnU_maybe_def
by (simp add: coerce_cfun cfcomp1 eta_cfun)

lemma mzero_maybe_def: "mzero = Nothing"
unfolding mzero_def zeroU_maybe_def
by simp

lemma join_maybe_simps [simp]:
  "join\<cdot>(\<bottom>::'a\<cdot>maybe\<cdot>maybe) = \<bottom>"
  "join\<cdot>Nothing = Nothing"
  "join\<cdot>(Just\<cdot>xs) = xs"
unfolding join_def by simp_all

subsection {* Maybe is not in @{text monad_plus} *}

text {*
  The @{text maybe} type does not satisfy the law @{text bind_mplus}.
*}

lemma maybe_counterexample1:
  "\<lbrakk>a = Just\<cdot>x; b = \<bottom>; k\<cdot>x = Nothing\<rbrakk>
    \<Longrightarrow> fplus\<cdot>a\<cdot>b \<guillemotright>= k \<noteq> fplus\<cdot>(a \<guillemotright>= k)\<cdot>(b \<guillemotright>= k)"
by simp

lemma maybe_counterexample2:
  "\<lbrakk>a = Just\<cdot>x; b = Just\<cdot>y; k\<cdot>x = Nothing; k\<cdot>y = Just\<cdot>z\<rbrakk>
    \<Longrightarrow> fplus\<cdot>a\<cdot>b \<guillemotright>= k \<noteq> fplus\<cdot>(a \<guillemotright>= k)\<cdot>(b \<guillemotright>= k)"
by simp

end


theory v5_isar_K
  imports Main "../QML"
begin

text \<open>
@{text "Compossibility\<^sub>5'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan @{term p}
while no table is made from matter that only partially overlaps @{term z}, then it is also possible
for table @{term x} to be originally made from matter @{term y} and in addition some table or other
@{term x'} to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan
@{term p} while no table is made from matter that only partially overlaps @{term z}.

@{text "Origin Uniqueness\<^sub>5'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>5'"}: If it is possible that a table @{term x'} is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} while no table is made from matter that only partially overlaps @{term z},
then necessarily any table that is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} while no table is made from matter that only partially overlaps @{term z}
is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>5'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not (the @{text "n\<^sup>t\<^sup>h"} table for any @{term n}) originally made from any non-overlapping
matter @{term z} according to any plan while no table is made from matter that only partially overlaps @{term z}.
\<close>

consts kTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> nat \<Rightarrow> \<sigma>" ("N")
(* (N x y p k) \<equiv> x is the kth table made from y according to p *)

lemma
assumes compossibilty5: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))\<rfloor>"
assumes sufficiency5: "\<lfloor>\<^bold>\<forall>y. \<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Ly \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Ly \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx)\<rfloor>"
assumes origin_uniqueness5: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))\<rfloor>"
shows origin_essentialism5: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> N x y p k) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k'))))\<rfloor>"
  text \<open>\<^item> Setting-up the worlds\<close>
(*<*)
proof (rule allI)
  fix w
  show  "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
  proof (rule allI)
    fix x
    show  "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
    proof (rule allI)
      fix y
      show  "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
      proof (rule allI)
        fix z
        show  "(\<^bold>\<forall>p. \<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
        proof (rule allI)
          fix p
          show  "(\<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
          proof (rule allI)
            fix k
            show  "((y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))))) w"
(*>*)

            proof (rule impI)
              assume antecedent: "(y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> N x y p k) w"
              show "\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k')))) w"
              proof (rule notI)
                assume "\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k' \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k'))) w"
                then have sufficiency5_ante: "\<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) w" by auto
                then have compossibilty5_ante: "(N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) w"
                  using antecedent by auto
                from antecedent have non_overlapping: "(y\<^bold>\<noteq>\<^sup>Lz) w" by (rule conjE)
                text\<open>\<^item> Deriving @{text "N x' z p k"} in @{term u} using @{term compossibilty5}\<close>
                from compossibilty5 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) w"..
(*<*)
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
                then have "(N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> ((\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))))))) w" by (rule allE)
(*>*)

                then have "\<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) w"
                  using compossibilty5_ante by (rule mp)
                then obtain u where u: "w r u \<and> ((N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) u)" by (rule exE)
                then have "(\<^bold>\<exists>x'. N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) u" by auto
                then obtain x' where x':  "(N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) u" by (rule exE)
                then have sufficiency5_cons_ante: "(N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) u" by simp
                then have "(N x' z p k) u" by (rule conjE)
                from u have "w r u" by (rule conjE)
                text \<open>\<^item> Deriving @{text "x' \<^bold>=\<^sup>L x"} in @{term u} using @{term sufficiency5}\<close>
                from sufficiency5 have "(\<^bold>\<forall>y. \<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Ly \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Ly \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx)) w"..
(*<*)
                then have "(\<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
                then have "(\<^bold>\<diamond>(N x z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. ((m\<^bold>=\<^sup>Lz) \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k)))) \<^bold>\<rightarrow> (x' \<^bold>=\<^sup>L x))) w" by (rule allE)
(*>*)

                then have "\<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx) w"
                  using sufficiency5_ante by (rule mp)
                then have "(\<^bold>\<forall>x'. (N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx) u"
                  using `w r u` by auto
                then have "((N x' z p k \<^bold>\<and> (\<^bold>\<forall>t'. \<^bold>\<forall>m. m\<^bold>=\<^sup>Lz \<^bold>\<rightarrow> \<^bold>\<not>(N t' m p k))) \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx) u"
                  by (rule allE)
                then have "(x'\<^bold>=\<^sup>Lx) u"
                  using sufficiency5_cons_ante by (rule mp)
                then have "(N x z p k) u" using `(N x' z p k) u` by auto
                text\<open>\<^item> Framing the @{term impossible_arg}\<close>
                from u have "(N x y p k) u" by simp
                then have impossible_arg: "(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz) u"
                  using `(N x z p k) u` and non_overlapping by auto
                text\<open>\<^item> Falsifying the @{term impossible_arg} using @{term origin_uniqueness5}\<close>
                from origin_uniqueness5 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w"..
(*<*)
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w" by (rule allE)
                then have "(\<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w" by (rule allE)
(*>*)

                then have "\<^bold>\<box>(\<^bold>\<not>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz)) w" by auto
                then have "\<^bold>\<not>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz) u"
                  using `w r u` by auto
                then show False using impossible_arg by (rule notE)
(*<*)
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed
(*>*)

end


(*  Title:      HOL/SPARK/Examples/RIPEMD-160/Hash.thy
    Author:     Fabian Immler, TU Muenchen

Verification of the RIPEMD-160 hash function
*)

theory Hash
imports RMD_Specification
begin

spark_open "rmd/hash"

abbreviation from_chain :: "chain \<Rightarrow> RMD.chain" where
  "from_chain c \<equiv> (
    word_of_int (h0 c),
    word_of_int (h1 c),
    word_of_int (h2 c),
    word_of_int (h3 c),
    word_of_int (h4 c))"

abbreviation to_chain :: "RMD.chain \<Rightarrow> chain" where
  "to_chain c \<equiv>
    (let (h0, h1, h2, h3, h4) = c in
      (|h0 = uint h0,
        h1 = uint h1,
        h2 = uint h2,
        h3 = uint h3,
        h4 = uint h4|))"

abbreviation round' :: "chain \<Rightarrow> block \<Rightarrow> chain" where
  "round' c b == to_chain (round (\<lambda>n. word_of_int (b (int n))) (from_chain c))"

abbreviation rounds' :: "chain \<Rightarrow> int \<Rightarrow> message \<Rightarrow> chain" where
  "rounds' h i X ==
     to_chain (rounds
      (\<lambda>n. \<lambda>m. word_of_int (X (int n) (int m)))
      (from_chain h)
      (nat i))"

abbreviation rmd_hash :: "message \<Rightarrow> int \<Rightarrow> chain" where
  "rmd_hash X i == to_chain (rmd
    (\<lambda>n. \<lambda>m. word_of_int (X (int n) (int m)))
    (nat i))"

spark_proof_functions
  round_spec = round'
  rounds = rounds'
  rmd_hash = rmd_hash

spark_vc function_hash_12
  using H1 H6
  by (simp add:
    rounds_def rmd_body_def round_def
    h_0_def h0_0_def h1_0_def h2_0_def h3_0_def h4_0_def)

lemma rounds_step:
  assumes "0 <= i"
  shows "rounds X b (Suc i) = round (X i) (rounds X b i)"
  by (simp add: rounds_def rmd_body_def)

lemma from_to_id: "from_chain (to_chain C) = C"
proof (cases C)
  fix a b c d e f::word32
  assume "C = (a, b, c, d, e)"
  thus ?thesis by (cases a) simp
qed

lemma steps_to_steps':
  "round X (foldl a b c) = round X (from_chain (to_chain (foldl a b c)))"
  unfolding from_to_id ..

lemma rounds'_step:
  assumes "0 <= i"
  shows "rounds' c (i + 1) x = round' (rounds' c i x) (x i)"
proof -
  have makesuc: "nat (i + 1) = Suc (nat i)" using assms by simp
  show ?thesis using assms
    by (simp add: makesuc rounds_def rmd_body_def steps_to_steps')
qed

spark_vc function_hash_13
proof -
  have loop_suc: "loop__1__i + 2 = (loop__1__i + 1) + 1" by simp
  have "0 <= loop__1__i + 1" using \<open>0 <= loop__1__i\<close> by simp
  show ?thesis
    unfolding loop_suc
    unfolding rounds'_step[OF \<open>0 <= loop__1__i + 1\<close>]
    unfolding H1[symmetric]
    unfolding H18 ..
qed

spark_vc function_hash_17
  unfolding rmd_def H1 rounds_def ..

spark_end

end


theory OutputSensitive
  imports "NREST.NREST"
    "NREST.RefineMonadicVCG"
    "../Refine_Imperative_HOL/IICF/IICF"
begin

definition "divide_SPEC n d = REST [ (n div d, n mod d) \<mapsto> n div d ]"

definition ddivide :: "nat \<Rightarrow> nat \<Rightarrow> (nat*nat) nrest" where
  "ddivide n d = RECT (\<lambda> df (q,r). if r \<ge> d then do {
          q' \<leftarrow> SPECT [q+1\<mapsto>1]; r'\<leftarrow> SPECT [r-d\<mapsto>1]; df (q',r') } else RETURNT (q,r)) (0,n)"

definition ddivide' :: "nat \<Rightarrow> nat \<Rightarrow> (nat*nat) nrest" where
  "ddivide' n d =  whileT (\<lambda>(q,r). r \<ge> d) (\<lambda>(q,r).  do {
          SPECT [ (q+1,r-d) \<mapsto> 1 ] }) (0,n) "

lemma "d>0 \<Longrightarrow> ddivide' n d \<le> divide_SPEC n d"
  unfolding  divide_SPEC_def ddivide'_def
  unfolding whileIET_def[symmetric, where I="\<lambda>(q,r). q*d+r=n"
        and E="\<lambda>(q,r). r div d"]
  apply(rule T_specifies_I)
  apply (vcg' \<open>-\<close>)
  subgoal by simp
  subgoal for s a b
    apply (auto simp: mm3_def)
    subgoal
      using div_le_mono by auto
    subgoal sorry
    done
  subgoal by auto
  done

end