theory prop_56
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster plus drop *)

(*hipster drop*)
lemma lemma_a []: "drop x3 Nil2 = Nil2"
by (hipster_induct_schemes drop.simps)

lemma lemma_aa [thy_expl]: "drop (S Z) (drop x3 y3) = drop (S x3) y3"
by (hipster_induct_schemes drop.simps)

lemma unknown []: "drop x (drop y z) = drop y (drop x z)"
oops

lemma unknown []: "drop (S x) (drop y z) = drop (S y) (drop x z)"
oops

  theorem x0 :
    "(drop n (drop m xs)) = (drop (plus n m) xs)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory SINVAR_Sink
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Sink (IFS)*}

datatype node_config = Sink | SinkPool | Unassigned

definition default_node_properties :: "node_config"
  where  "default_node_properties = Unassigned"

fun allowed_sink_flow :: "node_config \<Rightarrow> node_config \<Rightarrow> bool" where
  "allowed_sink_flow Sink _ = False" |
  "allowed_sink_flow SinkPool SinkPool = True" |
  "allowed_sink_flow SinkPool Sink = True" |
  "allowed_sink_flow SinkPool _ = False" |
  "allowed_sink_flow Unassigned _ = True"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. e1 \<noteq> e2 \<longrightarrow> allowed_sink_flow (nP e1) (nP e2))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation = True"

subsubsection {*Preliminaries*}

subsubsection{*ENF*}
  lemma Sink_ENFnr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl sinvar allowed_sink_flow"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_def)
  lemma Unassigned_to_All: "\<forall> e2. allowed_sink_flow Unassigned e2"
    by (rule allI, case_tac e2, simp_all)
  lemma Unassigned_default_candidate: "\<forall> e1 e2. \<not> allowed_sink_flow e1 e2 \<longrightarrow> \<not> allowed_sink_flow e1 Unassigned"
    apply(rule allI)+
    apply(case_tac "e2")
      apply simp_all
     apply(case_tac "e1")
       apply simp_all
    apply(case_tac "e1")
      apply simp_all
    done

  definition Sink_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "Sink_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 \<noteq> e2 \<and> \<not> allowed_sink_flow (nP e1) (nP e2)} })"
  lemma Sink_offending_set:
  "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Sink_offending_set"
    apply(simp only: fun_eq_iff ENFnr_offending_set[OF Sink_ENFnr] Sink_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation Sink: SecurityInvariant_IFS
where default_node_properties = default_node_properties
and sinvar = sinvar
and verify_globals = verify_globals
where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Sink_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule SecurityInvariant_withOffendingFlows.ENFnr_snds_weakrefl_instance[OF Sink_ENFnr Unassigned_default_candidate Unassigned_to_All])
     apply(simp_all)[2]

   apply(erule default_uniqueness_by_counterexample_IFS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: split_split_asm split_split)
   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: valid_graph_def)
    apply(case_tac otherbot, simp_all)
    apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := SinkPool, vertex_2 := Unassigned)" in exI, simp)
    apply(rule_tac x="vertex_2" in exI, simp)
    apply(rule_tac x="{(vertex_1, vertex_2)}" in exI, simp)
   apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := SinkPool, vertex_2 := Unassigned)" in exI, simp)
   apply(rule_tac x="vertex_2" in exI, simp)
   apply(rule_tac x="{(vertex_1, vertex_2)}" in exI, simp)

  apply(fact Sink_offending_set)
  done

  lemma TopoS_Sink: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


theory NegInfinityUni
  imports UniAtoms NegInfinity QE
begin

fun allZero' :: "real * real * real \<Rightarrow> atomUni fmUni" where
  "allZero' (a,b,c) = AndUni(AndUni(AtomUni(EqUni(0,0,a))) (AtomUni(EqUni(0,0,b)))) (AtomUni(EqUni(0,0,c)))"

lemma convert_allZero :
  assumes "convert_poly var p (xs'@x#xs) = Some p'"
  assumes "length xs' = var"
  shows "eval (allZero p var) (xs'@x#xs) = evalUni (allZero' p') x"
proof(cases p')
  case (fields a b c)
  then show ?thesis proof(cases "MPoly_Type.degree p var = 0")
    case True
    then show ?thesis
      using assms fields
      by(simp add:eval_list_conj isovar_greater_degree)
  next
    case False
    then have nonzero : "MPoly_Type.degree p var \<noteq> 0" by auto
    then show ?thesis
    proof(cases "MPoly_Type.degree p var = 1")
      case True
      then show ?thesis
        using assms fields
        apply(simp add:eval_list_conj isovar_greater_degree)
        by (metis)
    next
      case False
      then have degree2 : "MPoly_Type.degree p var = 2" using degree_convert_eq[OF assms(1)] nonzero by auto
      then show ?thesis
        using assms
        apply(simp add:eval_list_conj isovar_greater_degree)
        using insertion_isovarspars_free list_update_code(2)
        apply auto
        by (metis One_nat_def Suc_1 less_2_cases less_Suc_eq numeral_3_eq_3)
    qed
  qed
qed

fun alternateNegInfinity' :: "real * real * real \<Rightarrow> atomUni fmUni" where
  "alternateNegInfinity' (a,b,c) =
OrUni(AtomUni(LessUni(0,0,a)))(
AndUni(AtomUni(EqUni(0,0,a))) (
  OrUni(AtomUni(LessUni(0,0,-b)))(
  AndUni(AtomUni(EqUni(0,0,b)))(
    AtomUni(LessUni(0,0,c))
  ))
))
"

lemma convert_alternateNegInfinity :
  assumes "convert_poly var p (xs'@x#xs) = Some X"
  assumes "length xs' = var"
  shows "eval (alternateNegInfinity p var) (xs'@x#xs) = evalUni (alternateNegInfinity' X) x"
proof(cases X)
  case (fields a b c)
  then show ?thesis proof(cases "MPoly_Type.degree p var = 0")
    case True
    then show ?thesis
      using assms
      apply (simp add: isovar_greater_degree)
      apply auto
      apply (metis aEval.simps(2) eval.simps(1) eval_and eval_false eval_or  mult_one_left)
      by (metis aEval.simps(2) eval.simps(1) eval_or  mult_one_left)
  next
    case False
    then have nonzero : "MPoly_Type.degree p var \<noteq> 0" by auto
    then show ?thesis
    proof(cases "MPoly_Type.degree p var = 1")
      case True
      have letbind: "eval
     (let a_n = isolate_variable_sparse p var (Suc 0)
      in or (fm.Atom (Less (Const (- 1) * a_n)))
          (and (fm.Atom (Eq a_n))
            (let a_n = isolate_variable_sparse p var 0
             in or (fm.Atom (Less (Const 1 * a_n))) (and (fm.Atom (Eq a_n)) FalseF))))
     (xs'@x#xs) =
    eval
     (or (fm.Atom (Less (Const (- 1) * (isolate_variable_sparse p var (Suc 0)))))
          (and (fm.Atom (Eq (isolate_variable_sparse p var (Suc 0))))
            (or (fm.Atom (Less (Const 1 * (isolate_variable_sparse p var 0)))) (and (fm.Atom (Eq (isolate_variable_sparse p var 0))) FalseF))))
     (xs'@x#xs)"
        by meson
      show ?thesis
        using assms True unfolding fields
        by (simp add: isovar_greater_degree letbind eval_or eval_and insertion_mult insertion_const)
    next
      case False
      then have degree2 : "MPoly_Type.degree p var = 2" using degree_convert_eq[OF assms(1)] nonzero by auto
      have "[0..<3] = [0,1,2]"
        by (simp add: upt_rec)
      then have unfold : " (foldl
       (\<lambda>F i. let a_n = isolate_variable_sparse p var i
               in or (fm.Atom (Less ((if i mod 2 = 0 then Const 1 else Const (- 1)) * a_n)))
                   (and (fm.Atom (Eq a_n)) F))
       FalseF [0..<3]) =
     (let a_n = isolate_variable_sparse p var 2
               in or (fm.Atom (Less ((Const 1) * a_n)))
                   (and (fm.Atom (Eq a_n))
       (let a_n = isolate_variable_sparse p var (Suc 0)
      in or (fm.Atom (Less (Const (- 1) * a_n)))
          (and (fm.Atom (Eq a_n))
            (let a_n = isolate_variable_sparse p var 0
             in or (fm.Atom (Less (Const 1 * a_n))) (and (fm.Atom (Eq a_n)) FalseF))))))"
        by auto
      have letbind : "eval
     (foldl
       (\<lambda>F i. let a_n = isolate_variable_sparse p var i
               in or (fm.Atom (Less ((if i mod 2 = 0 then Const 1 else Const (- 1)) * a_n)))
                   (and (fm.Atom (Eq a_n)) F))
       FalseF [0..<3]) (xs'@x#xs) =
      eval

(or (fm.Atom (Less ( Const 1 * (isolate_variable_sparse p var 2))))
                   (and (fm.Atom (Eq (isolate_variable_sparse p var 2)))
(or (fm.Atom (Less (Const (- 1) * (isolate_variable_sparse p var (Suc 0)))))
          (and (fm.Atom (Eq (isolate_variable_sparse p var (Suc 0))))
            (or (fm.Atom (Less (Const 1 * (isolate_variable_sparse p var 0)))) (and (fm.Atom (Eq (isolate_variable_sparse p var 0))) FalseF))))))
(xs'@x#xs)" apply (simp add:unfold) by metis
      show ?thesis
        using degree2 assms unfolding fields by (simp add: isovar_greater_degree eval_or eval_and letbind insertion_mult insertion_const)
    qed
  qed
qed

fun substNegInfinityUni :: "atomUni \<Rightarrow> atomUni fmUni" where
  "substNegInfinityUni (EqUni p) = allZero' p " |
  "substNegInfinityUni (LessUni p) = alternateNegInfinity' p"|
  "substNegInfinityUni (LeqUni p) = OrUni (alternateNegInfinity' p) (allZero' p)"|
  "substNegInfinityUni (NeqUni p) = negUni (allZero' p)"

lemma convert_substNegInfinity :
  assumes "convert_atom var A (xs'@x#xs) = Some(A')"
  assumes "length xs' = var"
  shows "eval (substNegInfinity var A) (xs'@x#xs) = evalUni (substNegInfinityUni A') x"
  using assms
proof(cases A)
  case (Less p)
  have "\<exists>X. convert_poly var p (xs' @ x # xs) = Some X" using assms Less apply(cases "MPoly_Type.degree p var < 3") by (simp_all)
  then obtain X where X_def: "convert_poly var p (xs' @ x # xs) = Some X" by auto
  then have A' : "A' = LessUni X" using assms Less apply(cases "MPoly_Type.degree p var < 3") by (simp_all)
  show ?thesis unfolding Less substNegInfinity.simps
    unfolding convert_alternateNegInfinity[OF X_def assms(2)] A'
    apply(cases X) by simp
next
  case (Eq p)
  then show ?thesis using assms convert_allZero by auto
next
  case (Leq p)
  define p' where "p' = (case convert_poly var p (xs'@x#xs) of Some p' \<Rightarrow> p')"
  have A'_simp :  "A' = LeqUni p'"
    using assms Leq
    using p'_def by auto
  have allZ : "eval (allZero p var) (xs'@x#xs) = evalUni (allZero' p') x" using convert_allZero
    using Leq assms p'_def by auto
  have altNeg : "eval (alternateNegInfinity p var) (xs'@x#xs) = evalUni (alternateNegInfinity' p') x" using convert_alternateNegInfinity
    using Leq assms p'_def by auto
  show ?thesis
    unfolding Leq substNegInfinity.simps eval_Or A'_simp substNegInfinityUni.simps evalUni.simps
    using allZ altNeg by auto
next
  case (Neq p)
  then show ?thesis using assms convert_allZero convert_neg by auto
qed

lemma change_eval_eq:
  fixes x y:: "real"
  assumes "((aEvalUni (EqUni(a,b,c)) x \<noteq> aEvalUni (EqUni(a,b,c)) y) \<and> x < y)"
  shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
  using assms by auto
lemma change_eval_lt:
  fixes x y:: "real"
  assumes "((aEvalUni (LessUni (a,b,c)) x \<noteq> aEvalUni (LessUni (a,b,c)) y) \<and> x < y)"
  shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
proof -
  let ?p = "[:c, b, a:]"
  have "sign ?p x \<noteq> sign ?p y"
    using assms unfolding sign_def
    apply (simp add: distrib_left mult.commute mult.left_commute power2_eq_square)
    by linarith
  then have "(\<exists>w \<in> (root_list ?p). x \<le> w \<and> w \<le> y)" using changes_sign
      assms by auto
  then obtain w where w_prop: "w \<in> (root_list ?p) \<and> x \<le> w \<and> w \<le> y" by auto
  then have "a*w^2 + b*w + c = 0" unfolding root_list_def
    using add.commute distrib_right mult.assoc mult.commute power2_eq_square
    using quadratic_poly_eval by force
  then show ?thesis using w_prop by auto
qed

lemma no_change_eval_lt:
  fixes x y:: "real"
  assumes "x < y"
  assumes "\<not>(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
  shows "((aEvalUni (LessUni (a,b,c)) x = aEvalUni (LessUni (a,b,c)) y))"
  using change_eval_lt
  using assms(1) assms(2) by blast

lemma change_eval_neq:
  fixes x y:: "real"
  assumes "((aEvalUni (NeqUni (a,b,c)) x \<noteq> aEvalUni (NeqUni (a,b,c)) y) \<and> x < y)"
  shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
  using assms by auto

lemma change_eval_leq:
  fixes x y:: "real"
  assumes "((aEvalUni (LeqUni (a,b,c)) x \<noteq> aEvalUni (LeqUni (a,b,c)) y) \<and> x < y)"
  shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
proof -
  let ?p = "[:c, b, a:]"
  have "sign ?p x \<noteq> sign ?p y"
    using assms unfolding sign_def
    apply (simp add: distrib_left mult.commute mult.left_commute power2_eq_square)
    by linarith
  then have "(\<exists>w \<in> (root_list ?p). x \<le> w \<and> w \<le> y)" using changes_sign
      assms by auto
  then obtain w where w_prop: "w \<in> (root_list ?p) \<and> x \<le> w \<and> w \<le> y" by auto
  then have "a*w^2 + b*w + c = 0" unfolding root_list_def
    using add.commute distrib_right mult.assoc mult.commute power2_eq_square
    using quadratic_poly_eval by force
  then show ?thesis using w_prop by auto
qed

lemma change_eval:
  fixes x y:: "real"
  fixes At:: "atomUni"
  assumes xlt: "x < y"
  assumes noteq: "((aEvalUni At) x \<noteq> aEvalUni (At) y)"
  assumes "getPoly At = (a, b, c)"
  shows "(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
proof -
  have four_types: "At = (EqUni (a,b,c)) \<or> At = (LessUni (a,b,c)) \<or> At = (LeqUni (a,b,c)) \<or> At = (NeqUni (a,b,c))"
    using getPoly.elims assms(3) by force
  have eq_h: "At = (EqUni (a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
    using assms(1) assms(2) change_eval_eq
    by blast
  have less_h: "At = (LessUni(a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
    using change_eval_lt assms
    by blast
  have leq_h: "At = (LeqUni(a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
    using change_eval_leq assms
    by blast
  have neq_h: "At = (NeqUni(a,b,c)) \<longrightarrow> (\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
    using change_eval_neq assms
    by blast
  show ?thesis
    using four_types eq_h less_h leq_h neq_h
    by blast
qed

lemma no_change_eval:
  fixes x y:: "real"
  assumes "getPoly At = (a, b, c)"
  assumes "x < y"
  assumes "\<not>(\<exists>w. x \<le> w \<and> w \<le> y \<and> a*w^2 + b*w + c = 0)"
  shows  "((aEvalUni At) x = aEvalUni (At) y \<and> x < y)"
  using change_eval
  using assms(1) assms(2) assms(3) by blast

lemma same_eval'' :
  assumes "getPoly At = (a, b, c)"
  assumes nonz: "a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0"
  shows "\<exists>x. \<forall>y<x. (aEvalUni At y = aEvalUni At x)"
proof -
  let ?p = "[:c, b, a:]"
  have poly_eval: "\<forall>y. poly ?p y = a*y^2 + b*y + c"
    by (simp add: distrib_left power2_eq_square)
  have "?p \<noteq> 0" using nonz by auto
  then have "finite {y. poly ?p y = 0}"
    using poly_roots_finite
    by blast
  then have "finite {y. c + (a * y\<^sup>2 + b * y) = 0} \<Longrightarrow>
    \<forall>y. y * (b + y * a) = a * y\<^sup>2 + b * y \<Longrightarrow>
    finite {y. a * y\<^sup>2 + b * y + c = 0}"
  proof -
    assume a1: "finite {y. c + (a * y\<^sup>2 + b * y) = 0}"
    have "\<forall>x0. c + (a * x0\<^sup>2 + b * x0) = a * x0\<^sup>2 + b * x0 + c"
      by simp
    then show ?thesis
      using a1 by presburger
  qed
  then have finset: "finite {y. a*y^2 + b*y + c = 0}"
    using poly_eval
    by (metis \<open>finite {y. poly [:c, b, a:] y = 0}\<close> poly_roots_set_same)
  then have "\<exists>x. (\<forall>y. a*y^2 + b*y + c = 0 \<longrightarrow> x < y)"
  proof -
    let ?l = "sorted_list_of_set {y. a*y^2 + b*y + c = 0}"
    have "\<exists>x. x < ?l ! 0"
      using infzeros nonz by blast
    then obtain x where x_prop: "x < ?l! 0" by auto
    then have "\<forall> y. List.member ?l y \<longrightarrow> x < y"
    proof clarsimp
      fix y
      assume "List.member ?l y"
      then have "\<exists>n. n < length ?l \<and> ?l ! n = y"
        by (meson in_set_conv_nth in_set_member)
      then obtain n where n_prop: "n < length ?l \<and> ?l ! n = y"
        by auto
      have h: "\<forall>n < length ?l. ?l ! n \<ge> ?l !0" using sorted_iff_nth_mono
        using sorted_sorted_list_of_set by blast
      then have h: "y \<ge> ?l ! 0" using n_prop by auto
      then show "x < y" using x_prop by auto
    qed
    then show ?thesis
      using finset set_sorted_list_of_set in_set_member
      by (metis (mono_tags, lifting) mem_Collect_eq)
  qed
  then obtain x where x_prop: "(\<forall>y. a*y^2 + b*y + c = 0 \<longrightarrow> x < y)" by auto
  then have same_as: "\<forall>y<x. (aEvalUni At y = aEvalUni At x)"
    using no_change_eval change_eval assms
  proof -
    have f1: "\<forall>x0. (x0 < x) = (\<not> 0 \<le> x0 + - 1 * x)"
      by auto
    have f2: "(0 \<le> - 1 * x + v0_0) = (x + - 1 * v0_0 \<le> 0)"
      by auto
    have f3: "v0_0 + - 1 * x = - 1 * x + v0_0"
      by auto
    have f4: "\<forall>x0 x1 x2 x3. (x3::real) * x0\<^sup>2 + x2 * x0 + x1 = x1 + x3 * x0\<^sup>2 + x2 * x0"
      by auto
    have f5: "\<forall>x3 x4 x5. (aEvalUni x3 x5 \<noteq> aEvalUni x3 x4) = ((\<not> aEvalUni x3 x5) = aEvalUni x3 x4)"
      by fastforce
    have f6: "\<forall>x0 x1 x2 x3 x4 x5. (x5 < x4 \<and> (\<not> aEvalUni x3 x5) = aEvalUni x3 x4 \<and> getPoly x3 = (x2, x1, x0) \<longrightarrow> (\<exists>v6\<ge>x5. v6 \<le> x4 \<and> x0 + x2 * v6\<^sup>2 + x1 * v6 = 0)) = ((\<not> x5 < x4 \<or> (\<not> aEvalUni x3 x5) \<noteq> aEvalUni x3 x4 \<or> getPoly x3 \<noteq> (x2, x1, x0)) \<or> (\<exists>v6\<ge>x5. v6 \<le> x4 \<and> x0 + x2 * v6\<^sup>2 + x1 * v6 = 0))"
      by fastforce
    have f7: "\<forall>x0 x5. ((x0::real) \<le> x5) = (x0 + - 1 * x5 \<le> 0)"
      by auto
    have f8: "\<forall>x0 x6. ((x6::real) \<le> x0) = (0 \<le> x0 + - 1 * x6)"
      by auto
    have "\<forall>x4 x5. ((x5::real) < x4) = (\<not> x4 + - 1 * x5 \<le> 0)"
      by auto
    then have "(\<forall>r ra a rb rc rd. r < ra \<and> aEvalUni a r \<noteq> aEvalUni a ra \<and> getPoly a = (rb, rc, rd) \<longrightarrow> (\<exists>re\<ge>r. re \<le> ra \<and> rb * re\<^sup>2 + rc * re + rd = 0)) = (\<forall>r ra a rb rc rd. (ra + - 1 * r \<le> 0 \<or> (\<not> aEvalUni a r) \<noteq> aEvalUni a ra \<or> getPoly a \<noteq> (rb, rc, rd)) \<or> (\<exists>re. 0 \<le> re + - 1 * r \<and> re + - 1 * ra \<le> 0 \<and> rd + rb * re\<^sup>2 + rc * re = 0))"
      using f8 f7 f6 f5 f4 by presburger
    then have f9: "\<forall>r ra a rb rc rd. (ra + - 1 * r \<le> 0 \<or> (\<not> aEvalUni a r) \<noteq> aEvalUni a ra \<or> getPoly a \<noteq> (rb, rc, rd)) \<or> (\<exists>re. 0 \<le> re + - 1 * r \<and> re + - 1 * ra \<le> 0 \<and> rd + rb * re\<^sup>2 + rc * re = 0)"
      by (meson change_eval)
    obtain rr :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
      "\<forall>x0 x1 x2 x4 x5. (\<exists>v6. 0 \<le> v6 + - 1 * x5 \<and> v6 + - 1 * x4 \<le> 0 \<and> x0 + x2 * v6\<^sup>2 + x1 * v6 = 0) = (0 \<le> rr x0 x1 x2 x4 x5 + - 1 * x5 \<and> rr x0 x1 x2 x4 x5 + - 1 * x4 \<le> 0 \<and> x0 + x2 * (rr x0 x1 x2 x4 x5)\<^sup>2 + x1 * rr x0 x1 x2 x4 x5 = 0)"
      by moura
    then have f10: "\<forall>r ra a rb rc rd. ra + - 1 * r \<le> 0 \<or> aEvalUni a r = aEvalUni a ra \<or> getPoly a \<noteq> (rb, rc, rd) \<or> r + - 1 * rr rd rc rb ra r \<le> 0 \<and> 0 \<le> ra + - 1 * rr rd rc rb ra r \<and> rd + rb * (rr rd rc rb ra r)\<^sup>2 + rc * rr rd rc rb ra r = 0"
      using f9 by simp
    have f11: "(rr c b a x v0_0 + - 1 * x \<le> 0) = (0 \<le> x + - 1 * rr c b a x v0_0)"
      by force
    have "\<forall>x0. (x < x0) = (\<not> x0 + - 1 * x \<le> 0)"
      by auto
    then have f12: "\<forall>r. c + a * r\<^sup>2 + b * r \<noteq> 0 \<or> \<not> r + - 1 * x \<le> 0"
      using x_prop by auto
    obtain rra :: real where
      "(\<exists>v0. \<not> 0 \<le> v0 + - 1 * x \<and> aEvalUni At v0 \<noteq> aEvalUni At x) = (\<not> 0 \<le> rra + - 1 * x \<and> aEvalUni At rra \<noteq> aEvalUni At x)"
      by moura
    then show ?thesis
      using f12 f11 f10 f3 f2 f1
    proof -
      have f1: "\<forall>x0. (x0 < x) = (\<not> 0 \<le> x0 + - 1 * x)"
        by auto
      have f2: "(0 \<le> v0_0a + - 1 * x) = (x + - 1 * v0_0a \<le> 0)"
        by auto
      have f3: "(rr c b a x v0_0a + - 1 * x \<le> 0) = (0 \<le> x + - 1 * rr c b a x v0_0a)"
        by auto
      obtain rrb :: real where
        "(\<exists>v0. \<not> 0 \<le> v0 + - 1 * x \<and> aEvalUni At v0 \<noteq> aEvalUni At x) = (\<not> 0 \<le> rrb + - 1 * x \<and> aEvalUni At rrb \<noteq> aEvalUni At x)"
        by blast
      then show ?thesis
        using f3 f2 f1 assms(1) f10 f12
        by smt
    qed
  qed
  then show ?thesis by auto
qed

lemma inequality_case : "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) < 0) =
    (a < 0 \<or> a = 0 \<and> (0 < b \<or> b = 0 \<and> c < 0))"
proof-
  let ?At = "(LessUni (a, b, c))"
  have firsth : "\<And>x. (\<forall>y<x. a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow> a\<le>0)"
  proof -
    fix x
    assume lt: "\<forall>y<x. a * y\<^sup>2 + b * y + c < 0"
    have "\<exists>w. \<forall>y < w. y^2 > (-b/a)*y - c/a"  using ysq_dom_y_plus_coeff[where b = "-b/a", where c = "-c/a"]
      by auto
    then have gtdomhelp: "a > 0 \<Longrightarrow> \<exists>w. \<forall>y < w. a*y^2 > a*((-b/a)*y - c/a)"
      by auto
    have "\<forall>y. (a > 0 \<longrightarrow> a*((-b/a)*y - c/a) = -b*y - c)"
      by (simp add: right_diff_distrib')
    then have gtdom: "a > 0 \<Longrightarrow> \<exists>w.\<forall>y < w. a*y^2 > -b*y - c"
      using gtdomhelp
      by simp
    then have " a > 0 \<Longrightarrow> False"
    proof -
      assume "a > 0"
      then have "\<exists>w.\<forall>y < w. a*y^2 > -b*y - c" using gtdom by auto
      then obtain w where w_prop: "\<forall>y < w. a*y^2 + b*y + c > 0"
        by fastforce
      let ?mn = "min w x - 1"
      have gtz: "a*?mn^2 + b*?mn + c > 0" using w_prop
        by auto
      have ltz: "a*?mn^2 + b*?mn + c < 0" using lt by auto
      then show "False" using gtz ltz by auto
    qed
    then show "a \<le> 0"
      by fastforce
  qed
  have bleq0 : "\<And>x. (\<forall>y<x. b * y + c < 0 \<Longrightarrow> b\<ge>0)"
  proof -
    fix x
    assume lt: "\<forall>y<x. b * y + c < 0"
    have gtdom: "b < 0 \<Longrightarrow> \<exists>w.\<forall>y < w. b*y > - c"
      by (metis mult.commute neg_less_divide_eq)
    then have "b < 0 \<Longrightarrow> False"
    proof -
      assume "b < 0"
      then have "\<exists>w.\<forall>y < w. b*y > - c" using gtdom by auto
      then obtain w where w_prop: "\<forall>y < w .b*y + c > 0"
        by fastforce
      let ?mn = "min w x - 1"
      have gtz: "b*?mn + c > 0" using w_prop
        by auto
      have ltz: "b*?mn + c < 0" using lt by auto
      then show "False" using gtz ltz by auto
    qed
    then show "b \<ge> 0"
      by fastforce
  qed
  have secondh: "\<And>x. (\<forall>y<x. a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow> \<not> a < 0 \<Longrightarrow> \<not> 0 < b \<Longrightarrow> b = 0)"
    using firsth bleq0
    by (metis add.commute add.right_neutral less_eq_real_def mult_zero_class.mult_zero_left)
  have thirdh : "\<And>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow> \<not> a < 0 \<Longrightarrow> \<not> 0 < b \<Longrightarrow> c < 0"
    using firsth secondh add.commute add.right_neutral infzeros mult_zero_class.mult_zero_left not_numeral_le_zero order_refl
    by (metis less_eq_real_def)
  have fourthh : "a < 0 \<Longrightarrow> \<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0"
  proof -
    assume aleq: "a < 0"
    have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> y^2 > (-b/a)*y + (-c/a))"
      using ysq_dom_y_plus_coeff[where b = "-b/a", where c = "-c/a"]
      by blast
    then have hyp:"\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> a*y^2 \<le> a*(-b/a)*y + a*(-c/a))"
      by (metis (no_types, opaque_lifting) \<open>a < 0\<close> distrib_left less_eq_real_def linorder_not_le mult.assoc mult_less_cancel_left)
    have "\<forall>y. a*(-b/a)*y + a*(-c/a) = -b*y -c"
      using \<open>a < 0\<close> by auto
    then have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> a*y^2 \<le> -b*y - c)"
      using hyp by auto
    then have "\<exists>(w::real). \<forall>(y::real). (y < w \<longrightarrow> a*y^2 + b*y + c \<le> 0)"
      by (metis add.commute add_uminus_conv_diff le_diff_eq mult_minus_left real_add_le_0_iff)
    then obtain w where w_prop: "\<forall>(y::real). (y < w \<longrightarrow> a*y^2 + b*y + c \<le> 0)" by auto
    have "\<exists>x. \<forall>y < x. aEvalUni ?At x = aEvalUni ?At y" using same_eval''
    proof -
      have f1: "\<forall>x0 x1. ((x0::real) < x1) = (\<not> 0 \<le> x0 + - 1 * x1)"
        by linarith
      have "a \<noteq> 0"
        using \<open>a < 0\<close> by force
      then obtain rr :: "atomUni \<Rightarrow> real" where
        "\<forall>r. 0 \<le> r + - 1 * rr (LessUni (a, b, c)) \<or> aEvalUni (LessUni (a, b, c)) r = aEvalUni (LessUni (a, b, c)) (rr (LessUni (a, b, c)))"
        using f1 by (metis getPoly.simps(4) same_eval'')
      then show ?thesis
        using f1 by meson
    qed
    then obtain x where x_prop: "\<forall>y < x. aEvalUni ?At x = aEvalUni ?At y" by auto
    let ?mn = "min x w - 1"
    have "\<forall>y < ?mn.  aEvalUni ?At y = True \<or> aEvalUni ?At y = False"
      using x_prop by auto
    have "\<forall> y < ?mn. aEvalUni ?At y = False \<longrightarrow> a*y^2 + b*y + c \<ge> 0"
      by auto
    then have "\<And>y. \<forall>y<w. a * y\<^sup>2 + b * y + c \<le> 0 \<Longrightarrow>
         y < min x w - 1 \<Longrightarrow>
         \<not> a * y\<^sup>2 + b * y + c < 0 \<Longrightarrow>
         a * y\<^sup>2 + b * y + c = 0"
    proof -
      fix y :: real
      assume a1: "y < min x w - 1"
      assume a2: "\<not> a * y\<^sup>2 + b * y + c < 0"
      assume a3: "\<forall>y<w. a * y\<^sup>2 + b * y + c \<le> 0"
      have "y < w"
        using a1 by linarith
      then show "a * y\<^sup>2 + b * y + c = 0"
        using a3 a2 less_eq_real_def by blast
    qed
    then have "\<forall> y < ?mn. aEvalUni ?At y = False \<longrightarrow> a*y^2 + b*y + c = 0"
      using w_prop by auto
    then have "\<forall> y < ?mn. aEvalUni ?At y = False \<Longrightarrow> False" using infzeros aleq
      by (metis power_zero_numeral zero_less_power2)
    then have "\<forall> y < ?mn. aEvalUni ?At y = True"
    proof -
      { fix rr :: real
        have "\<forall>r ra. (ra::real) < r \<or> \<not> ra < r + - 1"
          by linarith
        then have "\<not> rr < min x w - 1 \<or> aEvalUni (LessUni (a, b, c)) rr"
          by (metis (no_types) \<open>\<forall>y<min x w - 1. aEvalUni (LessUni (a, b, c)) y = False \<Longrightarrow> False\<close> ab_group_add_class.ab_diff_conv_add_uminus less_eq_real_def min_less_iff_disj not_le x_prop) }
      then show ?thesis
        by blast
    qed
    then show ?thesis by auto
  qed
  have fifthh : "b > 0 \<Longrightarrow> \<exists>x. \<forall>y<x. b * y + c < 0"
  proof-
    assume bh : "b > 0"
    show "\<exists>x. \<forall>y<x. b * y + c < 0"
      apply(rule exI[where x="-c/b"])
      apply auto
      using bh
      by (simp add: mult.commute pos_less_minus_divide_eq)
  qed
  show ?thesis
    apply(auto)
    using firsth apply simp
    using secondh apply simp
    using thirdh apply simp
    using fourthh apply simp
    using fifthh by simp
qed

lemma inequality_case_geq : "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) > 0) =
    (a > 0 \<or> a = 0 \<and> (0 > b \<or> b = 0 \<and> c > 0))"
proof -
  have s1: "\<forall>y. - 1 * a * y\<^sup>2 + - 1 * b * y + - 1 * c < 0 \<longleftrightarrow>  a * y\<^sup>2 +  b * y +  c > 0"
    by auto
  have s2: "(- 1 * a < 0 \<or> - 1 * a = 0 \<and> (0 < - 1 * b \<or> - 1 * b = 0 \<and> - 1 * c < 0)) \<longleftrightarrow>
   (a > 0 \<or> a = 0 \<and> (0 > b \<or>  b = 0 \<and> c > 0))  "
    by auto
  have "(\<exists>x. \<forall>y<x. - 1 * a * y\<^sup>2 + - 1 * b * y + - 1 * c < 0) =
  (- 1 * a < 0 \<or> - 1 * a = 0 \<and> (0 < - 1 * b \<or> - 1 * b = 0 \<and> - 1 * c < 0))"
    using inequality_case[where a = "-1*a", where b = "-1*b", where c= "-1*c"]
    by auto
  then show ?thesis
    using s1 s2 by auto
qed

lemma infinity_evalUni_LessUni : "(\<exists>x. \<forall>y<x. aEvalUni (LessUni p) y) = (evalUni (substNegInfinityUni (LessUni p)) x)"
proof(cases p)
  case (fields a b c)
  show ?thesis
    unfolding fields  apply simp
    using inequality_case[of a b c] .
qed

lemma infinity_evalUni_EqUni : "(\<exists>x. \<forall>y<x. aEvalUni (EqUni p) y) = (evalUni (substNegInfinityUni (EqUni p)) x)"
proof(cases p)
  case (fields a b c)
  show ?thesis
    using infzeros[of _ a b c] by(auto simp add: fields)
qed

lemma infinity_evalUni_NeqUni : "(\<exists>x. \<forall>y<x. aEvalUni (NeqUni p) y) = (evalUni (substNegInfinityUni (NeqUni p)) x)"
proof(cases p)
  case (fields a b c)
  show ?thesis
    unfolding fields  apply simp
    using inequality_case[of a b c]
    using inequality_case_geq[of a b c]
    by (metis less_numeral_extra(3) linorder_neqE_linordered_idom mult_eq_0_iff)

qed

lemma infinity_evalUni_LeqUni : "(\<exists>x. \<forall>y<x. aEvalUni (LeqUni p) y) = (evalUni (substNegInfinityUni (LeqUni p)) x)"
proof(cases p)
  case (fields a b c)
  show ?thesis
    unfolding fields  apply simp
  proof -
    have h1: "((\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)) \<longrightarrow> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0)"
      using less_eq_real_def
      by auto
    have h2: "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) \<Longrightarrow> ((\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0))"
    proof -
      assume a1: "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0)"
      have "\<not>(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0) \<Longrightarrow> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) "
      proof -
        assume a2: "\<not>(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)"
        then have "a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0" by auto
        then have "(a < 0 \<or> a = 0 \<and> (0 < b \<or> b = 0 \<and> c < 0))"
        proof -
          have x1: "a > 0 \<Longrightarrow> False"
          proof -
            assume "a > 0"
            then have "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) > 0)" using inequality_case_geq
              by auto
            then  show ?thesis
              using a1
              by (meson a2 linorder_not_le min_less_iff_conj)
          qed
          then have x2: "a = 0 \<and> 0 > b \<Longrightarrow> False"
          proof -
            assume "a = 0 \<and> 0 > b"
            then have "(\<exists>(x::real). \<forall>(y::real)<x. (a::real) * y\<^sup>2 + (b::real) * y + (c::real) > 0)" using inequality_case_geq
              by blast
            then show ?thesis
              using a1
              by (meson a2 linorder_not_le min_less_iff_conj)
          qed
          then have x3: "a = 0 \<and> b = 0 \<and> c > 0 \<Longrightarrow> False "
            using a1 a2 by auto
          show ?thesis using x1 x2 x3
            by (meson \<open>a \<noteq> 0 \<or> b \<noteq> 0 \<or> c \<noteq> 0\<close> linorder_neqE_linordered_idom)
        qed
        then show "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0)" using inequality_case
          by auto
      qed
      then show ?thesis
        by auto
    qed
    have "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) = (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c < 0) \<or> (\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c = 0)"
      using h1 h2 by auto
    then show "(\<exists>x. \<forall>y<x. a * y\<^sup>2 + b * y + c \<le> 0) =
    (a < 0 \<or> a = 0 \<and> (0 < b \<or> b = 0 \<and> c < 0) \<or> a = 0 \<and> b = 0 \<and> c = 0)"
      using inequality_case[of a b c] infzeros[of _ a b c] by auto
  qed
qed

text "This is the vertical translation for substNegInfinityUni where we represent the virtual
substution of negative infinity in the univariate case"
lemma infinity_evalUni :
  shows "(\<exists>x. \<forall>y<x. aEvalUni At y) = (evalUni (substNegInfinityUni At) x)"
proof(cases At)
  case (LessUni p)
  then show ?thesis using infinity_evalUni_LessUni by auto
next
  case (EqUni p)
  then show ?thesis using infinity_evalUni_EqUni by auto
next
  case (LeqUni p)
  then show ?thesis using infinity_evalUni_LeqUni by auto
next
  case (NeqUni p)
  then show ?thesis using infinity_evalUni_NeqUni by auto
qed

end


(*<*)
theory Event_Data
  imports
    "HOL-Library.Char_ord"
    Code_Double
    Deriving.Derive
begin
(*>*)

section \<open>Event parameters\<close>

definition div_to_zero :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "div_to_zero x y = (let z = fst (Code_Numeral.divmod_abs x y) in
    if (x < 0) \<noteq> (y < 0) then - z else z)"

definition mod_to_zero :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "mod_to_zero x y = (let z = snd (Code_Numeral.divmod_abs x y) in
    if x < 0 then - z else z)"

lemma "b \<noteq> 0 \<Longrightarrow> div_to_zero a b * b + mod_to_zero a b = a"
  unfolding div_to_zero_def mod_to_zero_def Let_def
  by (auto simp: minus_mod_eq_mult_div[symmetric] div_minus_right mod_minus_right ac_simps)

datatype event_data = EInt integer | EFloat double | EString string

derive (eq) ceq event_data
derive ccompare event_data

instantiation event_data :: "{ord, plus, minus, uminus, times, divide, modulo}"
begin

fun less_eq_event_data where
  "EInt x \<le> EInt y \<longleftrightarrow> x \<le> y"
| "EInt x \<le> EFloat y \<longleftrightarrow> double_of_integer x \<le> y"
| "EInt _ \<le> EString _ \<longleftrightarrow> False"
| "EFloat x \<le> EInt y \<longleftrightarrow> x \<le> double_of_integer y"
| "EFloat x \<le> EFloat y \<longleftrightarrow> x \<le> y"
| "EFloat _ \<le> EString _ \<longleftrightarrow> False"
| "EString x \<le> EString y \<longleftrightarrow> lexordp_eq x y"
| "EString _ \<le> _ \<longleftrightarrow> False"

definition less_event_data :: "event_data \<Rightarrow> event_data \<Rightarrow> bool"  where
  "less_event_data x y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"

fun plus_event_data where
  "EInt x + EInt y = EInt (x + y)"
| "EInt x + EFloat y = EFloat (double_of_integer x + y)"
| "EFloat x + EInt y = EFloat (x + double_of_integer y)"
| "EFloat x + EFloat y = EFloat (x + y)"
| "(_::event_data) + _ = EFloat nan"

fun minus_event_data where
  "EInt x - EInt y = EInt (x - y)"
| "EInt x - EFloat y = EFloat (double_of_integer x - y)"
| "EFloat x - EInt y = EFloat (x - double_of_integer y)"
| "EFloat x - EFloat y = EFloat (x - y)"
| "(_::event_data) - _ = EFloat nan"

fun uminus_event_data where
  "- EInt x = EInt (- x)"
| "- EFloat x = EFloat (- x)"
| "- (_::event_data) = EFloat nan"

fun times_event_data where
  "EInt x * EInt y = EInt (x * y)"
| "EInt x * EFloat y = EFloat (double_of_integer x * y)"
| "EFloat x * EInt y = EFloat (x * double_of_integer y)"
| "EFloat x * EFloat y = EFloat (x * y)"
| "(_::event_data) * _ = EFloat nan"

fun divide_event_data where
  "EInt x div EInt y = EInt (div_to_zero x y)"
| "EInt x div EFloat y = EFloat (double_of_integer x div y)"
| "EFloat x div EInt y = EFloat (x div double_of_integer y)"
| "EFloat x div EFloat y = EFloat (x div y)"
| "(_::event_data) div _ = EFloat nan"

fun modulo_event_data where
  "EInt x mod EInt y = EInt (mod_to_zero x y)"
| "(_::event_data) mod _ = EFloat nan"

instance ..

end

primrec integer_of_event_data :: "event_data \<Rightarrow> integer" where
  "integer_of_event_data (EInt x) = x"
| "integer_of_event_data (EFloat x) = integer_of_double x"
| "integer_of_event_data (EString _) = 0"

primrec double_of_event_data :: "event_data \<Rightarrow> double" where
  "double_of_event_data (EInt x) = double_of_integer x"
| "double_of_event_data (EFloat x) = x"
| "double_of_event_data (EString _) = nan"

(*<*)
end
(*>*)


(*  Title:      HOL/Datatype_Examples/Process.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Processes.
*)

section {* Processes *}

theory Process
imports "~~/src/HOL/Library/Stream"
begin

codatatype 'a process =
  isAction: Action (prefOf: 'a) (contOf: "'a process") |
  isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")

(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)

subsection {* Basic properties *}

(* Constructors versus discriminators *)
theorem isAction_isChoice:
"isAction p \<or> isChoice p"
by (rule process.exhaust_disc) auto

theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
by (cases rule: process.exhaust[of p]) auto

subsection{* Coinduction *}

theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
  assumes phi: "\<phi> p p'" and
  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
  shows "p = p'"
  using assms
  by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))

(* Stronger coinduction, up to equality: *)
theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
  assumes phi: "\<phi> p p'" and
  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
  shows "p = p'"
  using assms
  by (coinduct rule: process.coinduct_strong) (metis process.collapse(1,2) process.disc(3))

subsection {* Coiteration (unfold) *}

section{* Coinductive definition of the notion of trace *}
coinductive trace where
"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
|
"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"

section{* Examples of corecursive definitions: *}

subsection{* Single-guard fixpoint definition *}

primcorec BX where
  "isAction BX"
| "prefOf BX = ''a''"
| "contOf BX = BX"

subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}

datatype x_y_ax = x | y | ax

primcorec F :: "x_y_ax \<Rightarrow> char list process" where
  "xyax = x \<Longrightarrow> isChoice (F xyax)"
| "ch1Of (F xyax) = F ax"
| "ch2Of (F xyax) = F y"
| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
| "contOf (F xyax) = F x"

definition "X = F x"  definition "Y = F y"  definition "AX = F ax"

lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
unfolding X_def Y_def AX_def by (subst F.code, simp)+

(* end product: *)
lemma X_AX:
"X = Choice AX (Action ''b'' X)"
"AX = Action ''a'' X"
using X_Y_AX by simp_all

section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}

hide_const x y ax X Y AX

(* Process terms *)
datatype ('a,'pvar) process_term =
 VAR 'pvar |
 PROC "'a process" |
 ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"

(* below, sys represents a system of equations *)
fun isACT where
"isACT sys (VAR X) =
 (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
|
"isACT sys (PROC p) = isAction p"
|
"isACT sys (ACT a T) = True"
|
"isACT sys (CH T1 T2) = False"

fun PREF where
"PREF sys (VAR X) =
 (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
|
"PREF sys (PROC p) = prefOf p"
|
"PREF sys (ACT a T) = a"

fun CONT where
"CONT sys (VAR X) =
 (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
|
"CONT sys (PROC p) = PROC (contOf p)"
|
"CONT sys (ACT a T) = T"

fun CH1 where
"CH1 sys (VAR X) =
 (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
|
"CH1 sys (PROC p) = PROC (ch1Of p)"
|
"CH1 sys (CH T1 T2) = T1"

fun CH2 where
"CH2 sys (VAR X) =
 (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
|
"CH2 sys (PROC p) = PROC (ch2Of p)"
|
"CH2 sys (CH T1 T2) = T2"

definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"

primcorec solution where
  "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"

lemma isACT_VAR:
assumes g: "guarded sys"
shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
using g unfolding guarded_def by (cases "sys X") auto

lemma solution_VAR:
assumes g: "guarded sys"
shows "solution sys (VAR X) = solution sys (sys X)"
proof(cases "isACT sys (VAR X)")
  case True
  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  show ?thesis
  unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
  unfolding guarded_def by (cases "sys X", auto)
next
  case False note FFalse = False
  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  show ?thesis
  unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
  unfolding guarded_def by (cases "sys X", auto)
qed

lemma solution_PROC[simp]:
"solution sys (PROC p) = p"
proof-
  {fix q assume "q = solution sys (PROC p)"
   hence "p = q"
   proof (coinduct rule: process_coind)
     case (iss p p')
     from isAction_isChoice[of p] show ?case
     proof
       assume p: "isAction p"
       hence 0: "isACT sys (PROC p)" by simp
       thus ?thesis using iss not_isAction_isChoice by auto
     next
       assume "isChoice p"
       hence 0: "\<not> isACT sys (PROC p)"
       using not_isAction_isChoice by auto
       thus ?thesis using iss isAction_isChoice by auto
     qed
   next
     case (Action a a' p p')
     hence 0: "isACT sys (PROC (Action a p))" by simp
     show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
   next
     case (Choice p q p' q')
     hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
     show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
   qed
  }
  thus ?thesis by metis
qed

lemma solution_ACT[simp]:
"solution sys (ACT a T) = Action a (solution sys T)"
by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))

lemma solution_CH[simp]:
"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))

(* Example: *)

fun sys where
"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
|
"sys (Suc 0) = ACT ''a'' (VAR 0)"
| (* dummy guarded term for variables outside the system: *)
"sys X = ACT ''a'' (VAR 0)"

lemma guarded_sys:
"guarded sys"
unfolding guarded_def proof (intro allI)
  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
qed

(* the actual processes: *)
definition "x \<equiv> solution sys (VAR 0)"
definition "ax \<equiv> solution sys (VAR (Suc 0))"

(* end product: *)
lemma x_ax:
"x = Choice ax (Action ''b'' x)"
"ax = Action ''a'' x"
unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+

(* Thanks to the inclusion of processes as process terms, one can
also consider parametrized systems of equations---here, x is a (semantic)
process parameter: *)

fun sys' where
"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
|
"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
| (* dummy guarded term : *)
"sys' X = ACT ''a'' (VAR 0)"

lemma guarded_sys':
"guarded sys'"
unfolding guarded_def proof (intro allI)
  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
qed

(* the actual processes: *)
definition "y \<equiv> solution sys' (VAR 0)"
definition "ay \<equiv> solution sys' (VAR (Suc 0))"

(* end product: *)
lemma y_ay:
"y = Choice x (Action ''b'' y)"
"ay = Choice (Action ''a'' y) x"
unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+

end


theory Asm
  imports Main Exp
begin
section \<open>Stack Machine and Compilation\<close>
datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = n # stk" |
"exec1 (LOAD x) s stk = s(x) # stk" |
"exec1 ADD _ (j # i # stk) = (i + j) # stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i # is) s stk = exec is s (exec1 i s stk)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma exec_append[simp]:
  "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
  apply(induction is1 arbitrary: stk)
  by auto

lemma correctness_asm[simp]:
  "exec (comp a) s stk = (aval a s) # stk"
  apply(induction a arbitrary: stk)
  by simp_all

end


(**)
section \<open> Tactics \<close>

text \<open> We provide some tactics for easier interaction with proofs about real arithmetic.\<close>

theory Proof_Automation
  imports
    Diff_Dyn_Logic
    "HOL-Eisbach.Eisbach"

begin

method hol_intros = (intro allI conjI impI iffI)

method hol_clarsimp uses simp = (hol_intros; (clarsimp simp: simp)?)

subsection \<open> Monomial simplification \<close>

method move_left for x::"'a::{ab_semigroup_mult,power}" = (
    (simp only: mult.assoc[symmetric])?, (* prepare for main loop *)
    (
      (simp only: mult.commute[where b="x^_"] mult.commute[where b="x"])?,
      (simp only: mult.assoc)
      )+
    ), (simp only: mult.assoc[symmetric])? (* clean after main loop *)

method move_right for x::"'a::{ab_semigroup_mult,power}" = (
    (simp only: mult.assoc)?,
    (
      (simp only: mult.commute[where a="x^_"] mult.commute[where a="x"])?,
      (simp only: mult.assoc[symmetric])+
      )+
    ), (simp only: mult.assoc[symmetric])?

named_theorems mon_pow_simps "simplification rules for powers in monomials "

declare semiring_normalization_rules(27) [mon_pow_simps] (* x * x ^ q = x ^ Suc q *)
    and semiring_normalization_rules(28) [mon_pow_simps] (* x ^ q * x = x ^ Suc q *)
    and semiring_normalization_rules(29) [mon_pow_simps] (* x * x = ?x\<^sup>2 *)

method mon_pow_simp = (
    (simp add: mon_pow_simps del: power_Suc)?,
    (simp only: mult.assoc)?,
    (simp add: mon_pow_simps del: power_Suc)?
    ) \<comment> \<open> simplifies powers in monomials \<close>

lemma "x * x * x * (y ^ Suc n * x * z * (y * x * z) * z * z) * z * z
  = x ^ 5 * y ^ Suc (Suc n) * z ^ 6" for x::real
  apply (move_left z)
  apply (move_left y)
  apply (move_left x)
  apply mon_pow_simp
  done

lemma "x * x * x * (y\<^sup>2 * x * z * (y * x * z) * z * z) * z * z
  = x ^ 5 * y ^ 3 * z ^ 6" for x::real
  apply (move_right x)
  apply (move_right y)
  apply (move_right z)
  apply mon_pow_simp
  done

method mon_simp_vars for x y::"'a::{ab_semigroup_mult,power}" = (
    (move_right x)?, (move_right y)?, mon_pow_simp?
    (* second argument should not be the right-most argument in a monomial *)
    )

lemma "x * x * (x:: real) * (y^2 * x * z * (y * x * z) * z * z) * z * z
  = x^5 * y^3 * z^6"
  by (mon_simp_vars x y)

lemma "y  * x * x * (x:: real) * (w * y^2 * x * z * (y * x * z) * z * w^4 * z) * z * z
  = x^5 * y^4 * z^6 * w^5"
  by (mon_simp_vars x y) (mon_simp_vars z w)

lemma "x * x * (x:: real) * (y^(Suc n) * x * z * (y * x * z) * z * z) * z * z
  = x^5 * y^(Suc (Suc n)) * z^6"
  by (mon_simp_vars x y)

method bin_unfold = (simp add: power2_diff power2_sum power_mult_distrib)

subsection \<open> Distribution of multiplication over addition \<close>

lemma sign_distrib_laws:
  shows "- (a + b) = - a - (b::'a::ab_group_add)"
  and "- (a - b) = - a + b"
  and "- (- a + b) = a - b"
  and "- (- a - b) = a + b"
  and "a - (b + c) = a - b - c"
  and "a - (b - c) = a - b + c"
  and "a - (- b + c) = a + b - c"
  and "a - (- b - c) = a + b + c"
  by simp_all

method distribute = (
    ((subst sign_distrib_laws)+)?,
    ((subst (asm) sign_distrib_laws)+)?,
    ((subst minus_mult_left)+)?, (* - (a * b) = - a * b *)
    ((subst (asm) minus_mult_left)+)?,
    ((subst ring_distribs)+)?,
    ((subst (asm) ring_distribs)+)?
    )

method distributes = (distribute, simp) \<comment> \<open> can be iterated \<close>

(* work left to do in methods below *)

lemma factorR:
  fixes a::real
  shows "a * b + a * c = (b + c) * a"
    and "b * a + a * c = (b + c) * a"
    and "a * b + c * a = (b + c) * a"
    and "b * a + c * a = (b + c) * a"
  by distributes+

lemma factorL:
  fixes a::real
  shows "a * b + a * c = a * (b + c)"
    and "b * a + a * c = a * (b + c)"
    and "a * b + c * a = a * (b + c)"
    and "b * a + c * a = a * (b + c)"
  by distributes+

lemma factor_fracR:
  fixes a::real
  assumes "c > 0"
  shows "a / c + b = (a + c * b) * (1 / c)"
    and "a + b / c = (c * a + b) * (1 / c)"
    and "a / c - b = (a - c * b) * (1 / c)"
    and "a - b / c = (c * a - b) * (1 / c)"
    and "- a / c + b = (- a + c * b) * (1 / c)"
    and "- a + b / c = (- c * a + b) * (1 / c)"
    and "- a / c - b = (a + c * b) * (- (1 / c))"
    and "- a - b / c = (c * a + b) * (- (1 / c))"
  using assms by distributes+

lemma "(36::real) * (x1\<^sup>2 * (x1 * x2 ^ 3)) - (- (24 * (x1\<^sup>2 * x2) * x1 ^ 3 * x2\<^sup>2)
  - 12 * (x1\<^sup>2 * x2) * x1 * x2 ^ 4) - 36 * (x1\<^sup>2 * (x2 * x1)) * x2\<^sup>2 - 12 * (x1\<^sup>2 * (x1 * x2 ^ 5))
  = 24 * (x1 ^ 5 * x2 ^ 3)" (is "?t1 - (- ?t2 - ?t3) - ?t4 - ?t5 = ?t6")
  apply distribute
  apply (move_right x1)
  apply (move_right x2)
  apply mon_pow_simp
  done

lemma "0 \<le> A \<Longrightarrow> 0 < b \<Longrightarrow> x2\<^sup>2 \<le> 2 * b * (m - x1) \<Longrightarrow> 0 \<le> (t::real)
  \<Longrightarrow> \<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> b * \<tau> \<le> x2 \<and> \<tau> \<le> \<epsilon>
  \<Longrightarrow> (x2 - b * t)\<^sup>2 \<le> 2 * b * (m - (x2 * t - b * t\<^sup>2 / 2 + x1))"
  apply bin_unfold
  apply distributes
  apply (mon_simp_vars b t)
  done

lemma "a * (b / c) = (a * b) / c" for a::real
  oops

lemma STTexample6_arith:
  assumes "0 < A" "0 < B" "0 < \<epsilon>" "0 \<le> x2" "0 \<le> (t::real)" "- B \<le> k" "k \<le> A"
    and key: "x1 + x2\<^sup>2 / (2 * B) + (A * (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * x2) / B + (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * x2)) \<le> S" (is "?k3 \<le> S")
    and ghyp: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> 0 \<le> k * \<tau> + x2 \<and> \<tau> \<le> \<epsilon>"
  shows "k * t\<^sup>2 / 2 + x2 * t + x1 + (k * t + x2)\<^sup>2 / (2 * B) \<le> S" (is "?k0 \<le> S")
  using assms
  apply -
  apply distribute
  apply (subst factor_fracR[where c="2 * B"], simp?)
  apply (subst (asm) factor_fracR[where c="2 * B"], simp?)
  apply (mon_simp_vars A B)
  apply (subst (asm) factor_fracR[where c="2"], simp?)
  apply mon_pow_simp
  apply (subst (asm) factor_fracR[where c="2"], simp?)
  apply mon_pow_simp
  apply (subst (asm) factor_fracR[where c="2 * B"], simp?)
  apply mon_pow_simp
  apply (subst (asm) factor_fracR[where c="2 * B"], simp?)
  apply mon_pow_simp
  apply (subst (asm) factor_fracR[where c="2"], simp?)
  apply mon_pow_simp
  apply (move_right A)
  apply mon_pow_simp
  apply distribute
  apply bin_unfold
  apply mon_pow_simp
  oops

subsection \<open> Derivative certification \<close>

method vderiv_single uses simp intro
  = (auto intro!: vderiv_intros intro simp: field_simps simp)[1]

method vderiv uses simp intro
  = ((expr_simp)?;
    force intro!: vderiv_intros intro simp: vec_eq_iff field_simps simp)

subsection \<open> Differential invariance \<close>

method diff_inv_on_single_eq_intro =
  (rule diff_inv_on_eqI
  | rule diff_inv_on_raw_eqI
  ) \<comment> \<open> applies @{term diff_inv_on}-rule \<close>

method diff_inv_on_eq = (
    (simp only: expr_defs hoare_diff_inv_on fbox_diff_inv_on)?,
    (diff_inv_on_single_eq_intro; expr_auto),
    (force simp: power2_eq_square intro!: vderiv_intros)?)

method diff_inv_on_single_ineq_intro for dnu dmu::"'a \<Rightarrow> real" =
  (rule diff_inv_on_leqI[where \<mu>'=dmu and \<nu>'=dnu]
  | rule diff_inv_on_lessI[where \<mu>'=dmu and \<nu>'=dnu]
  | rule diff_inv_on_raw_leqI[where \<mu>'=dmu and \<nu>'=dnu]
  | rule diff_inv_on_raw_lessI[where \<mu>'=dmu and \<nu>'=dnu]
  ) \<comment> \<open> applies @{term diff_inv_on}-rule \<close>

method diff_inv_on_ineq for dnu dmu::"'a \<Rightarrow> real" = (
    (simp only: expr_defs hoare_diff_inv_on fbox_diff_inv_on)?,
    diff_inv_on_single_ineq_intro dnu dmu;
    (force intro!: vderiv_intros)?)

method diff_inv_on_weaken_ineq for I::"'a \<Rightarrow> bool"
  and dLeq dGeg::"'a \<Rightarrow> real" = (
    (rule fbox_inv[where I=I]),
    (expr_simp add: le_fun_def),
    (diff_inv_on_ineq dLeq dGeg),
    vderiv,
    (expr_simp add: le_fun_def)
    )

method diff_cut_ineq for I::"'a \<Rightarrow> bool" (* create tactic move to guard where nmods... *)
  and dLeq dGeg::"'a \<Rightarrow> real" = (
    (rule diff_cut_on_rule[where C=I]),
    (diff_inv_on_weaken_ineq I dLeq dGeg)
    )

text \<open> A first attempt at a high-level automated proof strategy using differential induction.
  A sequence of commands is tried as alternatives, one by one, and the method then iterates. \<close>

method dDiscr = (rule_tac nmods_invariant; auto intro!: closure)

(* hoare_diff_inv_on' *)
method dInduct = ((intro hoare_invs)?; subst fbox_diff_inv_on;
    intro lderiv_rules;
    simp add: framed_derivs ldifferentiable closure usubst unrest_ssubst unrest usubst_eval)

method dInduct_auto = (dInduct; expr_simp; auto simp add: field_simps)

method dWeaken = (rule_tac diff_weak_on_rule; expr_simp; auto simp add: field_simps)

method dInduct_mega uses facts =
  ( fact facts \<comment> \<open> (1) Try any facts we have provided \<close>
  | (dWeaken ; force) \<comment> \<open> (2) Try differential weakening \<close>
  | rule_tac diff_cut_on_split' | rule_tac diff_cut_on_split \<comment> \<open> (4) Try differential cut (two options) \<close>
  | rule_tac hoare_if_then_else_inv
  | (dInduct_auto) \<comment> \<open> (5) Try differential induction \<close>
  )+

method dInduct_mega' uses facts =
  ( fact facts \<comment> \<open> (1) Try any facts we have provided \<close>
  | (dWeaken ; force) \<comment> \<open> (2) Try differential weakening \<close>
  | rule_tac diff_cut_on_split' | rule_tac diff_cut_on_split \<comment> \<open> (4) Try differential cut (two options) \<close>
  | rule_tac hoare_if_then_else_inv
  | (dDiscr ; force) \<comment> \<open> (3) Try proving as a discrete invariant \<close>
  | (dInduct_auto) \<comment> \<open> (5) Try differential induction \<close>
  )+

subsection \<open> Differential ghosts \<close>

method dGhost for y :: "real \<Longrightarrow> 's" and J :: "'s \<Rightarrow> bool" and k :: real
  = (rule diff_ghost_rule_very_simple[where y="y" and J="J" and k="k"],
    simp_all add: unrest usubst usubst_eval unrest_ssubst liberate_as_subst)

subsection \<open> Continuity \<close>

named_theorems continuity_intros "optimised compilation of continuity rules."

declare continuous_on_const [continuity_intros]
    and continuous_on_id [continuity_intros]
    and continuous_on_add [continuity_intros]
    and continuous_on_diff [continuity_intros]
    and continuous_on_mult [continuity_intros]
    and continuous_on_ln [continuity_intros]
    and continuous_on_minus [continuity_intros]
    and continuous_on_power [continuity_intros]
    and continuous_on_divide [continuity_intros]
    and continuous_on_cos [continuity_intros]
    and continuous_on_sin [continuity_intros]
    and continuous_on_exp [continuity_intros]
    and continuous_on_Pair [continuity_intros]
    and continuous_on_fst [continuity_intros]
    and continuous_on_snd [continuity_intros]
    and continuous_on_scaleR [continuity_intros]
    and continuous_on_inverse [continuity_intros]

lemma continuous_on_divideR: "continuous_on T f \<Longrightarrow> continuous_on T g
  \<Longrightarrow> \<forall>t\<in>T. g t \<noteq> 0 \<Longrightarrow> continuous_on T (\<lambda>t. f t /\<^sub>R g t)"
  for f::"'a::topological_space \<Rightarrow> 'b::real_normed_div_algebra"
  by (auto intro!: continuity_intros)

subsection \<open> Certification of uniqueness \<close>

method lipschitz_const for L :: real =
  (unfold local_lipschitz_on_def local_lipschitz_def lipschitz_on_def dist_norm, clarify,
    rule exI[where x="L"], expr_auto, (rule exI[where x="L"], auto)?)

method c1_lipschitz =
  (expr_simp; (auto intro!: c1_local_lipschitz derivative_eq_intros continuity_intros)?)

method c1_lipschitzI for df uses derivsI =
  (expr_simp, (rule_tac \<DD>=df in c1_local_lipschitz; expr_auto)?;
    (auto intro!: c1_local_lipschitz derivative_eq_intros continuity_intros derivsI)?)

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> 2] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> - $x] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> $y] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (y::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (z::real \<Longrightarrow> 's)
  \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x \<Longrightarrow> x \<bowtie> z \<Longrightarrow> z \<bowtie> x \<Longrightarrow> z \<bowtie> y \<Longrightarrow> y \<bowtie> z
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> $y, y \<leadsto> $z] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x +\<^sub>L y\<^esub> s)"
  by c1_lipschitz

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> 1 - $x] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> - ($y * $x)] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (y::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> - $y, y \<leadsto> $x] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x +\<^sub>L y\<^esub> s)"
  by c1_lipschitz

lemma trivial_prod_subst: "(\<lambda>x. case x of (t, a) \<Rightarrow> f t a) = (\<lambda>(t,a). f t a)"
  by simp

(* fails on nonlinear inputs *)
lemma "vwb_lens (x::real \<Longrightarrow> 's)
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> 1 - ($x)\<^sup>2] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  apply expr_simp
  thm c1_implies_local_lipschitz
  apply (rule_tac f'="\<lambda>(t,a). Blinfun (\<lambda>c. - (2 * c * a))" in c1_implies_local_lipschitz; clarsimp?)
   apply (auto intro!: derivative_eq_intros)
   apply (subst Blinfun_inverse; clarsimp)
  using bounded_linear_minus bounded_linear_mult_const bounded_linear_mult_right apply blast
  apply (subst trivial_prod_subst)
  apply (subst comp_def[symmetric, of Blinfun])
  apply (auto intro: continuity_intros split: prod.splits)
  find_theorems "_ \<Longrightarrow> continuous_on _ _" name: comp
  thm blinfun_apply_inverse Blinfun_inverse term Blinfun
  oops

(* but we can make it linear *)
lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (y::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> 1 - $y, y \<leadsto> 2 * $x] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

(* fails on nonlinear inputs *)
lemma "vwb_lens (x::real \<Longrightarrow> 's)
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> 1 - exp ($x)] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  oops

(* but we can make it linear *)
lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (y::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_lipschitz UNIV UNIV (\<lambda>t::real. [x \<leadsto> 1 - $y, y \<leadsto> $y] \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s)"
  by c1_lipschitz

subsection \<open> Certification of solutions \<close>

method local_flow for L :: real =
  ((auto simp add: local_flow_on_def)?,
    (unfold_locales, auto),
    (lipschitz_const L, vderiv, expr_auto))

method local_flow_Lconst =
  (local_flow "1/4" | local_flow "1/2" | local_flow "1" | local_flow "2")

method local_flow_on_auto =
  (((clarsimp simp: local_flow_on_def)?, unfold_locales; clarsimp?), c1_lipschitz, vderiv+)

lemma "vwb_lens x \<Longrightarrow> local_flow_on [x \<leadsto> 2] x UNIV UNIV (\<lambda>t. [x \<leadsto> 2 * \<guillemotleft>t\<guillemotright> + $x])"
  by local_flow_on_auto

lemma "vwb_lens (x::real \<Longrightarrow> 's)
  \<Longrightarrow> local_flow_on [x \<leadsto> - $x] x UNIV UNIV (\<lambda>t. [x \<leadsto> $x * exp (- \<guillemotleft>t\<guillemotright>)])"
  by local_flow_on_auto

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_flow_on [x \<leadsto> $y] x UNIV UNIV (\<lambda>t. [x \<leadsto> $y * \<guillemotleft>t\<guillemotright> + $x])"
  by local_flow_on_auto

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (y::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens (z::real \<Longrightarrow> 's)
  \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x \<Longrightarrow> x \<bowtie> z \<Longrightarrow> z \<bowtie> x \<Longrightarrow> z \<bowtie> y \<Longrightarrow> y \<bowtie> z
  \<Longrightarrow> local_flow_on [x \<leadsto> $y, y \<leadsto> $z] (x +\<^sub>L y) UNIV UNIV
  (\<lambda>t. [x \<leadsto> $z * \<guillemotleft>t\<guillemotright>\<^sup>2 / 2 + $y * \<guillemotleft>t\<guillemotright> + $x, y \<leadsto> $z * \<guillemotleft>t\<guillemotright> + $y])"
  by local_flow_on_auto

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_flow_on [x \<leadsto> - $x + 1] x UNIV UNIV (\<lambda>t. [x \<leadsto> 1 - exp (- \<guillemotleft>t\<guillemotright>) + $x * exp (- \<guillemotleft>t\<guillemotright>)])"
  by local_flow_on_auto

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_flow_on [x \<leadsto> - $y * $x] x UNIV UNIV (\<lambda>t. [x \<leadsto> $x * exp (- \<guillemotleft>t\<guillemotright> * $y)])"
  by local_flow_on_auto

lemma "vwb_lens (x::real \<Longrightarrow> 's) \<Longrightarrow> vwb_lens y \<Longrightarrow> x \<bowtie> y \<Longrightarrow> y \<bowtie> x
  \<Longrightarrow> local_flow_on [x \<leadsto> - $y, y \<leadsto> $x] (x +\<^sub>L y) UNIV UNIV
  (\<lambda>t. [x \<leadsto> $x * cos \<guillemotleft>t\<guillemotright> + - 1 * $y * sin \<guillemotleft>t\<guillemotright>, y \<leadsto> $y * cos \<guillemotleft>t\<guillemotright> + $x * sin \<guillemotleft>t\<guillemotright>])"
  by local_flow_on_auto

subsection \<open> Hoare Logic \<close>

text \<open> A simple tactic for Hoare logic that uses weakest liberal precondition calculations \<close>

(* Formally, this is not Hoare logic, rename? *)
method hoare_wp_simp uses local_flow
  = (((rule_tac hoare_loopI) | (rule hoare_loopI_break))?;
    simp add: unrest_ssubst var_alpha_combine wlp usubst usubst_eval
    refine_iff_implies fbox_solve[OF local_flow])

method hoare_wp_auto uses local_flow = (hoare_wp_simp local_flow: local_flow; expr_auto)

text \<open> First attempt at a system level prover \<close>

method dProve = (rule_tac hoare_loop_seqI, hoare_wp_auto, dInduct_mega', (expr_auto)+)

subsection \<open> Weakest liberal preconditions \<close>

(* most used solution theorems in arch2022:
  * fbox_g_ode_frame_flow
  * fbox_solve (which is essentially the one above)
  * fbox_g_dL_easiest (which transforms g_dl_ode_frames into g_evol_ons)
*)
method intro_loops = (rule hoare_loopI hoare_whileI hoare_loopI_break hoare_whileI_break)

method wlp_simp uses simp = (intro_loops?; (simp add: wlp simp)?)

method wlp_flow uses simp local_flow = (wlp_simp simp: simp fbox_solve[OF local_flow])

method wlp_full uses simp local_flow = ((wlp_flow simp: simp local_flow: local_flow)?; expr_auto)

method wlp_solve_one for \<phi>::"real \<Rightarrow> 'a \<Rightarrow> 'a" = (subst fbox_solve[where \<phi>=\<phi>], local_flow_on_auto?)

method wlp_solve for \<phi>::"real \<Rightarrow> 'a \<Rightarrow> 'a" uses simp
  = ((wlp_simp simp: simp)?, (wlp_solve_one \<phi>)+)

method wlp_expr_solve for \<phi>::"real \<Rightarrow> 'a \<Rightarrow> 'a" uses simp
  = ((wlp_solve \<phi> simp: simp); expr_auto?)

dataspace testing_wp_tactic =
  constants A::real B::real S::real V::real \<epsilon>::real
  variables x::real v::real a::real c::real d::real

lit_vars
no_notation (ASCII) disj (infixr "|" 30)

context testing_wp_tactic
begin

lemma "(v \<ge> 0 \<and> A > 0 \<and> B > 0 \<and> x + v\<^sup>2/(2 * B) \<le> S \<and> \<epsilon> > 0)\<^sub>e \<le>
  |LOOP
    ((\<questiondown>x + v\<^sup>2/(2*B) + (A/B + 1)*(A/2*\<epsilon>\<^sup>2 + \<epsilon> * v) \<le> S?; a ::= A)
      \<sqinter> (\<questiondown>v=0?; a ::= 0)
      \<sqinter> (a ::= - B; d ::= ?)
    );(
      (c ::= 0);
      {x` = v, v` = a, c` = 1 | (v \<ge> 0 \<and> x + v\<^sup>2/(2*B) \<le> S)}
    )
   INV (v \<ge> 0 \<and> x + v\<^sup>2/(2 * B) \<le> S)
  ] (x \<le> S)"
  apply (subst change_loopI[where I="(v \<ge> 0 \<and> A > 0 \<and> B > 0 \<and> x + v\<^sup>2/(2*B) \<le> S \<and> \<epsilon> > 0)\<^sup>e"])
  apply (wlp_expr_solve "(\<lambda>t. [c \<leadsto> t + c, x \<leadsto> $a * t\<^sup>2 / 2 + $v * t + $x, v \<leadsto> $a * t + $v])")
  by (smt (verit) divide_nonneg_nonneg zero_le_power)

lemma local_flow_test: "local_flow_on [c \<leadsto> 1, v \<leadsto> $a, x \<leadsto> $v] (x +\<^sub>L v +\<^sub>L c) UNIV UNIV
  (\<lambda>t. [c \<leadsto> t + c, x \<leadsto> $a * t\<^sup>2 / 2 + $v * t + $x, v \<leadsto> $a * t + $v])"
  by local_flow_on_auto

lemma "(v \<ge> 0 \<and> A > 0 \<and> B > 0 \<and> x + v\<^sup>2/(2 * B) \<le> S \<and> \<epsilon> > 0)\<^sub>e \<le>
  |LOOP
    ((\<questiondown>x + v\<^sup>2/(2*B) + (A/B + 1)*(A/2*\<epsilon>\<^sup>2 + \<epsilon> * v) \<le> S?; a ::= A)
      \<sqinter> (\<questiondown>v=0?; a ::= 0)
      \<sqinter> (a ::= - B; d ::= ?)
    );(
      (c ::= 0);
      {x` = v, v` = a, c` = 1 | (v \<ge> 0 \<and> x + v\<^sup>2/(2*B) \<le> S)}
    )
   INV (v \<ge> 0 \<and> x + v\<^sup>2/(2 * B) \<le> S)
  ] (x \<le> S)"
  apply (subst change_loopI[where I="(v \<ge> 0 \<and> A > 0 \<and> B > 0 \<and> x + v\<^sup>2/(2*B) \<le> S \<and> \<epsilon> > 0)\<^sup>e"])
  by (wlp_full local_flow: local_flow_test)
    (smt (verit) divide_nonneg_nonneg zero_le_power)

end

end
(**)


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Injection_Universe.thy                                               *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Injection Universes \<close>

theory Injection_Universe
  imports
    "HOL-Library.Countable"
    "Optics.Lenses"
begin

text \<open> An injection universe shows how one type @{typ "'a"} can be injected into another type,
  @{typ "'u"}. They are applied in UTP to provide local variables which require that we can
  injection a variety of different datatypes into a unified stack type. \<close>

record ('a, 'u) inj_univ =
  to_univ :: "'a \<Rightarrow> 'u" ("to-univ\<index>")

locale inj_univ =
  fixes I :: "('a, 'u) inj_univ" (structure)
  assumes inj_to_univ: "inj to-univ"
begin

definition from_univ :: "'u \<Rightarrow> 'a" ("from-univ") where
"from_univ = inv to-univ"

lemma to_univ_inv [simp]: "from-univ (to-univ x) = x"
  by (simp add: from_univ_def inv_f_f inj_to_univ)

text \<open> Lens-based view on universe injection and projection. \<close>

definition to_univ_lens :: "'a \<Longrightarrow> 'u" ("to-univ\<^sub>L") where
"to_univ_lens = \<lparr> lens_get = from-univ, lens_put = (\<lambda> s v. to-univ v) \<rparr>"

lemma mwb_to_univ_lens [simp]:
  "mwb_lens to_univ_lens"
  by (unfold_locales, simp_all add: to_univ_lens_def)

end

text \<open> Example universe based on natural numbers. Any countable type can be injected into it. \<close>

definition nat_inj_univ :: "('a::countable, nat) inj_univ" ("\<U>\<^sub>\<nat>") where
"nat_inj_univ = \<lparr> to_univ = to_nat \<rparr>"

lemma nat_inj_univ: "inj_univ nat_inj_univ"
  by (unfold_locales, simp add: nat_inj_univ_def)

end


theory Test
imports Main
        "../Listing"

begin

lemma appZips  : "len a = len b \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)"
(*apply(hipster_induct_schemes app.simps len.simps List.exhaust Nat.distinct)*)
apply(hipster_induct_schemes app.simps len.simps List.exhaust Nat.distinct)
by (tactic \<open>let
      val lemmas = [] (* (ThyExpl_Data.proved_of_ctxt @{context}) @ (Hipster_Rules.get @{context})*)
      val facts = @{thms app.simps  len.simps List.exhaust Nat.distinct} in
        ALLGOALS(Ind_Tacs.induct_simp_or_metis (facts,lemmas) @{context} (SOME @{thms "zip.induct"}) (SOME ["a","b"]))
      end\<close>)


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_48
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 z (nil2)) = nil2"
| "butlast (cons2 z (cons2 x2 x3)) =
     cons2 z (butlast (cons2 x2 x3))"

theorem property0 :(*Manually fixed TIP's bug.\<rightarrow> still broken.*)
  "((case xs of
         nil2 => True
         | cons2 y z => False) ==>
      ((x (butlast xs) (cons2 (last xs) (nil2))) = xs))"
  nitpick
  oops

end


(*  Author:     Tobias Nipkow, 2007  *)

header{* Quantifier elimination *}

theory QE
imports Logic
begin

text{* \noindent
The generic, i.e.\ theory-independent part of quantifier elimination.
Both DNF and an NNF-based procedures are defined and proved correct. *}

notation (input) Collect ("|_|")

subsection{*No Equality*}

context ATOM
begin

subsubsection{*DNF-based*}

text{* \noindent Taking care of atoms independent of variable 0: *}

definition
"qelim qe as =
 (let qf = qe [a\<leftarrow>as. depends\<^sub>0 a];
      indep = [Atom(decr a). a\<leftarrow>as, \<not> depends\<^sub>0 a]
  in and qf (list_conj indep))"

abbreviation is_dnf_qe :: "('a list \<Rightarrow> 'a fm) \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_dnf_qe qe as \<equiv> \<forall>xs. I(qe as) xs = (\<exists>x.\<forall>a\<in>set as. I\<^sub>a a (x#xs))"

text{*\noindent
Note that the exported abbreviation will have as a first parameter
the type @{typ"'b"} of values @{text xs} ranges over. *}

lemma I_qelim:
assumes qe: "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> is_dnf_qe qe as"
shows "is_dnf_qe (qelim qe) as" (is "\<forall>xs. ?P xs")
proof
  fix  xs
  let ?as0 = "filter depends\<^sub>0 as"
  let ?as1 = "filter (Not o depends\<^sub>0) as"
  have "I (qelim qe as) xs =
        (I (qe ?as0) xs \<and> (\<forall>a\<in>set(map decr ?as1). I\<^sub>a a xs))"
    (is "_ = (_ \<and> ?B)") by(force simp add:qelim_def)
  also have "\<dots> = ((\<exists>x. \<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)"
    by(simp add:qe not_dep_decr)
  also have "\<dots> = (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)" by blast
  also have "?B = (\<forall>a \<in> set ?as1. I\<^sub>a (decr a) xs)" by simp
  also have "(\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> \<dots>) =
             (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and>
                  (\<forall>a \<in> set ?as1. I\<^sub>a a (x#xs)))"
    by(simp add: not_dep_decr)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(?as0 @ ?as1). I\<^sub>a a (x#xs))"
    by (simp add:ball_Un)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(as). I\<^sub>a a (x#xs))"
    by simp blast
  finally show "?P xs" .
qed

text{* \noindent The generic DNF-based quantifier elimination procedure: *}

fun lift_dnf_qe :: "('a list \<Rightarrow> 'a fm) \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"lift_dnf_qe qe (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (lift_dnf_qe qe \<phi>\<^sub>1) (lift_dnf_qe qe \<phi>\<^sub>2)" |
"lift_dnf_qe qe (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (lift_dnf_qe qe \<phi>\<^sub>1) (lift_dnf_qe qe \<phi>\<^sub>2)" |
"lift_dnf_qe qe (Neg \<phi>) = neg(lift_dnf_qe qe \<phi>)" |
"lift_dnf_qe qe (ExQ \<phi>) = Disj (dnf(nnf(lift_dnf_qe qe \<phi>))) (qelim qe)" |
"lift_dnf_qe qe \<phi> = \<phi>"

lemma qfree_lift_dnf_qe: "(\<And>as. (\<forall>a\<in>set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as))
 \<Longrightarrow> qfree(lift_dnf_qe qe \<phi>)"
by (induct \<phi>) (simp_all add:qelim_def)

lemma qfree_lift_dnf_qe2: "qe : lists |depends\<^sub>0| \<rightarrow> |qfree|
 \<Longrightarrow> qfree(lift_dnf_qe qe \<phi>)"
using in_lists_conv_set[where ?'a = 'a]
by (simp add:Pi_def qfree_lift_dnf_qe)

lemma lem: "\<forall>P A. (\<exists>x\<in>A. \<exists>y. P x y) = (\<exists>y. \<exists>x\<in>A. P x y)" by blast

lemma I_lift_dnf_qe:
assumes  "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as)"
and "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> is_dnf_qe qe as"
shows "I (lift_dnf_qe qe \<phi>) xs = I \<phi> xs"
proof(induct \<phi> arbitrary:xs)
  case ExQ thus ?case
    by (simp add: assms I_qelim lem I_dnf nqfree_nnf qfree_lift_dnf_qe
                  I_nnf)
qed simp_all

lemma I_lift_dnf_qe2:
assumes  "qe : lists |depends\<^sub>0| \<rightarrow> |qfree|"
and "\<forall>as \<in> lists |depends\<^sub>0|. is_dnf_qe qe as"
shows "I (lift_dnf_qe qe \<phi>) xs = I \<phi> xs"
using assms in_lists_conv_set[where ?'a = 'a]
by(simp add:Pi_def I_lift_dnf_qe)

text{*\noindent Quantifier elimination with invariant (needed for Presburger): *}

lemma I_qelim_anormal:
assumes qe: "\<And>xs as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> is_dnf_qe qe as"
and nm: "\<forall>a \<in> set as. anormal a"
shows "I (qelim qe as) xs = (\<exists>x. \<forall>a\<in>set as. I\<^sub>a a (x#xs))"
proof -
  let ?as0 = "filter depends\<^sub>0 as"
  let ?as1 = "filter (Not o depends\<^sub>0) as"
  have "I (qelim qe as) xs =
        (I (qe ?as0) xs \<and> (\<forall>a\<in>set(map decr ?as1). I\<^sub>a a xs))"
    (is "_ = (_ \<and> ?B)") by(force simp add:qelim_def)
  also have "\<dots> = ((\<exists>x. \<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)"
    by(simp add:qe nm not_dep_decr)
  also have "\<dots> = (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)" by blast
  also have "?B = (\<forall>a \<in> set ?as1. I\<^sub>a (decr a) xs)" by simp
  also have "(\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> \<dots>) =
             (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and>
                  (\<forall>a \<in> set ?as1. I\<^sub>a a (x#xs)))"
    by(simp add: not_dep_decr)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(?as0 @ ?as1). I\<^sub>a a (x#xs))"
    by (simp add:ball_Un)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(as). I\<^sub>a a (x#xs))"
    by simp blast
  finally show ?thesis .
qed

declare [[simp_depth_limit = 5]]

lemma anormal_atoms_qelim:
  "(\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> normal(qe as)) \<Longrightarrow>
   \<forall>a \<in> set as. anormal a \<Longrightarrow> a : atoms(qelim qe as) \<Longrightarrow> anormal a"
apply(auto simp add:qelim_def and_def normal_def split:split_if_asm)
apply(auto simp add:anormal_decr dest!: atoms_list_conjE)
 apply(erule_tac x = "filter depends\<^sub>0 as" in meta_allE)
 apply(simp)
apply(erule_tac x = "filter depends\<^sub>0 as" in meta_allE)
apply(simp)
done

lemma normal_lift_dnf_qe:
assumes "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<Longrightarrow> qfree(qe as)"
and "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> normal(qe as)"
shows  "normal \<phi> \<Longrightarrow> normal(lift_dnf_qe qe \<phi>)"
proof(simp add:normal_def, induct \<phi>)
  case ExQ thus ?case
    apply (auto dest!: atoms_list_disjE)
    apply(rule anormal_atoms_qelim)
      prefer 3 apply assumption
     apply(simp add:assms)
    apply (simp add:normal_def qfree_lift_dnf_qe anormal_dnf_nnf assms)
    done
qed (simp_all add:and_def or_def neg_def Ball_def)

declare [[simp_depth_limit = 9]]
lemma I_lift_dnf_qe_anormal:
assumes "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<Longrightarrow> qfree(qe as)"
and "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> normal(qe as)"
and "\<And>xs as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> is_dnf_qe qe as"
shows "normal f \<Longrightarrow> I (lift_dnf_qe qe f) xs = I f xs"
proof(induct f arbitrary:xs)
  case ExQ thus ?case using normal_lift_dnf_qe[of qe]
    by (simp add: assms[simplified normal_def] anormal_dnf_nnf I_qelim_anormal lem I_dnf nqfree_nnf qfree_lift_dnf_qe I_nnf normal_def)
qed (simp_all add:normal_def)
declare [[simp_depth_limit = 50]]

lemma I_lift_dnf_qe_anormal2:
assumes "qe : lists |depends\<^sub>0| \<rightarrow> |qfree|"
and "qe : lists ( |depends\<^sub>0| \<inter> |anormal| ) \<rightarrow> |normal|"
and "\<forall>as \<in> lists( |depends\<^sub>0| \<inter> |anormal| ). is_dnf_qe qe as"
shows "normal f \<Longrightarrow> I (lift_dnf_qe qe f) xs = I f xs"
using assms in_lists_conv_set[where ?'a = 'a]
by(simp add:Pi_def I_lift_dnf_qe_anormal Int_def)

subsubsection{*NNF-based*}

fun lift_nnf_qe :: "('a fm \<Rightarrow> 'a fm) \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"lift_nnf_qe qe (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (lift_nnf_qe qe \<phi>\<^sub>1) (lift_nnf_qe qe \<phi>\<^sub>2)" |
"lift_nnf_qe qe (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (lift_nnf_qe qe \<phi>\<^sub>1) (lift_nnf_qe qe \<phi>\<^sub>2)" |
"lift_nnf_qe qe (Neg \<phi>) = neg(lift_nnf_qe qe \<phi>)" |
"lift_nnf_qe qe (ExQ \<phi>) = qe(nnf(lift_nnf_qe qe \<phi>))" |
"lift_nnf_qe qe \<phi> = \<phi>"

lemma qfree_lift_nnf_qe: "(\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>))
 \<Longrightarrow> qfree(lift_nnf_qe qe \<phi>)"
by (induct \<phi>) (simp_all add:nqfree_nnf)

lemma qfree_lift_nnf_qe2:
  "qe : |nqfree| \<rightarrow> |qfree| \<Longrightarrow> qfree(lift_nnf_qe qe \<phi>)"
by(simp add:Pi_def qfree_lift_nnf_qe)

lemma I_lift_nnf_qe:
assumes  "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>)"
and "\<And>xs \<phi>. nqfree \<phi> \<Longrightarrow> I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
proof(induct "\<phi>" arbitrary:xs)
  case ExQ thus ?case
    by (simp add: assms nqfree_nnf qfree_lift_nnf_qe I_nnf)
qed simp_all

lemma I_lift_nnf_qe2:
assumes  "qe : |nqfree| \<rightarrow> |qfree|"
and "ALL \<phi> : |nqfree|. ALL xs. I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
using assms by(simp add:Pi_def I_lift_nnf_qe)

lemma normal_lift_nnf_qe:
assumes "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>)"
and     "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> normal(qe \<phi>)"
shows "normal \<phi> \<Longrightarrow> normal(lift_nnf_qe qe \<phi>)"
by (induct \<phi>)
   (simp_all add: assms Logic.neg_def normal_nnf
                  nqfree_nnf qfree_lift_nnf_qe)

lemma I_lift_nnf_qe_normal:
assumes  "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>)"
and "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> normal(qe \<phi>)"
and "\<And>xs \<phi>. normal \<phi> \<Longrightarrow> nqfree \<phi> \<Longrightarrow> I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "normal \<phi> \<Longrightarrow> I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
proof(induct "\<phi>" arbitrary:xs)
  case ExQ thus ?case
    by (simp add: assms nqfree_nnf qfree_lift_nnf_qe I_nnf
                  normal_lift_nnf_qe normal_nnf)
qed auto

lemma I_lift_nnf_qe_normal2:
assumes  "qe : |nqfree| \<rightarrow> |qfree|"
and "qe : |nqfree| \<inter> |normal| \<rightarrow> |normal|"
and "ALL \<phi> : |normal| Int |nqfree|. ALL xs. I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "normal \<phi> \<Longrightarrow> I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
using assms by(simp add:Pi_def I_lift_nnf_qe_normal Int_def)

end

subsection{*With equality*}

text{* DNF-based quantifier elimination can accommodate equality atoms
in a generic fashion. *}

locale ATOM_EQ = ATOM +
fixes solvable\<^sub>0 :: "'a \<Rightarrow> bool"
and trivial :: "'a \<Rightarrow> bool"
and subst\<^sub>0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
assumes subst\<^sub>0:
  "\<lbrakk> solvable\<^sub>0 eq;  \<not>trivial eq;  I\<^sub>a eq (x#xs);  depends\<^sub>0 a \<rbrakk>
   \<Longrightarrow> I\<^sub>a (subst\<^sub>0 eq a) xs = I\<^sub>a a (x#xs)"
and trivial: "trivial eq \<Longrightarrow> I\<^sub>a eq xs"
and solvable: "solvable\<^sub>0 eq \<Longrightarrow> \<exists>x. I\<^sub>a eq (x#xs)"
and is_triv_self_subst: "solvable\<^sub>0 eq \<Longrightarrow> trivial (subst\<^sub>0 eq eq)"

begin

definition lift_eq_qe :: "('a list \<Rightarrow> 'a fm) \<Rightarrow> 'a list \<Rightarrow> 'a fm" where
"lift_eq_qe qe as =
 (let as = [a\<leftarrow>as. \<not> trivial a]
  in case [a\<leftarrow>as. solvable\<^sub>0 a] of
    [] \<Rightarrow> qe as
  | eq # eqs \<Rightarrow>
        (let ineqs = [a\<leftarrow>as. \<not> solvable\<^sub>0 a]
         in list_conj (map (Atom \<circ> (subst\<^sub>0 eq)) (eqs @ ineqs))))"

theorem I_lift_eq_qe:
assumes dep: "\<forall>a\<in>set as. depends\<^sub>0 a"
assumes qe: "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a \<and> \<not> solvable\<^sub>0 a) \<Longrightarrow>
   I (qe as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>a a (x#xs))"
shows "I (lift_eq_qe qe as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>a a (x#xs))"
  (is "?L = ?R")
proof -
  let ?as = "[a\<leftarrow>as. \<not> trivial a]"
  show ?thesis
  proof (cases "[a\<leftarrow>?as. solvable\<^sub>0 a]")
    case Nil
    hence "\<forall>a\<in>set as. \<not> trivial a \<longrightarrow> \<not> solvable\<^sub>0 a"
      by(auto simp: filter_empty_conv)
    thus "?L = ?R"
      by(simp add:lift_eq_qe_def dep qe cong:conj_cong) (metis trivial)
  next
    case (Cons eq _)
    then have "eq : set as" "solvable\<^sub>0 eq" "\<not> trivial eq"
      by (auto simp: filter_eq_Cons_iff)
    then obtain e where "I\<^sub>a eq (e#xs)" by(metis solvable)
    have "\<forall>a \<in> set as. I\<^sub>a a (e # xs) = I\<^sub>a (subst\<^sub>0 eq a) xs"
      by(simp add: subst\<^sub>0[OF `solvable\<^sub>0 eq` `\<not> trivial eq` `I\<^sub>a eq (e#xs)`] dep)
    thus ?thesis using Cons dep
      apply(simp add: lift_eq_qe_def,
            clarsimp simp: filter_eq_Cons_iff ball_Un)
      apply(rule iffI)
      apply(fastforce intro!:exI[of _ e] simp: trivial is_triv_self_subst)
      apply (metis subst\<^sub>0)
      done
  qed
qed;

definition "lift_dnfeq_qe = lift_dnf_qe \<circ> lift_eq_qe"

lemma qfree_lift_eq_qe:
  "(\<And>as. \<forall>a\<in>set as. depends\<^sub>0 a \<Longrightarrow> qfree (qe as)) \<Longrightarrow>
   \<forall>a\<in>set as. depends\<^sub>0 a \<Longrightarrow> qfree(lift_eq_qe qe as)"
by(simp add:lift_eq_qe_def ball_Un split:list.split)

lemma qfree_lift_dnfeq_qe: "(\<And>as. (\<forall>a\<in>set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as))
  \<Longrightarrow> qfree(lift_dnfeq_qe qe \<phi>)"
by(simp add: lift_dnfeq_qe_def qfree_lift_dnf_qe qfree_lift_eq_qe)

lemma I_lift_dnfeq_qe:
  "(\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as)) \<Longrightarrow>
   (\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a \<and> \<not> solvable\<^sub>0 a) \<Longrightarrow> is_dnf_qe qe as) \<Longrightarrow>
   I (lift_dnfeq_qe qe \<phi>) xs = I \<phi> xs"
by(simp add:lift_dnfeq_qe_def I_lift_dnf_qe qfree_lift_eq_qe I_lift_eq_qe)

lemma I_lift_dnfeq_qe2:
  "qe : lists |depends\<^sub>0| \<rightarrow> |qfree| \<Longrightarrow>
   (\<forall>as \<in> lists( |depends\<^sub>0| \<inter> - |solvable\<^sub>0| ). is_dnf_qe qe as) \<Longrightarrow>
   I (lift_dnfeq_qe qe \<phi>) xs = I \<phi> xs"
using in_lists_conv_set[where ?'a = 'a]
by(simp add:Pi_def I_lift_dnfeq_qe Int_def Compl_eq)

end

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_45
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

theorem property0 :
  "((zip (cons2 x xs) (cons2 y ys)) =
      (cons2 (pair2 x y) (zip xs ys)))"
  oops

end