(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Find_Names
imports Pure
keywords "find_names" :: diag
begin

text \<open>The @{command find_names} command, when given a theorem,
  finds other names the theorem appears under, via matching on the whole
  proposition. It will not identify unnamed theorems.\<close>

ML \<open>

local
(* all_facts_of and pretty_ref taken verbatim from non-exposed version
   in Find_Theorems.ML of official Isabelle/HOL distribution *)
fun all_facts_of ctxt =
  let
    val thy = Proof_Context.theory_of ctxt;
    val transfer = Global_Theory.transfer_theories thy;
    val local_facts = Proof_Context.facts_of ctxt;
    val global_facts = Global_Theory.facts_of thy;
  in
   (Facts.dest_all (Context.Proof ctxt) false [global_facts] local_facts
    @ Facts.dest_all (Context.Proof ctxt) false [] global_facts)
   |> maps Facts.selections
   |> map (apsnd transfer)
  end;

fun pretty_ref ctxt thmref =
  let
    val (name, sel) =
      (case thmref of
        Facts.Named ((name, _), sel) => (name, sel)
      | Facts.Fact _ => raise Fail "Illegal literal fact");
  in
    [Pretty.marks_str (#1 (Proof_Context.markup_extern_fact ctxt name), name),
      Pretty.str (Facts.string_of_selection sel)]
  end;

in

fun find_names ctxt thm =
  let
    fun eq_filter body thmref = (body = Thm.full_prop_of (snd thmref));
  in
    (filter (eq_filter (Thm.full_prop_of thm))) (all_facts_of ctxt)
    |> map #1
  end;

fun pretty_find_names ctxt thm =
  let
    val results = find_names ctxt thm;
    val position_markup = Position.markup (Position.thread_data ()) Markup.position;
  in
    ((Pretty.mark position_markup (Pretty.keyword1 "find_names")) ::
      Par_List.map (Pretty.item o (pretty_ref ctxt)) results)
    |> Pretty.fbreaks |> Pretty.block |> Pretty.writeln
  end

end

val _ =
  Outer_Syntax.command @{command_keyword find_names}
    "find other names of a named theorem"
    (Parse.thms1 >> (fn srcs => Toplevel.keep (fn st =>
      pretty_find_names (Toplevel.context_of st)
        (hd (Attrib.eval_thms (Toplevel.context_of st) srcs)))));
\<close>

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
 * Strengthen functions into simpler monads.
 *
 * Each block of lifting lemmas converts functions in the "L2" monadic
 * framework (an exception framework) into its own framework.
 *)

theory TypeStrengthen
imports
  L2Defs
  "Lib.OptionMonadND"
  ExecConcrete
begin

(* Set up the database and ts_rule attribute. *)
ML_file "monad_types.ML"
setup \<open>
 Attrib.setup (Binding.name "ts_rule") Monad_Types.ts_attrib
              "AutoCorres type strengthening rule"
\<close>

(*
 * Helpers for exception polymorphism lemmas (L2_call_Foo_polymorphic).
 *
 * They are used to rewrite a term like
 *
 *   L2_call x = Foo y
 *
 * into an identical term with a different exception type.
 *)

definition
  unliftE
where
  "unliftE (x :: ('a, 'u + 'b) nondet_monad) \<equiv> x <catch> (\<lambda>_. fail)"

lemma L2_call_liftE_unliftE:
    "L2_call x = liftE (unliftE (L2_call x))"
  apply (clarsimp simp: L2_call_def unliftE_def)
  apply (rule ext)
  apply (clarsimp simp: handleE'_def catch_def liftE_def bind_assoc)
  apply (clarsimp cong: bind_apply_cong)
  apply (clarsimp simp: bind_def split_def return_def split: sum.splits)
  apply (force simp: return_def fail_def split: sum.splits)+
  done

lemma unliftE_liftE [simp]:
    "unliftE (liftE x) = x"
  apply (clarsimp simp: unliftE_def catch_liftE)
  done

(*
 * Lifting into pure functional Isabelle.
 *)

definition "TS_return x \<equiv> liftE (return x)"

lemma L2_call_TS_return: "L2_call (TS_return a) = L2_gets (\<lambda>_. a) [''ret'']"
  apply (monad_eq simp: L2_call_def L2_gets_def TS_return_def)
  done

lemma TS_return_L2_gets:
    "L2_gets (\<lambda>_. P) n = TS_return P"
  by (monad_eq simp: L2_defs TS_return_def)

lemma L2_call_L2_gets_polymorphic:
  "(L2_call x :: ('s, 'a, 'e1) L2_monad) = L2_gets y n
    \<Longrightarrow> (L2_call x  :: ('s, 'a, 'e2) L2_monad) = L2_gets y n"
  apply (monad_eq simp: L2_defs L2_call_def Ball_def split: sum.splits)
  apply blast
  done

setup \<open>
Monad_Types.new_monad_type
  "pure"
  "Pure function"
  (Monad_Types.check_lifting_head [@{term "TS_return"}])
  100
  @{thms L2_call_TS_return TS_return_L2_gets}
  @{term "(%a. L2_gets (%_. a) [''ret'']) :: 'a => ('s, 'a, unit) L2_monad"}
  @{thm L2_call_L2_gets_polymorphic}
  #2
  (fn _ => error "monad_mono not applicable for pure monad")
|> Context.theory_map
\<close>

lemma TS_return_L2_seq:
    "L2_seq (TS_return A) (\<lambda>a. TS_return (B a))
       = TS_return (let a = A in B a)"
  by (monad_eq simp: L2_defs TS_return_def)

lemma TS_return_L2_condition:
    "L2_condition (\<lambda>_. c) (TS_return A) (TS_return B) = TS_return (if c then A else B)"
  by (monad_eq simp: L2_defs TS_return_def)

lemmas [ts_rule pure] =
  TS_return_L2_gets
  TS_return_L2_seq
  TS_return_L2_condition
  split_distrib[where T = TS_return]

lemma L2_seq_TS_return:
    "TS_return (let a = A in B a) = L2_seq (L2_gets (\<lambda>_. A) []) (\<lambda>a. L2_gets (\<lambda>_. B a) [])"
  by (monad_eq simp: L2_defs TS_return_def)

lemma L2_condition_TS_return:
    "TS_return (if c then A else B) = L2_condition (\<lambda>_. c) (L2_gets (\<lambda>_. A) []) (L2_gets (\<lambda>_. B) [])"
  by (monad_eq simp: L2_defs TS_return_def)

lemmas [ts_rule pure unlift] =
  TS_return_L2_gets      [where n = "[]", symmetric]
  TS_return_L2_seq       [symmetric]
  TS_return_L2_condition [symmetric]
  L2_seq_TS_return
  L2_condition_TS_return
  split_distrib[where T = TS_return, symmetric]

(*
 * Lifting into pure functional Isabelle with state.
 *)

definition "TS_gets x \<equiv> liftE (gets x)"

lemma TS_gets_L2_gets:
    "L2_gets X n = TS_gets X"
  by (monad_eq simp: L2_defs TS_gets_def)

lemma L2_call_TS_gets: "L2_call (TS_gets a) = L2_gets a [''TS_internal_retval'']"
  apply (monad_eq simp: L2_call_def L2_gets_def TS_gets_def)
  done

setup \<open>
Monad_Types.new_monad_type
  "gets"
  "Read-only function"
  (Monad_Types.check_lifting_head [@{term "TS_gets"}])
  80
  @{thms L2_call_TS_gets TS_gets_L2_gets}
  @{term "(%x. L2_gets x [''ret'']) :: ('s => 'a) => ('s, 'a, unit) L2_monad"}
  @{thm L2_call_L2_gets_polymorphic}
  (fn (state, ret, ex) => state --> ret)
  (fn _ => error "monad_mono not applicable for gets monad")
|> Context.theory_map
\<close>

lemma TS_gets_L2_seq:
    "L2_seq (TS_gets A) (\<lambda>x. TS_gets (B x)) = (TS_gets (\<lambda>s. let x = A s in B x s))"
  by (monad_eq simp: L2_defs TS_gets_def)

lemma TS_gets_L2_condition:
    "L2_condition c (TS_gets A) (TS_gets B) = TS_gets (\<lambda>s. if c s then (A s) else (B s))"
  by (monad_eq simp: L2_defs TS_gets_def)

lemmas [ts_rule gets] =
  TS_gets_L2_gets
  TS_gets_L2_seq
  TS_gets_L2_condition
  split_distrib[where T = TS_gets]

lemmas [ts_rule gets unlift] =
  TS_gets_L2_gets      [where n = "[]", symmetric]
  TS_gets_L2_seq       [symmetric]
  TS_gets_L2_condition [symmetric]
  split_distrib[where T = TS_gets, symmetric]

(*
 * Lifting into option monad.
 *)

definition "gets_theE \<equiv> \<lambda>x. (liftE (gets_the x))"

lemma L2_call_gets_theE [simp]: "L2_call (gets_theE x) = gets_theE x"
  apply (monad_eq simp: L2_call_def L2_gets_def gets_theE_def)
  done

lemma liftE_gets_theE: "gets_theE X = liftE (gets_the X)"
  apply (clarsimp simp: gets_theE_def)
  done
lemma L2_call_gets_theE_polymorphic:
  "(L2_call x :: ('s, 'a, 'e1) L2_monad) = gets_theE y
    \<Longrightarrow> (L2_call x  :: ('s, 'a, 'e2) L2_monad) = gets_theE y"
  apply (metis L2_call_liftE_unliftE liftE_gets_theE unliftE_liftE)
  done

lemma in_gets_theE [monad_eq]:
     "(rv, s') \<in> fst (gets_theE M s) = (\<exists>v'. rv = Inr v' \<and> s' = s \<and> M s = Some v')"
  apply (monad_eq simp: gets_theE_def)
  done

lemma snd_gets_theE [monad_eq]:
     "snd (gets_theE M s) = (M s = None)"
  apply (monad_eq simp: gets_theE_def gets_the_def Bex_def assert_opt_def split: option.splits)
  done

lemma gets_theE_ofail [simp]:
  "gets_theE ofail = fail"
  by (monad_eq simp: L2_defs ofail_def split: option.splits)

(* unused *)
lemma monad_mono_transfer_option:
  "\<lbrakk> \<And>m. (L2_call (f m) :: ('s, 'a, 'e) L2_monad) = gets_theE (f' m); monad_mono f \<rbrakk> \<Longrightarrow> option_monad_mono f'"
  apply atomize
  apply (clarsimp simp: monad_mono_def option_monad_mono_def)
  apply (clarsimp split: option.splits)
  apply (erule allE, erule allE, erule (1) impE)
  apply (erule_tac x=s in allE)
  apply (frule_tac x=x in spec)
  apply (drule_tac x=y in spec)
  apply rule
   apply (monad_eq simp: L2_call_def split: sum.splits)
   apply metis
  apply (monad_eq simp: L2_call_def split: sum.splits)
  apply (metis (full_types) sum.inject(2))
  done

setup \<open>
Monad_Types.new_monad_type
  "option"
  "Option monad"
  (Monad_Types.check_lifting_head [@{term "gets_theE"}])
  60
  @{thms L2_call_gets_theE gets_theE_ofail}
  @{term "gets_theE :: ('s => 'a option) => ('s, 'a, unit) L2_monad"}
  @{thm L2_call_gets_theE_polymorphic}
  (fn (state, ret, ex) =>
     state --> Term.map_atyps (fn t => if t = @{typ "'a"} then ret else t) @{typ "'a option"})
  (fn def => fn mono_thm => @{thm monad_mono_transfer_option} OF [def, mono_thm])
|> Context.theory_map
\<close>

lemma gets_theE_L2_gets:
  "L2_gets a n = gets_theE (ogets a)"
  by (monad_eq simp: L2_defs ogets_def)

lemma gets_theE_L2_seq:
  "L2_seq (gets_theE X) (\<lambda>x. gets_theE (Y x)) = gets_theE (X |>> Y)"
  by (monad_eq simp: L2_defs ogets_def Bex_def obind_def split: option.splits)

lemma gets_theE_L2_guard:
  "L2_guard G = gets_theE (oguard G)"
  by (monad_eq simp: L2_defs oguard_def split: option.splits)

lemma gets_theE_L2_condition:
  "L2_condition C (gets_theE L) (gets_theE R) = gets_theE (ocondition C L R)"
  by (monad_eq simp: L2_defs ocondition_def split: option.splits)

lemma gets_theE_L2_fail:
  "L2_fail = gets_theE (ofail)"
  by (monad_eq simp: L2_defs ofail_def split: option.splits)

lemma gets_theE_L2_recguard:
  "L2_recguard m (gets_theE x) = gets_theE (ocondition (\<lambda>_. m = 0) ofail x)"
  by (monad_eq simp: L2_defs ocondition_def ofail_def split: option.splits)

lemma gets_theE_L2_while:
  "L2_while C (\<lambda>x. gets_theE (B x)) i n = gets_theE (owhile C B i)"
  unfolding L2_while_def gets_theE_def gets_the_whileLoop[symmetric]
  by (rule whileLoopE_liftE)

lemmas [ts_rule option] =
  gets_theE_L2_seq
  gets_theE_L2_fail
  gets_theE_L2_guard
  gets_theE_L2_recguard
  gets_theE_L2_gets
  gets_theE_L2_condition
  gets_theE_L2_while
  split_distrib[where T = gets_theE]

lemmas [ts_rule option unlift] =
  gets_theE_L2_seq       [symmetric]
  gets_theE_L2_fail      [symmetric]
  gets_theE_L2_guard     [symmetric]
  gets_theE_L2_recguard  [symmetric]
  gets_theE_L2_gets      [where n = "[]", symmetric]
  gets_theE_L2_condition [symmetric]
  gets_theE_L2_while     [symmetric]
  split_distrib[where T = gets_theE, symmetric]

(*
 * Lifting into the nondeterministic state monad.
 * All L2 terms can be lifted into it.
 *)

lemma L2_call_liftE_polymorphic:
  "((L2_call x) :: ('s, 'a, 'e1) L2_monad) = liftE y
    \<Longrightarrow> (L2_call x :: ('s, 'a, 'e2) L2_monad) = liftE y"
  apply (metis L2_call_liftE_unliftE unliftE_liftE)
  done

lemma monad_mono_transfer_nondet:
  "\<lbrakk> \<And>m. (L2_call (f m) :: ('s, 'a, 'e) L2_monad) = liftE (f' m); monad_mono f \<rbrakk> \<Longrightarrow> monad_mono f'"
  apply atomize
  apply (clarsimp simp: monad_mono_def option_monad_mono_def)
  apply (erule allE, erule allE, erule (1) impE)
  apply (erule_tac x=s in allE)
  apply (frule_tac x=x in spec)
  apply (drule_tac x=y in spec)
  apply rule
   apply (monad_eq simp: L2_call_def split: sum.splits)
   apply (metis set_rev_mp sum.inject(2))
  apply (monad_eq simp: L2_call_def split: sum.splits)
  apply (* not *) fast
  done

setup \<open>
Monad_Types.new_monad_type
  "nondet"
  "Nondeterministic state monad (default)"
  (Monad_Types.check_lifting_head [@{term "liftE"}])
  0
  @{thms L2_call_liftE}
  @{term "liftE :: ('s, 'a) nondet_monad => ('s, 'a, unit) L2_monad"}
  @{thm L2_call_liftE_polymorphic}
  (fn (state, ret, ex) =>
     Term.map_atyps (fn t => if t = @{typ "'a"} then ret
                               else if t = @{typ "'s"} then state else t)
       @{typ "('s, 'a) nondet_monad"})
  (fn def => fn mono_thm => @{thm monad_mono_transfer_nondet} OF [def, mono_thm])
|> Context.theory_map
\<close>

lemma liftE_L2_seq: "L2_seq (liftE A) (\<lambda>x. liftE (B x)) = (liftE (A >>= B))"
  apply (clarsimp simp: L2_defs)
  apply (clarsimp simp: liftE_def bindE_def bind_assoc)
  done

lemma liftE_L2_condition: "L2_condition c (liftE A) (liftE B) = liftE (condition c A B)"
  apply (clarsimp simp: L2_defs)
  apply (rule ext)+
  apply monad_eq
  apply blast
  done

lemma liftE_L2_modify: "L2_modify m = liftE (modify m)"
  apply (clarsimp simp: L2_defs)
  done

lemma liftE_L2_gets: "L2_gets a n = liftE (gets a)"
  apply (clarsimp simp: L2_defs)
  done

lemma liftE_L2_recguard:
  "(L2_recguard x (liftE A)) = liftE (condition (\<lambda>s. x > 0) A fail)"
  apply (case_tac "x = 0")
   apply clarsimp
  apply (clarsimp simp: L2_recguard_def)
  done

lemma liftE_L2_while: "L2_while c (\<lambda>r. liftE (B r)) i n = liftE (whileLoop c B i)"
  apply (clarsimp simp: L2_while_def)
  apply (rule whileLoopE_liftE)
  done

lemma liftE_L2_throw: "L2_throw X n = throwError X"
  apply (monad_eq simp: L2_throw_def)
  done

lemma liftE_L2_catch: "L2_catch (liftE A) B = liftE A"
  apply (clarsimp simp: L2_defs)
  done

lemma liftE_L2_catch': "L2_catch A (\<lambda>x. liftE (B x)) = liftE (A <catch> B)"
  apply (clarsimp simp: L2_defs)
  apply (clarsimp simp: handleE'_def liftE_def catch_def bind_assoc)
  apply (rule arg_cong [where f="\<lambda>x. (A >>= x)"])
  apply (rule ext)
  apply (clarsimp split: sum.splits)
  done

lemma liftE_L2_unknown: "L2_unknown name = liftE (select UNIV)"
  apply (clarsimp simp: L2_defs)
  done

lemma liftE_L2_spec: "L2_spec S = liftE (spec S >>= (\<lambda>_. select UNIV))"
  apply (clarsimp simp: L2_defs)
  done

lemma liftE_L2_guard: "L2_guard G = liftE (guard G)"
  apply (clarsimp simp: L2_defs)
  done

lemma liftE_L2_fail: "L2_fail = liftE (fail)"
  apply (clarsimp simp: L2_defs liftE_def)
  done

lemma liftE_exec_concrete:
  "exec_concrete st (liftE x) = liftE (exec_concrete st x)"
  apply (rule monad_eqI)
    apply (clarsimp simp: in_liftE in_exec_concrete)
    apply force
   apply (clarsimp simp: in_liftE in_exec_concrete)
   apply force
  apply (clarsimp simp: snd_exec_concrete snd_liftE)
  done

lemma liftE_exec_abstract:
  "exec_abstract st (liftE x) = liftE (exec_abstract st x)"
  apply (rule monad_eqI)
    apply (clarsimp simp: in_liftE in_exec_abstract)
   apply (clarsimp simp: in_liftE in_exec_abstract)
  apply (clarsimp simp: snd_exec_abstract snd_liftE)
  done

lemma liftE_measure_call:
  "\<lbrakk> monad_mono A; \<And>m. L2_call (A m) = liftE (B m) \<rbrakk>
   \<Longrightarrow> L2_call (measure_call A) = liftE (measure_call B)"
  apply (monad_eq simp: measure_call_def L2_call_def L2_defs)
  apply (fast dest: monad_mono_incl)
  done

lemmas [ts_rule nondet] =
  liftE_L2_seq
  liftE_L2_condition
  liftE_L2_modify
  liftE_L2_gets
  liftE_L2_while
  liftE_L2_throw
  liftE_L2_catch
  liftE_L2_catch'
  liftE_L2_spec
  liftE_L2_guard
  liftE_L2_unknown
  liftE_L2_fail
  liftE_L2_recguard
  liftE_exec_concrete
  liftE_exec_abstract
  liftE_gets_theE
  liftE_measure_call
  split_distrib [where T=liftE]

definition
  "AC_call_L1 arg_xf gs ret_xf l1body
    = liftM (\<lambda>rv. case rv of Inr v \<Rightarrow> v)
        (L2_call_L1 arg_xf gs ret_xf l1body)"

lemma liftE_L2_call_L1[ts_rule nondet]:
  "L2_call_L1 arg_xf gs ret_xf l1body
    = liftE (AC_call_L1 arg_xf gs ret_xf l1body)"
  apply (simp add: AC_call_L1_def L2_call_L1_def
                   liftE_def liftM_def bind_assoc)
  apply (rule ext)
  apply (simp add: exec_gets exec_get)
  apply (rule bind_apply_cong[OF refl])+
  apply (clarsimp simp: bind_assoc returnOk_def in_monad split: sum.splits)
  done

lemmas [ts_rule nondet unlift] =
  liftE_L2_seq        [symmetric]
  liftE_L2_condition  [symmetric]
  liftE_L2_modify     [symmetric]
  liftE_L2_gets       [symmetric]
  liftE_L2_while      [symmetric]
  liftE_L2_throw      [symmetric]
  liftE_L2_catch      [symmetric]
  liftE_L2_catch'     [symmetric]
  liftE_L2_spec       [symmetric]
  liftE_L2_guard      [symmetric]
  liftE_L2_unknown    [symmetric]
  liftE_L2_fail       [symmetric]
  liftE_L2_recguard   [symmetric]
  liftE_exec_concrete [symmetric]
  liftE_exec_abstract [symmetric]
  liftE_gets_theE     [symmetric]
  split_distrib [where T=liftE, symmetric]

end


(*  Title:      JinjaDCI/BV/BVNoTypeErrors.thy

    Author:     Gerwin Klein, Susannah Mansky
    Copyright   GPL

    Based on the Jinja theory BV/BVNoTypeErrors.thy by Gerwin Klein
*)

section \<open> Welltyped Programs produce no Type Errors \<close>

theory BVNoTypeError
imports "../JVM/JVMDefensive" BVSpecTypeSafe
begin

lemma has_methodI:
  "P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C has M,b"
  by (unfold has_method_def) blast

text \<open>
  Some simple lemmas about the type testing functions of the
  defensive JVM:
\<close>
lemma typeof_NoneD [simp,dest]: "typeof v = Some x \<Longrightarrow> \<not>is_Addr v"
  by (cases v) auto

lemma is_Ref_def2:
  "is_Ref v = (v = Null \<or> (\<exists>a. v = Addr a))"
  by (cases v) (auto simp add: is_Ref_def)

lemma is_RefI [intro, simp]: "P,h \<turnstile> v :\<le> T \<Longrightarrow> is_refT T \<Longrightarrow> is_Ref v"
(*<*)
proof(cases T)
qed (auto simp add: is_refT_def is_Ref_def dest: conf_ClassD)
(*>*)

lemma is_BoolI [intro, simp]: "P,h \<turnstile> v :\<le> Boolean \<Longrightarrow> is_Bool v"
(*<*)by (unfold conf_def) auto(*>*)

declare defs1 [simp del]

lemma wt_jvm_prog_states_NonStatic:
assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  and mC: "P \<turnstile> C sees M,NonStatic: Ts\<rightarrow>T = (mxs, mxl, ins, et) in C"
  and \<Phi>: "\<Phi> C M ! pc = \<tau>" and pc: "pc < size ins"
shows "OK \<tau> \<in> states P mxs (1+size Ts+mxl)"
(*<*)
proof -
  let ?wf_md = "(\<lambda>P C (M, b, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt).
                       wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"
  have wfmd: "wf_prog ?wf_md P" using wf
    by (unfold wf_jvm_prog_phi_def) assumption
  show ?thesis using sees_wf_mdecl[OF wfmd mC] \<Phi> pc
    by (simp add: wf_mdecl_def wt_method_def check_types_def)
       (blast intro: nth_in)
qed
(*>*)

lemma wt_jvm_prog_states_Static:
assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  and mC: "P \<turnstile> C sees M,Static: Ts\<rightarrow>T = (mxs, mxl, ins, et) in C"
  and \<Phi>: "\<Phi> C M ! pc = \<tau>" and pc: "pc < size ins"
shows "OK \<tau> \<in> states P mxs (size Ts+mxl)"
(*<*)
proof -
  let ?wf_md = "(\<lambda>P C (M, b, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt).
                       wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"
  have wfmd: "wf_prog ?wf_md P" using wf
    by (unfold wf_jvm_prog_phi_def) assumption
  show ?thesis using sees_wf_mdecl[OF wfmd mC] \<Phi> pc
    by (simp add: wf_mdecl_def wt_method_def check_types_def)
       (blast intro: nth_in)
qed
(*>*)

text \<open>
  The main theorem: welltyped programs do not produce type errors if they
  are started in a conformant state.
\<close>
theorem no_type_error:
  fixes \<sigma> :: jvm_state
  assumes welltyped: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P" and conforms: "P,\<Phi> \<turnstile> \<sigma> \<surd>"
  shows "exec_d P \<sigma> \<noteq> TypeError"
(*<*)
proof -
  from welltyped obtain mb where wf: "wf_prog mb P" by (fast dest: wt_jvm_progD)

  obtain xcp h frs sh where s [simp]: "\<sigma> = (xcp, h, frs, sh)" by (cases \<sigma>)

  from conforms have "xcp \<noteq> None \<or> frs = [] \<Longrightarrow> check P \<sigma>"
    by (unfold correct_state_def check_def) auto
  moreover {
    assume "\<not>(xcp \<noteq> None \<or> frs = [])"
    then obtain stk reg C M pc ics frs' where
      xcp [simp]: "xcp = None" and
      frs [simp]: "frs = (stk,reg,C,M,pc,ics)#frs'"
      by (clarsimp simp add: neq_Nil_conv)

    from conforms obtain  ST LT b Ts T mxs mxl ins xt where
      hconf:  "P \<turnstile> h \<surd>" and
      shconf:  "P,h \<turnstile>\<^sub>s sh \<surd>" and
      meth:   "P \<turnstile> C sees M,b:Ts\<rightarrow>T = (mxs, mxl, ins, xt) in C" and
      \<Phi>:      "\<Phi> C M ! pc = Some (ST,LT)" and
      frame:  "conf_f P h sh (ST,LT) ins (stk,reg,C,M,pc,ics)" and
      frames: "conf_fs P h sh \<Phi> C M (size Ts) T frs'"
      by (fastforce simp add: correct_state_def dest: sees_method_fun)

    from frame obtain
      stk: "P,h \<turnstile> stk [:\<le>] ST" and
      reg: "P,h \<turnstile> reg [:\<le>\<^sub>\<top>] LT" and
      pc:  "pc < size ins"
      by (simp add: conf_f_def)

    from welltyped meth \<Phi> pc
    have "OK (Some (ST, LT)) \<in> states P mxs (1+size Ts+mxl)
        \<or> OK (Some (ST, LT)) \<in> states P mxs (size Ts+mxl)"
      by (cases b, auto dest: wt_jvm_prog_states_NonStatic wt_jvm_prog_states_Static)
    hence "size ST \<le> mxs" by (auto simp add: JVM_states_unfold)
    with stk have mxs: "size stk \<le> mxs"
      by (auto dest: list_all2_lengthD)

    from welltyped meth pc
    have "P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
      by (rule wt_jvm_prog_impl_wt_instr)
    hence app\<^sub>0: "app (ins!pc) P mxs T pc (size ins) xt (\<Phi> C M!pc) "
      by (simp add: wt_instr_def)
    with \<Phi> have eff:
      "\<forall>(pc',s')\<in>set (eff (ins ! pc) P pc xt (\<Phi> C M ! pc)). pc' < size ins"
      by (unfold app_def) simp

    from app\<^sub>0 \<Phi> have app:
      "xcpt_app (ins!pc) P pc mxs xt (ST,LT) \<and> app\<^sub>i (ins!pc, P, pc, mxs, T, (ST,LT))"
      by (clarsimp simp add: app_def)

    with eff stk reg
    have "check_instr (ins!pc) P h stk reg C M pc frs' sh"
    proof (cases "ins!pc")
      case (Getfield F C)
      with app stk reg \<Phi> obtain v vT stk' where
        field: "P \<turnstile> C sees F,NonStatic:vT in C" and
        stk:   "stk = v # stk'" and
        conf:  "P,h \<turnstile> v :\<le> Class C"
        by auto
      from conf have is_Ref: "is_Ref v" by auto
      moreover {
        assume "v \<noteq> Null"
        with conf field is_Ref wf
        have "\<exists>D vs. h (the_Addr v) = Some (D,vs) \<and> P \<turnstile> D \<preceq>\<^sup>* C"
          by (auto dest!: non_npD)
      }
      ultimately show ?thesis using Getfield field stk
        has_field_mono[OF has_visible_field[OF field]] hconfD[OF hconf]
        by (unfold oconf_def has_field_def) (fastforce dest: has_fields_fun)
    next
      case (Getstatic C F D)
      with app stk reg \<Phi> obtain vT where
        field: "P \<turnstile> C sees F,Static:vT in D"
        by auto

      then show ?thesis using Getstatic stk
        has_field_idemp[OF has_visible_field[OF field]] shconfD[OF shconf]
        by (unfold soconf_def has_field_def) (fastforce dest: has_fields_fun)
    next
      case (Putfield F C)
      with app stk reg \<Phi> obtain v ref vT stk' where
        field: "P \<turnstile> C sees F,NonStatic:vT in C" and
        stk:   "stk = v # ref # stk'" and
        confv: "P,h \<turnstile> v :\<le> vT" and
        confr: "P,h \<turnstile> ref :\<le> Class C"
        by fastforce
      from confr have is_Ref: "is_Ref ref" by simp
      moreover {
        assume "ref \<noteq> Null"
        with confr field is_Ref wf
        have "\<exists>D vs. h (the_Addr ref) = Some (D,vs) \<and> P \<turnstile> D \<preceq>\<^sup>* C"
          by (auto dest: non_npD)
      }
      ultimately show ?thesis using Putfield field stk confv by fastforce
    next
      case (Invoke M' n)
      with app have n: "n < size ST" by simp

      from stk have [simp]: "size stk = size ST" by (rule list_all2_lengthD)

      { assume "stk!n = Null" with n Invoke have ?thesis by simp }
      moreover {
        assume "ST!n = NT"
        with n stk have "stk!n = Null" by (auto simp: list_all2_conv_all_nth)
        with n Invoke have ?thesis by simp
      }
      moreover {
        assume Null: "stk!n \<noteq> Null" and NT: "ST!n \<noteq> NT"

        from NT app Invoke
        obtain D D' Ts T m where
          D:  "ST!n = Class D" and
          M': "P \<turnstile> D sees M',NonStatic: Ts\<rightarrow>T = m in D'" and
          Ts: "P \<turnstile> rev (take n ST) [\<le>] Ts"
          by auto

        from D stk n have "P,h \<turnstile> stk!n :\<le> Class D"
          by (auto simp: list_all2_conv_all_nth)
        with Null obtain a C' fs where
          [simp]: "stk!n = Addr a" "h a = Some (C',fs)" and
          "P \<turnstile> C' \<preceq>\<^sup>* D"
          by (fastforce dest!: conf_ClassD)

        with M' wf obtain m' Ts' T' D'' where
          C': "P \<turnstile> C' sees M',NonStatic: Ts'\<rightarrow>T' = m' in D''" and
          Ts': "P \<turnstile> Ts [\<le>] Ts'"
          by (auto dest!: sees_method_mono)

        from stk have "P,h \<turnstile> take n stk [:\<le>] take n ST" ..
        hence "P,h \<turnstile> rev (take n stk) [:\<le>] rev (take n ST)" ..
        also note Ts also note Ts'
        finally have "P,h \<turnstile> rev (take n stk) [:\<le>] Ts'" .

        with Invoke Null n C'
        have ?thesis by (auto simp add: is_Ref_def2 has_methodI)
      }
      ultimately show ?thesis by blast
    next
      case (Invokestatic C M' n)
      with app have n: "n \<le> size ST" by simp

      from stk have [simp]: "size stk = size ST" by (rule list_all2_lengthD)

      from app Invokestatic
      obtain D Ts T m where
        M': "P \<turnstile> C sees M',Static: Ts\<rightarrow>T = m in D" and
        Ts: "P \<turnstile> rev (take n ST) [\<le>] Ts"
        by auto

      from stk have "P,h \<turnstile> take n stk [:\<le>] take n ST" ..
      hence "P,h \<turnstile> rev (take n stk) [:\<le>] rev (take n ST)" ..
      also note Ts
      finally have "P,h \<turnstile> rev (take n stk) [:\<le>] Ts" .

      with Invokestatic n M'
      show ?thesis by (auto simp add: is_Ref_def2 has_methodI)
    next
      case Return
      show ?thesis
      proof(cases "M = clinit")
        case True
        have "is_class P C" by(rule sees_method_is_class[OF meth])
        with wf_sees_clinit[OF wf]
        obtain m where "P \<turnstile> C sees clinit,Static: [] \<rightarrow> Void = m in C"
         by(fastforce simp: is_class_def)

        with stk app \<Phi> meth frames True Return
        show ?thesis by (auto simp add: has_methodI)
      next
        case False with stk app \<Phi> meth frames Return
        show ?thesis by (auto intro: has_methodI)
      qed
    qed (auto simp add: list_all2_lengthD)
    hence "check P \<sigma>" using meth pc mxs by (auto simp: check_def intro: has_methodI)
  } ultimately
  have "check P \<sigma>" by blast
  thus "exec_d P \<sigma> \<noteq> TypeError" ..
qed
(*>*)

text \<open>
  The theorem above tells us that, in welltyped programs, the
  defensive machine reaches the same result as the aggressive
  one (after arbitrarily many steps).
\<close>
theorem welltyped_aggressive_imp_defensive:
  "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P \<Longrightarrow> P,\<Phi> \<turnstile> \<sigma> \<surd> \<Longrightarrow> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'
  \<Longrightarrow> P \<turnstile> (Normal \<sigma>) -jvmd\<rightarrow> (Normal \<sigma>')"
(*<*)
proof -
  assume wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P" and cf: "P,\<Phi> \<turnstile> \<sigma> \<surd>" and exec: "P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'"
  then have "(\<sigma>, \<sigma>') \<in> {(\<sigma>, \<sigma>'). exec (P, \<sigma>) = \<lfloor>\<sigma>'\<rfloor>}\<^sup>*" by(simp only: exec_all_def)
  then show ?thesis proof(induct rule: rtrancl_induct)
    case base
    then show ?case by (simp add: exec_all_d_def1)
  next
    case (step y z)
    then have \<sigma>y: "P \<turnstile> \<sigma> -jvm\<rightarrow> y" by (simp only: exec_all_def [symmetric])
    have exec_d: "exec_d P y = Normal \<lfloor>z\<rfloor>" using step
     no_type_error_commutes[OF no_type_error[OF wf BV_correct[OF wf \<sigma>y cf]]]
      by (simp add: exec_all_d_def1)
    show ?case using step.hyps(3) exec_1_d_NormalI[OF exec_d]
      by (simp add: exec_all_d_def1)
  qed
qed
(*>*)

text \<open>
  As corollary we get that the aggressive and the defensive machine
  are equivalent for welltyped programs (if started in a conformant
  state or in the canonical start state)
\<close>
corollary welltyped_commutes:
  fixes \<sigma> :: jvm_state
  assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P" and conforms: "P,\<Phi> \<turnstile> \<sigma> \<surd>"
  shows "P \<turnstile> (Normal \<sigma>) -jvmd\<rightarrow> (Normal \<sigma>') = P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'"
proof(rule iffI)
  assume "P \<turnstile> Normal \<sigma> -jvmd\<rightarrow> Normal \<sigma>'" then show "P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'"
    by (rule defensive_imp_aggressive)
next
  assume "P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'" then show "P \<turnstile> Normal \<sigma> -jvmd\<rightarrow> Normal \<sigma>'"
    by (rule welltyped_aggressive_imp_defensive [OF wf conforms])
qed

corollary welltyped_initial_commutes:
  assumes wf: "wf_jvm_prog P"
  assumes nstart: "\<not> is_class P Start"
  assumes meth: "P \<turnstile> C sees M,Static:[]\<rightarrow>Void = b in C"
  assumes nclinit: "M \<noteq> clinit"
  assumes Obj_start_m:
    "(\<And>b' Ts' T' m' D'. P \<turnstile> Object sees start_m, b' :  Ts'\<rightarrow>T' = m' in D'
         \<Longrightarrow> b' = Static \<and> Ts' = [] \<and> T' = Void)"
  defines start: "\<sigma> \<equiv> start_state P"
  shows "start_prog P C M \<turnstile> (Normal \<sigma>) -jvmd\<rightarrow> (Normal \<sigma>') = start_prog P C M \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'"
proof -
  from wf obtain \<Phi> where wf': "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P" by (auto simp: wf_jvm_prog_def)
  let ?\<Phi> = "\<Phi>_start \<Phi>"
  from start_prog_wf_jvm_prog_phi[where \<Phi>'="?\<Phi>", OF wf' nstart meth nclinit \<Phi>_start Obj_start_m]
   have "wf_jvm_prog\<^bsub>?\<Phi>\<^esub>(start_prog P C M)" by simp
  moreover
  from wf' nstart meth nclinit \<Phi>_start(2) have "start_prog P C M,?\<Phi> \<turnstile> \<sigma> \<surd>"
    unfolding start by (rule BV_correct_initial)
  ultimately show ?thesis by (rule welltyped_commutes)
qed

lemma not_TypeError_eq [iff]:
  "x \<noteq> TypeError = (\<exists>t. x = Normal t)"
  by (cases x) auto

locale cnf =
  fixes P and \<Phi> and \<sigma>
  assumes wf: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  assumes cnf: "correct_state P \<Phi> \<sigma>"

theorem (in cnf) no_type_errors:
  "P \<turnstile> (Normal \<sigma>) -jvmd\<rightarrow> \<sigma>' \<Longrightarrow> \<sigma>' \<noteq> TypeError"
proof -
  assume "P \<turnstile> (Normal \<sigma>) -jvmd\<rightarrow> \<sigma>'"
  then have "(Normal \<sigma>, \<sigma>') \<in> (exec_1_d P)\<^sup>*" by (unfold exec_all_d_def1) simp
  then show ?thesis proof(induct rule: rtrancl_induct)
    case (step y z)
    then obtain y\<^sub>n where [simp]: "y = Normal y\<^sub>n" by clarsimp
    have n\<sigma>y: "P \<turnstile> Normal \<sigma> -jvmd\<rightarrow> Normal y\<^sub>n" using step.hyps(1)
      by (fold exec_all_d_def1) simp
    have \<sigma>y: "P \<turnstile> \<sigma> -jvm\<rightarrow> y\<^sub>n" using defensive_imp_aggressive[OF n\<sigma>y] by simp
    show ?case using step no_type_error[OF wf BV_correct[OF wf \<sigma>y cnf]]
      by (auto simp add: exec_1_d_eq)
  qed simp
qed

locale start =
  fixes P and C and M and \<sigma> and T and b and P\<^sub>0
  assumes wf: "wf_jvm_prog P"
  assumes nstart: "\<not> is_class P Start"
  assumes sees: "P \<turnstile> C sees M,Static:[]\<rightarrow>Void = b in C"
  assumes nclinit: "M \<noteq> clinit"
  assumes Obj_start_m: "(\<And>b' Ts' T' m' D'. P \<turnstile> Object sees start_m, b' :  Ts'\<rightarrow>T' = m' in D'
         \<Longrightarrow> b' = Static \<and> Ts' = [] \<and> T' = Void)"
  defines "\<sigma> \<equiv> Normal (start_state P)"
  defines [simp]: "P\<^sub>0 \<equiv> start_prog P C M"

corollary (in start) bv_no_type_error:
  shows "P\<^sub>0 \<turnstile> \<sigma> -jvmd\<rightarrow> \<sigma>' \<Longrightarrow> \<sigma>' \<noteq> TypeError"
proof -
  from wf obtain \<Phi> where wf': "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P" by (auto simp: wf_jvm_prog_def)
  let ?\<Phi> = "\<Phi>_start \<Phi>"
  from start_prog_wf_jvm_prog_phi[where \<Phi>'="?\<Phi>", OF wf' nstart sees nclinit \<Phi>_start Obj_start_m]
   have "wf_jvm_prog\<^bsub>?\<Phi>\<^esub>P\<^sub>0" by simp
  moreover
  from BV_correct_initial[where \<Phi>'="?\<Phi>", OF wf' nstart sees nclinit \<Phi>_start(2)]
  have "correct_state P\<^sub>0 ?\<Phi> (start_state P)" by simp
  ultimately have "cnf P\<^sub>0 ?\<Phi> (start_state P)" by (rule cnf.intro)
  moreover assume "P\<^sub>0 \<turnstile> \<sigma> -jvmd\<rightarrow> \<sigma>'"
  ultimately show ?thesis by (unfold \<sigma>_def) (rule cnf.no_type_errors)
qed

end


(*  Title:      HOL/SMT.thy
    Author:     Sascha Boehme, TU Muenchen
    Author:     Jasmin Blanchette, VU Amsterdam
*)

section \<open>Bindings to Satisfiability Modulo Theories (SMT) solvers based on SMT-LIB 2\<close>

theory SMT
  imports Divides
  keywords "smt_status" :: diag
begin

subsection \<open>A skolemization tactic and proof method\<close>

lemma choices:
  "\<And>Q. \<forall>x. \<exists>y ya. Q x y ya \<Longrightarrow> \<exists>f fa. \<forall>x. Q x (f x) (fa x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb. Q x y ya yb \<Longrightarrow> \<exists>f fa fb. \<forall>x. Q x (f x) (fa x) (fb x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc. Q x y ya yb yc \<Longrightarrow> \<exists>f fa fb fc. \<forall>x. Q x (f x) (fa x) (fb x) (fc x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd. Q x y ya yb yc yd \<Longrightarrow>
     \<exists>f fa fb fc fd. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd ye. Q x y ya yb yc yd ye \<Longrightarrow>
     \<exists>f fa fb fc fd fe. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd ye yf. Q x y ya yb yc yd ye yf \<Longrightarrow>
     \<exists>f fa fb fc fd fe ff. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd ye yf yg. Q x y ya yb yc yd ye yf yg \<Longrightarrow>
     \<exists>f fa fb fc fd fe ff fg. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x) (fg x)"
  by metis+

lemma bchoices:
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya. Q x y ya \<Longrightarrow> \<exists>f fa. \<forall>x \<in> S. Q x (f x) (fa x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb. Q x y ya yb \<Longrightarrow> \<exists>f fa fb. \<forall>x \<in> S. Q x (f x) (fa x) (fb x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc. Q x y ya yb yc \<Longrightarrow> \<exists>f fa fb fc. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd. Q x y ya yb yc yd \<Longrightarrow>
    \<exists>f fa fb fc fd. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd ye. Q x y ya yb yc yd ye \<Longrightarrow>
    \<exists>f fa fb fc fd fe. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd ye yf. Q x y ya yb yc yd ye yf \<Longrightarrow>
    \<exists>f fa fb fc fd fe ff. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd ye yf yg. Q x y ya yb yc yd ye yf yg \<Longrightarrow>
    \<exists>f fa fb fc fd fe ff fg. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x) (fg x)"
  by metis+

ML \<open>
fun moura_tac ctxt =
  Atomize_Elim.atomize_elim_tac ctxt THEN'
  SELECT_GOAL (Clasimp.auto_tac (ctxt addSIs @{thms choice choices bchoice bchoices}) THEN
    ALLGOALS (Metis_Tactic.metis_tac (take 1 ATP_Proof_Reconstruct.partial_type_encs)
        ATP_Proof_Reconstruct.default_metis_lam_trans ctxt [] ORELSE'
      blast_tac ctxt))
\<close>

method_setup moura = \<open>
  Scan.succeed (SIMPLE_METHOD' o moura_tac)
\<close> "solve skolemization goals, especially those arising from Z3 proofs"

hide_fact (open) choices bchoices

subsection \<open>Triggers for quantifier instantiation\<close>

text \<open>
Some SMT solvers support patterns as a quantifier instantiation
heuristics. Patterns may either be positive terms (tagged by "pat")
triggering quantifier instantiations -- when the solver finds a
term matching a positive pattern, it instantiates the corresponding
quantifier accordingly -- or negative terms (tagged by "nopat")
inhibiting quantifier instantiations. A list of patterns
of the same kind is called a multipattern, and all patterns in a
multipattern are considered conjunctively for quantifier instantiation.
A list of multipatterns is called a trigger, and their multipatterns
act disjunctively during quantifier instantiation. Each multipattern
should mention at least all quantified variables of the preceding
quantifier block.
\<close>

typedecl 'a symb_list

consts
  Symb_Nil :: "'a symb_list"
  Symb_Cons :: "'a \<Rightarrow> 'a symb_list \<Rightarrow> 'a symb_list"

typedecl pattern

consts
  pat :: "'a \<Rightarrow> pattern"
  nopat :: "'a \<Rightarrow> pattern"

definition trigger :: "pattern symb_list symb_list \<Rightarrow> bool \<Rightarrow> bool" where
  "trigger _ P = P"

subsection \<open>Higher-order encoding\<close>

text \<open>
Application is made explicit for constants occurring with varying
numbers of arguments. This is achieved by the introduction of the
following constant.
\<close>

definition fun_app :: "'a \<Rightarrow> 'a" where "fun_app f = f"

text \<open>
Some solvers support a theory of arrays which can be used to encode
higher-order functions. The following set of lemmas specifies the
properties of such (extensional) arrays.
\<close>

lemmas array_rules = ext fun_upd_apply fun_upd_same fun_upd_other  fun_upd_upd fun_app_def

subsection \<open>Normalization\<close>

lemma case_bool_if[abs_def]: "case_bool x y P = (if P then x else y)"
  by simp

lemmas Ex1_def_raw = Ex1_def[abs_def]
lemmas Ball_def_raw = Ball_def[abs_def]
lemmas Bex_def_raw = Bex_def[abs_def]
lemmas abs_if_raw = abs_if[abs_def]
lemmas min_def_raw = min_def[abs_def]
lemmas max_def_raw = max_def[abs_def]

lemma nat_zero_as_int:
  "0 = nat 0"
  by simp

lemma nat_one_as_int:
  "1 = nat 1"
  by simp

lemma nat_numeral_as_int: "numeral = (\<lambda>i. nat (numeral i))" by simp
lemma nat_less_as_int: "(<) = (\<lambda>a b. int a < int b)" by simp
lemma nat_leq_as_int: "(\<le>) = (\<lambda>a b. int a \<le> int b)" by simp
lemma Suc_as_int: "Suc = (\<lambda>a. nat (int a + 1))" by (rule ext) simp
lemma nat_plus_as_int: "(+) = (\<lambda>a b. nat (int a + int b))" by (rule ext)+ simp
lemma nat_minus_as_int: "(-) = (\<lambda>a b. nat (int a - int b))" by (rule ext)+ simp
lemma nat_times_as_int: "(*) = (\<lambda>a b. nat (int a * int b))" by (simp add: nat_mult_distrib)
lemma nat_div_as_int: "(div) = (\<lambda>a b. nat (int a div int b))" by (simp add: nat_div_distrib)
lemma nat_mod_as_int: "(mod) = (\<lambda>a b. nat (int a mod int b))" by (simp add: nat_mod_distrib)

lemma int_Suc: "int (Suc n) = int n + 1" by simp
lemma int_plus: "int (n + m) = int n + int m" by (rule of_nat_add)
lemma int_minus: "int (n - m) = int (nat (int n - int m))" by auto

lemma nat_int_comparison:
  fixes a b :: nat
  shows "(a = b) = (int a = int b)"
    and "(a < b) = (int a < int b)"
    and "(a \<le> b) = (int a \<le> int b)"
  by simp_all

lemma int_ops:
  fixes a b :: nat
  shows "int 0 = 0"
    and "int 1 = 1"
    and "int (numeral n) = numeral n"
    and "int (Suc a) = int a + 1"
    and "int (a + b) = int a + int b"
    and "int (a - b) = (if int a < int b then 0 else int a - int b)"
    and "int (a * b) = int a * int b"
    and "int (a div b) = int a div int b"
    and "int (a mod b) = int a mod int b"
  by (auto intro: zdiv_int zmod_int)

lemma int_if:
  fixes a b :: nat
  shows "int (if P then a else b) = (if P then int a else int b)"
  by simp

subsection \<open>Integer division and modulo for Z3\<close>

text \<open>
The following Z3-inspired definitions are overspecified for the case where \<open>l = 0\<close>. This
Schönheitsfehler is corrected in the \<open>div_as_z3div\<close> and \<open>mod_as_z3mod\<close> theorems.
\<close>

definition z3div :: "int \<Rightarrow> int \<Rightarrow> int" where
  "z3div k l = (if l \<ge> 0 then k div l else - (k div - l))"

definition z3mod :: "int \<Rightarrow> int \<Rightarrow> int" where
  "z3mod k l = k mod (if l \<ge> 0 then l else - l)"

lemma div_as_z3div:
  "\<forall>k l. k div l = (if l = 0 then 0 else if l > 0 then z3div k l else z3div (- k) (- l))"
  by (simp add: z3div_def)

lemma mod_as_z3mod:
  "\<forall>k l. k mod l = (if l = 0 then k else if l > 0 then z3mod k l else - z3mod (- k) (- l))"
  by (simp add: z3mod_def)

subsection \<open>Extra theorems for veriT reconstruction\<close>

lemma verit_sko_forall: \<open>(\<forall>x. P x) \<longleftrightarrow> P (SOME x. \<not>P x)\<close>
  using someI[of \<open>\<lambda>x. \<not>P x\<close>]
  by auto

lemma verit_sko_forall': \<open>P (SOME x. \<not>P x) = A \<Longrightarrow> (\<forall>x. P x) = A\<close>
  by (subst verit_sko_forall)

lemma verit_sko_forall_indirect: \<open>x = (SOME x. \<not>P x) \<Longrightarrow> (\<forall>x. P x) \<longleftrightarrow> P x\<close>
  using someI[of \<open>\<lambda>x. \<not>P x\<close>]
  by auto

lemma verit_sko_ex: \<open>(\<exists>x. P x) \<longleftrightarrow> P (SOME x. P x)\<close>
  using someI[of \<open>\<lambda>x. P x\<close>]
  by auto

lemma verit_sko_ex': \<open>P (SOME x. P x) = A \<Longrightarrow> (\<exists>x. P x) = A\<close>
  by (subst verit_sko_ex)

lemma verit_sko_ex_indirect: \<open>x = (SOME x. P x) \<Longrightarrow> (\<exists>x. P x) \<longleftrightarrow> P x\<close>
  using someI[of \<open>\<lambda>x. P x\<close>]
  by auto

lemma verit_Pure_trans:
  \<open>P \<equiv> Q \<Longrightarrow> Q \<Longrightarrow> P\<close>
  by auto

lemma verit_if_cong:
  assumes \<open>b \<equiv> c\<close>
    and \<open>c \<Longrightarrow> x \<equiv> u\<close>
    and \<open>\<not> c \<Longrightarrow> y \<equiv> v\<close>
  shows \<open>(if b then x else y) \<equiv> (if c then u else v)\<close>
  using assms if_cong[of b c x u] by auto

lemma verit_if_weak_cong':
  \<open>b \<equiv> c \<Longrightarrow> (if b then x else y) \<equiv> (if c then x else y)\<close>
  by auto

lemma verit_ite_intro_simp:
  \<open>(if c then (a :: 'a) = (if c then P else Q') else Q) = (if c then a = P else Q)\<close>
  \<open>(if c then R else b = (if c then R' else Q')) =
    (if c then R else b = Q')\<close>
  \<open>(if c then a' = a' else b' = b')\<close>
  by (auto split: if_splits)

lemma verit_or_neg:
   \<open>(A \<Longrightarrow> B) \<Longrightarrow> B \<or> \<not>A\<close>
   \<open>(\<not>A \<Longrightarrow> B) \<Longrightarrow> B \<or> A\<close>
  by auto

lemma verit_subst_bool: \<open>P \<Longrightarrow> f True \<Longrightarrow> f P\<close>
  by auto

lemma verit_and_pos:
  \<open>(a \<Longrightarrow> \<not>b \<or> A) \<Longrightarrow> \<not>(a \<and> b) \<or> A\<close>
  \<open>(a \<Longrightarrow> A) \<Longrightarrow> \<not>a \<or> A\<close>
  \<open>(\<not>a \<Longrightarrow> A) \<Longrightarrow> a \<or> A\<close>
  by blast+

lemma verit_la_generic:
  \<open>(a::int) \<le> x \<or> a = x \<or> a \<ge> x\<close>
  by linarith

lemma verit_tmp_bfun_elim:
  \<open>(if b then P True else P False) = P b\<close>
  by (cases b) auto

lemma verit_eq_true_simplify:
  \<open>(P = True) \<equiv> P\<close>
  by auto

lemma verit_and_neg:
  \<open>B \<or> B' \<Longrightarrow> (A \<and> B) \<or> \<not>A \<or> B'\<close>
  \<open>B \<or> B' \<Longrightarrow> (\<not>A \<and> B) \<or> A \<or> B'\<close>
  by auto

lemma verit_forall_inst:
  \<open>A \<longleftrightarrow> B \<Longrightarrow> \<not>A \<or> B\<close>
  \<open>\<not>A \<longleftrightarrow> B \<Longrightarrow> A \<or> B\<close>
  \<open>A \<longleftrightarrow> B \<Longrightarrow> \<not>B \<or> A\<close>
  \<open>A \<longleftrightarrow> \<not>B \<Longrightarrow> B \<or> A\<close>
  \<open>A \<longrightarrow> B \<Longrightarrow> \<not>A \<or> B\<close>
  \<open>\<not>A \<longrightarrow> B \<Longrightarrow> A \<or> B\<close>
  by blast+

lemma verit_eq_transitive:
  \<open>A = B \<Longrightarrow> B = C \<Longrightarrow> A = C\<close>
  \<open>A = B \<Longrightarrow> C = B \<Longrightarrow> A = C\<close>
  \<open>B = A \<Longrightarrow> B = C \<Longrightarrow> A = C\<close>
  \<open>B = A \<Longrightarrow> C = B \<Longrightarrow> A = C\<close>
  by auto

subsection \<open>Setup\<close>

ML_file \<open>Tools/SMT/smt_util.ML\<close>
ML_file \<open>Tools/SMT/smt_failure.ML\<close>
ML_file \<open>Tools/SMT/smt_config.ML\<close>
ML_file \<open>Tools/SMT/smt_builtin.ML\<close>
ML_file \<open>Tools/SMT/smt_datatypes.ML\<close>
ML_file \<open>Tools/SMT/smt_normalize.ML\<close>
ML_file \<open>Tools/SMT/smt_translate.ML\<close>
ML_file \<open>Tools/SMT/smtlib.ML\<close>
ML_file \<open>Tools/SMT/smtlib_interface.ML\<close>
ML_file \<open>Tools/SMT/smtlib_proof.ML\<close>
ML_file \<open>Tools/SMT/smtlib_isar.ML\<close>
ML_file \<open>Tools/SMT/z3_proof.ML\<close>
ML_file \<open>Tools/SMT/z3_isar.ML\<close>
ML_file \<open>Tools/SMT/smt_solver.ML\<close>
ML_file \<open>Tools/SMT/cvc4_interface.ML\<close>
ML_file \<open>Tools/SMT/cvc4_proof_parse.ML\<close>
ML_file \<open>Tools/SMT/verit_proof.ML\<close>
ML_file \<open>Tools/SMT/verit_isar.ML\<close>
ML_file \<open>Tools/SMT/verit_proof_parse.ML\<close>
ML_file \<open>Tools/SMT/conj_disj_perm.ML\<close>
ML_file \<open>Tools/SMT/smt_replay_methods.ML\<close>
ML_file \<open>Tools/SMT/smt_replay.ML\<close>
ML_file \<open>Tools/SMT/z3_interface.ML\<close>
ML_file \<open>Tools/SMT/z3_replay_rules.ML\<close>
ML_file \<open>Tools/SMT/z3_replay_methods.ML\<close>
ML_file \<open>Tools/SMT/z3_replay.ML\<close>
ML_file \<open>Tools/SMT/verit_replay_methods.ML\<close>
ML_file \<open>Tools/SMT/verit_replay.ML\<close>
ML_file \<open>Tools/SMT/smt_systems.ML\<close>

method_setup smt = \<open>
  Scan.optional Attrib.thms [] >>
    (fn thms => fn ctxt =>
      METHOD (fn facts => HEADGOAL (SMT_Solver.smt_tac ctxt (thms @ facts))))
\<close> "apply an SMT solver to the current goal"

subsection \<open>Configuration\<close>

text \<open>
The current configuration can be printed by the command
\<open>smt_status\<close>, which shows the values of most options.
\<close>

subsection \<open>General configuration options\<close>

text \<open>
The option \<open>smt_solver\<close> can be used to change the target SMT
solver. The possible values can be obtained from the \<open>smt_status\<close>
command.
\<close>

declare [[smt_solver = z3]]

text \<open>
Since SMT solvers are potentially nonterminating, there is a timeout
(given in seconds) to restrict their runtime.
\<close>

declare [[smt_timeout = 20]]

text \<open>
SMT solvers apply randomized heuristics. In case a problem is not
solvable by an SMT solver, changing the following option might help.
\<close>

declare [[smt_random_seed = 1]]

text \<open>
In general, the binding to SMT solvers runs as an oracle, i.e, the SMT
solvers are fully trusted without additional checks. The following
option can cause the SMT solver to run in proof-producing mode, giving
a checkable certificate. This is currently only implemented for Z3.
\<close>

declare [[smt_oracle = false]]

text \<open>
Each SMT solver provides several commandline options to tweak its
behaviour. They can be passed to the solver by setting the following
options.
\<close>

declare [[cvc3_options = ""]]
declare [[cvc4_options = "--full-saturate-quant --inst-when=full-last-call --inst-no-entail --term-db-mode=relevant --multi-trigger-linear"]]
declare [[verit_options = "--index-fresh-sorts"]]
declare [[z3_options = ""]]

text \<open>
The SMT method provides an inference mechanism to detect simple triggers
in quantified formulas, which might increase the number of problems
solvable by SMT solvers (note: triggers guide quantifier instantiations
in the SMT solver). To turn it on, set the following option.
\<close>

declare [[smt_infer_triggers = false]]

text \<open>
Enable the following option to use built-in support for datatypes,
codatatypes, and records in CVC4. Currently, this is implemented only
in oracle mode.
\<close>

declare [[cvc4_extensions = false]]

text \<open>
Enable the following option to use built-in support for div/mod, datatypes,
and records in Z3. Currently, this is implemented only in oracle mode.
\<close>

declare [[z3_extensions = false]]

subsection \<open>Certificates\<close>

text \<open>
By setting the option \<open>smt_certificates\<close> to the name of a file,
all following applications of an SMT solver a cached in that file.
Any further application of the same SMT solver (using the very same
configuration) re-uses the cached certificate instead of invoking the
solver. An empty string disables caching certificates.

The filename should be given as an explicit path. It is good
practice to use the name of the current theory (with ending
\<open>.certs\<close> instead of \<open>.thy\<close>) as the certificates file.
Certificate files should be used at most once in a certain theory context,
to avoid race conditions with other concurrent accesses.
\<close>

declare [[smt_certificates = ""]]

text \<open>
The option \<open>smt_read_only_certificates\<close> controls whether only
stored certificates are should be used or invocation of an SMT solver
is allowed. When set to \<open>true\<close>, no SMT solver will ever be
invoked and only the existing certificates found in the configured
cache are used;  when set to \<open>false\<close> and there is no cached
certificate for some proposition, then the configured SMT solver is
invoked.
\<close>

declare [[smt_read_only_certificates = false]]

subsection \<open>Tracing\<close>

text \<open>
The SMT method, when applied, traces important information. To
make it entirely silent, set the following option to \<open>false\<close>.
\<close>

declare [[smt_verbose = true]]

text \<open>
For tracing the generated problem file given to the SMT solver as
well as the returned result of the solver, the option
\<open>smt_trace\<close> should be set to \<open>true\<close>.
\<close>

declare [[smt_trace = false]]

subsection \<open>Schematic rules for Z3 proof reconstruction\<close>

text \<open>
Several prof rules of Z3 are not very well documented. There are two
lemma groups which can turn failing Z3 proof reconstruction attempts
into succeeding ones: the facts in \<open>z3_rule\<close> are tried prior to
any implemented reconstruction procedure for all uncertain Z3 proof
rules;  the facts in \<open>z3_simp\<close> are only fed to invocations of
the simplifier when reconstructing theory-specific proof steps.
\<close>

lemmas [z3_rule] =
  refl eq_commute conj_commute disj_commute simp_thms nnf_simps
  ring_distribs field_simps times_divide_eq_right times_divide_eq_left
  if_True if_False not_not
  NO_MATCH_def

lemma [z3_rule]:
  "(P \<and> Q) = (\<not> (\<not> P \<or> \<not> Q))"
  "(P \<and> Q) = (\<not> (\<not> Q \<or> \<not> P))"
  "(\<not> P \<and> Q) = (\<not> (P \<or> \<not> Q))"
  "(\<not> P \<and> Q) = (\<not> (\<not> Q \<or> P))"
  "(P \<and> \<not> Q) = (\<not> (\<not> P \<or> Q))"
  "(P \<and> \<not> Q) = (\<not> (Q \<or> \<not> P))"
  "(\<not> P \<and> \<not> Q) = (\<not> (P \<or> Q))"
  "(\<not> P \<and> \<not> Q) = (\<not> (Q \<or> P))"
  by auto

lemma [z3_rule]:
  "(P \<longrightarrow> Q) = (Q \<or> \<not> P)"
  "(\<not> P \<longrightarrow> Q) = (P \<or> Q)"
  "(\<not> P \<longrightarrow> Q) = (Q \<or> P)"
  "(True \<longrightarrow> P) = P"
  "(P \<longrightarrow> True) = True"
  "(False \<longrightarrow> P) = True"
  "(P \<longrightarrow> P) = True"
  "(\<not> (A \<longleftrightarrow> \<not> B)) \<longleftrightarrow> (A \<longleftrightarrow> B)"
  by auto

lemma [z3_rule]:
  "((P = Q) \<longrightarrow> R) = (R \<or> (Q = (\<not> P)))"
  by auto

lemma [z3_rule]:
  "(\<not> True) = False"
  "(\<not> False) = True"
  "(x = x) = True"
  "(P = True) = P"
  "(True = P) = P"
  "(P = False) = (\<not> P)"
  "(False = P) = (\<not> P)"
  "((\<not> P) = P) = False"
  "(P = (\<not> P)) = False"
  "((\<not> P) = (\<not> Q)) = (P = Q)"
  "\<not> (P = (\<not> Q)) = (P = Q)"
  "\<not> ((\<not> P) = Q) = (P = Q)"
  "(P \<noteq> Q) = (Q = (\<not> P))"
  "(P = Q) = ((\<not> P \<or> Q) \<and> (P \<or> \<not> Q))"
  "(P \<noteq> Q) = ((\<not> P \<or> \<not> Q) \<and> (P \<or> Q))"
  by auto

lemma [z3_rule]:
  "(if P then P else \<not> P) = True"
  "(if \<not> P then \<not> P else P) = True"
  "(if P then True else False) = P"
  "(if P then False else True) = (\<not> P)"
  "(if P then Q else True) = ((\<not> P) \<or> Q)"
  "(if P then Q else True) = (Q \<or> (\<not> P))"
  "(if P then Q else \<not> Q) = (P = Q)"
  "(if P then Q else \<not> Q) = (Q = P)"
  "(if P then \<not> Q else Q) = (P = (\<not> Q))"
  "(if P then \<not> Q else Q) = ((\<not> Q) = P)"
  "(if \<not> P then x else y) = (if P then y else x)"
  "(if P then (if Q then x else y) else x) = (if P \<and> (\<not> Q) then y else x)"
  "(if P then (if Q then x else y) else x) = (if (\<not> Q) \<and> P then y else x)"
  "(if P then (if Q then x else y) else y) = (if P \<and> Q then x else y)"
  "(if P then (if Q then x else y) else y) = (if Q \<and> P then x else y)"
  "(if P then x else if P then y else z) = (if P then x else z)"
  "(if P then x else if Q then x else y) = (if P \<or> Q then x else y)"
  "(if P then x else if Q then x else y) = (if Q \<or> P then x else y)"
  "(if P then x = y else x = z) = (x = (if P then y else z))"
  "(if P then x = y else y = z) = (y = (if P then x else z))"
  "(if P then x = y else z = y) = (y = (if P then x else z))"
  by auto

lemma [z3_rule]:
  "0 + (x::int) = x"
  "x + 0 = x"
  "x + x = 2 * x"
  "0 * x = 0"
  "1 * x = x"
  "x + y = y + x"
  by (auto simp add: mult_2)

lemma [z3_rule]:  (* for def-axiom *)
  "P = Q \<or> P \<or> Q"
  "P = Q \<or> \<not> P \<or> \<not> Q"
  "(\<not> P) = Q \<or> \<not> P \<or> Q"
  "(\<not> P) = Q \<or> P \<or> \<not> Q"
  "P = (\<not> Q) \<or> \<not> P \<or> Q"
  "P = (\<not> Q) \<or> P \<or> \<not> Q"
  "P \<noteq> Q \<or> P \<or> \<not> Q"
  "P \<noteq> Q \<or> \<not> P \<or> Q"
  "P \<noteq> (\<not> Q) \<or> P \<or> Q"
  "(\<not> P) \<noteq> Q \<or> P \<or> Q"
  "P \<or> Q \<or> P \<noteq> (\<not> Q)"
  "P \<or> Q \<or> (\<not> P) \<noteq> Q"
  "P \<or> \<not> Q \<or> P \<noteq> Q"
  "\<not> P \<or> Q \<or> P \<noteq> Q"
  "P \<or> y = (if P then x else y)"
  "P \<or> (if P then x else y) = y"
  "\<not> P \<or> x = (if P then x else y)"
  "\<not> P \<or> (if P then x else y) = x"
  "P \<or> R \<or> \<not> (if P then Q else R)"
  "\<not> P \<or> Q \<or> \<not> (if P then Q else R)"
  "\<not> (if P then Q else R) \<or> \<not> P \<or> Q"
  "\<not> (if P then Q else R) \<or> P \<or> R"
  "(if P then Q else R) \<or> \<not> P \<or> \<not> Q"
  "(if P then Q else R) \<or> P \<or> \<not> R"
  "(if P then \<not> Q else R) \<or> \<not> P \<or> Q"
  "(if P then Q else \<not> R) \<or> P \<or> R"
  by auto

hide_type (open) symb_list pattern
hide_const (open) Symb_Nil Symb_Cons trigger pat nopat fun_app z3div z3mod

end


(*  Title:      Uint_Userguide.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>User guide for native words\<close>

(*<*)
theory Uint_Userguide imports
  Uint32
  Uint16
  Code_Target_Int_Bit
begin
(*>*)

text \<open>
  This tutorial explains how to best use the types for native
  words like @{typ "uint32"} in your formalisation.
  You can base your formalisation
  \begin{enumerate}
  \item either directly on these types,
  \item or on the generic @{typ "'a word"} and only introduce native
    words a posteriori via code generator refinement.
  \end{enumerate}

  The first option causes the least overhead if you have to prove only
  little about the words you use and start a fresh formalisation.
  Just use the native type @{typ uint32} instead of @{typ "32 word"}
  and similarly for \<open>uint64\<close>, \<open>uint16\<close>, and \<open>uint8\<close>.
  As native word types are meant only for code generation, the lemmas
  about @{typ "'a word"}  have not been duplicated, but you can transfer
  theorems between native word types and @{typ "'a word"} using the
  transfer package.

  Note, however, that this option restricts your work a bit:
  your own functions cannot be ``polymorphic'' in the word length,
  but you have to define a separate function for every word length you need.

  The second option is recommended if you already have a formalisation
  based on @{typ "'a word"} or if your proofs involve words and their
  properties. It separates code generation from modelling and proving,
  i.e., you can work with words as usual. Consequently, you have to
  manually setup the code generator to use the native types wherever
  you want. The following describes how to achieve this with moderate
  effort.

  Note, however, that some target languages of the code generator
  (especially OCaml) do not support all the native word types provided.
  Therefore, you should only import those types that you need -- the
  theory file for each type mentions at the top the restrictions for
  code generation. For example, PolyML does not provide the Word16
  structure, and OCaml provides neither Word8 nor Word16.
  You can still use these theories provided that you also import
  the theory @{theory Native_Word.Code_Target_Int_Bit} (which implements
  @{typ int} by target-language integers), but these words will
  be implemented via Isabelle's \<open>Word\<close> library, i.e.,
  you do not gain anything in terms of efficiency.

  \textbf{There is a separate code target \<open>SML_word\<close> for SML.}
  If you use one of the native words that PolyML does not support
  (such as \<open>uint16\<close> and \<open>uint64\<close> in 32-bit mode), but would
  like to map its operations to the Standard Basis Library functions,
  make sure to use the target \<open>SML_word\<close> instead of \<open>SML\<close>;
  if you only use native word sizes that PolyML supports, you can stick
  with \<open>SML\<close>.  This ensures that code generation within Isabelle
  as used by \<open>Quickcheck\<close>, \<open>value\<close> and @\{code\} in ML blocks
  continues to work.
\<close>

section \<open>Lifting functions from @{typ "'a word"} to native words\<close>

text \<open>
  This section shows how to convert functions from @{typ "'a word"} to native
  words. For example, the following function \<open>sum_squares\<close> computes
  the sum of the first @{term n} square numbers in 16 bit arithmetic using
  a tail-recursive function \<open>gen_sum_squares\<close> with accumulator;
  for convenience, \<open>sum_squares_int\<close> takes an integer instead of a word.
\<close>

function gen_sum_squares :: "16 word \<Rightarrow> 16 word \<Rightarrow> 16 word" where (*<*)[simp del]:(*>*)

  "gen_sum_squares accum n =
   (if n = 0 then accum else gen_sum_squares (accum + n * n) (n - 1))"
(*<*)by pat_completeness simp
termination by (relation \<open>measure (nat \<circ> uint \<circ> snd)\<close>) (simp_all add: measure_unat)(*>*)

definition sum_squares :: "16 word \<Rightarrow> 16 word" where
   "sum_squares = gen_sum_squares 0"

definition sum_squares_int :: "int \<Rightarrow> 16 word" where
  "sum_squares_int n = sum_squares (word_of_int n)"

text \<open>
  The generated code for @{term sum_squares} and @{term sum_squares_int}
  emulates words with unbounded integers and explicit modulus as specified
  in the theory @{theory "HOL-Library.Word"}. But for efficiency, we want that the
  generated code uses machine words and machine arithmetic. Unfortunately,
  as @{typ "'a word"} is polymorphic in the word length, the code generator
  can only do this if we use another type for machine words. The theory
  @{theory Native_Word.Uint16} defines the type @{typ uint16} for machine words of
  16~bits. We just have to follow two steps to use it:

  First, we lift all our functions from @{typ "16 word"} to @{typ uint16},
  i.e., @{term sum_squares}, @{term gen_sum_squares}, and
  @{term sum_squares_int} in our case. The theory @{theory Native_Word.Uint16} sets
  up the lifting package for this and has already taken care of the
  arithmetic and bit-wise operations.
\<close>
lift_definition gen_sum_squares_uint :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
  is gen_sum_squares .
lift_definition sum_squares_uint :: "uint16 \<Rightarrow> uint16" is sum_squares .
lift_definition sum_squares_int_uint :: "int \<Rightarrow> uint16" is sum_squares_int .

text \<open>
  Second, we also have to transfer the code equations for our functions.
  The attribute \<open>Transfer.transferred\<close> takes care of that, but it is
  better to check that the transfer succeeded: inspect the theorem to check
  that the new constants are used throughout.
\<close>

lemmas [Transfer.transferred, code] =
  gen_sum_squares.simps
  sum_squares_def
  sum_squares_int_def

text \<open>
  Finally, we export the code to standard ML.  We use the target
  \<open>SML_word\<close> instead of \<open>SML\<close> to have the operations
  on @{typ uint16} mapped to the Standard Basis Library. As PolyML
  does not provide a Word16 type, the mapping for @{typ uint16} is only
  active in the refined target \<open>SML_word\<close>.
\<close>
export_code sum_squares_int_uint in SML_word

text \<open>
  Nevertheless, we can still evaluate terms with @{term "uint16"} within
  Isabelle, i.e., PolyML, but this will be translated to @{typ "16 word"}
  and therefore less efficient.
\<close>

value "sum_squares_int_uint 40"

section \<open>Storing native words in datatypes\<close>

text \<open>
  The above lifting is necessary for all functions whose type mentions
  the word type. Fortunately, we do not have to duplicate functions that
  merely operate on datatypes that contain words. Nevertheless, we have
  to tell the code generator that these functions should call the new ones,
  which operate on machine words. This section shows how to achieve this
  with data refinement.
\<close>

subsection \<open>Example: expressions and two semantics\<close>

text \<open>
  As the running example, we consider a language of expressions (literal values, less-than comparisions and conditional) where values are either booleans or 32-bit words.
  The original specification uses the type @{typ "32 word"}.
\<close>

datatype val = Bool bool | Word "32 word"
datatype expr = Lit val | LT expr expr | IF expr expr expr

abbreviation (input) word :: "32 word \<Rightarrow> expr" where "word i \<equiv> Lit (Word i)"
abbreviation (input) bool :: "bool \<Rightarrow> expr" where "bool i \<equiv> Lit (Bool i)"

\<comment> \<open>Denotational semantics of expressions, @{term None} denotes a type error\<close>
fun eval :: "expr \<Rightarrow> val option" where
  "eval (Lit v) = Some v"
| "eval (LT e\<^sub>1 e\<^sub>2) =
  (case (eval e\<^sub>1, eval e\<^sub>2)
   of (Some (Word i\<^sub>1), Some (Word i\<^sub>2)) \<Rightarrow> Some (Bool (i\<^sub>1 < i\<^sub>2))
   | _ \<Rightarrow> None)"
| "eval (IF e\<^sub>1 e\<^sub>2 e\<^sub>3) =
  (case eval e\<^sub>1 of Some (Bool b) \<Rightarrow> if b then eval e\<^sub>2 else eval e\<^sub>3
   | _ \<Rightarrow> None)"

\<comment> \<open>Small-step semantics of expressions, it gets stuck upon type errors.\<close>
inductive step :: "expr \<Rightarrow> expr \<Rightarrow> bool" ("_ \<rightarrow> _" [50, 50] 60) where
  "e \<rightarrow> e' \<Longrightarrow> LT e e\<^sub>2 \<rightarrow> LT e' e\<^sub>2"
| "e \<rightarrow> e' \<Longrightarrow> LT (word i) e \<rightarrow> LT (word i) e'"
| "LT (word i\<^sub>1) (word i\<^sub>2) \<rightarrow> bool (i\<^sub>1 < i\<^sub>2)"
| "e \<rightarrow> e' \<Longrightarrow> IF e e\<^sub>1 e\<^sub>2 \<rightarrow> IF e' e\<^sub>1 e\<^sub>2"
| "IF (bool True) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>1"
| "IF (bool False) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>2"

\<comment> \<open>Compile the inductive definition with the predicate compiler\<close>
code_pred (modes: i \<Rightarrow> o \<Rightarrow> bool as reduce, i \<Rightarrow> i \<Rightarrow> bool as step') step .

subsection \<open>Change the datatype to use machine words\<close>

text \<open>
  Now, we want to use @{typ uint32} instead of @{typ "32 word"}.
  The goal is to make the code generator use the new type without
  duplicating any of the types (@{typ val}, @{typ expr}) or the
  functions (@{term eval}, @{term reduce}) on such types.

  The constructor @{term Word} has @{typ "32 word"} in its type, so
  we have to lift it to \<open>Word'\<close>, and the same holds for the
  case combinator @{term case_val}, which @{term case_val'} replaces.%
  \footnote{%
    Note that we should not declare a case translation for the new
    case combinator because this will break parsing case expressions
    with old case combinator.
  }
  Next, we set up the code generator accordingly:
  @{term Bool} and @{term Word'} are the new constructors for @{typ val},
  and @{term case_val'} is the new case combinator with an appropriate
  case certificate.%
  \footnote{%
    Case certificates tell the code generator to replace the HOL
    case combinator for a datatype with the case combinator of the
    target language.  Without a case certificate, the code generator
    generates a function that re-implements the case combinator;
    in a strict languages like ML or Scala, this means that the code
    evaluates all possible cases before it decides which one is taken.

    Case certificates are described in Haftmann's PhD thesis
    \<^cite>\<open>\<open>Def.\ 27\<close> in "Haftmann2009PhD"\<close>. For a datatype \<open>dt\<close>
    with constructors \<open>C\<^sub>1\<close> to \<open>C\<^sub>n\<close>
    where each constructor \<open>C\<^sub>i\<close> takes \<open>k\<^sub>i\<close> parameters,
    the certificate for the case combinator \<open>case_dt\<close>
    looks as follows:

    {
      \isamarkuptrue\isacommand{lemma}\isamarkupfalse\isanewline%
      \ \ \isakeyword{assumes}\ {\isachardoublequoteopen}CASE\ {\isasymequiv}\ dt{\isacharunderscore}case\ c\isactrlsub {\isadigit{1}}\ c\isactrlsub {\isadigit{2}}\ \ldots\ c\isactrlsub{n}{\isachardoublequoteclose}\isanewline
      \ \ \isakeyword{shows}\ {\isachardoublequoteopen}{\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ \ldots\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}{\isachardoublequoteclose}\isanewline
    }
  }
  We delete the code equations for the old constructor @{term Word}
  and case combinator @{term case_val} such that the code generator
  reports missing adaptations.
\<close>

lift_definition Word' :: "uint32 \<Rightarrow> val" is Word .

code_datatype Bool Word'

lift_definition case_val' :: "(bool \<Rightarrow> 'a) \<Rightarrow> (uint32 \<Rightarrow> 'a) \<Rightarrow> val \<Rightarrow> 'a" is case_val .

lemmas [code, simp] = val.case [Transfer.transferred]

lemma case_val'_cert:
  fixes bool word' b w
  assumes "CASE \<equiv> case_val' bool word'"
  shows "(CASE (Bool b) \<equiv> bool b) &&& (CASE (Word' w) \<equiv> word' w)"
  by (simp_all add: assms)

setup \<open>Code.declare_case_global @{thm case_val'_cert}\<close>

declare [[code drop: case_val Word]]

subsection \<open>Make functions use functions on machine words\<close>

text \<open>
  Finally, we merely have to change the code equations to use the
  new functions that operate on @{typ uint32}. As before, the
  attribute \<open>Transfer.transferred\<close> does the job. In our example,
  we adapt the equality test on @{typ val} (code equations
  @{thm [source] val.eq.simps}) and the denotational and small-step
  semantics (code equations @{thm [source] eval.simps} and
  @{thm [source] step.equation}, respectively).

  We check that the adaptation has suceeded by exporting the functions.
  As we only use native word sizes that PolyML supports, we can use
  the usual target \<open>SML\<close> instead of \<open>SML_word\<close>.
\<close>

lemmas [code] =
  val.eq.simps[THEN meta_eq_to_obj_eq, Transfer.transferred, THEN eq_reflection]
  eval.simps[Transfer.transferred]
  step.equation[Transfer.transferred]

export_code reduce step' eval checking SML

section \<open>Troubleshooting\<close>

text \<open>
  This section explains some possible problems when using native words.
  If you experience other difficulties, please contact the author.
\<close>

subsection \<open>\<open>export_code\<close> raises an exception \label{section:export_code:exception}\<close>

text \<open>
  Probably, you have defined and are using a function on a native word type,
  but the code equation refers to emulated words. For example, the following
  defines a function \<open>double\<close> that doubles a word. When we try to export
  code for \<open>double\<close> without any further setup, \<open>export_code\<close> will
  raise an exception or generate code that does not compile.
\<close>

lift_definition double :: "uint32 \<Rightarrow> uint32" is "\<lambda>x. x + x" .

text \<open>
  We have to prove a code equation that only uses the existing operations on
  @{typ uint32}. Then, \<open>export_code\<close> works again.
\<close>

lemma double_code [code]: "double n = n + n"
by transfer simp

subsection \<open>The generated code does not compile\<close>

text \<open>
  Probably, you have been exporting to a target language for which there
  is no setup, or your compiler does not provide the required API. Every
  theory for native words mentions at the start the limitations on code
  generation. Check that your concrete application meets all the
  requirements.

  Alternatively, this might be an instance of the problem described
  in \S\ref{section:export_code:exception}.

  For Haskell, you have to enable the extension TypeSynonymInstances with \texttt{-XTypeSynonymInstances}
  if you are using polymorphic bit operations on the native word types.
\<close>

subsection \<open>The generated code is too slow\<close>

text \<open>
  The generated code will most likely not be as fast as a direct implementation in the target language with manual tuning.
  This is because we want the configuration of the code generation to be sound (as it can be used to prove theorems in Isabelle).
  Therefore, the bit operations sometimes perform range checks before they call the target language API.
  Here are some examples:
  \begin{itemize}
  \item Shift distances and bit indices in target languages are often expected to fit into a bounded integer or word.
    However, the size of these types varies across target languages and platforms.
    Hence, no Isabelle/HOL type can model uniformly all of them.
    Instead, the bit operations use arbitrary-precision integers for such quantities and check at run-time that the values fit into a bounded integer or word, respectively -- if not, they raise an exception.

  \item Division and modulo operations explicitly test whether the divisor is $0$ and return the HOL value of division by $0$ in that case.
    This is necessary because some languages leave the behaviour of division by 0 unspecified.
  \end{itemize}

  If you have better ideas how to eliminate such checks and speed up the generated code without sacrificing soundness, please contact the author!
\<close>

(*<*)end(*>*)


theory week10A_demo
imports
  "autocorres-1.4/autocorres/AutoCorres"
  GCD
begin

text {*
  To run this demo you must have the AutoCorres tool.
  This demo was tested with the AutoCorres tarball from the COMP4161 website.

  You can download AutoCorres from
  \url{http://www.cse.unsw.edu.au/~cs4161/autocorres-1.4.tar.gz}

  The following instructions assume you downloaded autocorres-1.4.tar.gz

  1. Unpack the .tar.gz file, which will create the directory autocorres-1.4

     tar -xzf autocorres-1.4.tar.gz

  2. To test that it builds with your Isabelle version, build the AutoCorres heap

     L4V_ARCH=X64 isabelle build -v -b -d autocorres-1.4 AutoCorres
OR:
     L4V_ARCH=ARM isabelle build -v -b -d autocorres-1.4 AutoCorres

     (depending whether you want 32-bit or 64-bit words)

  3. Load this demo theory using the AutoCorres heap

     L4V_ARCH=X64 isabelle jedit -d autocorres-1.4 -l AutoCorres week10A_demo.thy
OR:
     L4V_ARCH=ARM isabelle jedit -d autocorres-1.4 -l AutoCorres week10A_demo.thy

    (needs to be the same as the one used to build the heap in 2.)

  To parse the C file you need to have 'cpp' installed. On Linux you
  will probably already have gcc. On Mac OS, you may need to download
  the Command Line Tools. You can do this via Xcode if you have it installed.
  Or you can download standalone packages with command
    xcode-select --install
  in a terminal window.

  Make sure the demo C file simple.c is in the same directory as this .thy file
*}

text {*
  Parse in the C file; give each function a deeply embedded semantics in
  the SIMPL language.
*}
install_C_file "simple.c"

text {*
  Use AutoCorres to give each function a (monadic) shallow embedding that
  is designed to be more easily reasoned about.
  (The ts_force_nondet option below forces AutoCorres not to type strengthen
   the gcd function. Try removing it to see type strengthening in action.
   You might also like to experiment with forcing other levels of type
   strengthening for max by adding ts_force monad=max  where monad is
   one of pure, gets, option, nondet.)
*}
autocorres [unsigned_word_abs=gcd max except, ts_force nondet=gcd] "simple.c"
text {*
   Enter the environment in which all of the C parser and AutoCorres output is placed
*}
context simple begin

text {*
  View the AutoCorres semantics of the max function
*}
thm max'_def

text {*
  This is its original semantics in SIMPL
*}
thm max_body_def

text {*
  The state type of the monad that AutoCorres produces is called @{typ lifted_globals}.

  It is a record containing a set of heaps, one for each pointer
  type used in the program. Ours uses only unsigned *, i.e. 32-bit word pointers.
*}
term heap_w32
term heap_w32_update

text {*
  This is the AutoCorres semantics of the func function. Observe that it
  is very similar to the hand-written example from the last lecture.
*}
thm func'_def

text {*
  The automated tactic "wp" does automatic rule application of the monadic
  weakest precondition style rules we saw last lecture.
*}
lemma func'_partial_wp:
  "\<lbrace>\<lambda>s. heap_w32 s p \<ge> 10 \<and> Q () s\<rbrace> func' p \<lbrace>Q\<rbrace>"
  apply(unfold func'_def)
  apply(rule hoare_weaken_pre)
   apply wp
  apply auto
  done

text {*
  AutoCorres gives the gcd function a semantics in the nondeterministic
  state monad with failure (from last lecture). Observe that the guard to
  check for the absence of division by zero in the SIMPL is absent from the
  state monad version, because AutoCorres can prove it isn't needed due to the
  loop condition.
*}
thm gcd'_def gcd_body_def

text {*
  AutoCorres also proves that its (monadic) abstractions of each function
  correspond to their semantics in SIMPL. In this sense AutoCorres is a
  self-certifying tool, and doesn't need to be trusted.
*}
thm gcd'_ac_corres max'_ac_corres func'_ac_corres

lemma gcd'_correct:
  "\<lbrace>\<lambda>_. True\<rbrace> gcd' a b \<lbrace>\<lambda>r s. r = gcd a b\<rbrace>"
  apply(unfold gcd'_def)
  apply(rule hoare_weaken_pre)
   apply wp
   apply(rule whileLoop_wp[where I="\<lambda>(x,y) _. gcd x y = gcd a b"])
    apply clarsimp
    apply wp
    apply clarsimp (*sledgehammer*)
    apply (metis gcd.commute gcd_red_nat)
   apply clarsimp (*sledgehammer*)
  using gr_zeroI apply fastforce
   apply clarsimp
  done

lemma gcd'_correct2:
  "\<lbrace>\<lambda>_. True\<rbrace> gcd' a b \<lbrace>\<lambda>r s. r = gcd a b\<rbrace>"
  apply (unfold gcd'_def)
  apply (rule hoare_weaken_pre)
  (*sledgehammer*)
   apply (metis (no_types, lifting) hoare_chain simple.gcd'_correct simple.gcd'_def)
  apply simp
  done

text {*
  AutoCorres loops can be annotated with invariants which will be used by
  the wp ruleset when doing automated proofs. You annotate a rule by
  using the @{thm whileLoop_add_inv} substitution rule.
*}
lemma gcd'_le:
  "\<lbrace>\<lambda>_. True\<rbrace> gcd' a b \<lbrace>\<lambda>r s. r \<le> max a b\<rbrace>"
  apply(unfold gcd'_def)
  apply(subst whileLoop_add_inv[where I="\<lambda>(x,y) _. max x y \<le> max a b"])
  apply wp
    apply clarsimp
    using dual_order.trans mod_le_divisor apply blast
   apply clarsimp
  apply clarsimp
  done

thm unlessE_def
text {*
  A helper lemma about @{term unlessE}.
*}
lemma validE_unlessE[wp]:
  "\<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<Longrightarrow>
   \<lbrace>\<lambda>s. if P then Q () s else P' s\<rbrace> unlessE P f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace>"
  apply(clarsimp simp: unlessE_def)
  apply wp
  done

text {*
  wp tends to handle most reasoning about exceptions over AutoCorres output
*}
lemma except'_result:
  "\<lbrace>\<lambda>_. True\<rbrace> except' u \<lbrace>\<lambda>r _. r \<ge> 6 \<and> r \<le> 8\<rbrace>"
  apply(unfold except'_def)
  apply(subst whileLoopE_add_inv[where I="\<lambda>(ret, u) _. u < 9"])
  apply wp
    apply clarsimp
   apply clarsimp
  apply clarsimp
  apply wp
  done

text {*
  Some more helper lemmas.
*}
lemma no_fail_returnOk [simp]:
  "no_fail P (returnOk v)"
  apply(auto simp: no_fail_def)
  done

lemma validNF_unlessE[wp]:
  "\<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace>! \<Longrightarrow>
   \<lbrace>\<lambda>s. if P then Q () s else P' s\<rbrace> unlessE P f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace>!"
  apply(clarsimp simp: validE_NF_def unlessE_def | wp )+
  done
thm valid_def validNF_def no_fail_def

text {*
  This lemma proves additionally that the @{term except'} function never
  fails --- i.e. it proves \emph{total correctness}, and guarantees the
  side-conditions on the soundness of the AutoCorres-produced abstraction of
  the C code.
*}
lemma except'_result_nf:
  "\<lbrace>\<lambda>_. True\<rbrace> except' u \<lbrace>\<lambda>r _. r \<ge> 6 \<and> r \<le> 8\<rbrace>!"
  apply(unfold except'_def)
  apply(subst whileLoopE_add_inv[where I="\<lambda>(ret,u) _. u \<le> 8" and M="\<lambda>((ret,u),_). (9::nat) - u"])
  apply (wp | clarsimp)+
    apply(simp add: UINT_MAX_def, arith)
   apply clarsimp
  apply wp
  apply clarsimp
  done

end (* context simple *)

end


(*  Title:      HOL/Nitpick_Examples/Mono_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's monotonicity check.
*)

section \<open>Examples Featuring Nitpick's Monotonicity Check\<close>

theory Mono_Nits
imports MainRLT
        (* "~/afp/thys/DPT-SAT-Solver/DPT_SAT_Solver" *)
        (* "~/afp/thys/AVL-Trees/AVL2" "~/afp/thys/Huffman/Huffman" *)
begin

ML \<open>
open Nitpick_Util
open Nitpick_HOL
open Nitpick_Preproc

exception BUG

val thy = \<^theory>
val ctxt = \<^context>
val subst = []
val tac_timeout = seconds 1.0
val case_names = case_const_names ctxt
val defs = all_defs_of thy subst
val nondefs = all_nondefs_of ctxt subst
val def_tables = const_def_tables ctxt subst defs
val nondef_table = const_nondef_table nondefs
val simp_table = Unsynchronized.ref (const_simp_table ctxt subst)
val psimp_table = const_psimp_table ctxt subst
val choice_spec_table = const_choice_spec_table ctxt subst
val intro_table = inductive_intro_table ctxt subst def_tables
val ground_thm_table = ground_theorem_table thy
val ersatz_table = ersatz_table ctxt
val hol_ctxt as {thy, ...} : hol_context =
  {thy = thy, ctxt = ctxt, max_bisim_depth = ~1, boxes = [], wfs = [],
   user_axioms = NONE, debug = false, whacks = [], binary_ints = SOME false,
   destroy_constrs = true, specialize = false, star_linear_preds = false,
   total_consts = NONE, needs = NONE, tac_timeout = tac_timeout, evals = [],
   case_names = case_names, def_tables = def_tables,
   nondef_table = nondef_table, nondefs = nondefs, simp_table = simp_table,
   psimp_table = psimp_table, choice_spec_table = choice_spec_table,
   intro_table = intro_table, ground_thm_table = ground_thm_table,
   ersatz_table = ersatz_table, skolems = Unsynchronized.ref [],
   special_funs = Unsynchronized.ref [], unrolled_preds = Unsynchronized.ref [],
   wf_cache = Unsynchronized.ref [], constr_cache = Unsynchronized.ref []}
val binarize = false

fun is_mono t =
  Nitpick_Mono.formulas_monotonic hol_ctxt binarize \<^typ>\<open>'a\<close> ([t], [])

fun is_const t =
  let val T = fastype_of t in
    Logic.mk_implies (Logic.mk_equals (Free ("dummyP", T), t), \<^Const>\<open>False\<close>)
    |> is_mono
  end

fun mono t = is_mono t orelse raise BUG
fun nonmono t = not (is_mono t) orelse raise BUG
fun const t = is_const t orelse raise BUG
fun nonconst t = not (is_const t) orelse raise BUG
\<close>

ML \<open>Nitpick_Mono.trace := false\<close>

ML_val \<open>const \<^term>\<open>A::('a\<Rightarrow>'b)\<close>\<close>
ML_val \<open>const \<^term>\<open>(A::'a set) = A\<close>\<close>
ML_val \<open>const \<^term>\<open>(A::'a set set) = A\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x::'a set. a \<in> x)\<close>\<close>
ML_val \<open>const \<^term>\<open>{{a::'a}} = C\<close>\<close>
ML_val \<open>const \<^term>\<open>{f::'a\<Rightarrow>nat} = {g::'a\<Rightarrow>nat}\<close>\<close>
ML_val \<open>const \<^term>\<open>A \<union> (B::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>\<lambda>A B x::'a. A x \<or> B x\<close>\<close>
ML_val \<open>const \<^term>\<open>P (a::'a)\<close>\<close>
ML_val \<open>const \<^term>\<open>\<lambda>a::'a. b (c (d::'a)) (e::'a) (f::'a)\<close>\<close>
ML_val \<open>const \<^term>\<open>\<forall>A::'a set. a \<in> A\<close>\<close>
ML_val \<open>const \<^term>\<open>\<forall>A::'a set. P A\<close>\<close>
ML_val \<open>const \<^term>\<open>P \<or> Q\<close>\<close>
ML_val \<open>const \<^term>\<open>A \<union> B = (C::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>A B x::'a. A x \<or> B x) A B = C\<close>\<close>
ML_val \<open>const \<^term>\<open>(if P then (A::'a set) else B) = C\<close>\<close>
ML_val \<open>const \<^term>\<open>let A = (C::'a set) in A \<union> B\<close>\<close>
ML_val \<open>const \<^term>\<open>THE x::'b. P x\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x::'a. False)\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x::'a. True)\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x::'a. False) = (\<lambda>x::'a. False)\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x::'a. True) = (\<lambda>x::'a. True)\<close>\<close>
ML_val \<open>const \<^term>\<open>Let (a::'a) A\<close>\<close>
ML_val \<open>const \<^term>\<open>A (a::'a)\<close>\<close>
ML_val \<open>const \<^term>\<open>insert (a::'a) A = B\<close>\<close>
ML_val \<open>const \<^term>\<open>- (A::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>finite (A::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>\<not> finite (A::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>finite (A::'a set set)\<close>\<close>
ML_val \<open>const \<^term>\<open>\<lambda>a::'a. A a \<and> \<not> B a\<close>\<close>
ML_val \<open>const \<^term>\<open>A < (B::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>A \<le> (B::'a set)\<close>\<close>
ML_val \<open>const \<^term>\<open>[a::'a]\<close>\<close>
ML_val \<open>const \<^term>\<open>[a::'a set]\<close>\<close>
ML_val \<open>const \<^term>\<open>[A \<union> (B::'a set)]\<close>\<close>
ML_val \<open>const \<^term>\<open>[A \<union> (B::'a set)] = [C]\<close>\<close>
ML_val \<open>const \<^term>\<open>{(\<lambda>x::'a. x = a)} = C\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>a::'a. \<not> A a) = B\<close>\<close>
ML_val \<open>const \<^prop>\<open>\<forall>F f g (h::'a set). F f \<and> F g \<and> \<not> f a \<and> g a \<longrightarrow> \<not> f a\<close>\<close>
ML_val \<open>const \<^term>\<open>\<lambda>A B x::'a. A x \<and> B x \<and> A = B\<close>\<close>
ML_val \<open>const \<^term>\<open>p = (\<lambda>(x::'a) (y::'a). P x \<or> \<not> Q y)\<close>\<close>
ML_val \<open>const \<^term>\<open>p = (\<lambda>(x::'a) (y::'a). p x y :: bool)\<close>\<close>
ML_val \<open>const \<^term>\<open>p = (\<lambda>A B x. A x \<and> \<not> B x) (\<lambda>x. True) (\<lambda>y. x \<noteq> y)\<close>\<close>
ML_val \<open>const \<^term>\<open>p = (\<lambda>y. x \<noteq> y)\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x. (p::'a\<Rightarrow>bool\<Rightarrow>bool) x False)\<close>\<close>
ML_val \<open>const \<^term>\<open>(\<lambda>x y. (p::'a\<Rightarrow>'a\<Rightarrow>bool\<Rightarrow>bool) x y False)\<close>\<close>
ML_val \<open>const \<^term>\<open>f = (\<lambda>x::'a. P x \<longrightarrow> Q x)\<close>\<close>
ML_val \<open>const \<^term>\<open>\<forall>a::'a. P a\<close>\<close>

ML_val \<open>nonconst \<^term>\<open>\<forall>P (a::'a). P a\<close>\<close>
ML_val \<open>nonconst \<^term>\<open>THE x::'a. P x\<close>\<close>
ML_val \<open>nonconst \<^term>\<open>SOME x::'a. P x\<close>\<close>
ML_val \<open>nonconst \<^term>\<open>(\<lambda>A B x::'a. A x \<or> B x) = myunion\<close>\<close>
ML_val \<open>nonconst \<^term>\<open>(\<lambda>x::'a. False) = (\<lambda>x::'a. True)\<close>\<close>
ML_val \<open>nonconst \<^prop>\<open>\<forall>F f g (h::'a set). F f \<and> F g \<and> \<not> a \<in> f \<and> a \<in> g \<longrightarrow> F h\<close>\<close>

ML_val \<open>mono \<^prop>\<open>Q (\<forall>x::'a set. P x)\<close>\<close>
ML_val \<open>mono \<^prop>\<open>P (a::'a)\<close>\<close>
ML_val \<open>mono \<^prop>\<open>{a} = {b::'a}\<close>\<close>
ML_val \<open>mono \<^prop>\<open>(\<lambda>x. x = a) = (\<lambda>y. y = (b::'a))\<close>\<close>
ML_val \<open>mono \<^prop>\<open>(a::'a) \<in> P \<and> P \<union> P = P\<close>\<close>
ML_val \<open>mono \<^prop>\<open>\<forall>F::'a set set. P\<close>\<close>
ML_val \<open>mono \<^prop>\<open>\<not> (\<forall>F f g (h::'a set). F f \<and> F g \<and> \<not> a \<in> f \<and> a \<in> g \<longrightarrow> F h)\<close>\<close>
ML_val \<open>mono \<^prop>\<open>\<not> Q (\<forall>x::'a set. P x)\<close>\<close>
ML_val \<open>mono \<^prop>\<open>\<not> (\<forall>x::'a. P x)\<close>\<close>
ML_val \<open>mono \<^prop>\<open>myall P = (P = (\<lambda>x::'a. True))\<close>\<close>
ML_val \<open>mono \<^prop>\<open>myall P = (P = (\<lambda>x::'a. False))\<close>\<close>
ML_val \<open>mono \<^prop>\<open>\<forall>x::'a. P x\<close>\<close>
ML_val \<open>mono \<^term>\<open>(\<lambda>A B x::'a. A x \<or> B x) \<noteq> myunion\<close>\<close>

ML_val \<open>nonmono \<^prop>\<open>A = (\<lambda>x::'a. True) \<and> A = (\<lambda>x. False)\<close>\<close>
ML_val \<open>nonmono \<^prop>\<open>\<forall>F f g (h::'a set). F f \<and> F g \<and> \<not> a \<in> f \<and> a \<in> g \<longrightarrow> F h\<close>\<close>

ML \<open>
val preproc_timeout = seconds 5.0
val mono_timeout = seconds 1.0

fun is_forbidden_theorem name =
  length (Long_Name.explode name) <> 2 orelse
  String.isPrefix "type_definition" (List.last (Long_Name.explode name)) orelse
  String.isPrefix "arity_" (List.last (Long_Name.explode name)) orelse
  String.isSuffix "_def" name orelse
  String.isSuffix "_raw" name

fun theorems_of thy =
  filter (fn (name, th) =>
             not (is_forbidden_theorem name) andalso
             Thm.theory_name th = Context.theory_name thy)
         (Global_Theory.all_thms_of thy true)

fun check_formulas tsp =
  let
    fun is_type_actually_monotonic T =
      Nitpick_Mono.formulas_monotonic hol_ctxt binarize T tsp
    val free_Ts = fold Term.add_tfrees ((op @) tsp) [] |> map TFree
    val (mono_free_Ts, nonmono_free_Ts) =
      Timeout.apply mono_timeout
          (List.partition is_type_actually_monotonic) free_Ts
  in
    if not (null mono_free_Ts) then "MONO"
    else if not (null nonmono_free_Ts) then "NONMONO"
    else "NIX"
  end
  handle Timeout.TIMEOUT _ => "TIMEOUT"
       | NOT_SUPPORTED _ => "UNSUP"
       | exn => if Exn.is_interrupt exn then Exn.reraise exn else "UNKNOWN"

fun check_theory thy =
  let
    val path = File.tmp_path (Context.theory_name thy ^ ".out" |> Path.explode)
    val _ = File.write path ""
    fun check_theorem (name, th) =
      let
        val t = th |> Thm.prop_of |> Type.legacy_freeze |> close_form
        val neg_t = Logic.mk_implies (t, \<^prop>\<open>False\<close>)
        val (nondef_ts, def_ts, _, _, _, _) =
          Timeout.apply preproc_timeout (preprocess_formulas hol_ctxt [])
                              neg_t
        val res = name ^ ": " ^ check_formulas (nondef_ts, def_ts)
      in File.append path (res ^ "\n"); writeln res end
      handle Timeout.TIMEOUT _ => ()
  in thy |> theorems_of |> List.app check_theorem end
\<close>

(*
ML_val {* check_theory @{theory AVL2} *}
ML_val {* check_theory @{theory Fun} *}
ML_val {* check_theory @{theory Huffman} *}
ML_val {* check_theory @{theory List} *}
ML_val {* check_theory @{theory Map} *}
ML_val {* check_theory @{theory Relation} *}
*)

end


section "Solution to Day N of AoC 2020"

theory dayN
  imports Main "HOL.Code_Numeral" string_utils list_natural_utils natural_utils list_utils
begin

text "This is a solution to the puzzle for day N"

subsection "Input parsing"

(* TODO insert input parsing code here *)

subsection "Solution Algorithm"

(* TODO replace part1 and part2 below with real solutions *)

definition part1 :: "string \<Rightarrow> natural"
  where "part1 s = 0"

definition part2 :: "string \<Rightarrow> natural"
  where "part2 s = 0"

subsection "Testing"

(* TODO evaluate with some example inputs *)

definition example_input::string where "example_input = ''
''"

lemma "part1 example_input = 0"
  by eval

lemma "part2 example_input = 0"
  by eval

(* TODO remember to export part2 once complete *)

export_code "part1" in Haskell module_name Solution

end