section\<open>The binder \<^term>\<open>Least\<close>\<close>
theory Least
  imports
    Names

begin

text\<open>We have some basic results on the least ordinal satisfying
a predicate.\<close>

lemma Least_Ord: "(\<mu> \<alpha>. R(\<alpha>)) = (\<mu> \<alpha>. Ord(\<alpha>) \<and> R(\<alpha>))"
  unfolding Least_def by (simp add:lt_Ord)

lemma Ord_Least_cong:
  assumes "\<And>y. Ord(y) \<Longrightarrow> R(y) \<longleftrightarrow> Q(y)"
  shows "(\<mu> \<alpha>. R(\<alpha>)) = (\<mu> \<alpha>. Q(\<alpha>))"
proof -
  from assms
  have "(\<mu> \<alpha>. Ord(\<alpha>) \<and> R(\<alpha>)) = (\<mu> \<alpha>. Ord(\<alpha>) \<and> Q(\<alpha>))"
    by simp
  then
  show ?thesis using Least_Ord by simp
qed

definition
  least :: "[i\<Rightarrow>o,i\<Rightarrow>o,i] \<Rightarrow> o" where
  "least(M,Q,i) \<equiv> ordinal(M,i) \<and> (
         (empty(M,i) \<and> (\<forall>b[M]. ordinal(M,b) \<longrightarrow> \<not>Q(b)))
       \<or> (Q(i) \<and> (\<forall>b[M]. ordinal(M,b) \<and> b\<in>i\<longrightarrow> \<not>Q(b))))"

definition
  least_fm :: "[i,i] \<Rightarrow> i" where
  "least_fm(q,i) \<equiv> And(ordinal_fm(i),
   Or(And(empty_fm(i),Forall(Implies(ordinal_fm(0),Neg(q)))),
      And(Exists(And(q,Equal(0,succ(i)))),
          Forall(Implies(And(ordinal_fm(0),Member(0,succ(i))),Neg(q))))))"

lemma least_fm_type[TC] :"i \<in> nat \<Longrightarrow> q\<in>formula \<Longrightarrow> least_fm(q,i) \<in> formula"
  unfolding least_fm_def
  by simp

(* Refactorize Formula and Relative to include the following three lemmas *)
lemmas basic_fm_simps = sats_subset_fm' sats_transset_fm' sats_ordinal_fm'

lemma sats_least_fm :
  assumes p_iff_sats:
    "\<And>a. a \<in> A \<Longrightarrow> P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
    "\<lbrakk>y \<in> nat; env \<in> list(A) ; 0\<in>A\<rbrakk>
    \<Longrightarrow> sats(A, least_fm(p,y), env) \<longleftrightarrow>
        least(##A, P, nth(y,env))"
  using nth_closed p_iff_sats unfolding least_def least_fm_def
  by (simp add:basic_fm_simps)

lemma least_iff_sats:
  assumes is_Q_iff_sats:
      "\<And>a. a \<in> A \<Longrightarrow> is_Q(a) \<longleftrightarrow> sats(A, q, Cons(a,env))"
  shows
  "\<lbrakk>nth(j,env) = y; j \<in> nat; env \<in> list(A); 0\<in>A\<rbrakk>
   \<Longrightarrow> least(##A, is_Q, y) \<longleftrightarrow> sats(A, least_fm(q,j), env)"
  using sats_least_fm [OF is_Q_iff_sats, of j , symmetric]
  by simp

lemma least_conj: "a\<in>M \<Longrightarrow> least(##M, \<lambda>x. x\<in>M \<and> Q(x),a) \<longleftrightarrow> least(##M,Q,a)"
  unfolding least_def by simp

(* Better to have this in M_basic or similar *)
lemma (in M_ctm) unique_least: "a\<in>M \<Longrightarrow> b\<in>M \<Longrightarrow> least(##M,Q,a) \<Longrightarrow> least(##M,Q,b) \<Longrightarrow> a=b"
  unfolding least_def
  by (auto, erule_tac i=a and j=b in Ord_linear_lt; (drule ltD | simp); auto intro:Ord_in_Ord)

context M_trivial
begin

subsection\<open>Absoluteness and closure under \<^term>\<open>Least\<close>\<close>

lemma least_abs:
  assumes "\<And>x. Q(x) \<Longrightarrow> M(x)" "M(a)"
  shows "least(M,Q,a) \<longleftrightarrow> a = (\<mu> x. Q(x))"
  unfolding least_def
proof (cases "\<forall>b[M]. Ord(b) \<longrightarrow> \<not> Q(b)"; intro iffI; simp add:assms)
  case True
  with \<open>\<And>x. Q(x) \<Longrightarrow> M(x)\<close>
  have "\<not> (\<exists>i. Ord(i) \<and> Q(i)) " by blast
  then
  show "0 =(\<mu> x. Q(x))" using Least_0 by simp
  then
  show "ordinal(M, \<mu> x. Q(x)) \<and> (empty(M, Least(Q)) \<or> Q(Least(Q)))"
    by simp
next
  assume "\<exists>b[M]. Ord(b) \<and> Q(b)"
  then
  obtain i where "M(i)" "Ord(i)" "Q(i)" by blast
  assume "a = (\<mu> x. Q(x))"
  moreover
  note \<open>M(a)\<close>
  moreover from  \<open>Q(i)\<close> \<open>Ord(i)\<close>
  have "Q(\<mu> x. Q(x))" (is ?G)
    by (blast intro:LeastI)
  moreover
  have "(\<forall>b[M]. Ord(b) \<and> b \<in> (\<mu> x. Q(x)) \<longrightarrow> \<not> Q(b))" (is "?H")
    using less_LeastE[of Q _ False]
    by (auto, drule_tac ltI, simp, blast)
  ultimately
  show "ordinal(M, \<mu> x. Q(x)) \<and> (empty(M, \<mu> x. Q(x)) \<and> (\<forall>b[M]. Ord(b) \<longrightarrow> \<not> Q(b)) \<or> ?G \<and> ?H)"
    by simp
next
  assume 1:"\<exists>b[M]. Ord(b) \<and> Q(b)"
  then
  obtain i where "M(i)" "Ord(i)" "Q(i)" by blast
  assume "Ord(a) \<and> (a = 0 \<and> (\<forall>b[M]. Ord(b) \<longrightarrow> \<not> Q(b)) \<or> Q(a) \<and> (\<forall>b[M]. Ord(b) \<and> b \<in> a \<longrightarrow> \<not> Q(b)))"
  with 1
  have "Ord(a)" "Q(a)" "\<forall>b[M]. Ord(b) \<and> b \<in> a \<longrightarrow> \<not> Q(b)"
    by blast+
  moreover from this and \<open>\<And>x. Q(x) \<Longrightarrow> M(x)\<close>
  have "Ord(b) \<Longrightarrow> b \<in> a \<Longrightarrow> \<not> Q(b)" for b
    by blast
  moreover from this and \<open>Ord(a)\<close>
  have "b < a \<Longrightarrow> \<not> Q(b)" for b
    unfolding lt_def using Ord_in_Ord by blast
  ultimately
  show "a = (\<mu> x. Q(x))"
    using Least_equality by simp
qed

lemma Least_closed:
  assumes "\<And>x. Q(x) \<Longrightarrow> M(x)"
  shows "M(\<mu> x. Q(x))"
  using assms LeastI[of Q] Least_0 by (cases "(\<exists>i. Ord(i) \<and> Q(i))", auto)

end (* M_trivial *)

end


(*
    Title:      Code_Generation_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Exporting code to SML and Haskell*}

theory Code_Generation_IArrays
imports
  Examples_Gauss_Jordan_IArrays
begin

subsection{*Exporting code*}

text{*The following two equations are necessary to execute code. If we don't remove them from code unfold, the exported code
will not work (there exist problems with the number 1 and number 0. Those problems appear when the HMA library is imported).*}

lemma [code_unfold del]: "1 \<equiv> real_of_rat 1" by simp
lemma [code_unfold del]: "0 \<equiv> real_of_rat 0" by simp

definition "matrix_z2 = IArray[IArray[0,1], IArray[1,1::bit], IArray[1,0::bit]]"
definition "matrix_rat = IArray[IArray[1,0,8], IArray[5.7,22,1], IArray[41,-58/7,78::rat]]"
definition "matrix_real = IArray[IArray[0,1], IArray[1,-2::real]]"
definition "vec_rat = IArray[21,5,7::rat]"

definition "print_result_Gauss A = iarray_of_iarray_to_list_of_list (Gauss_Jordan_iarrays A)"
definition "print_rank A = rank_iarray A"
definition "print_det A = det_iarrays A"

definition "print_result_z2 = print_result_Gauss (matrix_z2)"
definition "print_result_rat = print_result_Gauss (matrix_rat)"
definition "print_result_real = print_result_Gauss (matrix_real)"

definition "print_rank_z2 = print_rank (matrix_z2)"
definition "print_rank_rat = print_rank (matrix_rat)"
definition "print_rank_real = print_rank (matrix_real)"

definition "print_det_rat = print_det (matrix_rat)"
definition "print_det_real = print_det (matrix_real)"

definition "print_inverse A = inverse_matrix_iarray A"
definition "print_inverse_real A = print_inverse (matrix_real)"
definition "print_inverse_rat A = print_inverse (matrix_rat)"

definition "print_system A b = print_result_system_iarrays (solve_iarrays A b)"
definition "print_system_rat = print_result_system_iarrays (solve_iarrays matrix_rat vec_rat)"

subsection{*The Mathematica bug*}

text{*Varona et al \cite{VA} detected that the commercial software @{text "Mathematica\<registered>"},
in its versions 8.0, 9.0 and 9.0.1, was computing erroneously determinants of matrices
of big integers, even for small dimensions  (in their work they present an example of a
matrix of dimension @{text "14 \<times> 14"}). The situation is
such that even the same determinant, computed twice, produces two different and wrong results.

Here we reproduce that example. The computation of the determinant is correctly carried out by
the exported code from this formalization, in both SML and Haskell.
*}

definition "powersMatrix =
IArray[
IArray[10^123,0,0,0,0,0,0,0,0,0,0,0,0,0],
IArray[0,10^152,0,0,0,0,0,0,0,0,0,0,0,0],
IArray[0,0,10^185,0,0,0,0,0,0,0,0,0,0,0],
IArray[0,0,0,10^220,0,0,0,0,0,0,0,0,0,0],
IArray[0,0,0,0,10^397,0,0,0,0,0,0,0,0,0],
IArray[0,0,0,0,0,10^449,0,0,0,0,0,0,0,0],
IArray[0,0,0,0,0,0,10^503,0,0,0,0,0,0,0],
IArray[0,0,0,0,0,0,0,10^563,0,0,0,0,0,0],
IArray[0,0,0,0,0,0,0,0,10^979,0,0,0,0,0],
IArray[0,0,0,0,0,0,0,0,0,10^1059,0,0,0,0],
IArray[0,0,0,0,0,0,0,0,0,0,10^1143,0,0,0],
IArray[0,0,0,0,0,0,0,0,0,0,0,10^1229,0,0],
IArray[0,0,0,0,0,0,0,0,0,0,0,0,10^1319,0],
IArray[0,0,0,0,0,0,0,0,0,0,0,0,0,(10^1412)::rat]]"

definition "basicMatrix =
IArray[
IArray[-32, 69, 89,-60,-83,-22,-14,-58,85,56,-65,-30,-86,-9],
IArray[6, 99, 11, 57, 47,-42,-48,-65, 25, 50,-70,-3,-90, 31],
IArray[78, 38, 12, 64,-67,-4,-52,-65, 19, 71, 38,-17, 51,-3],
IArray[-93, 30, 89, 22, 13, 48,-73, 93, 11,-97,-49, 61,-25,-4],
IArray[54,-22, 54,-53,-52, 64, 19, 1, 81,-72,-11, 50, 0,-81],
IArray[65,-58, 3, 57, 19, 77, 76,-57,-80, 22, 93,-85, 67, 58],
IArray[29,-58, 47, 87, 3,-6,-81, 5, 98, 86,-98, 51,-62,-66],
IArray[93,-77, 16,-64, 48, 84, 97, 75, 89, 63, 34,-98,-94, 19],
IArray[45,-99, 3,-57, 32, 60, 74, 4, 69, 98,-40,-69,-28,-26],
IArray[-13, 51,-99,-2, 48, 71,-81,-32, 78, 27,-28,-22, 22, 94],
IArray[11, 72,-74, 86, 79,-58,-89, 80, 70, 55,-49, 51,-42, 66],
IArray[-72, 53, 49,-46, 17,-22,-48,-40,-28,-85, 88,-30, 74, 32],
IArray[-92,-22,-90, 67,-25,-28,-91,-8, 32,-41, 10, 6, 85, 21],
IArray[47,-73,-30,-60, 99, 9,-86,-70, 84, 55, 19, 69, 11,-84::rat]]"

definition "smallMatrix=
IArray[
IArray[528, 853,-547,-323, 393,-916,-11,-976, 279,-665, 906,-277, 103,-485],
IArray[878, 910,-306,-260, 575,-765,-32, 94, 254, 276,-156, 625,-8,-566],
IArray[-357, 451,-475, 327,-84, 237, 647, 505,-137, 363,-808, 332, 222,-998],
IArray[-76, 26,-778, 505, 942,-561,-350, 698,-532,-507,-78,-758, 346,-545],
IArray[-358, 18,-229,-880,-955,-346, 550,-958, 867,-541,-962, 646, 932, 168],
IArray[192, 233, 620,955,-877, 281, 357,-226,-820, 513,-882, 536,-237, 877],
IArray[-234,-71,-831, 880,-135,-249,-427, 737, 664, 298,-552,-1,-712,-691],
IArray[80, 748, 684, 332, 730,-111,-643, 102,-242,-82,-28, 585, 207,-986],
IArray[967, 1,-494, 633, 891,-907,-586, 129, 688, 150,-501,-298, 704,-68],
IArray[406,-944,-533,-827, 615, 907,-443,-350, 700,-878, 706, 1,800, 120],
IArray[33,-328,-543, 583,-443,-635,904,-745,-398,-110, 751, 660, 474, 255],
IArray[-537,-311, 829, 28, 175, 182,-930, 258,-808,-399,-43,-68,-553, 421],
IArray[-373,-447,-252,-619,-418, 764, 994,-543,-37,-845, 30,-704, 147,-534],
IArray[638,-33, 932,-335,-75,-676,-934, 239, 210, 665, 414,-803, 564,-805::rat]]"

definition "bigMatrix=(basicMatrix **i powersMatrix) + smallMatrix"

end


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

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

theory FOL
imports IFOL
keywords "print_claset" "print_induct_rules" :: diag
begin

ML_file \<open>~~/src/Provers/classical.ML\<close>
ML_file \<open>~~/src/Provers/blast.ML\<close>
ML_file \<open>~~/src/Provers/clasimp.ML\<close>

subsection \<open>The classical axiom\<close>

axiomatization where
  classical: \<open>(\<not> P \<Longrightarrow> P) \<Longrightarrow> P\<close>

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

lemma ccontr: \<open>(\<not> P \<Longrightarrow> False) \<Longrightarrow> P\<close>
  by (erule FalseE [THEN classical])

subsubsection \<open>Classical introduction rules for \<open>\<or>\<close> and \<open>\<exists>\<close>\<close>

lemma disjCI: \<open>(\<not> Q \<Longrightarrow> P) \<Longrightarrow> P \<or> Q\<close>
  apply (rule classical)
  apply (assumption | erule meta_mp | rule disjI1 notI)+
  apply (erule notE disjI2)+
  done

text \<open>Introduction rule involving only \<open>\<exists>\<close>\<close>
lemma ex_classical:
  assumes r: \<open>\<not> (\<exists>x. P(x)) \<Longrightarrow> P(a)\<close>
  shows \<open>\<exists>x. P(x)\<close>
  apply (rule classical)
  apply (rule exI, erule r)
  done

text \<open>Version of above, simplifying \<open>\<not>\<exists>\<close> to \<open>\<forall>\<not>\<close>.\<close>
lemma exCI:
  assumes r: \<open>\<forall>x. \<not> P(x) \<Longrightarrow> P(a)\<close>
  shows \<open>\<exists>x. P(x)\<close>
  apply (rule ex_classical)
  apply (rule notI [THEN allI, THEN r])
  apply (erule notE)
  apply (erule exI)
  done

lemma excluded_middle: \<open>\<not> P \<or> P\<close>
  apply (rule disjCI)
  apply assumption
  done

lemma case_split [case_names True False]:
  assumes r1: \<open>P \<Longrightarrow> Q\<close>
    and r2: \<open>\<not> P \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
  apply (rule excluded_middle [THEN disjE])
  apply (erule r2)
  apply (erule r1)
  done

ML \<open>
  fun case_tac ctxt a fixes =
    Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), a)] fixes @{thm case_split};
\<close>

method_setup case_tac = \<open>
  Args.goal_spec -- Scan.lift (Args.embedded_inner_syntax -- Parse.for_fixes) >>
    (fn (quant, (s, fixes)) => fn ctxt => SIMPLE_METHOD'' quant (case_tac ctxt s fixes))
\<close> "case_tac emulation (dynamic instantiation!)"

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

text \<open>Classical implies (\<open>\<longrightarrow>\<close>) elimination.\<close>
lemma impCE:
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and r1: \<open>\<not> P \<Longrightarrow> R\<close>
    and r2: \<open>Q \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule excluded_middle [THEN disjE])
   apply (erule r1)
  apply (rule r2)
  apply (erule major [THEN mp])
  done

text \<open>
  This version of \<open>\<longrightarrow>\<close> elimination works on \<open>Q\<close> before \<open>P\<close>. It works best for those cases in which P holds ``almost everywhere''.
  Can't install as default: would break old proofs.
\<close>
lemma impCE':
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and r1: \<open>Q \<Longrightarrow> R\<close>
    and r2: \<open>\<not> P \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule excluded_middle [THEN disjE])
   apply (erule r2)
  apply (rule r1)
  apply (erule major [THEN mp])
  done

text \<open>Double negation law.\<close>
lemma notnotD: \<open>\<not> \<not> P \<Longrightarrow> P\<close>
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma contrapos2:  \<open>\<lbrakk>Q; \<not> P \<Longrightarrow> \<not> Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (rule classical)
  apply (drule (1) meta_mp)
  apply (erule (1) notE)
  done

subsubsection \<open>Tactics for implication and contradiction\<close>

text \<open>
  Classical \<open>\<longleftrightarrow>\<close> elimination. Proof substitutes \<open>P = Q\<close> in
  \<open>\<not> P \<Longrightarrow> \<not> Q\<close> and \<open>P \<Longrightarrow> Q\<close>.
\<close>
lemma iffCE:
  assumes major: \<open>P \<longleftrightarrow> Q\<close>
    and r1: \<open>\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R\<close>
    and r2: \<open>\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule major [unfolded iff_def, THEN conjE])
  apply (elim impCE)
     apply (erule (1) r2)
    apply (erule (1) notE)+
  apply (erule (1) r1)
  done

(*Better for fast_tac: needs no quantifier duplication!*)
lemma alt_ex1E:
  assumes major: \<open>\<exists>! x. P(x)\<close>
    and r: \<open>\<And>x. \<lbrakk>P(x);  \<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  using major
proof (rule ex1E)
  fix x
  assume * : \<open>\<forall>y. P(y) \<longrightarrow> y = x\<close>
  assume \<open>P(x)\<close>
  then show \<open>R\<close>
  proof (rule r)
    {
      fix y y'
      assume \<open>P(y)\<close> and \<open>P(y')\<close>
      with * have \<open>x = y\<close> and \<open>x = y'\<close>
        by - (tactic "IntPr.fast_tac \<^context> 1")+
      then have \<open>y = y'\<close> by (rule subst)
    } note r' = this
    show \<open>\<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'\<close>
      by (intro strip, elim conjE) (rule r')
  qed
qed

lemma imp_elim: \<open>P \<longrightarrow> Q \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R\<close>
  by (rule classical) iprover

lemma swap: \<open>\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R\<close>
  by (rule classical) iprover

section \<open>Classical Reasoner\<close>

ML \<open>
structure Cla = Classical
(
  val imp_elim = @{thm imp_elim}
  val not_elim = @{thm notE}
  val swap = @{thm swap}
  val classical = @{thm classical}
  val sizef = size_of_thm
  val hyp_subst_tacs = [hyp_subst_tac]
);

structure Basic_Classical: BASIC_CLASSICAL = Cla;
open Basic_Classical;
\<close>

(*Propositional rules*)
lemmas [intro!] = refl TrueI conjI disjCI impI notI iffI
  and [elim!] = conjE disjE impCE FalseE iffCE
ML \<open>val prop_cs = claset_of \<^context>\<close>

(*Quantifier rules*)
lemmas [intro!] = allI ex_ex1I
  and [intro] = exI
  and [elim!] = exE alt_ex1E
  and [elim] = allE
ML \<open>val FOL_cs = claset_of \<^context>\<close>

ML \<open>
  structure Blast = Blast
  (
    structure Classical = Cla
    val Trueprop_const = dest_Const \<^const>\<open>Trueprop\<close>
    val equality_name = \<^const_name>\<open>eq\<close>
    val not_name = \<^const_name>\<open>Not\<close>
    val notE = @{thm notE}
    val ccontr = @{thm ccontr}
    val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
  );
  val blast_tac = Blast.blast_tac;
\<close>

lemma ex1_functional: \<open>\<lbrakk>\<exists>! z. P(a,z); P(a,b); P(a,c)\<rbrakk> \<Longrightarrow> b = c\<close>
  by blast

text \<open>Elimination of \<open>True\<close> from assumptions:\<close>
lemma True_implies_equals: \<open>(True \<Longrightarrow> PROP P) \<equiv> PROP P\<close>
proof
  assume \<open>True \<Longrightarrow> PROP P\<close>
  from this and TrueI show \<open>PROP P\<close> .
next
  assume \<open>PROP P\<close>
  then show \<open>PROP P\<close> .
qed

lemma uncurry: \<open>P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R\<close>
  by blast

lemma iff_allI: \<open>(\<And>x. P(x) \<longleftrightarrow> Q(x)) \<Longrightarrow> (\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))\<close>
  by blast

lemma iff_exI: \<open>(\<And>x. P(x) \<longleftrightarrow> Q(x)) \<Longrightarrow> (\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))\<close>
  by blast

lemma all_comm: \<open>(\<forall>x y. P(x,y)) \<longleftrightarrow> (\<forall>y x. P(x,y))\<close>
  by blast

lemma ex_comm: \<open>(\<exists>x y. P(x,y)) \<longleftrightarrow> (\<exists>y x. P(x,y))\<close>
  by blast

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

text \<open>
  Avoids duplication of subgoals after \<open>expand_if\<close>, when the true and
  false cases boil down to the same thing.
\<close>

lemma cases_simp: \<open>(P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> Q) \<longleftrightarrow> Q\<close>
  by blast

subsubsection \<open>Miniscoping: pushing quantifiers in\<close>

text \<open>
  We do NOT distribute of \<open>\<forall>\<close> over \<open>\<and>\<close>, or dually that of
  \<open>\<exists>\<close> over \<open>\<or>\<close>.

  Baaz and Leitsch, On Skolemization and Proof Complexity (1994) show that
  this step can increase proof length!
\<close>

text \<open>Existential miniscoping.\<close>
lemma int_ex_simps:
  \<open>\<And>P Q. (\<exists>x. P(x) \<and> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<and> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<exists>x. Q(x))\<close>
  \<open>\<And>P Q. (\<exists>x. P(x) \<or> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<or> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<exists>x. Q(x))\<close>
  by iprover+

text \<open>Classical rules.\<close>
lemma cla_ex_simps:
  \<open>\<And>P Q. (\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<exists>x. Q(x))\<close>
  by blast+

lemmas ex_simps = int_ex_simps cla_ex_simps

text \<open>Universal miniscoping.\<close>
lemma int_all_simps:
  \<open>\<And>P Q. (\<forall>x. P(x) \<and> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<and> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<forall>x. Q(x))\<close>
  \<open>\<And>P Q. (\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<exists> x. P(x)) \<longrightarrow> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<forall>x. Q(x))\<close>
  by iprover+

text \<open>Classical rules.\<close>
lemma cla_all_simps:
  \<open>\<And>P Q. (\<forall>x. P(x) \<or> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<or> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<forall>x. Q(x))\<close>
  by blast+

lemmas all_simps = int_all_simps cla_all_simps

subsubsection \<open>Named rewrite rules proved for IFOL\<close>

lemma imp_disj1: \<open>(P \<longrightarrow> Q) \<or> R \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)\<close> by blast
lemma imp_disj2: \<open>Q \<or> (P \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)\<close> by blast

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

lemma not_imp: \<open>\<not> (P \<longrightarrow> Q) \<longleftrightarrow> (P \<and> \<not> Q)\<close> by blast
lemma not_iff: \<open>\<not> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<longleftrightarrow> \<not> Q)\<close> by blast

lemma not_all: \<open>(\<not> (\<forall>x. P(x))) \<longleftrightarrow> (\<exists>x. \<not> P(x))\<close> by blast
lemma imp_all: \<open>((\<forall>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<exists>x. P(x) \<longrightarrow> Q)\<close> by blast

lemmas meta_simps =
  triv_forall_equality  \<comment> \<open>prunes params\<close>
  True_implies_equals  \<comment> \<open>prune asms \<open>True\<close>\<close>

lemmas IFOL_simps =
  refl [THEN P_iff_T] conj_simps disj_simps not_simps
  imp_simps iff_simps quant_simps

lemma notFalseI: \<open>\<not> False\<close> by iprover

lemma cla_simps_misc:
  \<open>\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q\<close>
  \<open>P \<or> \<not> P\<close>
  \<open>\<not> P \<or> P\<close>
  \<open>\<not> \<not> P \<longleftrightarrow> P\<close>
  \<open>(\<not> P \<longrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(\<not> P \<longleftrightarrow> \<not> Q) \<longleftrightarrow> (P \<longleftrightarrow> Q)\<close> by blast+

lemmas cla_simps =
  de_Morgan_conj de_Morgan_disj imp_disj1 imp_disj2
  not_imp not_all not_ex cases_simp cla_simps_misc

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

simproc_setup defined_Ex (\<open>\<exists>x. P(x)\<close>) = \<open>fn _ => Quantifier1.rearrange_Ex\<close>
simproc_setup defined_All (\<open>\<forall>x. P(x)\<close>) = \<open>fn _ => Quantifier1.rearrange_All\<close>

ML \<open>
(*intuitionistic simprules only*)
val IFOL_ss =
  put_simpset FOL_basic_ss \<^context>
  addsimps @{thms meta_simps IFOL_simps int_ex_simps int_all_simps}
  addsimprocs [\<^simproc>\<open>defined_All\<close>, \<^simproc>\<open>defined_Ex\<close>]
  |> Simplifier.add_cong @{thm imp_cong}
  |> simpset_of;

(*classical simprules too*)
val FOL_ss =
  put_simpset IFOL_ss \<^context>
  addsimps @{thms cla_simps cla_ex_simps cla_all_simps}
  |> simpset_of;
\<close>

setup \<open>
  map_theory_simpset (put_simpset FOL_ss) #>
  Simplifier.method_setup Splitter.split_modifiers
\<close>

ML_file \<open>~~/src/Tools/eqsubst.ML\<close>

subsection \<open>Other simple lemmas\<close>

lemma [simp]: \<open>((P \<longrightarrow> Q) \<longleftrightarrow> (P \<longrightarrow> R)) \<longleftrightarrow> (P \<longrightarrow> (Q \<longleftrightarrow> R))\<close>
  by blast

lemma not_disj_iff_imp: \<open>\<not> P \<or> Q \<longleftrightarrow> (P \<longrightarrow> Q)\<close>
  by blast

subsubsection \<open>Monotonicity of implications\<close>

lemma conj_mono: \<open>\<lbrakk>P1 \<longrightarrow> Q1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<and> P2) \<longrightarrow> (Q1 \<and> Q2)\<close>
  by fast (*or (IntPr.fast_tac 1)*)

lemma disj_mono: \<open>\<lbrakk>P1 \<longrightarrow> Q1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<or> P2) \<longrightarrow> (Q1 \<or> Q2)\<close>
  by fast (*or (IntPr.fast_tac 1)*)

lemma imp_mono: \<open>\<lbrakk>Q1 \<longrightarrow> P1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<longrightarrow> P2) \<longrightarrow> (Q1 \<longrightarrow> Q2)\<close>
  by fast (*or (IntPr.fast_tac 1)*)

lemma imp_refl: \<open>P \<longrightarrow> P\<close>
  by (rule impI)

text \<open>The quantifier monotonicity rules are also intuitionistically valid.\<close>
lemma ex_mono: \<open>(\<And>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))\<close>
  by blast

lemma all_mono: \<open>(\<And>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (\<forall>x. P(x)) \<longrightarrow> (\<forall>x. Q(x))\<close>
  by blast

subsection \<open>Proof by cases and induction\<close>

text \<open>Proper handling of non-atomic rule statements.\<close>

context
begin

qualified definition \<open>induct_forall(P) \<equiv> \<forall>x. P(x)\<close>
qualified definition \<open>induct_implies(A, B) \<equiv> A \<longrightarrow> B\<close>
qualified definition \<open>induct_equal(x, y) \<equiv> x = y\<close>
qualified definition \<open>induct_conj(A, B) \<equiv> A \<and> B\<close>

lemma induct_forall_eq: \<open>(\<And>x. P(x)) \<equiv> Trueprop(induct_forall(\<lambda>x. P(x)))\<close>
  unfolding atomize_all induct_forall_def .

lemma induct_implies_eq: \<open>(A \<Longrightarrow> B) \<equiv> Trueprop(induct_implies(A, B))\<close>
  unfolding atomize_imp induct_implies_def .

lemma induct_equal_eq: \<open>(x \<equiv> y) \<equiv> Trueprop(induct_equal(x, y))\<close>
  unfolding atomize_eq induct_equal_def .

lemma induct_conj_eq: \<open>(A &&& B) \<equiv> Trueprop(induct_conj(A, B))\<close>
  unfolding atomize_conj induct_conj_def .

lemmas induct_atomize = induct_forall_eq induct_implies_eq induct_equal_eq induct_conj_eq
lemmas induct_rulify [symmetric] = induct_atomize
lemmas induct_rulify_fallback =
  induct_forall_def induct_implies_def induct_equal_def induct_conj_def

text \<open>Method setup.\<close>

ML_file \<open>~~/src/Tools/induct.ML\<close>
ML \<open>
  structure Induct = Induct
  (
    val cases_default = @{thm case_split}
    val atomize = @{thms induct_atomize}
    val rulify = @{thms induct_rulify}
    val rulify_fallback = @{thms induct_rulify_fallback}
    val equal_def = @{thm induct_equal_def}
    fun dest_def _ = NONE
    fun trivial_tac _ _ = no_tac
  );
\<close>

declare case_split [cases type: o]

end

ML_file \<open>~~/src/Tools/case_product.ML\<close>

hide_const (open) eq

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Preliminaries\<close>
subsection \<open>Missing Multiset\<close>

text \<open>This theory provides some definitions and lemmas on multisets which we did not find in the
  Isabelle distribution.\<close>

theory Missing_Multiset
imports
  "HOL-Library.Multiset"
  Missing_List
begin

lemma remove_nth_soundness:
  assumes "n < length as"
  shows "mset (remove_nth n as) = mset as - {#(as!n)#}"
using assms
proof (induct as arbitrary: n)
  case (Cons a as)
  note [simp] = remove_nth_def
  show ?case
  proof (cases n)
    case (Suc n)
    with Cons have n_bd: "n < length as" by auto
    with Cons have "mset (remove_nth n as) = mset as - {#as ! n#}" by auto
    hence G: "mset (remove_nth (Suc n) (a # as)) = mset as - {#as ! n#} + {#a#}"
      by simp
    thus ?thesis
    proof (cases "a = as!n")
      case True
      with G and Suc and insert_DiffM2[symmetric]
        and insert_DiffM2[of _ "{#as ! n#}"]
        and nth_mem_mset[of n as] and n_bd
      show ?thesis by auto
    next
      case False
      from G and Suc and diff_union_swap[OF this[symmetric], symmetric] show ?thesis by simp
    qed
  qed auto
qed auto

lemma multiset_subset_insert: "{ps. ps \<subseteq># add_mset x xs} =
    {ps. ps \<subseteq># xs} \<union> add_mset x ` {ps. ps \<subseteq># xs}" (is "?l = ?r")
proof -
  {
    fix ps
    have "(ps \<in> ?l) = (ps \<subseteq># xs + {# x #})" by auto
    also have "\<dots> = (ps \<in> ?r)"
    proof (cases "x \<in># ps")
      case True
      then obtain qs where ps: "ps = qs + {#x#}" by (metis insert_DiffM2)
      show ?thesis unfolding ps mset_subset_eq_mono_add_right_cancel
        by (auto dest: mset_subset_eq_insertD)
    next
      case False
      hence id: "(ps \<subseteq># xs + {#x#}) = (ps \<subseteq># xs)"
        by (simp add: subset_mset.inf.absorb_iff2 inter_add_left1)
      show ?thesis unfolding id using False by auto
    qed
    finally have "(ps \<in> ?l) = (ps \<in> ?r)" .
  }
  thus ?thesis by auto
qed

lemma multiset_of_subseqs: "mset ` set (subseqs xs) = { ps. ps \<subseteq># mset xs}"
proof (induct xs)
  case (Cons x xs)
  show ?case (is "?l = ?r")
  proof -
    have id: "?r = {ps. ps \<subseteq># mset xs} \<union> (add_mset x) ` {ps. ps \<subseteq># mset xs}"
      by (simp add: multiset_subset_insert)
    show ?thesis unfolding id Cons[symmetric]
      by (auto simp add: Let_def) (metis UnCI image_iff mset.simps(2))
  qed
qed simp

lemma fold_remove1_mset: "mset ws \<subseteq># mset vs \<Longrightarrow> mset (fold remove1 ws vs) + mset ws = mset vs"
proof (induct ws arbitrary: vs)
  case (Cons w ws vs)
  from Cons(2) have "w \<in> set vs" using set_mset_mono by force
  from remove1_mset[OF this] have vs: "mset vs = mset (remove1 w vs) + {#w#}" by simp
  from Cons(2)[unfolded vs] have "mset ws \<subseteq># mset (remove1 w vs)" by auto
  from Cons(1)[OF this,symmetric]
  show ?case unfolding vs by (simp add: ac_simps)
qed simp

lemma subseqs_sub_mset: "ws \<in> set (subseqs vs) \<Longrightarrow> mset ws \<subseteq># mset vs"
proof (induct vs arbitrary: ws)
  case (Cons v vs Ws)
  note mem = Cons(2)
  note IH = Cons(1)
  show ?case
  proof (cases Ws)
    case (Cons w ws)
    show ?thesis
    proof (cases "v = w")
      case True
      from mem Cons have "ws \<in> set (subseqs vs)" by (auto simp: Let_def Cons_in_subseqsD[of _ ws vs])
      from IH[OF this]
      show ?thesis unfolding Cons True by simp
    next
      case False
      with mem Cons have "Ws \<in> set (subseqs vs)" by (auto simp: Let_def Cons_in_subseqsD[of _ ws vs])
      note IH = mset_subset_eq_count[OF IH[OF this]]
      with IH[of v] show ?thesis by (intro mset_subset_eqI, auto, linarith)
    qed
  qed simp
qed simp

lemma filter_mset_inequality: "filter_mset f xs \<noteq> xs \<Longrightarrow> \<exists> x \<in># xs. \<not> f x"
  by (induct xs, auto)

end


theory list_SelectPermutations2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun select2 :: "'a => (('a, ('a list)) Pair2) list =>
                (('a, ('a list)) Pair2) list" where
"select2 x (Nil2) = Nil2"
| "select2 x (Cons2 (Pair y2 ys) x2) =
     Cons2 (Pair y2 (Cons2 x ys)) (select2 x x2)"

fun select :: "'a list => (('a, ('a list)) Pair2) list" where
"select (Nil2) = Nil2"
| "select (Cons2 y xs) = Cons2 (Pair y xs) (select2 y (select xs))"

fun propSelectPermutations :: "((int, (int list)) Pair2) list =>
                               (int list) list" where
"propSelectPermutations (Nil2) = Nil2"
| "propSelectPermutations (Cons2 (Pair y2 ys) z) =
     Cons2 (Cons2 y2 ys) (propSelectPermutations z)"

fun eq :: "Nat => Nat => bool" where
"eq (Z) (Z) = True"
| "eq (Z) (S z) = False"
| "eq (S x2) (Z) = False"
| "eq (S x2) (S y2) = eq x2 y2"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun all :: "('t => bool) => 't list => bool" where
"all x (Nil2) = True"
| "all x (Cons2 z xs) = and2 (x z) (all x xs)"

(*hipster select2
          select
          propSelectPermutations
          eq
          dot
          count
          and2
          all *)

theorem x0 :
  "!! (xs :: int list) (z :: int) .
     all
       (% (x :: int list) =>
          dot
            (% (y :: Nat) => eq (count z xs) y)
            (% (x2 :: int list) => count z x2) x)
       (propSelectPermutations (select xs))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory T154
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T154
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


(*  Title:        OptionCpo
    Author:       Sebastian Stüber
    Author:       Jens Christoph Bürger
    e-mail:       sebastian.stueber@rwth-aachen.de
    e-mail:       jens.buerger@rwth-aachen.de

    Description:  Defines "option" as CPO
                   + Lemmas about partial functions
*)

theory OptionCpo
  imports SetPcpo Prelude (* "~~/src/HOL/HOLCF/Library/Option_Cpo" *)
begin

(* Some packages set a custom default type (eg cpo). This is overwritten. *)
default_sort type

(* Abbreviation for special if-then-else command to create an "option" *)
abbreviation if_then_abbr :: "bool \<Rightarrow> 'a \<rightharpoonup> 'a" ("(_\<leadsto>_)" [1000] 999) where
"A \<leadsto> B \<equiv> if A then Some B else None"

(* Abbreviation for applying a partial function f to argument s and retrieving the value *)
abbreviation the_abbrv:: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b " ("_\<rightharpoonup>_") where
"f \<rightharpoonup> s \<equiv> the (f s)"

lemma cont2cont_if_bottom [cont2cont, simp]:
  assumes f: "cont (λx. f x)"
    and g: "cont (λx. g x)"
  shows "cont (λx. if f x = ⊥ then ⊥ else g x)"
proof (rule cont_apply [OF f])
  show "cont (λy. if y = ⊥ then ⊥ else g x)" for x
    unfolding cont_def is_lub_def is_ub_def ball_simps
    by (simp add: lub_eq_bottom_iff)
  show "cont (λx. if y = ⊥ then ⊥ else g x)" for y
    by (simp add: g)
qed

(* ----------------------------------------------------- *)
  section \<open>Option is po\<close>
(* ----------------------------------------------------- *)

(* A class defining symetric equality. *)
class myEQ =
  fixes myEQ :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes "myEQ x y \<longleftrightarrow> myEQ y x"
begin
end

instantiation nat::myEQ
begin
  definition myEQ_nat:: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "myEQ_nat a b = (a = b)"

  instance
  apply(intro_classes)
  by(auto simp add: myEQ_nat_def)
end

(* Defines a partial order about options if the base type 'a is already a partial order. *)
instantiation option :: (po) po
begin
  (* Define the ordering. "None" is only comparable with "None". *)
  (* If both arguments are \<noteq>None then the ordering of 'a is used. *)
  definition below_option_def: "b1 \<sqsubseteq> b2 \<equiv>  b1=b2  \<or> (b1 \<noteq> None \<and> b2 \<noteq> None \<and> the b1\<sqsubseteq>the b2)"

  (* Show that the ordering definition defines a correct partial order. *)
  instance
  apply intro_classes
    apply(simp add:below_option_def)
   apply (smt below_option_def below_trans)
  by (metis below_antisym below_option_def option.expand)
end

(* ----------------------------------------------------- *)
  section \<open>Option is CPO\<close>
(* ----------------------------------------------------- *)

(* Defines a complete partial order (cpo) about options if the base type 'a is already a cpo. *)
instantiation option :: (cpo) cpo
begin

  (* An option chain is either completely "Some 'a" or completely "None" *)
  lemma chain_NotNone: assumes "chain S" and "S i \<noteq> None"
    shows "S j \<noteq> None"
  by (metis assms below_option_def chain_tord)

  lemma chain_None[simp]: assumes "chain S" and "S i = None"
    shows "S j = None"
  using assms chain_NotNone by blast

  (* Definition of the Lub for option-chains *)
  (* If the chain contains only "None" then the Lub is "None" else the Lub is the lub of 'a *)
  definition optionLub :: "(nat \<Rightarrow> 'a::cpo option) \<Rightarrow> 'a option" where
  "optionLub S \<equiv> (S 0 \<noteq> None) \<leadsto> (\<Squnion>i. the (S i))"

  (* Show optionLub upper bound of the chain. Used for instance proof. *)
  lemma optionLub_max: assumes "chain S" shows "S i \<sqsubseteq> optionLub S"
  by (smt assms below_option_def chain_NotNone is_ub_thelub option.sel option.simps(3) optionLub_def po_class.chainI po_class.chain_def po_eq_conv)

  (* Show optionLub below every upper bound. Used for instance proof. *)
  lemma optionLub_least: assumes "chain S" and "range S <| u"
    shows "optionLub S \<sqsubseteq> u"
  by (smt assms(1) assms(2) below_option_def is_ub_def lub_below option.sel option.simps(3) optionLub_def po_class.chain_def po_eq_conv rangeI)

  (* Show optionLub is the Lub of each chain. Used for instance proof. *)
  lemma optionLub_isLub: assumes "chain S" shows "range S <<| optionLub S"
  by (simp add: assms is_lub_def optionLub_least optionLub_max ub_rangeI)

instance
  apply intro_classes
  using optionLub_isLub by blast
end

(* ----------------------------------------------------- *)
  section \<open>Lemmas about Options \<close>
(* ----------------------------------------------------- *)

(* "the" is a monotonic function. Used in "op_the_cont" proof. *)
lemma op_the_mono[simp]: "monofun the"
  by (metis below_option_def below_refl monofunI)

(* Wrapping a chain in the option type preserves the chain property *)
lemma op_the_chain: assumes "chain Y" shows "chain (\<lambda>i. the (Y i))"
  by (metis assms below_option_def below_refl ch2ch_monofun monofunI)

(* "the" is a continuous function *)
lemma op_the_cont [simp]: "cont the"
  by (smt ch2ch_monofun chain_NotNone contI eq_imp_below is_lub_maximal lub_eq lub_eqI op_the_mono option.sel optionLub_def optionLub_isLub rangeI thelubE ub_rangeI)

(* "optionLub" is the lub *)
lemma op_is_lub: assumes "chain S"
  shows "(\<Squnion>i. S i) = optionLub S"
  using assms cpo_lubI is_lub_unique optionLub_isLub by blast

(* Retrieving the element inside the option before or after calculating the lub is the same *)
lemma op_the_lub: fixes S:: "nat \<Rightarrow> 'a::cpo option"
  assumes "chain S"
  shows "the (\<Squnion>i. S i) = (\<Squnion>i. the (S i))"
  using assms cont2contlubE op_the_cont by blast

(* "Some" is a continuous function *)
lemma some_cont[simp]: "cont Some"
  by (smt below_option_def contI cpo_lubI lub_eq op_is_lub option.sel option.simps(3) optionLub_def po_class.chain_def)

(* If the below-relation holds on the orig. elements, it also holds on their option counterpart *)
lemma some_below: assumes "x\<sqsubseteq>y"
  shows "Some x \<sqsubseteq> Some y"
  by (simp add: assms below_option_def)

(* If the below-relation holds on option elements, it also holds on the base elements *)
lemma some_below2: assumes "Some x \<sqsubseteq> Some y"
  shows "x \<sqsubseteq> y"
  by (metis assms below_option_def option.sel po_eq_conv)

(* ----------------------------------------------------- *)
  section \<open>Lemmas about partial functions \<close>
(* ----------------------------------------------------- *)

(* Rule for =: If the domain and their behaviour on said domain is =, they are = *)
lemma part_eq: assumes "dom x = dom y" and "\<And>i. i\<in>dom x \<Longrightarrow> the (x i) = the (y i)"
  shows "x = y"
  by (metis assms(1) assms(2) domIff map_le_antisym map_le_def option.collapse)

(* Rule for \<sqsubseteq>: If the domain is equal and every image over said domain is \<sqsubseteq>, they are \<sqsubseteq> *)
lemma part_below: assumes "dom x = dom y" and "\<And>i. i\<in>dom x \<Longrightarrow> the (x i) \<sqsubseteq> the (y i)"
  shows "x \<sqsubseteq> y"
  by (metis assms(1) assms(2) below_option_def domIff fun_belowI)

(* If two partial functions are in the "below" relation, their domain is identical. *)
lemma part_dom_eq: assumes "a\<sqsubseteq>b"
  shows "dom a = dom b"
  by (smt Collect_cong assms below_option_def dom_def fun_below_iff)

(* In a chain all elements have the same domain *)
lemma part_dom_eq1: assumes "chain S"
  shows "dom (S i) = dom (S j)"
  using assms chain_tord part_dom_eq by blast

(* Lub has the same domain as all elements in the chain *)
lemma part_dom_lub: fixes S::"nat \<Rightarrow> ('a \<rightharpoonup> 'b::cpo)"
  assumes "chain S"
  shows "dom (S i) = dom (\<Squnion>i. S i)"
  by (simp add: assms is_ub_thelub part_dom_eq)

(* Applying Some on both side does not change the below-relation *)
lemma part_some_below[simp]: assumes "g\<sqsubseteq>h"
  shows "(\<lambda>x. Some (g x)) \<sqsubseteq> (\<lambda>x. Some (h x))"
  by (meson assms below_fun_def some_below)

(* "the" in use with partial functions. *)

(* For any chain Y of partial functions, fixing the input to c results in another chain *)
lemma part_the_chain: assumes "chain Y" shows "chain (\<lambda>i. the (Y i c))"
  by (simp add: assms ch2ch_fun op_the_chain)

(* For any chain Y of partial functions, whose range is a cpo, fixing the input to c results in
   another chain in a cpo on which the continuity of "the" can be used *)
lemma part_the_cont2: fixes Y :: "nat \<Rightarrow> ('a \<rightharpoonup> 'b::cpo)"
  assumes "chain Y"
  shows "the (\<Squnion>i. Y i c) = (\<Squnion>i. the (Y i c))"
  by (simp add: assms ch2ch_fun op_the_lub)

(* First Lub, then fixing the input, then retrieving the value = First fixing, retrieving, lub *)
lemma part_the_lub: fixes S :: "nat \<Rightarrow> ('a \<rightharpoonup> 'b::cpo)"
  assumes "chain S"
  shows "the ((\<Squnion>i. S i) a) = (\<Squnion>i. the (S i a)) "
  using assms ch2ch_fun lub_fun op_the_lub by fastforce

(* uses SetPcpo *)

(* Used to show that "dom" is cont. *)
lemma subset_cont: assumes "chain Y" and "\<forall>i. g\<cdot>(Y i) \<subseteq> cs"
  shows "g\<cdot>(\<Squnion>i. Y i) \<subseteq> cs"
  by (metis SetPcpo.less_set_def assms(1) assms(2) ch2ch_Rep_cfunR contlub_cfun_arg lub_below)

(* Used to show that "dom" is cont. *)
lemma the_subset_cont: fixes Y :: "nat \<Rightarrow> ('a \<rightharpoonup> 'b::cpo)"
  assumes "chain Y" and "\<forall>i. g\<cdot>(the ((Y i) c)) \<subseteq> cs"
  shows "g\<cdot>(the (\<Squnion>i. Y i c)) \<subseteq> cs"
  by (simp add: assms(1) assms(2) part_the_chain subset_cont part_the_cont2)

(* Domain of a function created with the special if-then-else command is the same as in if-expr. *)
lemma if_then_dom [simp]: "dom (\<lambda>c. (c \<in> cs)\<leadsto>g c) = cs"
  using po_eq_conv by fastforce

(* A chain of partial functions that contains "empty" contains only "empty" *)
lemma part_allempty[simp]: assumes "chain Y" and "Map.empty \<in> range Y"
  shows "(Y i) = Map.empty"
  by (metis assms(1) assms(2) domIff part_dom_eq1 rangeE)

(* ----------------------------------------------------- *)
  subsection \<open>map dom\<close>
(* ----------------------------------------------------- *)

(* "dom" is a monotonic function *)
lemma dom_monofun[simp]: "monofun dom"
  by (simp add: monofunI part_dom_eq)

(* "dom" is a continuous function*)
lemma dom_cont [simp]: "cont dom"
  by (simp add: contI part_dom_lub thelubE)

(* ----------------------------------------------------- *)
  subsection \<open>map add \<close>
(* ----------------------------------------------------- *)

(* Alternative definition of (op ++). In case you don't like "case". *)
lemma mapadd2if_then: "(a ++ b) c = (if (b c)=None then (a c) else (b c))"
  by (simp add: domIff map_add_dom_app_simps(1) map_add_dom_app_simps(3))

(* Show that both sides are monotonic. Used in cont proof. *)
lemma part_add_monofunL[simp]: "monofun  (\<lambda>a. a ++ b)"
  by (smt below_refl fun_below_iff map_add_dom_app_simps(1) map_add_dom_app_simps(3) monofunI part_dom_eq)

lemma part_add_monofunR[simp]: "monofun  (\<lambda>b. a ++ b)"
  by (smt below_refl fun_below_iff map_add_dom_app_simps(1) map_add_dom_app_simps(3) monofunI part_dom_eq)

(* Used in cont proof *)
(* Since the part of the domain that gets mapped to None remains unchanged for any chain Y of partial
   functions, it doesn't matter whether one overrides this part with the function a before or after
   taking the lub. *)
lemma map_add_lessR: fixes Y :: "nat \<Rightarrow> ('a \<rightharpoonup> 'b :: cpo)"
  assumes "chain Y"
  shows "a ++ (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. a ++ Y i)" (is "?L \<sqsubseteq> ?R")
  proof (rule part_below)
    show "dom ?L = dom ?R" by (metis assms dom_map_add monofunE part_add_monofunR part_dom_lub po_class.chain_def)
  next
    fix c
    assume "c\<in> dom ?L"
    thus "the ((a ++ (\<Squnion>i. Y i)) c) \<sqsubseteq> the ((\<Squnion>i. a ++ Y i) c)"
    by (smt assms part_the_lub is_ub_thelub lub_eq map_add_dom_app_simps(1) map_add_dom_app_simps(3) monofunE not_below2not_eq part_add_monofunR part_dom_lub po_class.chain_def)
  qed

lemma map_add_lessL: fixes Y :: "nat \<Rightarrow> ('a \<rightharpoonup> 'b :: cpo)"
  assumes "chain Y"
  shows "(\<Squnion>i. Y i)++a \<sqsubseteq> (\<Squnion>i. Y i ++ a)" (is "?L \<sqsubseteq> ?R")
by (smt assms below_lub dom_map_add lub_eq mapadd2if_then not_below2not_eq part_below part_dom_lub part_the_chain part_the_lub po_class.chain_def)

(* Both sides are continuous *)
lemma part_add_contR [simp]: "cont (\<lambda>b. a ++ b)"
  by (simp add: Cont.contI2 map_add_lessR part_add_monofunR)

lemma part_add_contL [simp]: "cont (\<lambda>a. a ++ b)"
  by (simp add: Cont.contI2 map_add_lessL part_add_monofunL)

(* Adding a to a continuous function b is continuous *)
lemma part_add_cont[simp]: "cont (\<lambda>a . \<Lambda> b . a ++ b)"
  using cont2cont_LAM part_add_contL part_add_contR by blast

(* If the domain of the added function b1 is a subset of b2's domain, the adding leaves b2 unaltered *)
lemma part_add_id [simp]: assumes "dom b1\<subseteq>dom b2" shows "b1 ++ b2 = b2"
  by (metis assms dom_map_add map_le_def map_le_map_add part_eq sup.orderE)

(* ----------------------------------------------------- *)
  subsection \<open>map restrict \<close>
(* ----------------------------------------------------- *)

(* Restricting partial functions with a fixed set cs is monotone *)
lemma part_restrict_monofun[simp]: "monofun (\<lambda>b. b |` cs)"
  by (simp add: fun_belowD fun_belowI monofunI restrict_map_def)

(* Restricting partial functions with a fixed set cs is continuous *)
lemma part_restrict_cont [simp]: "cont (\<lambda>b . b |` cs)"
  proof (rule contI2)
   show "monofun (\<lambda>b. b |` cs)" by (simp add: part_restrict_monofun)
  next
  show "\<forall>Y:: nat \<Rightarrow> ('a \<rightharpoonup> 'b::cpo). chain Y \<longrightarrow> (\<Squnion>i. Y i) |` cs \<sqsubseteq> (\<Squnion>i. Y i |` cs)"
  by (smt domIff eq_imp_below fun_below_iff lub_eq lub_fun part_dom_lub po_class.chain_def restrict_map_def)
qed

(* Restricting x ++ y to a domain cs2 disjoint from dom y results in a restricted x *)
lemma map_union_restrict[simp]: assumes "(dom y)\<inter>cs2 = {}"
  shows "((x ++ y) |` cs2) = x |` cs2"
  apply(rule part_eq)
   apply (simp add: Int_Un_distrib2 assms)
  by (metis assms disjoint_iff_not_equal map_add_dom_app_simps(3) restrict_in restrict_out)

(* Restricting x ++ y to dom y results in y *)
lemma map_union_restrict2[simp]: "(x ++ y) |` dom y = y"
  by (smt Int_absorb1 dom_restrict map_le_def map_le_implies_dom_le map_le_map_add part_eq restrict_in)

(* Up partial functions: Instead of mapping to None, map to Some \<bottom> *)
definition part_up:: "('a \<rightharpoonup> 'b::pcpo) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"part_up f \<equiv> \<lambda> a. if a\<in>dom f then f a else Some \<bottom>"

(* Upping preserves chain properties *)
lemma part_up_chain: assumes "chain Y"
  shows "chain (\<lambda>i. part_up (Y i))"
  by (smt assms part_up_def below_option_def fun_belowD fun_belowI part_dom_eq1 po_class.chain_def)

(* Upping is monotonic *)
lemma part_up_monofun: "monofun part_up"
  by (smt below_option_def fun_belowD fun_belowI monofunI part_dom_eq part_up_def)

(* Upping is continuous *)
lemma part_up_cont: "cont part_up"
  by (smt Cont.contI2 cont2cont_lambda is_ub_thelub lub_eq lub_fun mono2mono_fun part_dom_lub part_up_def part_up_monofun po_eq_conv)

(* Testing Stuff *)

lemma "monofun (\<lambda>s. [c \<mapsto> s])"
  by (simp add: monofun_def part_below)

(* If S is a chain, the sequence of constant total mappings mapping to the resp. elem. in S is too *)
lemma part_map_chain: assumes "chain S" shows "chain (\<lambda>i. [c \<mapsto> S i])"
  by (smt assms dom_empty dom_fun_upd fun_upd_same option.sel option.simps(3) part_below po_class.chain_def singletonD)

(* Stuff used in SPF *)

(* The mapping from empty to empty is continuous *)
lemma part_emptys_cont[simp]: "cont [Map.empty \<mapsto> Map.empty]"
proof (rule contI)
  fix Y:: "nat \<Rightarrow> ('a \<rightharpoonup> 'b)"
  assume chY: "chain Y"
  thus "range (\<lambda>i. [Map.empty \<mapsto> Map.empty] (Y i)) <<| [Map.empty \<mapsto> Map.empty] (\<Squnion>i. Y i)"
  proof (cases "Map.empty \<in> range (Y)")
    case True
    thus ?thesis by (simp add: chY is_lub_maximal lub_maximal part_allempty po_eq_conv rangeI ub_rangeI)
  next
    case False
    hence "\<forall>i. (dom(Y i) \<noteq> {})" by (smt dom_eq_empty_conv rangeI)
    hence "(\<Squnion>i. Y i) \<noteq> Map.empty" by (simp add: chY part_dom_lub)
    thus ?thesis by (smt False fun_upd_apply image_cong image_iff is_lub_const)
  qed
qed

(* Converts a set into an indicator function, returning Some \<bottom> for elements in the set and None otherwise *)
definition optionLeast :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'b :: pcpo)" where
"optionLeast as \<equiv> \<lambda>a. (a\<in>as) \<leadsto> \<bottom>"

(* The domain of the resulting indicator function is defined by the input set *)
lemma optionleast_dom [simp]: "dom(optionLeast cs) = cs"
  by (simp add: optionLeast_def)

(* In all channels "c" in the channel set "cs" flows the stream "\<epsilon>" *)
lemma optionleast_getch [simp]: assumes "c \<in> cs" shows "((optionLeast cs) \<rightharpoonup> c) = \<bottom>"
  by (simp add: assms optionLeast_def)

(* sbLeast returns the smallest stream bundle with the given domain *)
lemma optionleast_least [simp]: assumes "cs = dom b"
  shows "optionLeast cs \<sqsubseteq> b"
  by (metis assms minimal optionleast_dom optionleast_getch part_below)

(* The smallest function with empty domain ist the empty function *)
lemma optionleast_empty: "optionLeast {} = Map.empty"
  by (simp add: optionLeast_def)

(* If sbLeast{} (or empty\<Omega>) is in a chain, all elements are equal *)
lemma optionleast_range: assumes "chain Y" and "optionLeast {} \<in> range Y"
  shows "\<And>i. (Y i) = optionLeast {}"
  by (smt assms(1) assms(2) dom_eq_empty_conv optionleast_dom part_allempty)

(* For non-empty sets, the indicator function's range contains \<bottom> *)
lemma optionLeast_ran [simp]: "cs \<noteq> {} \<Longrightarrow> \<bottom> \<in> ran (optionLeast cs)"
by (meson all_not_in_conv optionLeast_def ranI)

(* The range of the indicator function consists of only \<bottom> *)
lemma optionLeast_ran_2 [simp]: "x \<in> ran (optionLeast cs) \<Longrightarrow> x=\<bottom>"
by (smt domI domIff mem_Collect_eq option.inject optionLeast_def ran_def)

(* The range is not always empty *)
lemma ran_exists: assumes "b\<in>ran f"
  shows "\<exists> d. (f\<rightharpoonup>d) = b"
  by (smt CollectD assms option.sel ran_def)

(* The if-part of the special if-then-else command and the lub are commutative *)
lemma if_then_lub [simp]: assumes "chain Y"
  shows "True\<leadsto>(g\<cdot>(\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. (True)\<leadsto>(g\<cdot>(Y i)))"
  by (smt assms ch2ch_monofun contlub_cfun_arg lub_eq monofun_Rep_cfun2 op_is_lub option.sel option.simps(3) optionLub_def po_class.chain_def po_eq_conv some_below)

lemma if_then_lub2 [simp]: assumes "chain Y" and "cont g"
  shows "True\<leadsto>(g (\<Squnion>i. Y i)) \<sqsubseteq> (\<Squnion>i. (True)\<leadsto>(g (Y i)))"
  by (metis (mono_tags, lifting) Abs_cfun_inverse2 assms(1) assms(2) if_then_lub lub_eq)

(* If x is below y, then any partial functions obtained via the special if-then-else command are too *)
lemma if_then_below[simp]: assumes "x\<sqsubseteq>y"
  shows "(\<lambda>c. (c \<in> A)\<leadsto>g\<cdot>x) \<sqsubseteq> (\<lambda>c. (c \<in> A)\<leadsto>g\<cdot>y)"
  by (simp add: assms below_option_def fun_belowI monofun_cfun_arg)

(* If Y is a chain, then the seq. of part. func. obtained via the special if-then-else comm. are too *)
lemma if_then_chain [simp]: assumes "chain Y"
  shows "chain (\<lambda>i c. (c \<in> A)\<leadsto>g\<cdot>(Y i))"
  by (smt assms below_option_def fun_belowI monofun_cfun_arg option.distinct(1) option.sel po_class.chain_def)

(* Lub does not alter the domain *)
lemma if_then_lubdom [simp]: assumes "chain Y"
  shows "dom (\<Squnion>i. (\<lambda>c. (c \<in> A)\<leadsto>g\<cdot>(Y i))) = A"
  proof -
  have "dom (\<lambda>c. ((c \<in> A)\<leadsto>(g\<cdot>(Y 0)))) = A" by simp
  thus ?thesis
  proof -
  have "chain (\<lambda>n b. (b \<in> A)\<leadsto>g\<cdot>(Y n))"
  using assms if_then_chain by blast
  then show ?thesis
  using \<open>dom (\<lambda>c. (c \<in> A)\<leadsto>g\<cdot>(Y 0)) = A\<close> part_dom_lub by blast
    qed
  qed

lemma if_then_chain2: "chain Y \<Longrightarrow> chain (\<lambda>i.  (\<lambda>c. (c \<in> A)\<leadsto>((Y i) c)))"
  by (simp add: below_fun_def below_option_def po_class.chain_def)

lemma if_then_cont_inner:"(\<And>x y. x\<sqsubseteq>y \<Longrightarrow> P x = P y) \<Longrightarrow> cont (\<lambda>c. (P c)\<leadsto>f\<cdot>c)"
  apply(rule contI2, rule monofunI)
  apply (simp add: domIff monofun_cfun_arg some_below)
  by (smt if_then_lub is_ub_thelub lub_eq po_class.chain_def po_eq_conv)

lemma if_then_cont [simp]: "cont (\<lambda>f.  (\<lambda>c. (c \<in> A)\<leadsto>(f c)))"
  apply(rule contI2, rule monofunI)
  apply (simp add: below_fun_def some_below)
  apply auto
  apply(rule fun_belowI)
  apply auto
  apply (smt ch2ch_fun cont2contlubE contlub_lambda lub_eq not_below2not_eq po_class.chain_def some_below some_cont)
  by (smt below_option_def domIff fun_belowD fun_belowI option.distinct(1) option.sel part_dom_lub po_class.chain_def)

lemma if_then_cont2 [simp]: "cont (\<lambda>f.  (\<lambda>c. (P c)\<leadsto>(f c)))"
proof -
  obtain A where "\<And>c. P c \<longleftrightarrow> c\<in>A"
    by auto
  hence h: "\<And>f. (\<lambda>c. (P c)\<leadsto>(f c)) =  (\<lambda>c. (c \<in> A)\<leadsto>(f c))"
    by simp
  show ?thesis unfolding h by simp
qed

lemma if_then_cont3 [simp]: "cont (\<lambda>f.  (\<lambda>c. (P c)\<leadsto>(f\<cdot>c)))"
proof(rule contI)
  fix Y::"nat \<Rightarrow> 'a \<rightarrow> 'b"
  assume "chain Y"
  obtain K where k_chain: "chain K" and k_def: "\<And>i. K i = Rep_cfun (Y i)"
    by (simp add: \<open>chain (Y::nat \<Rightarrow> 'a \<rightarrow> 'b)\<close> ch2ch_lambda)
  hence k_lub_eq: "(\<Squnion>i. K i) = (Rep_cfun (\<Squnion>i. Y i))"
    proof -
      obtain nn :: "(nat \<Rightarrow> 'b) \<Rightarrow> (nat \<Rightarrow> 'b) \<Rightarrow> nat" where
        "\<forall>f fa. f (nn f fa) \<noteq> fa (nn f fa) \<or> Lub f = Lub fa"
    by moura
      then have "\<forall>a f. Lub f = (\<Squnion>n. Y n\<cdot>a) \<or> f (nn f (\<lambda>n. Y n\<cdot>a)) \<noteq> K (nn f (\<lambda>n. Y n\<cdot>a)) a"
        by (metis \<open>\<And>i::nat. (K::nat \<Rightarrow> 'a \<Rightarrow> 'b) i = Rep_cfun ((Y::nat \<Rightarrow> 'a \<rightarrow> 'b) i)\<close>)
      then have "\<forall>a. Lub Y\<cdot>a = (\<Squnion>n. K n a)"
        by (metis \<open>chain (Y::nat \<Rightarrow> 'a \<rightarrow> 'b)\<close> contlub_cfun_fun)
      then show ?thesis
    by (simp add: \<open>chain (K::nat \<Rightarrow> 'a \<Rightarrow> 'b)\<close> fun_belowI lub_fun po_eq_conv)
qed
  have h1: "range (\<lambda>(i::nat) c::'a. (P c)\<leadsto>((Y i)\<cdot>c)) = range (\<lambda>(i::nat) c::'a. (P c)\<leadsto>((K i)c))"
    using k_def by presburger
  have h2: "(\<lambda>c::'a. (P c)\<leadsto>(\<Squnion>i::nat. Y i)\<cdot>c) = (\<lambda>c::'a. (P c)\<leadsto>(\<Squnion>i::nat. K i)c)"
    using k_lub_eq by auto
  hence "chain K \<Longrightarrow> range (\<lambda>(i::nat) c::'a. (P c)\<leadsto>((K i) c)) <<| (\<lambda>c::'a. (P c)\<leadsto>(\<Squnion>i::nat. K i) c)"
    using contE if_then_cont2 k_chain by blast
  thus "range (\<lambda>(i::nat) c::'a. (P c)\<leadsto>((Y i)\<cdot>c)) <<| (\<lambda>c::'a. (P c)\<leadsto>(\<Squnion>i::nat. Y i)\<cdot>c)"
    by (metis h1 k_chain k_lub_eq)
qed

lemma if_then_mono4 [simp]: "(\<And>x y. x\<sqsubseteq>y \<Longrightarrow> P x = P y) \<Longrightarrow> monofun (\<lambda>f.  (\<Lambda> c. (P c)\<leadsto>(f\<cdot>c)))"
  apply(rule monofunI)
  apply(simp add: below_cfun_def if_then_cont_inner)
  by (simp add: below_option_def fun_belowD fun_belowI)

lemma if_then_cont4 [simp]: "(\<And>x y. x\<sqsubseteq>y \<Longrightarrow> P x = P y) \<Longrightarrow> cont (\<lambda>f.  (\<Lambda> c. (P c)\<leadsto>(f\<cdot>c)))"
  using if_then_cont_inner if_then_mono4
  oops

(* The domain of the special if-then-else command ist determined by the if-clause and vice versa *)
lemma domIff2: "b\<in>dom (\<lambda>b2. ((P b2) \<leadsto> h b2)) \<longleftrightarrow> P b"
  using domIff by force

(* "Some" can be pulled out when applied to a chain *)
lemma some_lub_chain_eq: fixes Y :: "nat \<Rightarrow> 'a::cpo"
            assumes "chain Y"
            shows " Some (\<Squnion> i. Y i) = (\<Squnion> i. Some (Y i))"
  using assms cont2contlubE some_cont by blast

lemma some_lub_chain_eq3: fixes Y :: "nat \<Rightarrow> 'a::cpo"
            assumes "chain Y"
            shows "(\<Squnion> i. Some (Y i)) = Some (\<Squnion> i. Y i)"
 by (simp add: some_lub_chain_eq assms)

(* "Some" can be pulled out when applied to a function which is applied to a chain *)
lemma some_lub_chain_eq2: fixes Y:: "nat \<Rightarrow> 'a::cpo"
             fixes f:: "'a \<Rightarrow> 'b::cpo"
             assumes "chain (\<lambda>i. f (Y i))"
             shows " Some (\<Squnion> i. f (Y i)) = (\<Squnion> i. Some (f (Y i)))"
  using assms(1) some_lub_chain_eq by blast

lemma option_one_cont: "cont (\<lambda>x. [c \<mapsto> f\<cdot>x])"
  apply(rule contI2, rule monofunI)
   apply (simp add: below_option_def fun_belowI monofun_cfun_arg)
  apply (auto simp add: below_fun_def below_option_def)
  apply (smt below_option_def chain_monofun domIff fun_belowI fun_upd_apply option.exhaust_sel part_dom_lub po_class.chain_def some_below)
  apply (simp add: contlub_cfun_arg part_map_chain part_the_lub)
  by (smt below_option_def cont_pref_eq1I domIff fun_belowI fun_upd_apply option.sel option.simps(3) part_dom_lub po_class.chain_def)

subsection \<open>Lub\<close>

(* Two lubs can be merged together if a function F is cont in x for every i *)
lemma cont2lub_lub_eq: assumes cont: "\<And>i. cont (\<lambda>x. F i x)"
  shows "chain Y\<longrightarrow>  (\<Squnion>i. F i (\<Squnion>i. Y i)) = (\<Squnion>i ia. F i (Y ia))"
proof -
  { assume "\<exists>a. (\<Squnion>n. F a (Y n)) \<noteq> F a (Lub Y)"
    have ?thesis
      by (simp add: cont cont2contlubE) }
  thus ?thesis
    by force
qed

(* The lub is not affected by index shift *)
lemma lub_suc_shift: fixes Y:: "nat \<Rightarrow> 'a::cpo" assumes "chain Y"
  shows "(\<Squnion>i. Y (Suc i)) = (\<Squnion>i. Y i)"
proof-
  have f1: "(\<Squnion>i. Y (Suc i)) = (\<Squnion>i. Y (i + 1))"
    by auto
  thus ?thesis
    apply (subst f1)
    by (subst lub_range_shift, simp_all add: assms)
qed

(* Two chain lubs are equal if one is the shifted-by-one version of the other *)
lemma lub_suc_shift_eq: fixes Y:: "nat \<Rightarrow> 'a::cpo" fixes Z:: "nat \<Rightarrow> 'a::cpo"
              assumes "chain Y" and "chain Z"
              and "\<And> i. (Y (Suc i) = Z (Suc (Suc(i))))"
shows "(\<Squnion>i. (Y i)) = (\<Squnion>i. (Z i))"
proof -
  have f1: "(\<Squnion>i. (Y (Suc(i)))) = (\<Squnion>i. (Z i))"
    apply (simp only: assms(3))
    apply (subst lub_suc_shift)
    using assms(2) po_class.chain_def
    apply blast
    by (subst lub_suc_shift, simp_all add: assms)

  have f2: "(\<Squnion>i. Y (Suc i)) = (\<Squnion>i. Y i)"
    by (simp add: assms(1) lub_suc_shift)
  thus ?thesis
    by (simp add: f1)
qed

(* Two interleaved chains have the same least upper bound *)
lemma lub_interl_chain_eq:  fixes Y:: "nat \<Rightarrow> 'a::cpo" fixes Z:: "nat \<Rightarrow> 'a::cpo"
  assumes "\<And> i. Y i \<sqsubseteq> Z i" and "\<And> i. Z i \<sqsubseteq> Y (Suc i)"
  shows "(\<Squnion>i. (Y i)) = (\<Squnion>i. (Z i))"
proof -
  have f1: "(\<Squnion>i. (Y i)) \<sqsubseteq> (\<Squnion>i. (Z i))"
    by (meson assms(1) assms(2) below_trans lub_mono po_class.chain_def)
  moreover
  have f2: "(\<Squnion>i. (Z i)) \<sqsubseteq> (\<Squnion>i. (Y i))"
  proof (rule ccontr)
    assume "\<not> ((\<Squnion>i. (Z i)) \<sqsubseteq> (\<Squnion>i. (Y i)))"
    thus False
      by (meson assms(1) assms(2) below_lub lub_below_iff po_class.chain_def rev_below_trans)
  qed
  ultimately
  show ?thesis
    by (simp add: below_antisym)
qed

(* Lubs are equal if chain index is multiplied (only every m-th element taken into consideration) *)
lemma lub_range_mult:  fixes Y:: "nat \<Rightarrow> 'a::cpo" assumes "chain Y" and "m \<ge> 1"
  shows "(\<Squnion>i. Y (i)) = (\<Squnion>i. Y (m * i))"
proof -
  have f1: "\<forall> (i::nat). i \<le> (m * i)"
    using assms(2) by auto
  have f2: "\<forall> i. Y (i) \<sqsubseteq> Y (m * i)"
    by (simp add: assms(1) f1 po_class.chain_mono)
  have f3: "chain (\<lambda>i. Y (m * i))"
    by (metis (no_types, lifting) Suc_n_not_le_n assms mult.commute nat_le_linear
          nat_mult_le_cancel_disj po_class.chain_def po_class.chain_mono)

  hence "(\<Squnion>i. Y (m * i)) \<sqsubseteq> (\<Squnion>i. Y (i))"
    using assms lub_below_iff by blast
  thus ?thesis
    by (simp only: assms below_antisym f2 f3 lub_mono)
qed

(* Lub equality rule for multiplied indices *)
lemma lub_mult_shift_eq: fixes Y:: "nat \<Rightarrow> 'a::cpo" fixes Z:: "nat \<Rightarrow> 'a::cpo"
  assumes "chain Y" and "chain Z" and "m \<ge> 1"
  and "\<And> i. Y (i) = Z (m * i)"
shows "(\<Squnion>i. (Y i)) = (\<Squnion>i. (Z i))"
  apply (simp only: assms(4))
  using assms(2) assms(3) lub_range_mult by fastforce

lemma lub_mult2_shift_eq: fixes Y:: "nat \<Rightarrow> 'a::cpo" fixes Z:: "nat \<Rightarrow> 'a::cpo"
  assumes "chain Y" and "chain Z"
  and "\<And> i. Y (i) = Z (2 * i)"
shows "(\<Squnion>i. (Y i)) = (\<Squnion>i. (Z i))"
  apply (simp add: assms)
  by (metis assms(2) lub_range_mult one_le_numeral)

(* Copied from the HOLCF library *)

(* Case distinction for chains *)
lemma option_chain_cases:
  assumes Y: "chain Y"
  obtains "Y = (\<lambda>i. None)" | A where "chain A" and "Y = (\<lambda>i. Some (A i))"
 apply (cases "Y 0")
  apply (rule that(1))
  apply (rule ext)
  apply (cut_tac j=i in chain_mono [OF Y le0], simp)
  apply (simp add: below_option_def)
 apply (rule that(2))
  apply (rule ch2ch_monofun [OF op_the_mono Y])
 apply (rule ext)
 apply (cut_tac j=i in chain_mono [OF Y le0], simp)
 apply (case_tac "Y i", simp_all)
  by (simp add: below_option_def)

(* If the lub is x, then all elements in the chain are \<noteq>None and "Some" can be inserted *)
lemma is_lub_Some: "range S <<| x \<Longrightarrow> range (\<lambda>i. Some (S i)) <<| Some x"
 apply (rule is_lubI)
  apply (rule ub_rangeI)
  apply (simp add: is_lubD1 some_below ub_rangeD)
 apply (frule ub_rangeD [where i=arbitrary])
 apply (case_tac u, simp_all)
  apply (simp add: below_option_def)
  by (meson is_lub_def some_below some_below2 ub_rangeD ub_rangeI)

(* Rules for continuity proofs of case distinctions *)
lemma cont2cont_case_option:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h1: "\<And>a. cont (\<lambda>x. h x a)"
  assumes h2: "\<And>x. cont (\<lambda>a. h x a)"
  shows "cont (\<lambda>x. case f x of None \<Rightarrow> g x | Some a \<Rightarrow> h x a)"
apply (rule cont_apply [OF f])
apply (rule contI)
apply (erule option_chain_cases)
apply (simp add: is_lub_const)
  apply (smt cont_def cpo_lubI h2 image_cong is_lub_Some lub_eqI option.simps(5))
apply (case_tac y, simp_all add: g h1)
done

lemma cont2cont_case_option' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h: "cont (\<lambda>p. h (fst p) (snd p))"
  shows "cont (\<lambda>x. case f x of None \<Rightarrow> g x | Some a \<Rightarrow> h x a)"
using assms by (simp add: cont2cont_case_option prod_cont_iff)

subsection \<open>Using option types with Fixrec\<close>

(* Matches None, fails otherwise *)
definition
  "match_None = (\<Lambda> x k. case x of None \<Rightarrow> k | Some a \<Rightarrow> Fixrec.fail)"

(* Matches Some, fails otherwise *)
definition
  "match_Some = (\<Lambda> x k. case x of None \<Rightarrow> Fixrec.fail | Some a \<Rightarrow> k\<cdot>a)"

(* Simp rules for match_None *)
lemma match_None_simps [simp]:
  "match_None\<cdot>None\<cdot>k = k"
  "match_None\<cdot>(Some a)\<cdot>k = Fixrec.fail"
unfolding match_None_def by simp_all

(* Simp rules for match_Some *)
lemma match_Some_simps [simp]:
  "match_Some\<cdot>None\<cdot>k = Fixrec.fail"
  "match_Some\<cdot>(Some a)\<cdot>k = k\<cdot>a"
unfolding match_Some_def by simp_all

(* Setup Fixrec *)
setup \<open>
  Fixrec.add_matchers
    [ (@{const_name None}, @{const_name match_None}),
      (@{const_name Some}, @{const_name match_Some}) ]
\<close>

end


(*  Author:     Tobias Nipkow, 2007  *)

section\<open>Presburger arithmetic\<close>

theory PresArith
imports QE "HOL-Library.ListVector"
begin

declare iprod_assoc[simp]

subsection\<open>Syntax\<close>

datatype atom =
  Le int "int list" | Dvd int int "int list" | NDvd int int "int list"

fun divisor :: "atom \<Rightarrow> int" where
"divisor (Le i ks) = 1" |
"divisor (Dvd d i ks) = d" |
"divisor (NDvd d i ks) = d"

fun neg\<^sub>Z :: "atom \<Rightarrow> atom fm" where
"neg\<^sub>Z (Le i ks) = Atom(Le (1-i) (-ks))" |
"neg\<^sub>Z (Dvd d i ks) = Atom(NDvd d i ks)" |
"neg\<^sub>Z (NDvd d i ks) = Atom(Dvd d i ks)"

fun hd_coeff :: "atom \<Rightarrow> int" where
"hd_coeff (Le i ks) = (case ks of [] \<Rightarrow> 0 | k#_ \<Rightarrow> k)" |
"hd_coeff (Dvd d i ks) = (case ks of [] \<Rightarrow> 0 | k#_ \<Rightarrow> k)" |
"hd_coeff (NDvd d i ks) = (case ks of [] \<Rightarrow> 0 | k#_ \<Rightarrow> k)"

fun decr\<^sub>Z :: "atom \<Rightarrow> atom" where
"decr\<^sub>Z (Le i ks) = Le i (tl ks)" |
"decr\<^sub>Z (Dvd d i ks) = Dvd d i (tl ks)" |
"decr\<^sub>Z (NDvd d i ks) = NDvd d i (tl ks)"

fun I\<^sub>Z :: "atom \<Rightarrow> int list \<Rightarrow> bool" where
"I\<^sub>Z (Le i ks) xs = (i \<le> \<langle>ks,xs\<rangle>)" |
"I\<^sub>Z (Dvd d i ks) xs = (d dvd i+\<langle>ks,xs\<rangle>)" |
"I\<^sub>Z (NDvd d i ks) xs = (\<not> d dvd i+\<langle>ks,xs\<rangle>)"

definition "atoms\<^sub>0 = ATOM.atoms\<^sub>0 (\<lambda>a. hd_coeff a \<noteq> 0)"
(* FIXME !!! (incl: display should hide params)*)

interpretation Z:
  ATOM neg\<^sub>Z "(\<lambda>a. divisor a \<noteq> 0)" I\<^sub>Z "(\<lambda>a. hd_coeff a \<noteq> 0)" decr\<^sub>Z
  rewrites "ATOM.atoms\<^sub>0 (\<lambda>a. hd_coeff a \<noteq> 0) = atoms\<^sub>0"
proof goal_cases
  case 1
  thus ?case
    apply(unfold_locales)
    apply(case_tac a)
    apply simp_all
    apply(case_tac a)
    apply simp_all
    apply(case_tac a)
    apply (simp_all)
    apply arith
    apply(case_tac a)
    apply(simp_all add: split: list.splits)
    apply(case_tac a)
    apply simp_all
    done
next
  case 2
  thus ?case by(simp add:atoms\<^sub>0_def)
qed

setup \<open>Sign.revert_abbrev "" @{const_abbrev Z.I}\<close>
setup \<open>Sign.revert_abbrev "" @{const_abbrev Z.lift_dnf_qe}\<close>
(* FIXME doesn't work*)
(* FIXME does not help
setup {* Sign.revert_abbrev "" @{const_abbrev Z.normal} *}
*)

abbreviation
"hd_coeff_is1 a \<equiv>
  (case a of Le _ _ \<Rightarrow> hd_coeff a \<in> {1,-1} | _ \<Rightarrow> hd_coeff a = 1)"

fun asubst :: "int \<Rightarrow> int list \<Rightarrow> atom \<Rightarrow> atom" where
"asubst i' ks' (Le i (k#ks)) = Le (i - k*i') (k *\<^sub>s ks' + ks)" |
"asubst i' ks' (Dvd d i (k#ks)) = Dvd d (i + k*i') (k *\<^sub>s ks' + ks)" |
"asubst i' ks' (NDvd d i (k#ks)) = NDvd d (i + k*i') (k *\<^sub>s ks' + ks)" |
"asubst i' ks' a = a"

abbreviation subst :: "int \<Rightarrow> int list \<Rightarrow> atom fm \<Rightarrow> atom fm"
where "subst i ks \<equiv> map\<^sub>f\<^sub>m (asubst i ks)"

lemma IZ_asubst: "I\<^sub>Z (asubst i ks a) xs = I\<^sub>Z a ((i + \<langle>ks,xs\<rangle>) # xs)"
apply (cases a)
apply (rename_tac list)
apply (case_tac list)
apply (simp_all add:algebra_simps iprod_left_add_distrib)
apply (rename_tac list)
apply (case_tac list)
apply (simp_all add:algebra_simps iprod_left_add_distrib)
apply (rename_tac list)
apply (case_tac list)
apply (simp_all add:algebra_simps iprod_left_add_distrib)
done

lemma I_subst:
  "qfree \<phi> \<Longrightarrow> Z.I \<phi> ((i + \<langle>ks,xs\<rangle>) # xs) = Z.I (subst i ks \<phi>) xs"
by (induct \<phi>) (simp_all add:IZ_asubst)

lemma divisor_asubst[simp]: "divisor (asubst i ks a) = divisor a"
by(induct i ks a rule:asubst.induct) auto

definition "lbounds as = [(i,ks). Le i (k#ks) \<leftarrow> as, k>0]"
definition "ubounds as = [(i,ks). Le i (k#ks) \<leftarrow> as, k<0]"
lemma set_lbounds:
  "set(lbounds as) = {(i,ks)|i k ks. Le i (k#ks) \<in> set as \<and> k>0}"
by(auto simp: lbounds_def split:list.splits atom.splits if_splits)
lemma set_ubounds:
  "set(ubounds as) = {(i,ks)|i k ks. Le i (k#ks) \<in> set as \<and> k<0}"
by(auto simp: ubounds_def split:list.splits atom.splits if_splits)

lemma lbounds_append[simp]: "lbounds(as @ bs) = lbounds as @ lbounds bs"
by(simp add:lbounds_def)

subsection\<open>LCM and lemmas\<close>

fun zlcms :: "int list \<Rightarrow> int" where
"zlcms [] = 1" |
"zlcms (i#is) = lcm i (zlcms is)"

lemma dvd_zlcms: "i \<in> set is \<Longrightarrow> i dvd zlcms is"
by(induct "is") auto

lemma zlcms_pos: "\<forall>i \<in> set is. i\<noteq>0 \<Longrightarrow> zlcms is > 0"
by(induct "is")(auto simp:lcm_pos_int)

lemma zlcms0_iff[simp]: "(zlcms is = 0) = (0 \<in> set is)"
by (metis mod_by_0 dvd_eq_mod_eq_0 dvd_zlcms zlcms_pos less_le)

lemma elem_le_zlcms: "\<forall>i \<in> set is. i \<noteq> 0 \<Longrightarrow> i \<in> set is \<Longrightarrow> i \<le> zlcms is"
by (metis dvd_zlcms zdvd_imp_le zlcms_pos)

subsection\<open>Setting coeffiencients to 1 or -1\<close>

fun hd_coeff1 :: "int \<Rightarrow> atom \<Rightarrow> atom" where
"hd_coeff1 m (Le i (k#ks)) =
   (if k=0 then Le i (k#ks)
    else let m' = m div (abs k) in Le (m'*i) (sgn k # (m' *\<^sub>s ks)))" |
"hd_coeff1 m (Dvd d i (k#ks)) =
   (if k=0 then Dvd d i (k#ks)
    else let m' = m div k in Dvd (m'*d) (m'*i) (1 # (m' *\<^sub>s ks)))" |
"hd_coeff1 m (NDvd d i (k#ks)) =
   (if k=0 then NDvd d i (k#ks)
    else let m' = m div k in NDvd (m'*d) (m'*i) (1 # (m' *\<^sub>s ks)))" |
"hd_coeff1 _ a = a"

text\<open>The def of @{const hd_coeff1} on @{const Dvd} and @{const NDvd} is
different from the @{const Le} because it allows the resulting head
coefficient to be 1 rather than 1 or -1. We show that the other version has
the same semantics:\<close>

lemma "\<lbrakk> k \<noteq> 0; k dvd m \<rbrakk> \<Longrightarrow>
  I\<^sub>Z (hd_coeff1 m (Dvd d i (k#ks))) (x#e) = (let m' = m div (abs k) in
  I\<^sub>Z (Dvd (m'*d) (m'*i) (sgn k # (m' *\<^sub>s ks))) (x#e))"
apply(auto simp:algebra_simps abs_if sgn_if)
 apply(simp add: zdiv_zminus2_eq_if dvd_eq_mod_eq_0[THEN iffD1] algebra_simps)
 apply (metis diff_conv_add_uminus add.left_commute dvd_minus_iff minus_add_distrib)
apply(simp add: zdiv_zminus2_eq_if dvd_eq_mod_eq_0[THEN iffD1] algebra_simps)
apply (metis diff_conv_add_uminus add.left_commute dvd_minus_iff minus_add_distrib)
done

lemma I_hd_coeff1_mult_a: assumes "m>0"
shows "hd_coeff a dvd m | hd_coeff a = 0 \<Longrightarrow> I\<^sub>Z (hd_coeff1 m a) (m*x#xs) = I\<^sub>Z a (x#xs)"
proof(induct a)
  case [simp]: (Le i ks)
  show ?case
  proof(cases ks)
    case Nil thus ?thesis by simp
  next
    case [simp]: (Cons k ks')
    show ?thesis
    proof cases
      assume "k=0" thus ?thesis by simp
    next
      assume "k\<noteq>0"
      with Le have "\<bar>k\<bar> dvd m" by simp
      let ?m' = "m div \<bar>k\<bar>"
      have "?m' > 0" using \<open>\<bar>k\<bar> dvd m\<close> pos_imp_zdiv_pos_iff \<open>m>0\<close> \<open>k\<noteq>0\<close>
        by(simp add:zdvd_imp_le)
      have 1: "k*(x*?m') = sgn k * x * m"
      proof -
        have "k*(x*?m') = (sgn k * abs k) * (x * ?m')"
          by(simp only: mult_sgn_abs)
        also have "\<dots> = sgn k * x * (abs k * ?m')" by simp
        also have "\<dots> = sgn k * x * m"
          using dvd_mult_div_cancel[OF \<open>\<bar>k\<bar> dvd m\<close>] by(simp add:algebra_simps)
        finally show ?thesis .
      qed
      have "I\<^sub>Z (hd_coeff1 m (Le i ks)) (m*x#xs) \<longleftrightarrow>
            (i*?m' \<le> sgn k * m*x + ?m' * \<langle>ks',xs\<rangle>)"
        using \<open>k\<noteq>0\<close> by(simp add: algebra_simps)
      also have "\<dots> \<longleftrightarrow> ?m'*i \<le> ?m' * (k*x + \<langle>ks',xs\<rangle>)" using 1
        by(simp (no_asm_simp) add:algebra_simps)
      also have "\<dots> \<longleftrightarrow> i \<le> k*x + \<langle>ks',xs\<rangle>" using \<open>?m'>0\<close>
        by simp
      finally show ?thesis by(simp)
    qed
  qed
next
  case [simp]: (Dvd d i ks)
  show ?case
  proof(cases ks)
    case Nil thus ?thesis by simp
  next
    case [simp]: (Cons k ks')
    show ?thesis
    proof cases
      assume "k=0" thus ?thesis by simp
    next
      assume "k\<noteq>0"
      with Dvd have "k dvd m" by simp
      let ?m' = "m div k"
      have "?m' \<noteq> 0" using \<open>k dvd m\<close> zdiv_eq_0_iff \<open>m>0\<close> \<open>k\<noteq>0\<close>
        by(simp add:linorder_not_less zdvd_imp_le)
      have 1: "k*(x*?m') = x * m"
      proof -
        have "k*(x*?m') = x*(k*?m')" by(simp add:algebra_simps)
        also have "\<dots> = x*m" using dvd_mult_div_cancel[OF \<open>k dvd m\<close>]
          by(simp add:algebra_simps)
        finally show ?thesis .
      qed
      have "I\<^sub>Z (hd_coeff1 m (Dvd d i ks)) (m*x#xs) \<longleftrightarrow>
            (?m'*d dvd ?m'*i + m*x + ?m' * \<langle>ks',xs\<rangle>)"
        using \<open>k\<noteq>0\<close> by(simp add: algebra_simps)
      also have "\<dots> \<longleftrightarrow> ?m'*d dvd ?m' * (i + k*x + \<langle>ks',xs\<rangle>)" using 1
        by(simp (no_asm_simp) add:algebra_simps)
      also have "\<dots> \<longleftrightarrow> d dvd i + k*x + \<langle>ks',xs\<rangle>" using \<open>?m'\<noteq>0\<close> by(simp)
      finally show ?thesis by(simp add:algebra_simps)
    qed
  qed
next
  case [simp]: (NDvd d i ks)
  show ?case
  proof(cases ks)
    case Nil thus ?thesis by simp
  next
    case [simp]: (Cons k ks')
    show ?thesis
    proof cases
      assume "k=0" thus ?thesis by simp
    next
      assume "k\<noteq>0"
      with NDvd have "k dvd m" by simp
      let ?m' = "m div k"
      have "?m' \<noteq> 0" using \<open>k dvd m\<close> zdiv_eq_0_iff \<open>m>0\<close> \<open>k\<noteq>0\<close>
        by(simp add:linorder_not_less zdvd_imp_le)
      have 1: "k*(x*?m') = x * m"
      proof -
        have "k*(x*?m') = x*(k*?m')" by(simp add:algebra_simps)
        also have "\<dots> = x*m" using dvd_mult_div_cancel[OF \<open>k dvd m\<close>]
          by(simp add:algebra_simps)
        finally show ?thesis .
      qed
      have "I\<^sub>Z (hd_coeff1 m (NDvd d i ks)) (m*x#xs) \<longleftrightarrow>
            \<not>(?m'*d dvd ?m'*i + m*x + ?m' * \<langle>ks',xs\<rangle>)"
        using \<open>k\<noteq>0\<close> by(simp add: algebra_simps)
      also have "\<dots> \<longleftrightarrow> \<not> ?m'*d dvd ?m' * (i + k*x + \<langle>ks',xs\<rangle>)" using 1
        by(simp (no_asm_simp) add:algebra_simps)
      also have "\<dots> \<longleftrightarrow> \<not> d dvd i + k*x + \<langle>ks',xs\<rangle>" using \<open>?m'\<noteq>0\<close> by(simp)
      finally show ?thesis by(simp add:algebra_simps)
    qed
  qed
qed

lemma I_hd_coeff1_mult: assumes "m>0"
shows "qfree \<phi> \<Longrightarrow> \<forall> a \<in> set(Z.atoms\<^sub>0 \<phi>). hd_coeff a dvd m \<Longrightarrow>
 Z.I (map\<^sub>f\<^sub>m (hd_coeff1 m) \<phi>) (m*x#xs) = Z.I \<phi> (x#xs)"
proof(induct \<phi>)
  case (Atom a)
  thus ?case using I_hd_coeff1_mult_a[OF \<open>m>0\<close>] by auto
qed simp_all

end


theory StoreHeapModel
  imports PredTrans
begin

type_synonym 'a stran = "'a \<times> heap \<Rightarrow> ('a \<times> heap) option"

definition valid_mem :: "'a option \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "in" 100) where
  "x in Q \<equiv> case x of None \<Rightarrow> False | Some y \<Rightarrow> y \<in> Q"

definition basic :: "'a stran \<Rightarrow> 'a ptran" ("\<langle>_\<rangle>") where
  "basic f Q \<equiv> {(s, h). f (s, h) in Q}"

definition assign :: "('v, 's) lval \<Rightarrow> ('s \<Rightarrow>'v) \<Rightarrow> 's ptran" where
  "assign u_upd t \<equiv> \<langle>\<lambda>(s, h). Some (u_upd (\<lambda>_. t s) s, h)\<rangle>"

definition lookup :: "(nat, 's) lval \<Rightarrow> 's nat_exp \<Rightarrow> 's ptran" where
  "lookup u_upd t \<equiv> \<langle>\<lambda>(s, h). if t s \<in> dom h
                              then Some (u_upd (\<lambda>_. the (h (t s))) s, h)
                              else None\<rangle>"

definition mutation :: "'s nat_exp \<Rightarrow> 's nat_exp \<Rightarrow> 's ptran" where
  "mutation e t \<equiv> \<langle>\<lambda>(s, h). if e s \<in> dom h
                            then Some (s, h(e s \<mapsto> t s))
                            else None\<rangle>"

definition alloc :: "(nat, 's) lval \<Rightarrow> 's nat_exp \<Rightarrow> 's ptran" where
  "alloc u_upd t \<equiv> \<langle>\<lambda>(s, h). let N = (SOME n. n \<notin> dom h) in
                    Some (u_upd (\<lambda>_. N) s, h ++ [N \<mapsto> t s])\<rangle>"

definition disposal :: "'s nat_exp \<Rightarrow> 's ptran" where
  "disposal e \<equiv> \<langle>\<lambda>(s, h). if e s \<in> dom h
                         then Some (s, h(e s := None))
                         else None\<rangle>"

(***********************************************************************************************)

(* Monotonic *)

lemma mono_basic [mptran]: "mono (basic f)"
  apply (auto simp: mono_def basic_def valid_mem_def)
  apply (case_tac "f(a, b)")
  apply force+
done

lemma mono_assign [mptran]: "mono (assign u t)"
  by (auto simp: assign_def intro: mptran)

lemma mono_lookup [mptran]: "mono (lookup u t)"
  by (auto simp: lookup_def intro: mptran)

lemma mono_mutation [mptran]: "mono (mutation e t)"
  by (auto simp: mutation_def intro: mptran)

lemma mono_alloc [mptran]: "mono (alloc u t)"
  by (auto simp: alloc_def intro: mptran)

lemma mono_disposal [mptran]: "mono (disposal e)"
  by (auto simp: disposal_def intro: mptran)

(***********************************************************************************************)

(* Locality *)

definition basic_local :: "'a stran \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "basic_local f R \<equiv> \<forall>s h1 h2 Q. h1 \<bottom> h2 \<and> f (s, h1) in Q \<and> (s, h2) \<in> R \<longrightarrow> f(s, h1 ++ h2) in (Q * R)"

lemma local_eq: "local (basic f) R \<longleftrightarrow> basic_local f R"
  by (force simp: local_def basic_local_def basic_def sep_def)

lemma local_assign: "free_pred v R \<Longrightarrow> local (assign v t) R"
  by (force simp: subst_pred_def local_eq basic_local_def assign_def basic_def sep_def valid_mem_def)

lemma local_lookup [lptran]: "free_pred u R \<Longrightarrow> local (lookup u t) R"
  apply (auto simp: local_eq basic_local_def lookup_def basic_def sep_def valid_mem_def)
  apply (rule_tac x=h1 in exI)
  apply (rule_tac x=h2 in exI)
  apply (subgoal_tac "the ((h1 ++ h2) (t s)) = y")
  apply (force simp: subst_pred_def)
  by (simp add: heap_divider)

lemma local_mutation [lptran]: "local (mutation e t) R"
  apply (auto simp: local_eq basic_local_def mutation_def basic_def sep_def valid_mem_def)
  apply (rule_tac x="h1(e s \<mapsto> t s)" in exI)
  apply (rule_tac x=h2 in exI)
  apply auto
  apply (metis (no_types, lifting) dom_fun_upd fun_upd_triv map_add_comm map_add_upd option.distinct(1) ortho_def)
  apply (auto simp: ortho_def)
done

lemma "dom h \<noteq> UNIV \<Longrightarrow> \<exists>n. n \<notin> dom h"
  apply auto
done

lemma local_alloc [lptran]: "\<forall>h. \<exists>n. n \<notin> dom h \<Longrightarrow> local (alloc u t) R"
  apply (simp add: alloc_def local_eq basic_local_def)
  apply auto
oops

lemma local_disposal [lptran]: "local (disposal e) R"
  apply (simp add: disposal_def local_def ortho_def sep_def basic_def valid_mem_def)
  apply auto
  apply (erule_tac x="h1(e s := None)" in allE)
  apply auto
  apply (erule_tac x="h2" in allE)
  apply auto
  apply (auto simp: map_add_def)
  apply (erule notE)
  apply (rule ext)
  apply auto
  apply (metis disjoint_iff_not_equal domI domIff fun_upd_apply option.case_eq_if)
  by (metis fun_upd_apply)

(***********************************************************************************************)

(* Separation Logic *)

lemma hl_basic [sl]: "P \<subseteq> {s. f s in Q} \<Longrightarrow> ht P (basic f) Q"
  by (auto simp: ht_def basic_def seq_def)

lemma hl_assign [sl]: "P \<subseteq> subst_pred Q z_upd t \<Longrightarrow> ht P (assign z_upd t) Q"
  by (auto simp: assign_def subst_pred_def valid_mem_def intro!: sl)

(* Mutation *)

lemma sl_mut_local [sl]: "ht (e \<mapsto> -) (mutation e e') (e \<mapsto> e')"
  by (auto simp: mutation_def valid_mem_def any_singleton_def singleton_def intro!: sl)

lemma sl_mut_local' [sl]: "ht (e \<mapsto> n) (mutation e e') (e \<mapsto> e')"
  by (auto simp: mutation_def valid_mem_def any_singleton_def singleton_def intro!: sl)

lemma sl_mut_global [sl]: "ht ((e \<mapsto> -) * r) (mutation e e') ((e \<mapsto> e') * r)"
  by (auto intro: sl lptran sl_frame)

lemma sl_mut_global' [sl]: "ht ((e \<mapsto> n) * r) (mutation e e') ((e \<mapsto> e') * r)"
  by (auto intro: sl lptran sl_frame)

lemma sl_mut: "ht ((e \<mapsto> -) * ((e \<mapsto> e') -* r)) (mutation e e') r"
  apply (rule hl_post[where Q'="(e \<mapsto> e') * ((e \<mapsto> e') -* r)"])
  by (auto simp: Assertions.bbi.sep_impl_annil1 intro!: sl_mut_global mptran)

lemma sl_mut_suc [sl]: "ht (v \<mapsto> a, b) (mutation (\<lambda>s. v s + 1) e) (v \<mapsto> a, e)"
  by (auto simp add: doublet_def intro: sl_frame2 lptran sl)

(* Allocation *)

lemma sl_alloc_local [sl]: "free u_upd e \<Longrightarrow> vars1 u_upd u \<Longrightarrow> ht emp (alloc u_upd e) (u \<mapsto> e)"
  apply (auto simp: alloc_def emp_def valid_mem_def singleton_def intro!: sl)
  apply (case_tac "let N = SOME n. True in Some (u_upd (\<lambda>_. N) a, [N \<mapsto> e a])")
  apply (metis option.distinct(1))
  apply (auto simp add: Let_unfold)
done

(* Disposal *)

lemma sl_dipose_local [sl]: "ht (e \<mapsto> -) (disposal e) (emp)"
  by (auto simp: disposal_def singleton_def valid_mem_def any_singleton_def emp_def intro!: sl)

lemma sl_disposal [sl]: "ht ((e \<mapsto> -) * r) (disposal e) r"
  by (subst bbi.mult_1[symmetric], (rule sl | rule lptran | rule sl_frame)+)

lemma sl_disposal_alt [sl]: "ht ((e \<mapsto> n) * r) (disposal e) r"
  apply (rule hl_pre)
  defer
  apply (rule sl_disposal)
  apply (rule bbi.qiso)
  by (auto simp: any_singleton_def singleton_def)

(* Lookup *)

lemma sl_lookup_local: "vars2 v_upd v v' \<Longrightarrow> vars3 v_upd v' \<Longrightarrow> free v_upd e \<Longrightarrow>
    ht (e \<mapsto> v') (lookup v_upd e) ((v \<Midarrow> v') \<sqinter> (e \<mapsto> v'))"
  by (auto simp: lookup_def valid_mem_def singleton_def intro!: sl)

lemma sl_lookup_lkl: "vars1 v_upd v \<Longrightarrow> vars3 v_upd v'' \<Longrightarrow> free v_upd e \<Longrightarrow>
    ht ((v \<Midarrow> v') \<sqinter> (e \<mapsto> v'')) (lookup v_upd e) ((v \<Midarrow> v'') \<sqinter> (subst e v_upd v' \<mapsto> v))"
  by (auto simp: lookup_def valid_mem_def singleton_def intro!: sl)

lemma sl_lookup: "ht (EXS v'. (e \<mapsto> v') * ((e \<mapsto> v') -* (subst_pred r v_upd v'))) (lookup v_upd e) r"
  apply (auto simp: lookup_def intro!: sl)
  apply (subgoal_tac "(a, b) \<in> subst_pred r v_upd x")
  prefer 2
  using bbi.sep_impl_annil1 apply blast
  apply (auto simp: subst_pred_def)
  apply (clarsimp simp: valid_mem_def)
  prefer 2
  apply (clarsimp simp: valid_mem_def)
  apply (clarsimp simp: sep_def singleton_def)
  apply (rule_tac x="x a" in exI)
  apply (simp add: heap_divider)
  apply (subgoal_tac "y = x a")
  apply simp
  apply (clarsimp simp: sep_def singleton_def)
  apply auto
  by (simp add: domI ortho_def)

lemma sl_lookup': "ht (EXS v'. (e \<mapsto> $v') * ((e \<mapsto> $v') -* (subst_pred r v_upd $v'))) (lookup v_upd e) r"
  apply (auto simp: lookup_def intro!: sl)
  apply (subgoal_tac "(a, b) \<in> subst_pred r v_upd $x")
  prefer 2
  using bbi.sep_impl_annil1 apply blast
  apply (auto simp: subst_pred_def)
  apply (clarsimp simp: valid_mem_def)
  prefer 2
  apply (clarsimp simp: valid_mem_def)
  apply (clarsimp simp: sep_def singleton_def)
  apply (rule_tac x="x" in exI)
  apply (simp add: heap_divider)
  apply (subgoal_tac "y = x")
  apply simp
  apply (clarsimp simp: sep_def singleton_def)
  apply auto
  by (simp add: domI ortho_def)

lemma sl_lookup_alt: "ht (EXS v'. (e \<hookrightarrow> v') \<sqinter> (subst_pred r v_upd v')) (lookup v_upd e) r"
  apply (rule hl_pre)
  prefer 2
  apply (rule sl_lookup)
  apply (rule Collect_mono)
  apply (rule impI)
  apply (erule exE)
  apply (rule_tac x=xa in exI)
  apply (rule impE)
  prefer 2
  apply assumption
  prefer 2
  apply assumption
  apply (rule in_mono)
  apply (rule reynolds6)
done

lemma sl_lookup_alt' [sl]: "ht (EXS v'. (e \<hookrightarrow> $v') \<sqinter> (subst_pred r v_upd $v')) (lookup v_upd e) r"
  apply (rule hl_pre)
  prefer 2
  apply (rule sl_lookup)
  apply (rule Collect_mono)
  apply (rule impI)
  apply (erule exE)
  apply (rule_tac x="$xa" in exI)
  apply (rule impE)
  prefer 2
  apply assumption
  prefer 2
  apply assumption
  apply (rule in_mono)
  apply (rule reynolds6)
done

lemma sl_lookup_var: "p \<subseteq> (EXS v'. (e \<hookrightarrow> $v') \<sqinter> (subst_pred q v_upd $v')) \<Longrightarrow> ht p (lookup v_upd e) q"
  apply (rule hl_pre)
  apply assumption
  apply (rule sl_lookup_alt')
done

lemma lookup_suc_ref [sl]:"\<forall>x s. v (k_upd (\<lambda>_. x) s) = v s \<Longrightarrow> \<forall>x s. k (k_upd (\<lambda>_. x) s) = x \<Longrightarrow>
  \<forall>x. subst_pred (R k) k_upd (\<lambda>_. x) = R (\<lambda>_. x) \<Longrightarrow>
  ht (EXS x. (v \<mapsto> (\<lambda>_. a), (\<lambda>_. x)) * R (\<lambda>_. x)) (lookup k_upd (\<lambda>s. v s + 1)) ((v \<mapsto> (\<lambda>_. a), k) * R k)"
  apply (rule hl_classic)
  apply (rule mptran)+
  defer
  defer
  apply (rule sl_lookup_alt')
  defer
  apply (rule subset_refl)
  apply (rule mono_exs)
  apply (simp add: doublet_def)
  apply (rule conjI)
  apply (simp add: points_to_def)
  apply (metis (no_types, lifting) Assertions.bbi.intuitionistic_sep_conj_top Assertions.bbi.intuitionistic_sep_impl_closure Assertions.bbi.intuitionistic_top Assertions.bbi.sep_impl_annir2 Assertions.bbi.sep_impl_isoE Assertions.bbi.sep_impl_top_x Assertions.bbi.strongest_intuitionistic sep_comm top_greatest)
  apply (subst spred)+
  apply simp
done

lemma lookup_suc_ref':"\<forall>x s. v (k_upd (\<lambda>_. x) s) = v s \<Longrightarrow> \<forall>x s. k (k_upd (\<lambda>_. x) s) = x \<Longrightarrow>
  \<forall>x. subst_pred (R k) k_upd (\<lambda>_. x) = R (\<lambda>_. x) \<Longrightarrow>
  ht (EXS x. (v \<mapsto> (\<lambda>_. a), (\<lambda>_. x)) * R (\<lambda>_. x)) (lookup k_upd (\<lambda>s. v s + 1)) ((v \<mapsto> -) * (((\<lambda>s. v s + 1) \<mapsto> -) * R k))"
  apply (rule hl_classic)
  apply (rule mptran)+
  defer
  defer
  apply (rule sl_lookup_alt')
  defer
  apply (rule subset_refl)
  apply (rule mono_exs)
  apply (simp add: doublet_def)
  apply (rule conjI)
  apply (simp add: points_to_def)
  apply (metis (no_types, lifting) Assertions.bbi.intuitionistic_sep_conj_top Assertions.bbi.intuitionistic_sep_impl_closure Assertions.bbi.intuitionistic_top Assertions.bbi.sep_impl_annir2 Assertions.bbi.sep_impl_isoE Assertions.bbi.sep_impl_top_x Assertions.bbi.strongest_intuitionistic sep_comm top_greatest)
  apply (subst spred)+
  apply simp
  apply sep_auto
done

lemma lookup_suc_var_ref [sl]:"\<forall>x s. v (k_upd (\<lambda>_. x) s) = v s \<Longrightarrow> \<forall>x s. k (k_upd (\<lambda>_. x) s) = x \<Longrightarrow>
  \<forall>x. subst_pred (R k) k_upd (\<lambda>_. x) = R (\<lambda>_. x) \<Longrightarrow> P \<le> (EXS x. (v \<mapsto> (\<lambda>_. a), (\<lambda>_. x)) * R (\<lambda>_. x)) \<Longrightarrow>
  ht P (lookup k_upd (\<lambda>s. v s + 1)) ((v \<mapsto> -) * (((\<lambda>s. v s + 1) \<mapsto> -) * R k))"
  apply (rule hl_pre)
  defer
  apply (rule lookup_suc_ref')
  apply simp+
done

no_notation basic ("\<langle>_\<rangle>")

(***********************************************************************************************)

(* Hoare tactic *)

named_theorems hl_rules

method hoare_init uses simp =
  ((subst simp | subst fst_conv | subst snd_conv)+)?

method hoare_step uses simp hl =
  (hoare_init simp: simp, (assumption | rule subset_refl | rule mptran  | rule lptran | rule hl sl | rule allI | rule ballI | subst sep_assoc | rule hl_exs2))

method hoare_ind uses simp hl =
  (hoare_step simp: simp hl: hl; (hoare_ind simp: simp hl: hl)?)+

method hoare uses simp hl =
  (hoare_init simp: simp; (hoare_ind simp: simp hl: hl)?)

method hl_aux uses rule =
  (rule allI, rule rule; ((erule_tac x=u in allE)+, assumption))

end