(*  Title:      FOL/IFOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section \<open>Intuitionistic first-order logic\<close>

theory my_new_IFOL
imports Pure
begin

ML \<open>\<^assert> (not (can ML \<open>open RunCall\<close>))\<close>
ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>
ML_file \<open>~~/src/Provers/splitter.ML\<close>
ML_file \<open>~~/src/Provers/hypsubst.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/zipper.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/isand.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/rw_inst.ML\<close>
ML_file \<open>~~/src/Provers/quantifier1.ML\<close>
ML_file \<open>~~/src/Tools/intuitionistic.ML\<close>
ML_file \<open>~~/src/Tools/project_rule.ML\<close>
ML_file \<open>~~/src/Tools/atomize_elim.ML\<close>

subsection \<open>Syntax and axiomatic basis\<close>

setup Pure_Thy.old_appl_syntax_setup

class "term"
default_sort \<open>term\<close>

typedecl o
typedecl i

judgment
  Trueprop :: \<open>o \<Rightarrow> prop\<close>  (\<open>(_)\<close> 5)

(*
datatype 'a list =
    Nil    ("[]")
  | Cons 'a  "'a list"    (infixr "#" 65)

syntax
  -- {* list Enumeration *}
  "_list" :: "args => 'a list"    ("[(_)]")

translations
  "[x, xs]" == "x#[xs]"
  "[x]" == "x#[]"
*)
typedecl ctx

judgment
  Truectx :: \<open>prop \<Rightarrow> ctx\<close>  (\<open>(_)\<close> 4)

(*typedecl myprop *)

subsubsection \<open>Equality\<close>

(*
axiomatization
  eq :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>=\<close> 50)
where
  refl: \<open>a = a\<close> and
  subst: \<open>a = b \<Longrightarrow> P(a) \<Longrightarrow> P(b)\<close>
*)

subsubsection \<open>Propositional logic\<close>

axiomatization
  False :: \<open>o\<close> (\<open>\<bottom>\<close>) and
  conj :: \<open>[o, o] => o\<close>  (infixr \<open>\<and>\<close> 35) and
  disj :: \<open>[o, o] => o\<close>  (infixr \<open>\<or>\<close> 30) and
  imp :: \<open>[o, o] => o\<close>  (infixr \<open>\<longrightarrow>\<close> 25)

definition Not (\<open>\<not> _\<close> [40] 40)
  where not_def: \<open>\<not> P \<equiv> P \<longrightarrow> \<bottom>\<close>

definition True (\<open>\<top>\<close>)
  where true_def \<open>True \<equiv> \<not>\<bottom>\<close>

axiomatization
  empctx :: \<open>ctx\<close> (\<open>*\<close>)and
  addctx :: \<open>[ctx, o] \<Rightarrow> ctx\<close> (infixl \<open>,\<close> 9) and
  deriv :: \<open>[ctx, o] \<Rightarrow> prop\<close> (infixr \<open>\<turnstile>\<close> 8)
(* and  metaimp :: \<open>[prop, prop] => prop\<close>  (infixr \<open>\<leadsto>\<close> 36) *)

(*
judgment
  mypro :: \<open>myprop \<Rightarrow> prop\<close>  (\<open>(_)\<close> 5)

axiomatization
  where
  hyp: \<open>G, P \<turnstile> P\<close> and
  mp: \<open>(G \<turnstile> (P \<longrightarrow> Q)) \<leadsto> ((G \<turnstile> P) \<leadsto> (G \<turnstile> Q))\<close> and
  ded: \<open>(G, P \<turnstile> Q) \<leadsto> (G \<turnstile> (P \<longrightarrow> Q))\<close>

axiomatization
  where
  MA1 : \<open>(G \<turnstile> A) \<leadsto> ((G \<turnstile> B) \<leadsto> (G \<turnstile> A))\<close> and
(* MA2 similarly *)
  MMP : \<open>\<lbrakk>(G \<turnstile> A) \<leadsto> (G \<turnstile> B); G \<turnstile> A\<rbrakk> \<Longrightarrow> G \<turnstile> B\<close>
*)

typedecl var

axiomatization
  interpr :: \<open>var \<Rightarrow> i\<close> (\<open>\<bottom>\<close>)

axiomatization
  ZF :: \<open>ctx\<close>

axiomatization
  FV :: \<open>ctx \<Rightarrow> i\<close>

axiomatization
  IN :: \<open>i \<Rightarrow> i \<Rightarrow> o\<close>  (infixr \<open>\<in>\<close> 10)

definition NotIN (\<open>_ \<notin> _\<close> 40) (* [40] 40 *)
  where notin_def: \<open>x \<notin> y \<equiv> \<not>(x \<in> y)\<close>

(*
axiomatization
 notinctx :: \<open>i\<Rightarrow>ctx\<Rightarrow>prop\<close> ( \<open>_ \<notin>FV(_)\<close> 8)
where
 ax1: \<open>x\<notin>FV(G)\<close>
*)

axiomatization
  All :: \<open>(i \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<forall>\<close> 10) and
  Ex :: \<open>(i \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>\<close> 10) (* 'a *)
where
  spec: \<open>G \<turnstile> (\<forall>x. R(x)) \<longrightarrow> R(t)\<close> and
  gen: \<open>\<lbrakk>\<And>x. G \<turnstile> R(x)\<rbrakk> \<Longrightarrow> G \<turnstile> \<forall>x. R(x)\<close>
(*  gen: \<open>\<lbrakk>G \<turnstile> R(x); ZF \<turnstile> x \<notin> FV(G)\<rbrakk> \<Longrightarrow> G \<turnstile> \<forall>x. R(x)\<close>  (* sic! *) *)
(* here we imply that VARIABLES and SETS are the same entity.
Can we do so? *)
(*  gen: \<open>\<lbrakk>G \<turnstile> R(x); ZF \<turnstile> x\<notin>FV(G)\<rbrakk> \<Longrightarrow> G \<turnstile> \<forall>x. R(x)\<close>  (* sic! *) *)

axiomatization
  where
  hyp: \<open>G, P \<turnstile> P\<close> and
  weak: \<open>(G \<turnstile> P) \<Longrightarrow> (G, A \<turnstile> P)\<close> and
(*  spec: \<open>G \<turnstile> ((\<forall>x::i. ((P::"i\<Rightarrow>o") x)) \<longrightarrow> (P (t::i)))\<close> and*)
  mp: \<open>\<lbrakk>(G \<turnstile> (P \<longrightarrow> Q)); (G \<turnstile> P)\<rbrakk> \<Longrightarrow> (G \<turnstile> Q)\<close> and
  mp_rev: \<open>\<lbrakk>(G \<turnstile> P); (G \<turnstile> (P \<longrightarrow> Q))\<rbrakk> \<Longrightarrow> (G \<turnstile> Q)\<close> and
  ded: \<open>(G, P \<turnstile> Q) \<Longrightarrow> (G \<turnstile> (P \<longrightarrow> Q))\<close>

lemma bad2: \<open>(*, (\<exists>y. y\<in>x)) \<turnstile> (\<forall>x. \<exists>y. y\<in>x)\<close>
  apply (rule gen)
  apply (rule hyp)
  done

(* Checked!
axiomatization
  noteq :: \<open>i \<Rightarrow> i \<Rightarrow> o\<close>  (infixr \<open>\<noteq>\<close> 10)

lemma fkt: "G \<turnstile> (\<forall>x. \<exists>y. x\<noteq>y)"
  sorry

lemma bad: "G \<turnstile> (\<exists>y. y\<noteq>y)"
  apply (rule mp_rev)
  apply (rule fkt)
  apply (rule spec)
  sorry
*)

lemma firstthm: \<open>*, A, B \<turnstile> B\<close>
  by (rule hyp)

lemma lem1: \<open>*, A, B \<turnstile> A\<close>
  by (rule weak, rule hyp)

lemma idgp: \<open>(G \<turnstile> P) \<Longrightarrow> (G \<turnstile> P)\<close>
  apply assumption
  done

(* end of my part *)

axiomatization
where
  conjI: \<open>\<lbrakk>P;  Q\<rbrakk> \<Longrightarrow> P \<and> Q\<close> and
  conjunct1: \<open>P \<and> Q \<Longrightarrow> P\<close> and
  conjunct2: \<open>P \<and> Q \<Longrightarrow> Q\<close> and

  disjI1: \<open>P \<Longrightarrow> P \<or> Q\<close> and
  disjI2: \<open>Q \<Longrightarrow> P \<or> Q\<close> and
  disjE: \<open>\<lbrakk>P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close> and

  impI: \<open>(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q\<close> and
  mp: \<open>\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close> and

  FalseE: \<open>False \<Longrightarrow> P\<close>

subsubsection \<open>Quantifiers\<close>

axiomatization
  All :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<forall>\<close> 10) and
  Ex :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>\<close> 10)
where
  allI: \<open>(\<And>x. P(x)) \<Longrightarrow> (\<forall>x. P(x))\<close> and
  spec: \<open>(\<forall>x. P(x)) \<Longrightarrow> P(x)\<close> and
  exI: \<open>P(x) \<Longrightarrow> (\<exists>x. P(x))\<close> and
  exE: \<open>\<lbrakk>\<exists>x. P(x); \<And>x. P(x) \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close>

subsubsection \<open>Definitions\<close>

definition \<open>True \<equiv> False \<longrightarrow> False\<close>

definition Not (\<open>\<not> _\<close> [40] 40)
  where not_def: \<open>\<not> P \<equiv> P \<longrightarrow> False\<close>

definition iff  (infixr \<open>\<longleftrightarrow>\<close> 25)
  where \<open>P \<longleftrightarrow> Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)\<close>

definition Only1 :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>!\<close> 10)
  where only1_def: \<open>!x. P(x) \<equiv> (\<forall>x.\<forall>y. P(x) \<and> P(y) \<longrightarrow> x = y)\<close>

definition Ex1 :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>!\<close> 10)
  where ex1new_def: \<open>\<exists>!x. P(x) \<equiv> (\<exists>x. P(x)) \<and> (!x. P(x))\<close>

axiomatization where  \<comment> \<open>Reflection, admissible\<close>
  eq_reflection: \<open>(x = y) \<Longrightarrow> (x \<equiv> y)\<close> and
  iff_reflection: \<open>(P \<longleftrightarrow> Q) \<Longrightarrow> (P \<equiv> Q)\<close>

abbreviation not_equal :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>\<noteq>\<close> 50)
  where \<open>x \<noteq> y \<equiv> \<not> (x = y)\<close>

subsubsection \<open>Old-style ASCII syntax\<close>

notation (ASCII)
  not_equal  (infixl \<open>~=\<close> 50) and
  Not  (\<open>~ _\<close> [40] 40) and
  conj  (infixr \<open>&\<close> 35) and
  disj  (infixr \<open>|\<close> 30) and
  All  (binder \<open>ALL \<close> 10) and
  Ex  (binder \<open>EX \<close> 10) and
  Ex1  (binder \<open>EX! \<close> 10) and
  imp  (infixr \<open>-->\<close> 25) and
  iff  (infixr \<open><->\<close> 25)

subsection \<open>Lemmas and proof tools\<close>

lemmas strip = impI allI

lemma TrueI: \<open>True\<close>
  unfolding True_def by (rule impI)

subsubsection \<open>Sequent-style elimination rules for \<open>\<and>\<close> \<open>\<longrightarrow>\<close> and \<open>\<forall>\<close>\<close>

lemma conjE:
  assumes major: \<open>P \<and> Q\<close>
    and r: \<open>\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
   apply (rule major [THEN conjunct1])
  apply (rule major [THEN conjunct2])
  done

lemma impE:
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and \<open>P\<close>
  and r: \<open>Q \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
  apply (rule major [THEN mp])
  apply (rule \<open>P\<close>)
  done

lemma allE:
  assumes major: \<open>\<forall>x. P(x)\<close>
    and r: \<open>P(x) \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
  apply (rule major [THEN spec])
  done

text \<open>Duplicates the quantifier; for use with \<^ML>\<open>eresolve_tac\<close>.\<close>
lemma all_dupE:
  assumes major: \<open>\<forall>x. P(x)\<close>
    and r: \<open>\<lbrakk>P(x); \<forall>x. P(x)\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
   apply (rule major [THEN spec])
  apply (rule major)
  done

subsubsection \<open>Negation rules, which translate between \<open>\<not> P\<close> and \<open>P \<longrightarrow> False\<close>\<close>

lemma notI: \<open>(P \<Longrightarrow> False) \<Longrightarrow> \<not> P\<close>
  unfolding not_def by (erule impI)

lemma notE: \<open>\<lbrakk>\<not> P; P\<rbrakk> \<Longrightarrow> R\<close>
  unfolding not_def by (erule mp [THEN FalseE])

lemma rev_notE: \<open>\<lbrakk>P; \<not> P\<rbrakk> \<Longrightarrow> R\<close>
  by (erule notE)

text \<open>This is useful with the special implication rules for each kind of \<open>P\<close>.\<close>
lemma not_to_imp:
  assumes \<open>\<not> P\<close>
    and r: \<open>P \<longrightarrow> False \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
  apply (rule r)
  apply (rule impI)
  apply (erule notE [OF \<open>\<not> P\<close>])
  done

text \<open>
  For substitution into an assumption \<open>P\<close>, reduce \<open>Q\<close> to \<open>P \<longrightarrow> Q\<close>, substitute into this implication, then apply \<open>impI\<close> to
  move \<open>P\<close> back into the assumptions.
\<close>
lemma rev_mp: \<open>\<lbrakk>P; P \<longrightarrow> Q\<rbrakk> \<Longrightarrow> Q\<close>
  by (erule mp)

text \<open>Contrapositive of an inference rule.\<close>
lemma contrapos:
  assumes major: \<open>\<not> Q\<close>
    and minor: \<open>P \<Longrightarrow> Q\<close>
  shows \<open>\<not> P\<close>
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

subsubsection \<open>Modus Ponens Tactics\<close>

text \<open>
  Finds \<open>P \<longrightarrow> Q\<close> and P in the assumptions, replaces implication by
  \<open>Q\<close>.
\<close>
ML \<open>
  fun mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN assume_tac ctxt i;
  fun eq_mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN eq_assume_tac i;
\<close>

subsection \<open>If-and-only-if\<close>

lemma iffI: \<open>\<lbrakk>P \<Longrightarrow> Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  apply (unfold iff_def)
  apply (rule conjI)
   apply (erule impI)
  apply (erule impI)
  done

lemma iffE:
  assumes major: \<open>P \<longleftrightarrow> Q\<close>
    and r: \<open>P \<longrightarrow> Q \<Longrightarrow> Q \<longrightarrow> P \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (insert major)
apply (unfold iff_def)
  apply (erule conjE)
  apply (erule r)
  apply assumption
  done

subsubsection \<open>Destruct rules for \<open>\<longleftrightarrow>\<close> similar to Modus Ponens\<close>

lemma iffD1: \<open>\<lbrakk>P \<longleftrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close>
  apply (unfold iff_def)
  apply (erule conjunct1 [THEN mp])
  apply assumption
  done

lemma iffD2: \<open>\<lbrakk>P \<longleftrightarrow> Q; Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (unfold iff_def)
  apply (erule conjunct2 [THEN mp])
  apply assumption
  done

lemma rev_iffD1: \<open>\<lbrakk>P; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> Q\<close>
  apply (erule iffD1)
  apply assumption
  done

lemma rev_iffD2: \<open>\<lbrakk>Q; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (erule iffD2)
  apply assumption
  done

lemma iff_refl: \<open>P \<longleftrightarrow> P\<close>
  by (rule iffI)

lemma iff_sym: \<open>Q \<longleftrightarrow> P \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  apply (erule iffE)
  apply (rule iffI)
  apply (assumption | erule mp)+
  done

lemma iff_trans: \<open>\<lbrakk>P \<longleftrightarrow> Q; Q \<longleftrightarrow> R\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> R\<close>
  apply (rule iffI)
  apply (assumption | erule iffE | erule (1) notE impE)+
  done

subsection \<open>Equality rules\<close>

lemma sym: \<open>a = b \<Longrightarrow> b = a\<close>
  apply (erule subst)
  apply (rule refl)
  done

lemma trans: \<open>\<lbrakk>a = b; b = c\<rbrakk> \<Longrightarrow> a = c\<close>
  apply (erule subst, assumption)
  done

lemma not_sym: \<open>b \<noteq> a \<Longrightarrow> a \<noteq> b\<close>
  apply (erule contrapos)
  apply (erule sym)
  done

text \<open>
  Two theorems for rewriting only one instance of a definition:
  the first for definitions of formulae and the second for terms.
\<close>

lemma def_imp_iff: \<open>(A \<equiv> B) \<Longrightarrow> A \<longleftrightarrow> B\<close>
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: \<open>(A \<equiv> B) \<Longrightarrow> A = B\<close>
  apply unfold
  apply (rule refl)
  done

lemma meta_eq_to_iff: \<open>x \<equiv> y \<Longrightarrow> x \<longleftrightarrow> y\<close>
  by unfold (rule iff_refl)

subsection \<open>Only\<close>

text \<open>Quantifier "!x. P(x)" means "at most one object has property P"\<close>

lemma only1I:
  assumes H: \<open>(\<And>x y. (\<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y))\<close>
  shows \<open>!x. P(x)\<close>
  by (unfold only1_def, rule allI, rule allI, rule impI, rule H,
        erule conjunct1, erule conjunct2)

lemma only1D: \<open>!x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y)\<close>
  apply(unfold only1_def)
  apply(rule mp, rule spec, erule spec)
  apply(erule conjI, assumption)
  done

lemma only1E:
  assumes major: \<open>!x. P(x)\<close>
      and r: \<open>(\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> R\<close>
    shows \<open>R\<close>
  by (rule r, rule only1D[OF major], assumption+)

lemma only1lem:
  assumes H:\<open>(\<And>x. P(x) \<Longrightarrow> x = a)\<close>
  shows \<open>(\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y)\<close>
proof -
  fix x y
  assume W1:\<open>P(x)\<close>
  assume W2:\<open>P(y)\<close>
  have E1:\<open>x = a\<close> by (rule H[OF W1])
  have E2:\<open>y = a\<close> by (rule H[OF W2])
  show \<open>x = y\<close> by (rule trans[OF E1 sym[OF E2]])
qed

lemma only1I2:
  assumes H:\<open>(\<And>x. P(x) \<Longrightarrow> x = a)\<close>
  shows \<open>!x. P(x)\<close>
  apply (rule only1I)
  apply (rule only1lem)
  apply (rule H, assumption+)
  done

lemma only1rearr :
  assumes 1: \<open>!x. P(x)\<close>
  assumes M: \<open>P(x)\<close>
  shows \<open>\<forall>y. P(y) \<longrightarrow> y = x\<close>
proof (rule allI, rule impI, rule only1E[OF 1])
  fix y
  assume N: \<open>P(y)\<close>
  assume K: \<open>(\<And>x y. P(x) \<Longrightarrow> P(y) \<Longrightarrow> x = y)\<close>
  show \<open>y = x\<close> by (rule K[OF N M])
qed

subsection \<open>Unique existence\<close>

text \<open>
  NOTE THAT the following 2 quantifications:

    \<^item> \<open>\<exists>!x\<close> such that [\<open>\<exists>!y\<close> such that P(x,y)]   (sequential)
    \<^item> \<open>\<exists>!x,y\<close> such that P(x,y)                   (simultaneous)

  do NOT mean the same thing. The parser treats \<open>\<exists>!x y.P(x,y)\<close> as sequential.
\<close>

lemma ex1newI: \<open>\<lbrakk>\<exists>x. P(x); !x. P(x)\<rbrakk> \<Longrightarrow> \<exists>! x. P(x)\<close>
  by (unfold ex1new_def, rule conjI, assumption+)

lemma ex1newE: \<open>\<exists>!x. P(x) \<Longrightarrow> (\<lbrakk>\<exists>x. P(x); !x. P(x)\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (unfold ex1new_def)
  apply (assumption | erule exE conjE)+
  done

lemma ex1newD1: \<open>\<exists>!x. P(x) \<Longrightarrow> \<exists>x. P(x)\<close>
  by (erule ex1newE)

lemma ex1newD2: \<open>\<exists>!x. P(x) \<Longrightarrow> !x. P(x)\<close>
  by (erule ex1newE)

lemma ex1badI:
  assumes 1: \<open>P(a)\<close>
    and 2: \<open>(\<And>x. P(x) \<Longrightarrow> x = a)\<close>
  shows \<open>\<exists>!x. P(x)\<close>
proof(rule ex1newI)
  show \<open>\<exists>x. P(x)\<close> by (rule exI, rule 1)
next
  show \<open>!x. P(x)\<close> by (rule only1I2, rule 2, assumption)
qed

lemma ex1unfold: \<open>\<exists>!x. P(x) \<Longrightarrow> \<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x)\<close>
proof (erule ex1newE)
  assume 1: \<open>\<exists>x. P(x)\<close>
  assume 2: \<open>!x. P(x)\<close>
  show \<open>\<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x)\<close>
    by(rule exE[OF 1], rule exI, rule conjI, assumption, erule only1rearr[OF 2])
qed

lemma ex1fold: \<open>\<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x) \<Longrightarrow> \<exists>!x. P(x)\<close>
  by (erule exE, erule conjE, erule ex1badI, rule mp, erule spec, assumption)

lemma ex1_def : \<open>\<exists>!x. P(x) \<equiv> (\<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x))\<close>
  by (rule iff_reflection, rule iffI, erule ex1unfold, erule ex1fold)

lemma ex1I: \<open>P(a) \<Longrightarrow> (\<And>x. P(x) \<Longrightarrow> x = a) \<Longrightarrow> \<exists>!x. P(x)\<close>
  apply (unfold ex1_def)
  apply (assumption | rule exI conjI allI impI)+
  done

text \<open>Sometimes easier to use: the premises have no shared variables. Safe!\<close>

lemma ex_ex1I: \<open>\<exists>x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> \<exists>!x. P(x)\<close>
  by (erule ex1newI, erule only1I)

lemma ex1E':
  assumes 0: \<open>(\<And>x. \<lbrakk>P(x); \<forall>y. P(y) \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R)\<close>
  shows \<open>(\<exists>! x. P(x)) \<Longrightarrow> R\<close>
  apply (erule ex1newE)
  apply (erule exE)
  apply (rule 0, assumption, erule only1rearr, assumption)
  done

lemma ex_ex1I': \<open>\<exists>x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> \<exists>!x. P(x)\<close>
  apply (erule exE)
  apply (rule ex1I)
   apply assumption
  apply assumption
  done

lemma ex1E: \<open>\<exists>! x. P(x) \<Longrightarrow> (\<And>x. \<lbrakk>P(x); \<forall>y. P(y) \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (unfold ex1_def)
  apply (assumption | erule exE conjE)+
  done

subsubsection \<open>\<open>\<longleftrightarrow>\<close> congruence rules for simplification\<close>

text \<open>Use \<open>iffE\<close> on a premise. For \<open>conj_cong\<close>, \<open>imp_cong\<close>, \<open>all_cong\<close>, \<open>ex_cong\<close>.\<close>
ML \<open>
  fun iff_tac ctxt prems i =
    resolve_tac ctxt (prems RL @{thms iffE}) i THEN
    REPEAT1 (eresolve_tac ctxt @{thms asm_rl mp} i);
\<close>

method_setup iff =
  \<open>Attrib.thms >>
    (fn prems => fn ctxt => SIMPLE_METHOD' (iff_tac ctxt prems))\<close>

lemma conj_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<and> Q) \<longleftrightarrow> (P' \<and> Q')\<close>
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

text \<open>Reversed congruence rule!  Used in ZF/Order.\<close>
lemma conj_cong2:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(Q \<and> P) \<longleftrightarrow> (Q' \<and> P')\<close>
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

lemma disj_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close> and \<open>Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<or> Q) \<longleftrightarrow> (P' \<or> Q')\<close>
  apply (insert assms)
  apply (erule iffE disjE disjI1 disjI2 |
    assumption | rule iffI | erule (1) notE impE)+
  done

lemma imp_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q')\<close>
  apply (insert assms)
  apply (assumption | rule iffI impI | erule iffE | erule (1) notE impE | iff assms)+
  done

lemma iff_cong: \<open>\<lbrakk>P \<longleftrightarrow> P'; Q \<longleftrightarrow> Q'\<rbrakk> \<Longrightarrow> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P' \<longleftrightarrow> Q')\<close>
  apply (erule iffE | assumption | rule iffI | erule (1) notE impE)+
  done

lemma not_cong: \<open>P \<longleftrightarrow> P' \<Longrightarrow> \<not> P \<longleftrightarrow> \<not> P'\<close>
  apply (assumption | rule iffI notI | erule (1) notE impE | erule iffE notE)+
  done

lemma all_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))\<close>
  apply (assumption | rule iffI allI | erule (1) notE impE | erule allE | iff assms)+
  done

lemma ex_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))\<close>
  apply (erule exE | assumption | rule iffI exI | erule (1) notE impE | iff assms)+
  done

lemma ex1_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<exists>!x. P(x)) \<longleftrightarrow> (\<exists>!x. Q(x))\<close>
  apply (erule ex1E spec [THEN mp] | assumption | rule iffI ex1I | erule (1) notE impE | iff assms)+
  done

text \<open>Substitution.\<close>
lemma ssubst: \<open>\<lbrakk>b = a; P(a)\<rbrakk> \<Longrightarrow> P(b)\<close>
  apply (drule sym)
  apply (erule (1) subst)
  done

text \<open>A special case of \<open>ex1E\<close> that would otherwise need quantifier
  expansion.\<close>
lemma ex1_equalsE: \<open>\<lbrakk>\<exists>!x. P(x); P(a); P(b)\<rbrakk> \<Longrightarrow> a = b\<close>
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

subsubsection \<open>Polymorphic congruence rules\<close>

lemma subst_context: \<open>a = b \<Longrightarrow> t(a) = t(b)\<close>
  apply (erule ssubst)
  apply (rule refl)
  done

lemma subst_context2: \<open>\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> t(a,c) = t(b,d)\<close>
  apply (erule ssubst)+
  apply (rule refl)
  done

lemma subst_context3: \<open>\<lbrakk>a = b; c = d; e = f\<rbrakk> \<Longrightarrow> t(a,c,e) = t(b,d,f)\<close>
  apply (erule ssubst)+
  apply (rule refl)
  done

text \<open>
  Useful with \<^ML>\<open>eresolve_tac\<close> for proving equalities from known
  equalities.

        a = b
        |   |
        c = d
\<close>
lemma box_equals: \<open>\<lbrakk>a = b; a = c; b = d\<rbrakk> \<Longrightarrow> c = d\<close>
  apply (rule trans)
   apply (rule trans)
    apply (rule sym)
    apply assumption+
  done

text \<open>Dual of \<open>box_equals\<close>: for proving equalities backwards.\<close>
lemma simp_equals: \<open>\<lbrakk>a = c; b = d; c = d\<rbrakk> \<Longrightarrow> a = b\<close>
  apply (rule trans)
   apply (rule trans)
    apply assumption+
  apply (erule sym)
  done

subsubsection \<open>Congruence rules for predicate letters\<close>

lemma pred1_cong: \<open>a = a' \<Longrightarrow> P(a) \<longleftrightarrow> P(a')\<close>
  apply (rule iffI)
   apply (erule (1) subst)
  apply (erule (1) ssubst)
  done

lemma pred2_cong: \<open>\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> P(a,b) \<longleftrightarrow> P(a',b')\<close>
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

lemma pred3_cong: \<open>\<lbrakk>a = a'; b = b'; c = c'\<rbrakk> \<Longrightarrow> P(a,b,c) \<longleftrightarrow> P(a',b',c')\<close>
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

text \<open>Special case for the equality predicate!\<close>
lemma eq_cong: \<open>\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> a = b \<longleftrightarrow> a' = b'\<close>
  apply (erule (1) pred2_cong)
  done

subsection \<open>Simplifications of assumed implications\<close>

text \<open>
  Roy Dyckhoff has proved that \<open>conj_impE\<close>, \<open>disj_impE\<close>, and
  \<open>imp_impE\<close> used with \<^ML>\<open>mp_tac\<close> (restricted to atomic formulae) is
  COMPLETE for intuitionistic propositional logic.

  See R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
  (preprint, University of St Andrews, 1991).
\<close>

lemma conj_impE:
  assumes major: \<open>(P \<and> Q) \<longrightarrow> S\<close>
    and r: \<open>P \<longrightarrow> (Q \<longrightarrow> S) \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule conjI impI major [THEN mp] r)+

lemma disj_impE:
  assumes major: \<open>(P \<or> Q) \<longrightarrow> S\<close>
    and r: \<open>\<lbrakk>P \<longrightarrow> S; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule disjI1 disjI2 impI major [THEN mp] r)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.\<close>
lemma imp_impE:
  assumes major: \<open>(P \<longrightarrow> Q) \<longrightarrow> S\<close>
    and r1: \<open>\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q\<close>
    and r2: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule impI major [THEN mp] r1 r2)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.\<close>
lemma not_impE: \<open>\<not> P \<longrightarrow> S \<Longrightarrow> (P \<Longrightarrow> False) \<Longrightarrow> (S \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (drule mp)
   apply (rule notI)
   apply assumption
  apply assumption
  done

text \<open>Simplifies the implication. UNSAFE.\<close>
lemma iff_impE:
  assumes major: \<open>(P \<longleftrightarrow> Q) \<longrightarrow> S\<close>
    and r1: \<open>\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q\<close>
    and r2: \<open>\<lbrakk>Q; P \<longrightarrow> S\<rbrakk> \<Longrightarrow> P\<close>
    and r3: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+
  done

text \<open>What if \<open>(\<forall>x. \<not> \<not> P(x)) \<longrightarrow> \<not> \<not> (\<forall>x. P(x))\<close> is an assumption?
  UNSAFE.\<close>
lemma all_impE:
  assumes major: \<open>(\<forall>x. P(x)) \<longrightarrow> S\<close>
    and r1: \<open>\<And>x. P(x)\<close>
    and r2: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule allI impI major [THEN mp] r1 r2)+
  done

text \<open>
  Unsafe: \<open>\<exists>x. P(x)) \<longrightarrow> S\<close> is equivalent
  to \<open>\<forall>x. P(x) \<longrightarrow> S\<close>.\<close>
lemma ex_impE:
  assumes major: \<open>(\<exists>x. P(x)) \<longrightarrow> S\<close>
    and r: \<open>P(x) \<longrightarrow> S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (assumption | rule exI impI major [THEN mp] r)+
  done

text \<open>Courtesy of Krzysztof Grabczewski.\<close>
lemma disj_imp_disj: \<open>P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> S) \<Longrightarrow> R \<or> S\<close>
  apply (erule disjE)
  apply (rule disjI1) apply assumption
  apply (rule disjI2) apply assumption
  done

ML \<open>
structure Project_Rule = Project_Rule
(
  val conjunct1 = @{thm conjunct1}
  val conjunct2 = @{thm conjunct2}
  val mp = @{thm mp}
)
\<close>

ML_file \<open>fologic.ML\<close>

lemma thin_refl: \<open>\<lbrakk>x = x; PROP W\<rbrakk> \<Longrightarrow> PROP W\<close> .

ML \<open>
structure Hypsubst = Hypsubst
(
  val dest_eq = FOLogic.dest_eq
  val dest_Trueprop = FOLogic.dest_Trueprop
  val dest_imp = FOLogic.dest_imp
  val eq_reflection = @{thm eq_reflection}
  val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
  val imp_intr = @{thm impI}
  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
\<close>

ML_file \<open>intprover.ML\<close>

subsection \<open>Intuitionistic Reasoning\<close>

setup \<open>Intuitionistic.method_setup \<^binding>\<open>iprover\<close>\<close>

lemma impE':
  assumes 1: \<open>P \<longrightarrow> Q\<close>
    and 2: \<open>Q \<Longrightarrow> R\<close>
    and 3: \<open>P \<longrightarrow> Q \<Longrightarrow> P\<close>
  shows \<open>R\<close>
proof -
  from 3 and 1 have \<open>P\<close> .
  with 1 have \<open>Q\<close> by (rule impE)
  with 2 show \<open>R\<close> .
qed

lemma allE':
  assumes 1: \<open>\<forall>x. P(x)\<close>
    and 2: \<open>P(x) \<Longrightarrow> \<forall>x. P(x) \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
proof -
  from 1 have \<open>P(x)\<close> by (rule spec)
  from this and 1 show \<open>Q\<close> by (rule 2)
qed

lemma notE':
  assumes 1: \<open>\<not> P\<close>
    and 2: \<open>\<not> P \<Longrightarrow> P\<close>
  shows \<open>R\<close>
proof -
  from 2 and 1 have \<open>P\<close> .
  with 1 show \<open>R\<close> by (rule notE)
qed

lemmas [Pure.elim!] = disjE iffE FalseE conjE exE
  and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
  and [Pure.elim 2] = allE notE' impE'
  and [Pure.intro] = exI disjI2 disjI1

setup \<open>
  Context_Rules.addSWrapper
    (fn ctxt => fn tac => hyp_subst_tac ctxt ORELSE' tac)
\<close>

lemma iff_not_sym: \<open>\<not> (Q \<longleftrightarrow> P) \<Longrightarrow> \<not> (P \<longleftrightarrow> Q)\<close>
  by iprover

lemmas [sym] = sym iff_sym not_sym iff_not_sym
  and [Pure.elim?] = iffD1 iffD2 impE

lemma eq_commute: \<open>a = b \<longleftrightarrow> b = a\<close>
  apply (rule iffI)
  apply (erule sym)+
  done

subsection \<open>Atomizing meta-level rules\<close>

lemma atomize_all [atomize]: \<open>(\<And>x. P(x)) \<equiv> Trueprop (\<forall>x. P(x))\<close>
proof
  assume \<open>\<And>x. P(x)\<close>
  then show \<open>\<forall>x. P(x)\<close> ..
next
  assume \<open>\<forall>x. P(x)\<close>
  then show \<open>\<And>x. P(x)\<close> ..
qed

lemma atomize_imp [atomize]: \<open>(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)\<close>
proof
  assume \<open>A \<Longrightarrow> B\<close>
  then show \<open>A \<longrightarrow> B\<close> ..
next
  assume \<open>A \<longrightarrow> B\<close> and \<open>A\<close>
  then show \<open>B\<close> by (rule mp)
qed

lemma atomize_eq [atomize]: \<open>(x \<equiv> y) \<equiv> Trueprop (x = y)\<close>
proof
  assume \<open>x \<equiv> y\<close>
  show \<open>x = y\<close> unfolding \<open>x \<equiv> y\<close> by (rule refl)
next
  assume \<open>x = y\<close>
  then show \<open>x \<equiv> y\<close> by (rule eq_reflection)
qed

lemma atomize_iff [atomize]: \<open>(A \<equiv> B) \<equiv> Trueprop (A \<longleftrightarrow> B)\<close>
proof
  assume \<open>A \<equiv> B\<close>
  show \<open>A \<longleftrightarrow> B\<close> unfolding \<open>A \<equiv> B\<close> by (rule iff_refl)
next
  assume \<open>A \<longleftrightarrow> B\<close>
  then show \<open>A \<equiv> B\<close> by (rule iff_reflection)
qed

lemma atomize_conj [atomize]: \<open>(A &&& B) \<equiv> Trueprop (A \<and> B)\<close>
proof
  assume conj: \<open>A &&& B\<close>
  show \<open>A \<and> B\<close>
  proof (rule conjI)
    from conj show \<open>A\<close> by (rule conjunctionD1)
    from conj show \<open>B\<close> by (rule conjunctionD2)
  qed
next
  assume conj: \<open>A \<and> B\<close>
  show \<open>A &&& B\<close>
  proof -
    from conj show \<open>A\<close> ..
    from conj show \<open>B\<close> ..
  qed
qed

lemmas [symmetric, rulify] = atomize_all atomize_imp
  and [symmetric, defn] = atomize_all atomize_imp atomize_eq atomize_iff

subsection \<open>Atomizing elimination rules\<close>

lemma atomize_exL[atomize_elim]: \<open>(\<And>x. P(x) \<Longrightarrow> Q) \<equiv> ((\<exists>x. P(x)) \<Longrightarrow> Q)\<close>
  by rule iprover+

lemma atomize_conjL[atomize_elim]: \<open>(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (A \<and> B \<Longrightarrow> C)\<close>
  by rule iprover+

lemma atomize_disjL[atomize_elim]: \<open>((A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C) \<equiv> ((A \<or> B \<Longrightarrow> C) \<Longrightarrow> C)\<close>
  by rule iprover+

lemma atomize_elimL[atomize_elim]: \<open>(\<And>B. (A \<Longrightarrow> B) \<Longrightarrow> B) \<equiv> Trueprop(A)\<close> ..

subsection \<open>Calculational rules\<close>

lemma forw_subst: \<open>a = b \<Longrightarrow> P(b) \<Longrightarrow> P(a)\<close>
  by (rule ssubst)

lemma back_subst: \<open>P(a) \<Longrightarrow> a = b \<Longrightarrow> P(b)\<close>
  by (rule subst)

text \<open>
  Note that this list of rules is in reverse order of priorities.
\<close>

lemmas basic_trans_rules [trans] =
  forw_subst
  back_subst
  rev_mp
  mp
  trans

subsection \<open>``Let'' declarations\<close>

nonterminal letbinds and letbind

definition Let :: \<open>['a::{}, 'a => 'b] \<Rightarrow> ('b::{})\<close>
  where \<open>Let(s, f) \<equiv> f(s)\<close>

syntax
  "_bind"       :: \<open>[pttrn, 'a] => letbind\<close>           (\<open>(2_ =/ _)\<close> 10)
  ""            :: \<open>letbind => letbinds\<close>              (\<open>_\<close>)
  "_binds"      :: \<open>[letbind, letbinds] => letbinds\<close>  (\<open>_;/ _\<close>)
  "_Let"        :: \<open>[letbinds, 'a] => 'a\<close>             (\<open>(let (_)/ in (_))\<close> 10)

translations
  "_Let(_binds(b, bs), e)"  == "_Let(b, _Let(bs, e))"
  "let x = a in e"          == "CONST Let(a, \<lambda>x. e)"

lemma LetI:
  assumes \<open>\<And>x. x = t \<Longrightarrow> P(u(x))\<close>
  shows \<open>P(let x = t in u(x))\<close>
  apply (unfold Let_def)
  apply (rule refl [THEN assms])
  done

subsection \<open>Intuitionistic simplification rules\<close>

lemma conj_simps:
  \<open>P \<and> True \<longleftrightarrow> P\<close>
  \<open>True \<and> P \<longleftrightarrow> P\<close>
  \<open>P \<and> False \<longleftrightarrow> False\<close>
  \<open>False \<and> P \<longleftrightarrow> False\<close>
  \<open>P \<and> P \<longleftrightarrow> P\<close>
  \<open>P \<and> P \<and> Q \<longleftrightarrow> P \<and> Q\<close>
  \<open>P \<and> \<not> P \<longleftrightarrow> False\<close>
  \<open>\<not> P \<and> P \<longleftrightarrow> False\<close>
  \<open>(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)\<close>
  by iprover+

lemma disj_simps:
  \<open>P \<or> True \<longleftrightarrow> True\<close>
  \<open>True \<or> P \<longleftrightarrow> True\<close>
  \<open>P \<or> False \<longleftrightarrow> P\<close>
  \<open>False \<or> P \<longleftrightarrow> P\<close>
  \<open>P \<or> P \<longleftrightarrow> P\<close>
  \<open>P \<or> P \<or> Q \<longleftrightarrow> P \<or> Q\<close>
  \<open>(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)\<close>
  by iprover+

lemma not_simps:
  \<open>\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q\<close>
  \<open>\<not> False \<longleftrightarrow> True\<close>
  \<open>\<not> True \<longleftrightarrow> False\<close>
  by iprover+

lemma imp_simps:
  \<open>(P \<longrightarrow> False) \<longleftrightarrow> \<not> P\<close>
  \<open>(P \<longrightarrow> True) \<longleftrightarrow> True\<close>
  \<open>(False \<longrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(True \<longrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(P \<longrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(P \<longrightarrow> \<not> P) \<longleftrightarrow> \<not> P\<close>
  by iprover+

lemma iff_simps:
  \<open>(True \<longleftrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(P \<longleftrightarrow> True) \<longleftrightarrow> P\<close>
  \<open>(P \<longleftrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(False \<longleftrightarrow> P) \<longleftrightarrow> \<not> P\<close>
  \<open>(P \<longleftrightarrow> False) \<longleftrightarrow> \<not> P\<close>
  by iprover+

text \<open>The \<open>x = t\<close> versions are needed for the simplification
  procedures.\<close>
lemma quant_simps:
  \<open>\<And>P. (\<forall>x. P) \<longleftrightarrow> P\<close>
  \<open>(\<forall>x. x = t \<longrightarrow> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>(\<forall>x. t = x \<longrightarrow> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>\<And>P. (\<exists>x. P) \<longleftrightarrow> P\<close>
  \<open>\<exists>x. x = t\<close>
  \<open>\<exists>x. t = x\<close>
  \<open>(\<exists>x. x = t \<and> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>(\<exists>x. t = x \<and> P(x)) \<longleftrightarrow> P(t)\<close>
  by iprover+

text \<open>These are NOT supplied by default!\<close>
lemma distrib_simps:
  \<open>P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R\<close>
  \<open>(Q \<or> R) \<and> P \<longleftrightarrow> Q \<and> P \<or> R \<and> P\<close>
  \<open>(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)\<close>
  by iprover+

subsubsection \<open>Conversion into rewrite rules\<close>

lemma P_iff_F: \<open>\<not> P \<Longrightarrow> (P \<longleftrightarrow> False)\<close>
  by iprover
lemma iff_reflection_F: \<open>\<not> P \<Longrightarrow> (P \<equiv> False)\<close>
  by (rule P_iff_F [THEN iff_reflection])

lemma P_iff_T: \<open>P \<Longrightarrow> (P \<longleftrightarrow> True)\<close>
  by iprover
lemma iff_reflection_T: \<open>P \<Longrightarrow> (P \<equiv> True)\<close>
  by (rule P_iff_T [THEN iff_reflection])

subsubsection \<open>More rewrite rules\<close>

lemma conj_commute: \<open>P \<and> Q \<longleftrightarrow> Q \<and> P\<close> by iprover
lemma conj_left_commute: \<open>P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)\<close> by iprover
lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: \<open>P \<or> Q \<longleftrightarrow> Q \<or> P\<close> by iprover
lemma disj_left_commute: \<open>P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)\<close> by iprover
lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: \<open>P \<and> (Q \<or> R) \<longleftrightarrow> (P \<and> Q \<or> P \<and> R)\<close> by iprover
lemma conj_disj_distribR: \<open>(P \<or> Q) \<and> R \<longleftrightarrow> (P \<and> R \<or> Q \<and> R)\<close> by iprover

lemma disj_conj_distribL: \<open>P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)\<close> by iprover
lemma disj_conj_distribR: \<open>(P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)\<close> by iprover

lemma imp_conj_distrib: \<open>(P \<longrightarrow> (Q \<and> R)) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)\<close> by iprover
lemma imp_conj: \<open>((P \<and> Q) \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))\<close> by iprover
lemma imp_disj: \<open>(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)\<close> by iprover

lemma de_Morgan_disj: \<open>(\<not> (P \<or> Q)) \<longleftrightarrow> (\<not> P \<and> \<not> Q)\<close> by iprover

lemma not_ex: \<open>(\<not> (\<exists>x. P(x))) \<longleftrightarrow> (\<forall>x. \<not> P(x))\<close> by iprover
lemma imp_ex: \<open>((\<exists>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> Q)\<close> by iprover

lemma ex_disj_distrib: \<open>(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> ((\<exists>x. P(x)) \<or> (\<exists>x. Q(x)))\<close>
  by iprover

lemma all_conj_distrib: \<open>(\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> ((\<forall>x. P(x)) \<and> (\<forall>x. Q(x)))\<close>
  by iprover

end


theory Fold_Spmf
  imports
    More_CC
begin

primrec (transfer)
  foldl_spmf :: "('b \<Rightarrow> 'a \<Rightarrow> 'b spmf) \<Rightarrow> 'b spmf \<Rightarrow> 'a list \<Rightarrow> 'b spmf"
  where
    foldl_spmf_Nil: "foldl_spmf f p [] = p"
  | foldl_spmf_Cons: "foldl_spmf f p (x # xs) = foldl_spmf f (bind_spmf p (\<lambda>a. f a x)) xs"

lemma foldl_spmf_return_pmf_None [simp]:
  "foldl_spmf f (return_pmf None) xs = return_pmf None"
  by(induction xs) simp_all

lemma foldl_spmf_bind_spmf: "foldl_spmf f (bind_spmf p g) xs = bind_spmf p (\<lambda>a. foldl_spmf f (g a) xs)"
  by(induction xs arbitrary: g) simp_all

lemma bind_foldl_spmf_return:
  "bind_spmf p (\<lambda>x. foldl_spmf f (return_spmf x) xs) = foldl_spmf f p xs"
  by(simp add: foldl_spmf_bind_spmf[symmetric])

lemma foldl_spmf_map [simp]: "foldl_spmf f p (map g xs) = foldl_spmf (map_fun id (map_fun g id) f) p xs"
  by(induction xs arbitrary: p) simp_all

lemma foldl_spmf_identity [simp]: "foldl_spmf (\<lambda>s x. return_spmf s) p xs = p"
  by(induction xs arbitrary: p) simp_all

lemma foldl_spmf_conv_foldl:
  "foldl_spmf (\<lambda>s x. return_spmf (f s x)) p xs = map_spmf (\<lambda>s. foldl f s xs) p"
  by(induction xs arbitrary: p)(simp_all add: map_spmf_conv_bind_spmf[symmetric] spmf.map_comp o_def)

lemma foldl_spmf_Cons':
  "foldl_spmf f (return_spmf a) (x # xs) = bind_spmf (f a x) (\<lambda>a'. foldl_spmf f (return_spmf a') xs)"
  by(simp add: bind_foldl_spmf_return)

lemma foldl_spmf_append: "foldl_spmf f p (xs @ ys) = foldl_spmf f (foldl_spmf f p xs) ys"
  by(induction xs arbitrary: p) simp_all

lemma
  foldl_spmf_helper:
  assumes "\<And>x. h (f x) = x"
  assumes "\<And>x. f (h x) = x"
  shows "foldl_spmf (\<lambda>a e. map_spmf h (g (f a) e)) acc es =
    map_spmf h (foldl_spmf g (map_spmf f acc) es)"
  using assms proof (induction es arbitrary: acc)
  case (Cons a es)
  then show ?case
    by (simp add: spmf.map_comp map_bind_spmf bind_map_spmf o_def)
qed (simp add: map_spmf_conv_bind_spmf)

lemma
  foldl_spmf_helper2:
  assumes "\<And>x y. p (f x y) = x"
  assumes "\<And>x y. q (f x y) = y"
  assumes "\<And>x. f (p x) (q x) = x"
  shows "foldl_spmf (\<lambda>a e. map_spmf (f (p a)) (g (q a) e)) acc es =
    bind_spmf acc (\<lambda>acc'. map_spmf (f (p acc')) (foldl_spmf g (return_spmf (q acc')) es))"
  proof (induction es arbitrary: acc)
    note [simp] = spmf.map_comp map_bind_spmf bind_map_spmf o_def
  case (Cons e es)
  then show ?case
    apply (simp add: map_spmf_conv_bind_spmf assms)
    apply (subst bind_spmf_assoc[symmetric])
    by (simp add: bind_foldl_spmf_return)
qed (simp add: assms(3))

lemma foldl_pair_constl: "foldl (\<lambda>s e. map_prod (\<lambda>_. c) (\<lambda>r. f r e) s) (c, sr) l =
    Pair c (foldl (\<lambda>s e. f s e) sr l)"
  by (induction l arbitrary: sr) (auto simp add: map_prod_def split_def)

lemma foldl_spmf_pair_left:
  "foldl_spmf (\<lambda>(l, r) e. map_spmf (\<lambda>l'. (l', r)) (f l e)) (return_spmf (l, r)) es =
    map_spmf (\<lambda>l'. (l', r)) (foldl_spmf f (return_spmf l) es)"
  apply (induction es arbitrary: l)
   apply simp_all
  apply (subst (2) map_spmf_conv_bind_spmf)
  apply (subst foldl_spmf_bind_spmf)
  apply (subst (2) bind_foldl_spmf_return[symmetric])
  by (simp add: map_spmf_conv_bind_spmf)

lemma foldl_spmf_pair_left2:
  "foldl_spmf (\<lambda>(l, _) e. map_spmf (\<lambda>l'. (l', c')) (f l e)) (return_spmf (l, c)) es =
    map_spmf (\<lambda>l'. (l', if es = [] then c else c')) (foldl_spmf f (return_spmf l) es)"
  apply (induction es arbitrary: l c c')
   apply simp_all
  apply (subst (2) map_spmf_conv_bind_spmf)
  apply (subst foldl_spmf_bind_spmf)
  apply (subst (2) bind_foldl_spmf_return[symmetric])
  by (simp add: map_spmf_conv_bind_spmf)

lemma foldl_pair_constr: "foldl (\<lambda>s e. map_prod (\<lambda>l. f l e) (\<lambda>_. c) s) (sl, c) l =
   Pair (foldl (\<lambda>s e. f s e) sl l) c"
  by (induction l arbitrary: sl) (auto simp add: map_prod_def split_def)

lemma foldl_spmf_pair_right:
  "foldl_spmf (\<lambda>(l, r) e. map_spmf (\<lambda>r'. (l, r')) (f r e)) (return_spmf (l, r)) es =
    map_spmf (\<lambda>r'. (l, r')) (foldl_spmf f (return_spmf r) es)"
  apply (induction es arbitrary: r)
   apply simp_all
  apply (subst (2) map_spmf_conv_bind_spmf)
  apply (subst foldl_spmf_bind_spmf)
  apply (subst (2) bind_foldl_spmf_return[symmetric])
  by (simp add: map_spmf_conv_bind_spmf)

lemma foldl_spmf_pair_right2:
  "foldl_spmf (\<lambda>(_, r) e. map_spmf (\<lambda>r'. (c', r')) (f r e)) (return_spmf (c, r)) es =
    map_spmf (\<lambda>r'. (if es = [] then c else c', r')) (foldl_spmf f (return_spmf r) es)"
  apply (induction es arbitrary: r c c')
   apply simp_all
  apply (subst (2) map_spmf_conv_bind_spmf)
  apply (subst foldl_spmf_bind_spmf)
  apply (subst (2) bind_foldl_spmf_return[symmetric])
  by (auto simp add: map_spmf_conv_bind_spmf split_def)

lemma foldl_spmf_pair_right3:
  "foldl_spmf (\<lambda>(l, r) e. map_spmf (Pair (g e)) (f r e)) (return_spmf (l, r)) es =
    map_spmf (Pair (if es = [] then l else g (last es))) (foldl_spmf f (return_spmf r) es)"
  apply (induction es arbitrary: r l)
   apply simp_all
  apply (subst (2) map_spmf_conv_bind_spmf)
  apply (subst foldl_spmf_bind_spmf)
  apply (subst (2) bind_foldl_spmf_return[symmetric])
  by (clarsimp simp add: split_def map_bind_spmf o_def)

lemma foldl_pullout: "bind_spmf f (\<lambda>x. bind_spmf (foldl_spmf g init (events x)) (\<lambda>y. h x y)) =
    bind_spmf (bind_spmf f (\<lambda>x. foldl_spmf (\<lambda>(l, r) e. map_spmf (Pair l) (g r e)) (map_spmf (Pair x) init) (events x)))
     (\<lambda>(x, y). h x y)" for f g h init events
    apply (simp add: foldl_spmf_helper2[where f=Pair and p=fst and q=snd, simplified] split_def)
    apply (clarsimp simp add: map_spmf_conv_bind_spmf)
  by (subst bind_spmf_assoc[symmetric]) (auto simp add: bind_foldl_spmf_return)

lemma bind_foldl_spmf_pair_append: "
  bind_spmf
    (foldl_spmf (\<lambda>(x, y) e. map_spmf (apfst ((@) x)) (f y e)) (return_spmf (a @ c, b)) es)
    (\<lambda>(x, y). g x y) =
  bind_spmf
    (foldl_spmf (\<lambda>(x, y) e. map_spmf (apfst ((@) x)) (f y e)) (return_spmf (c, b)) es)
    (\<lambda>(x, y). g (a @ x) y)"
  apply (induction es arbitrary: c b)
   apply (simp_all add: split_def map_spmf_conv_bind_spmf apfst_def map_prod_def)
  apply (subst (1 2) foldl_spmf_bind_spmf)
  by simp

lemma foldl_spmf_chain: "
(foldl_spmf (\<lambda>(oevents, s_event) event. map_spmf (map_prod ((@) oevents) id) (fff s_event event)) (return_spmf ([], s_event)) ievents)
  \<bind> (\<lambda>(oevents, s_event'). foldl_spmf ggg (return_spmf s_core) oevents
        \<bind> (\<lambda>s_core'. return_spmf (f s_core' s_event'))) =
foldl_spmf (\<lambda>(s_event, s_core) event. fff s_event event \<bind>  (\<lambda>(oevents, s_event').
      map_spmf (Pair s_event') (foldl_spmf ggg (return_spmf s_core) oevents))) (return_spmf (s_event, s_core)) ievents
  \<bind> (\<lambda>(s_event', s_core'). return_spmf (f s_core' s_event'))"
proof (induction ievents arbitrary: s_event s_core)
  case Nil
  show ?case by simp
next
  case (Cons e es)

  show ?case
    apply (subst (1 2) foldl_spmf_Cons')
    apply (simp add: split_def)
    apply (subst map_spmf_conv_bind_spmf)
    apply simp
    apply (rule bind_spmf_cong[OF refl])
    apply (subst (2) map_spmf_conv_bind_spmf)
    apply simp
    apply (subst Cons.IH[symmetric, simplified split_def])
    apply (subst bind_commute_spmf)
    apply (subst (2) map_spmf_conv_bind_spmf[symmetric])
    apply (subst map_bind_spmf[symmetric, simplified o_def])
    apply (subst (1) foldl_spmf_bind_spmf[symmetric])
    apply (subst (3) map_spmf_conv_bind_spmf)
    apply (simp add: foldl_spmf_append[symmetric] map_prod_def split_def)
    subgoal for x
      apply (cases x)
      subgoal for a b
        apply (simp add: split_def)
        apply (subst bind_foldl_spmf_pair_append[where c="[]" and a=a and b=b and es=es, simplified apfst_def map_prod_def append_Nil2 split_def id_def])
        by simp
      done
    done
qed

\<comment> \<open>pauses\<close>
primrec pauses :: "'a list \<Rightarrow> (unit, 'a, 'b) gpv" where
  "pauses [] = Done ()"
| "pauses (x # xs) = Pause x (\<lambda>_. pauses xs)"

lemma WT_gpv_pauses [WT_intro]:
  "\<I> \<turnstile>g pauses xs \<surd>" if "set xs \<subseteq> outs_\<I> \<I>"
  using that by(induction xs) auto

lemma exec_gpv_pauses:
  "exec_gpv callee (pauses xs) s =
   map_spmf (Pair ()) (foldl_spmf (map_fun id (map_fun id (map_spmf snd)) callee) (return_spmf s) xs)"
  by(induction xs arbitrary: s)(simp_all add: split_def foldl_spmf_Cons' map_bind_spmf bind_map_spmf o_def del: foldl_spmf_Cons)

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Hash maps implementation}\<close>
theory HashMap_Impl
imports
  RBTMapImpl
  ListMapImpl
  "../../Lib/HashCode"
  "../../Lib/Code_Target_ICF"
begin

text \<open>
  We use a red-black tree instead of an indexed array. This
  has the disadvantage of being more complex, however we need not bother
  about a fixed-size array and rehashing if the array becomes too full.

  The entries of the red-black tree are lists of (key,value) pairs.
\<close>

subsection \<open>Abstract Hashmap\<close>
text \<open>
  We first specify the behavior of our hashmap on the level of maps.
  We will then show that our implementation based on hashcode-map and bucket-map
  is a correct implementation of this specification.
\<close>
type_synonym
  ('k,'v) abs_hashmap = "hashcode \<rightharpoonup> ('k \<rightharpoonup> 'v)"

  \<comment> \<open>Map entry of map by function\<close>
abbreviation map_entry where "map_entry k f m == m(k := f (m k))"

  \<comment> \<open>Invariant: Buckets only contain entries with the right hashcode and there are no empty buckets\<close>
definition ahm_invar:: "('k::hashable,'v) abs_hashmap \<Rightarrow> bool"
  where "ahm_invar m ==
    (\<forall>hc cm k. m hc = Some cm \<and> k\<in>dom cm \<longrightarrow> hashcode k = hc) \<and>
    (\<forall>hc cm. m hc = Some cm \<longrightarrow> cm \<noteq> Map.empty)"

  \<comment> \<open>Abstract a hashmap to the corresponding map\<close>
definition ahm_\<alpha> where
  "ahm_\<alpha> m k == case m (hashcode k) of
    None \<Rightarrow> None |
    Some cm \<Rightarrow> cm k"

  \<comment> \<open>Lookup an entry\<close>
definition ahm_lookup :: "'k::hashable \<Rightarrow> ('k,'v) abs_hashmap \<Rightarrow> 'v option"
  where "ahm_lookup k m == (ahm_\<alpha> m) k"

  \<comment> \<open>The empty hashmap\<close>
definition ahm_empty :: "('k::hashable,'v) abs_hashmap"
  where "ahm_empty = Map.empty"

  \<comment> \<open>Update/insert an entry\<close>
definition ahm_update where
  "ahm_update k v m ==
    case m (hashcode k) of
      None \<Rightarrow> m (hashcode k \<mapsto> [k \<mapsto> v]) |
      Some cm \<Rightarrow> m (hashcode k \<mapsto> cm (k \<mapsto> v))
  "

  \<comment> \<open>Delete an entry\<close>
definition ahm_delete where
  "ahm_delete k m == map_entry (hashcode k)
    (\<lambda>v. case v of
      None \<Rightarrow> None |
      Some bm \<Rightarrow> (
        if bm |` (- {k}) = Map.empty then
          None
        else
          Some ( bm |` (- {k}))
      )
    ) m
  "

definition ahm_isEmpty where
  "ahm_isEmpty m == m=Map.empty"

text \<open>
  Now follow correctness lemmas, that relate the hashmap operations to
  operations on the corresponding map. Those lemmas are named op\_correct, where
  (is) the operation.
\<close>

lemma ahm_invarI: "\<lbrakk>
  !!hc cm k. \<lbrakk>m hc = Some cm; k\<in>dom cm\<rbrakk> \<Longrightarrow> hashcode k = hc;
  !!hc cm. \<lbrakk> m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty
  \<rbrakk> \<Longrightarrow> ahm_invar m"
  by (unfold ahm_invar_def) blast

lemma ahm_invarD: "\<lbrakk> ahm_invar m; m hc = Some cm; k\<in>dom cm \<rbrakk> \<Longrightarrow> hashcode k = hc"
  by (unfold ahm_invar_def) blast

lemma ahm_invarDne: "\<lbrakk> ahm_invar m; m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty"
  by (unfold ahm_invar_def) blast

lemma ahm_invar_bucket_not_empty[simp]:
  "ahm_invar m \<Longrightarrow> m hc \<noteq> Some Map.empty"
  by (auto dest: ahm_invarDne)

lemmas ahm_lookup_correct = ahm_lookup_def

lemma ahm_empty_correct:
  "ahm_\<alpha> ahm_empty = Map.empty"
  "ahm_invar ahm_empty"
  apply (rule ext)
  apply (unfold ahm_empty_def)
  apply (auto simp add: ahm_\<alpha>_def intro: ahm_invarI split: option.split)
  done

lemma ahm_update_correct:
  "ahm_\<alpha> (ahm_update k v m) = ahm_\<alpha> m (k \<mapsto> v)"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_update k v m)"
  apply (rule ext)
  apply (unfold ahm_update_def)
  apply (auto simp add: ahm_\<alpha>_def split: option.split)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD ahm_invarDne split: if_split_asm)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD split: if_split_asm)
  apply (drule (1) ahm_invarD)
  apply auto
  done

lemma fun_upd_apply_ne: "x\<noteq>y \<Longrightarrow> (f(x:=v)) y = f y"
  by simp

lemma cancel_one_empty_simp: "m |` (-{k}) = Map.empty \<longleftrightarrow> dom m \<subseteq> {k}"
proof
  assume "m |` (- {k}) = Map.empty"
  hence "{} = dom (m |` (-{k}))" by auto
  also have "\<dots> = dom m - {k}" by auto
  finally show "dom m \<subseteq> {k}" by blast
next
  assume "dom m \<subseteq> {k}"
  hence "dom m - {k} = {}" by auto
  hence "dom (m |` (-{k})) = {}" by auto
  thus "m |` (-{k}) = Map.empty" by blast
qed

lemma ahm_delete_correct:
  "ahm_\<alpha> (ahm_delete k m) = (ahm_\<alpha> m) |` (-{k})"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_delete k m)"
  apply (rule ext)
  apply (unfold ahm_delete_def)
  apply (auto simp add: ahm_\<alpha>_def Let_def Map.restrict_map_def
              split: option.split)[1]
  apply (drule_tac x=x in fun_cong)
  apply (auto)[1]
  apply (rule ahm_invarI)
  apply (auto split: if_split_asm option.split_asm dest: ahm_invarD)
  apply (drule (1) ahm_invarD)
  apply (auto simp add: restrict_map_def split: if_split_asm option.split_asm)
  done

lemma ahm_isEmpty_correct: "ahm_invar m \<Longrightarrow> ahm_isEmpty m \<longleftrightarrow> ahm_\<alpha> m = Map.empty"
proof
  assume "ahm_invar m" "ahm_isEmpty m"
  thus "ahm_\<alpha> m = Map.empty"
    by (auto simp add: ahm_isEmpty_def ahm_\<alpha>_def intro: ext)
next
  assume I: "ahm_invar m"
    and E: "ahm_\<alpha> m = Map.empty"

  show "ahm_isEmpty m"
  proof (rule ccontr)
    assume "\<not>ahm_isEmpty m"
    then obtain hc bm where MHC: "m hc = Some bm"
      by (unfold ahm_isEmpty_def)
         (blast elim: nempty_dom dest: domD)
    from ahm_invarDne[OF I, OF MHC] obtain k v where
      BMK: "bm k = Some v"
      by (blast elim: nempty_dom dest: domD)
    from ahm_invarD[OF I, OF MHC] BMK have [simp]: "hashcode k = hc"
      by auto
    hence "ahm_\<alpha> m k = Some v"
      by (simp add: ahm_\<alpha>_def MHC BMK)
    with E show False by simp
  qed
qed

lemmas ahm_correct = ahm_empty_correct ahm_lookup_correct ahm_update_correct
                     ahm_delete_correct ahm_isEmpty_correct

  \<comment> \<open>Bucket entries correspond to map entries\<close>

  \<comment> \<open>Map entries correspond to bucket entries\<close>
lemma ahm_e_is_be: "\<lbrakk>
  ahm_\<alpha> m k = Some v;
  !!bm. \<lbrakk>m (hashcode k) = Some bm; bm k = Some v \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (unfold ahm_\<alpha>_def)
     (auto split: option.split_asm)

subsection \<open>Concrete Hashmap\<close>
text \<open>
  In this section, we define the concrete hashmap that is made from the
  hashcode map and the bucket map.

  We then show the correctness of the operations w.r.t. the abstract hashmap, and
  thus, indirectly, w.r.t. the corresponding map.
\<close>

type_synonym
  ('k,'v) hm_impl = "(hashcode, ('k,'v) lm) rm"

subsubsection "Operations"

  \<comment> \<open>Auxiliary function: Apply function to value of an entry\<close>
definition rm_map_entry
  :: "hashcode \<Rightarrow> ('v option \<Rightarrow> 'v option) \<Rightarrow> (hashcode, 'v) rm \<Rightarrow> (hashcode,'v) rm"
  where
  "rm_map_entry k f m ==
      case rm.lookup k m of
        None \<Rightarrow> (
          case f None of
            None \<Rightarrow> m |
            Some v \<Rightarrow> rm.update k v m
        ) |
        Some v \<Rightarrow> (
          case f (Some v) of
            None \<Rightarrow> rm.delete k m |
            Some v' \<Rightarrow> rm.update k v' m
        )
    "

  \<comment> \<open>Empty hashmap\<close>
definition empty :: "unit \<Rightarrow> ('k :: hashable, 'v) hm_impl" where "empty == rm.empty"

  \<comment> \<open>Update/insert entry\<close>
definition update :: "'k::hashable \<Rightarrow> 'v \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl"
  where
  "update k v m ==
   let hc = hashcode k in
     case rm.lookup hc m of
       None \<Rightarrow> rm.update hc (lm.update k v (lm.empty ())) m |
       Some bm \<Rightarrow> rm.update hc (lm.update k v bm) m"

  \<comment> \<open>Lookup value by key\<close>
definition lookup :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> 'v option" where
  "lookup k m ==
   case rm.lookup (hashcode k) m of
     None \<Rightarrow> None |
     Some lm \<Rightarrow> lm.lookup k lm"

  \<comment> \<open>Delete entry by key\<close>
definition delete :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl" where
  "delete k m ==
   rm_map_entry (hashcode k)
     (\<lambda>v. case v of
       None \<Rightarrow> None |
       Some lm \<Rightarrow> (
         let lm' = lm.delete k lm
         in  if lm.isEmpty lm' then None else Some lm'
       )
     ) m"

  \<comment> \<open>Emptiness check\<close>
definition "isEmpty == rm.isEmpty"

  \<comment> \<open>Interruptible iterator\<close>
definition "iteratei m c f \<sigma>0 ==
  rm.iteratei m c (\<lambda>(hc, lm) \<sigma>.
    lm.iteratei lm c f \<sigma>
  ) \<sigma>0"

lemma iteratei_alt_def :
  "iteratei m = set_iterator_image snd (
     set_iterator_product (rm.iteratei m) (\<lambda>hclm. lm.iteratei (snd hclm)))"
proof -
  have aux: "\<And>c f. (\<lambda>(hc, lm). lm.iteratei lm c f) = (\<lambda>m. lm.iteratei (snd m) c f)"
    by auto
  show ?thesis
    unfolding set_iterator_product_def set_iterator_image_alt_def
      iteratei_def[abs_def] aux
    by (simp add: split_beta)
qed

subsubsection "Correctness w.r.t. Abstract HashMap"
text \<open>
  The following lemmas establish the correctness of the operations w.r.t. the
  abstract hashmap.

  They have the naming scheme op\_correct', where (is) the name of the
  operation.
\<close>

  \<comment> \<open>Abstract concrete hashmap to abstract hashmap\<close>
definition hm_\<alpha>' where "hm_\<alpha>' m == \<lambda>hc. case rm.\<alpha> m hc of
  None \<Rightarrow> None |
  Some lm \<Rightarrow> Some (lm.\<alpha> lm)"

  \<comment> \<open>Invariant for concrete hashmap:
    The hashcode-map and bucket-maps satisfy their invariants and
    the invariant of the corresponding abstract hashmap is satisfied.\<close>

definition "invar m == ahm_invar (hm_\<alpha>' m)"

lemma rm_map_entry_correct:
  "rm.\<alpha> (rm_map_entry k f m) = (rm.\<alpha> m)(k := f (rm.\<alpha> m k))"
  apply (auto
    simp add: rm_map_entry_def rm.delete_correct rm.lookup_correct rm.update_correct
    split: option.split)
  done

lemma empty_correct':
  "hm_\<alpha>' (empty ()) = ahm_empty"
  "invar (empty ())"
  by (simp_all add: hm_\<alpha>'_def empty_def ahm_empty_def rm.correct invar_def ahm_invar_def)

lemma lookup_correct':
  "invar m \<Longrightarrow> lookup k m = ahm_lookup k (hm_\<alpha>' m)"
  apply (unfold lookup_def invar_def)
  apply (auto split: option.split
              simp add: ahm_lookup_def ahm_\<alpha>_def hm_\<alpha>'_def
                        rm.correct lm.correct)
  done

lemma update_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (update k v m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: update_def ahm_update_def hm_\<alpha>'_def Let_def
                          rm.correct lm.correct
                split: option.split)
    done
  thus "invar m \<Longrightarrow> invar (update k v m)"
    by (simp add: invar_def ahm_update_correct)
qed

lemma delete_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (delete k m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: delete_def ahm_delete_def hm_\<alpha>'_def
                          rm_map_entry_correct
                          rm.correct lm.correct Let_def
                split: option.split option.split_asm)
    done
  thus "invar (delete k m)" using \<open>invar m\<close>
    by (simp add: ahm_delete_correct invar_def)
qed

lemma isEmpty_correct':
  "invar hm \<Longrightarrow> isEmpty hm \<longleftrightarrow> ahm_\<alpha> (hm_\<alpha>' hm) = Map.empty"
apply (simp add: isEmpty_def rm.isEmpty_correct invar_def
                 ahm_isEmpty_correct[unfolded ahm_isEmpty_def, symmetric])
by (auto simp add: hm_\<alpha>'_def ahm_\<alpha>_def fun_eq_iff split: option.split_asm)

(*
lemma sel_correct':
  assumes "invar hm"
  shows "\<lbrakk> sel hm f = Some r; \<And>u v. \<lbrakk> ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  and "\<lbrakk> sel hm f = None; ahm_\<alpha> (hm_\<alpha>' hm) u = Some v \<rbrakk> \<Longrightarrow> f (u, v) = None"
proof -
  assume sel: "sel hm f = Some r"
    and P: "\<And>u v. \<lbrakk>ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r\<rbrakk> \<Longrightarrow> P"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from TrueI sel obtain hc lm where "rm_\<alpha> hm hc = Some lm"
    and "lm_sel lm f = Some r"
    unfolding sel_def by (rule rm.sel_someE) simp
  from TrueI `lm_sel lm f = Some r`
  obtain k v where "lm_\<alpha> lm k = Some v" "f (k, v) = Some r"
    by(rule lm.sel_someE)
  from `rm_\<alpha> hm hc = Some lm` have "hm_\<alpha>' hm hc = Some (lm_\<alpha> lm)"
    by(simp add: hm_\<alpha>'_def)
  with IA have "ahm_\<alpha> (hm_\<alpha>' hm) k = Some v" using `lm_\<alpha> lm k = Some v`
    by(rule ahm_be_is_e)
  thus P using `f (k, v) = Some r` by(rule P)
next
  assume sel: "sel hm f = None"
    and \<alpha>: "ahm_\<alpha> (hm_\<alpha>' hm) u = Some v"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from \<alpha> obtain lm where \<alpha>_u: "hm_\<alpha>' hm (hashcode u) = Some lm"
    and "lm u = Some v" by (rule ahm_e_is_be)
  from \<alpha>_u obtain lmc where "rm_\<alpha> hm (hashcode u) = Some lmc" "lm = lm_\<alpha> lmc"
    by(auto simp add: hm_\<alpha>'_def split: option.split_asm)
  with `lm u = Some v` have "lm_\<alpha> lmc u = Some v" by simp
  from sel rm.sel_noneD [OF TrueI _ `rm_\<alpha> hm (hashcode u) = Some lmc`,
         of "(\<lambda>(hc, lm). lm_sel lm f)"]
  have "lm_sel lmc f = None" unfolding sel_def by simp
  with TrueI show "f (u, v) = None" using `lm_\<alpha> lmc u = Some v` by(rule lm.sel_noneD)
qed
*)

lemma iteratei_correct':
  assumes invar: "invar hm"
  shows "map_iterator (iteratei hm) (ahm_\<alpha> (hm_\<alpha>' hm))"
proof -
  from rm.iteratei_correct
  have it_rm: "map_iterator (rm.iteratei hm) (rm.\<alpha> hm)" by simp

  from lm.iteratei_correct
  have it_lm: "\<And>lm. map_iterator (lm.iteratei lm) (lm.\<alpha> lm)" by simp

  from set_iterator_product_correct
    [OF it_rm, of "\<lambda>hclm. lm.iteratei (snd hclm)"
     "\<lambda>hclm. map_to_set (lm.\<alpha> (snd hclm))", OF it_lm]
  have it_prod: "set_iterator
         (set_iterator_product (rm.iteratei hm) (\<lambda>hclm. lm.iteratei (snd hclm)))
         (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
    by simp

  show ?thesis unfolding iteratei_alt_def
  proof (rule set_iterator_image_correct[OF it_prod])
    from invar
    show "inj_on snd
       (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def split: option.splits)
      apply (metis domI option.inject)
    done
  next
    from invar
    show "map_to_set (ahm_\<alpha> (hm_\<alpha>' hm)) =
          snd ` (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def set_eq_iff image_iff split: option.splits)
      apply (auto simp add: dom_def ahm_\<alpha>_def split: option.splits)
    done
  qed
qed

lemmas hm_correct' = empty_correct' lookup_correct' update_correct'
                     delete_correct' isEmpty_correct'
                     iteratei_correct'
lemmas hm_invars = empty_correct'(2) update_correct'(2)
                   delete_correct'(2)

hide_const (open) empty invar lookup update delete isEmpty iteratei

end


(*
   Copyright 2016 Yoichi Hirai

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
*)

theory RLP

imports Main "~~/src/HOL/Word/Word"

begin

type_synonym "byte" = "8 word"

datatype "tree" =
  Leaf "byte list" |
  Node "tree list"

fun BE_rev :: "nat \<Rightarrow> byte list"
where
"BE_rev 0 = []" |
"BE_rev n = (if n < 256 then [of_nat n] else
         (of_nat (n mod 256)) # BE_rev (n div 256))"

value "BE_rev 256"

definition BE :: "nat \<Rightarrow> byte list"
where
"BE n = rev (BE_rev n)"

value "BE 300"

fun BD_rev :: "byte list \<Rightarrow> nat"
where
"BD_rev [] = 0" |
"BD_rev (h # t) = 256 * (BD_rev t) + (unat h)"

lemma BD_rev_BE_rev [simp]: "BD_rev (BE_rev n) = n"
apply(induct n rule: BE_rev.induct)
apply(simp)
apply(auto)
  apply(simp add: Word.unat_word_ariths(1) Word.unat_of_nat)
apply(simp add: Word.unat_of_nat)
done

definition BD :: "byte list \<Rightarrow> nat"
where
"BD lst = BD_rev (rev lst)"

lemma BD_BE [simp]: "BD (BE n) = n"
by (simp add: BD_def BE_def)

fun "r_b" :: "byte list \<Rightarrow> byte list"
where
"r_b [] = [128]" |
"r_b [k] = (if k < 128 then [k] else [129, k])" | (* there was a mistake, putting 128 twice *)
"r_b lst =
   (if length lst < 56 then
      of_nat (128 + length lst) # lst
    else
      of_nat (183 + length(BE(length lst))) # (BE(length lst) @ lst))
"

value "r_b (map of_nat (upt 0 100))"

definition "read_n_bytes" :: "nat \<Rightarrow> byte list \<Rightarrow> (byte list  * (* rest *) byte list) option"
where
"read_n_bytes n lst =
  (if length lst \<ge> n then
     Some (take n lst, drop n lst)
   else None)
"

definition "de_r_b" :: "byte list \<Rightarrow> (byte list * (*rest*) byte list) option"
where
  "de_r_b ll =
  (case ll of
    [] \<Rightarrow> None
  | k # lst \<Rightarrow>
    (if k = 128 then
       Some ([], lst)
     else if k < 128 then
       Some ([k], lst)
     else if k < 184 then
       (let len = unat k - 128 in
       (if length lst \<ge> len then Some (take len lst, drop len lst)
                                         else None))
     else if k \<le> 192 then
      (case read_n_bytes (unat k - 183) lst of
         None \<Rightarrow> None
       | Some(be_bytes, x_and_rest) \<Rightarrow>
         read_n_bytes (BD be_bytes) x_and_rest
      )
     else
       None
    )
  )"

  value "r_b (map of_nat (upt 0 10))"
  value "de_r_b (r_b (map of_nat (upt 0 10)))"

lemma encode_r_b_middle[simp] :
    "length vc < 54 \<Longrightarrow>
       de_r_b ((130 + of_nat (length vc)) # v # vb # vc @ tail) = Some (v # vb # vc, tail)"
apply(simp add: de_r_b_def word_less_nat_alt unat_word_ariths unat_of_nat)
apply(unat_arith)
apply(simp add: unat_of_nat)
done

lemma BE0[simp] : "(BE (n) = []) = (n = 0)"
apply(simp only: BE_def)
by(induct n rule: BE_rev.induct; simp)

lemma read_n_n[simp] : "read_n_bytes (length lst) (lst @ rest) = Some (lst, rest)"
apply(induction lst)
apply(simp add: read_n_bytes_def)+
done

lemma encode_r_b_last[simp] :
"length (BE (length (v # vb # vc))) \<le> 9 \<Longrightarrow>
       \<not> length vc < 54 \<Longrightarrow>
       de_r_b
        ((183 + of_nat (length (BE (Suc (Suc (length vc)))))) #
         BE (Suc (Suc (length vc))) @ v # vb # vc @ tail) =
       Some (v # vb # vc, tail)"
apply(simp add: de_r_b_def word_less_nat_alt unat_word_ariths unat_of_nat)
apply(auto)

apply(unat_arith)
apply(simp add: unat_of_nat)

apply(simp add: read_n_bytes_def)

apply(unat_arith)
apply(simp add: unat_of_nat)
done

lemma inv_r_b[simp] : "length(BE(length lst)) \<le> 9 \<Longrightarrow> de_r_b (r_b lst @ tail) = Some (lst, tail)"
apply(induction lst rule: r_b.induct)
apply(simp add: de_r_b_def)
apply(simp add: "r_b.simps")
apply(auto)
apply(simp add: de_r_b_def)
apply(simp add: de_r_b_def)
done

fun "RLP" :: "tree \<Rightarrow> byte list"
where
"RLP(Leaf l) = r_b l" |
"RLP(Node lst) =
  (let s = concat (map RLP lst) in
   let len_s = length s in
   (if len_s < 56 then
      of_nat (192 + len_s) # s
    else
      of_nat (247 + length (BE len_s)) # (BE len_s @ s) ))"

definition "RLP_nat" :: "nat \<Rightarrow> byte list"
where
"RLP_nat i = RLP (Leaf (BE i))"

text "TODO :: also define a decoder and say something"

end