theory Example3
imports
  "../Numerics/Euler_Affine"
  "../Numerics/Optimize_Float"
  "~~/src/HOL/Decision_Procs/Approximation"
begin

subsection {* Example 3 *}

approximate_affine e3 "\<lambda>(t, x). (1::real, x*x + t*t::real)"

lemma e3_fderiv: "((\<lambda>(t, x). (1::real, x*x + t*t::real)) has_derivative
  (\<lambda>(x, y) (h, j). (0, 2 * (j * y) + 2 * (h * x))) x) (at x within X)"
       by (auto intro!: derivative_eq_intros simp: split_beta')

approximate_affine e3_d "\<lambda>(x, y) (h, j). (0::real, 2 * (j * y) + 2 * (h * x)::real)"

interpretation e3: aform_approximate_ivp "uncurry_options e3" "uncurry_options e3_d"
  "\<lambda>(t, x). (1::real, x*x + t*t::real)"
  "\<lambda>(x, y) (h, j). (0, 2 * (j * y) + 2 * (h * x))"
  apply unfold_locales
  apply (rule e3[THEN Joints2_JointsI]) apply assumption apply assumption
  apply (rule e3_fderiv)
  apply (rule e3_d[THEN Joints2_JointsI]) apply assumption apply assumption
  apply (auto intro!: continuous_intros simp: split_beta')
  done

definition "e3_optns = default_optns
    \<lparr> precision := 30,
      tolerance := FloatR 1 (- 4),
      stepsize  := FloatR 1 (- 8),
      result_fun := ivls_result 23 1,
      printing_fun := (\<lambda>_ _ _. ())\<rparr>"

definition "e3test = (\<lambda>_::unit. euler_series_result (uncurry_options e3) (uncurry_options e3_d) e3_optns 0 (aform_of_point (0, 1)) (2 ^ 5))"

lemma e3test: "e3test () =
  Some (FloatR 32 (- 8),
   [(FloatR 31 (- 8), (FloatR 62 (- 9), FloatR 4774828 (- 22)), (FloatR 64 (- 9), FloatR 4796453 (- 22)),
     FloatR 32 (- 8), (FloatR 32 (- 8), FloatR 4796405 (- 22)), FloatR 32 (- 8), FloatR 4796453 (- 22)),
    (FloatR 30 (- 8), (FloatR 60 (- 9), FloatR 4753458 (- 22)), (FloatR 62 (- 9), FloatR 4774874 (- 22)),
     FloatR 31 (- 8), (FloatR 31 (- 8), FloatR 4774829 (- 22)), FloatR 31 (- 8), FloatR 4774874 (- 22)),
    (FloatR 29 (- 8), (FloatR 58 (- 9), FloatR 4732291 (- 22)), (FloatR 60 (- 9), FloatR 4753502 (- 22)),
     FloatR 30 (- 8), (FloatR 30 (- 8), FloatR 4753458 (- 22)), FloatR 30 (- 8), FloatR 4753502 (- 22)),
    (FloatR 28 (- 8), (FloatR 56 (- 9), FloatR 4711325 (- 22)), (FloatR 58 (- 9), FloatR 4732333 (- 22)),
     FloatR 29 (- 8), (FloatR 29 (- 8), FloatR 4732292 (- 22)), FloatR 29 (- 8), FloatR 4732333 (- 22)),
    (FloatR 27 (- 8), (FloatR 54 (- 9), FloatR 4690555 (- 22)), (FloatR 56 (- 9), FloatR 4711365 (- 22)),
     FloatR 28 (- 8), (FloatR 28 (- 8), FloatR 4711325 (- 22)), FloatR 28 (- 8), FloatR 4711365 (- 22)),
    (FloatR 26 (- 8), (FloatR 52 (- 9), FloatR 4669980 (- 22)), (FloatR 54 (- 9), FloatR 4690593 (- 22)),
     FloatR 27 (- 8), (FloatR 27 (- 8), FloatR 4690555 (- 22)), FloatR 27 (- 8), FloatR 4690593 (- 22)),
    (FloatR 25 (- 8), (FloatR 50 (- 9), FloatR 4649595 (- 22)), (FloatR 52 (- 9), FloatR 4670016 (- 22)),
     FloatR 26 (- 8), (FloatR 26 (- 8), FloatR 4669980 (- 22)), FloatR 26 (- 8), FloatR 4670016 (- 22)),
    (FloatR 24 (- 8), (FloatR 48 (- 9), FloatR 4629399 (- 22)), (FloatR 50 (- 9), FloatR 4649630 (- 22)),
     FloatR 25 (- 8), (FloatR 25 (- 8), FloatR 4649595 (- 22)), FloatR 25 (- 8), FloatR 4649630 (- 22)),
    (FloatR 23 (- 8), (FloatR 46 (- 9), FloatR 4609388 (- 22)), (FloatR 48 (- 9), FloatR 4629432 (- 22)),
     FloatR 24 (- 8), (FloatR 24 (- 8), FloatR 4629399 (- 22)), FloatR 24 (- 8), FloatR 4629432 (- 22)),
    (FloatR 22 (- 8), (FloatR 44 (- 9), FloatR 4589560 (- 22)), (FloatR 46 (- 9), FloatR 4609419 (- 22)),
     FloatR 23 (- 8), (FloatR 23 (- 8), FloatR 4609388 (- 22)), FloatR 23 (- 8), FloatR 4609419 (- 22)),
    (FloatR 21 (- 8), (FloatR 42 (- 9), FloatR 4569911 (- 22)), (FloatR 44 (- 9), FloatR 4589589 (- 22)),
     FloatR 22 (- 8), (FloatR 22 (- 8), FloatR 4589560 (- 22)), FloatR 22 (- 8), FloatR 4589589 (- 22)),
    (FloatR 20 (- 8), (FloatR 40 (- 9), FloatR 4550440 (- 22)), (FloatR 42 (- 9), FloatR 4569939 (- 22)),
     FloatR 21 (- 8), (FloatR 21 (- 8), FloatR 4569911 (- 22)), FloatR 21 (- 8), FloatR 4569939 (- 22)),
    (FloatR 19 (- 8), (FloatR 38 (- 9), FloatR 4531142 (- 22)), (FloatR 40 (- 9), FloatR 4550466 (- 22)),
     FloatR 20 (- 8), (FloatR 20 (- 8), FloatR 4550440 (- 22)), FloatR 20 (- 8), FloatR 4550466 (- 22)),
    (FloatR 18 (- 8), (FloatR 36 (- 9), FloatR 4512017 (- 22)), (FloatR 38 (- 9), FloatR 4531167 (- 22)),
     FloatR 19 (- 8), (FloatR 19 (- 8), FloatR 4531143 (- 22)), FloatR 19 (- 8), FloatR 4531167 (- 22)),
    (FloatR 17 (- 8), (FloatR 34 (- 9), FloatR 4493060 (- 22)), (FloatR 36 (- 9), FloatR 4512040 (- 22)),
     FloatR 18 (- 8), (FloatR 18 (- 8), FloatR 4512017 (- 22)), FloatR 18 (- 8), FloatR 4512040 (- 22)),
    (FloatR 16 (- 8), (FloatR 32 (- 9), FloatR 4474270 (- 22)), (FloatR 34 (- 9), FloatR 4493082 (- 22)),
     FloatR 17 (- 8), (FloatR 17 (- 8), FloatR 4493060 (- 22)), FloatR 17 (- 8), FloatR 4493082 (- 22)),
    (FloatR 15 (- 8), (FloatR 30 (- 9), FloatR 4455644 (- 22)), (FloatR 32 (- 9), FloatR 4474290 (- 22)),
     FloatR 16 (- 8), (FloatR 16 (- 8), FloatR 4474270 (- 22)), FloatR 16 (- 8), FloatR 4474290 (- 22)),
    (FloatR 14 (- 8), (FloatR 28 (- 9), FloatR 4437179 (- 22)), (FloatR 30 (- 9), FloatR 4455663 (- 22)),
     FloatR 15 (- 8), (FloatR 15 (- 8), FloatR 4455644 (- 22)), FloatR 15 (- 8), FloatR 4455663 (- 22)),
    (FloatR 13 (- 8), (FloatR 26 (- 9), FloatR 4418873 (- 22)), (FloatR 28 (- 9), FloatR 4437196 (- 22)),
     FloatR 14 (- 8), (FloatR 14 (- 8), FloatR 4437179 (- 22)), FloatR 14 (- 8), FloatR 4437196 (- 22)),
    (FloatR 12 (- 8), (FloatR 24 (- 9), FloatR 4400724 (- 22)), (FloatR 26 (- 9), FloatR 4418889 (- 22)),
     FloatR 13 (- 8), (FloatR 13 (- 8), FloatR 4418873 (- 22)), FloatR 13 (- 8), FloatR 4418889 (- 22)),
    (FloatR 11 (- 8), (FloatR 22 (- 9), FloatR 4382728 (- 22)), (FloatR 24 (- 9), FloatR 4400738 (- 22)),
     FloatR 12 (- 8), (FloatR 12 (- 8), FloatR 4400724 (- 22)), FloatR 12 (- 8), FloatR 4400738 (- 22)),
    (FloatR 10 (- 8), (FloatR 20 (- 9), FloatR 4364885 (- 22)), (FloatR 22 (- 9), FloatR 4382742 (- 22)),
     FloatR 11 (- 8), (FloatR 11 (- 8), FloatR 4382728 (- 22)), FloatR 11 (- 8), FloatR 4382742 (- 22)),
    (FloatR 9 (- 8), (FloatR 18 (- 9), FloatR 4347191 (- 22)), (FloatR 20 (- 9), FloatR 4364897 (- 22)),
     FloatR 10 (- 8), (FloatR 10 (- 8), FloatR 4364885 (- 22)), FloatR 10 (- 8), FloatR 4364897 (- 22)),
    (FloatR 8 (- 8), (FloatR 16 (- 9), FloatR 4329644 (- 22)), (FloatR 18 (- 9), FloatR 4347202 (- 22)),
     FloatR 9 (- 8), (FloatR 9 (- 8), FloatR 4347191 (- 22)), FloatR 9 (- 8), FloatR 4347202 (- 22)),
    (FloatR 7 (- 8), (FloatR 14 (- 9), FloatR 4312242 (- 22)), (FloatR 16 (- 9), FloatR 4329654 (- 22)),
     FloatR 8 (- 8), (FloatR 8 (- 8), FloatR 4329644 (- 22)), FloatR 8 (- 8), FloatR 4329654 (- 22)),
    (FloatR 6 (- 8), (FloatR 12 (- 9), FloatR 4294983 (- 22)), (FloatR 14 (- 9), FloatR 4312251 (- 22)),
     FloatR 7 (- 8), (FloatR 7 (- 8), FloatR 4312242 (- 22)), FloatR 7 (- 8), FloatR 4312251 (- 22)),
    (FloatR 5 (- 8), (FloatR 10 (- 9), FloatR 4277864 (- 22)), (FloatR 12 (- 9), FloatR 4294990 (- 22)),
     FloatR 6 (- 8), (FloatR 6 (- 8), FloatR 4294983 (- 22)), FloatR 6 (- 8), FloatR 4294990 (- 22)),
    (FloatR 4 (- 8), (FloatR 8 (- 9), FloatR 4260884 (- 22)), (FloatR 10 (- 9), FloatR 4277870 (- 22)),
     FloatR 5 (- 8), (FloatR 5 (- 8), FloatR 4277864 (- 22)), FloatR 5 (- 8), FloatR 4277870 (- 22)),
    (FloatR 3 (- 8), (FloatR 6 (- 9), FloatR 4244040 (- 22)), (FloatR 8 (- 9), FloatR 4260889 (- 22)), FloatR 4 (- 8),
     (FloatR 4 (- 8), FloatR 4260884 (- 22)), FloatR 4 (- 8), FloatR 4260889 (- 22)),
    (FloatR 2 (- 8), (FloatR 4 (- 9), FloatR 4227329 (- 22)), (FloatR 6 (- 9), FloatR 4244044 (- 22)), FloatR 3 (- 8),
     (FloatR 3 (- 8), FloatR 4244040 (- 22)), FloatR 3 (- 8), FloatR 4244044 (- 22)),
    (FloatR 1 (- 8), (FloatR 2 (- 9), FloatR 4210751 (- 22)), (FloatR 4 (- 9), FloatR 4227333 (- 22)), FloatR 2 (- 8),
     (FloatR 2 (- 8), FloatR 4227330 (- 22)), FloatR 2 (- 8), FloatR 4227333 (- 22)),
    (FloatR 0 0, (FloatR 0 (- 9), FloatR 4194304 (- 22)), (FloatR 2 (- 9), FloatR 4210754 (- 22)), FloatR 1 (- 8),
     (FloatR 1 (- 8), FloatR 4210751 (- 22)), FloatR 1 (- 8), FloatR 4210754 (- 22))])"
   by eval

lemma x0: "(0, 1) \<in> Affine (aform_of_point (0::real, 1::real))"
  by (rule Affine_aform_of_point)

lemma stepsize: "0 < stepsize e3_optns"
  by (auto simp: e3_optns_def)

lemma result_fun: "result_fun e3_optns = ivls_result 23 1"
  by (auto simp: e3_optns_def)

lemmas certification = e3.euler_series_ivls_result[OF stepsize x0 result_fun e3test[simplified e3test_def],
  simplified e3.euler_ivp_def]

lemma last_enclosure: "e3.enclosure
     (ivp.solution
       \<lparr>ivp_f = \<lambda>(t, x). case x of (t, x) \<Rightarrow> (1, x * x + t * t), ivp_t0 = 0, ivp_x0 = (0, 1), ivp_T = {0..FloatR 32 (- 8)},
          ivp_X = UNIV\<rparr>)
     0 (FloatR 32 (- 8))
     (map set_res_of_ivl_res
       [(FloatR 31 (- 8), (FloatR 62 (- 9), FloatR 4774828 (- 22)), (FloatR 64 (- 9), FloatR 4796453 (- 22)),
         FloatR 32 (- 8), (FloatR 32 (- 8), FloatR 4796405 (- 22)), FloatR 32 (- 8), FloatR 4796453 (- 22))])"
  using certification
  unfolding e3.enclosure_def
  apply (subst (asm) list.map)
  apply (subst (asm) list_all_simps)
  apply (drule conjunct1)
  apply (simp )
  done

lemma
  "unique_solution \<lparr>ivp_f = \<lambda>(s::real, t::real, x::real). (1, x * x + t * t), ivp_t0 = 0,
    ivp_x0 = (0, 1), ivp_T = {0..1 / 8}, ivp_X = UNIV\<rparr>"
  "ivp.solution    \<lparr>ivp_f = \<lambda>(s::real, t::real, x::real). (1, x * x + t * t), ivp_t0 = 0,
    ivp_x0 = (0, 1), ivp_T = {0..1 / 8}, ivp_X = UNIV\<rparr> (1 / 8) \<in>
    {(1 / 8, 4796405 / 4194304) .. (1 / 8, 4796453 / 4194304)}"
  using certification(1) last_enclosure
  by (simp_all add: e3.enclosure_def)

subsubsection {* Comparison with bounds analytically obtained by Walter~\cite{walter} in section 9,
  Example V. *}

text {* First approximation. *}

notepad begin
  fix solution
  assume Walter: "\<And>x. solution x \<in> {1/(1 - x)..tan(x + pi/4)}"
  let ?x = "0.125::real"
  value "1 / (1 - 0.125)"
  have "1/(1-?x) \<in> {1.142857139 .. 1.142857146}" by simp
  moreover
  approximate "tan (0.125 + pi/4)"
  have "tan(?x + pi/4) \<in> {1.287426935 .. 1.287426955}"
    by (approximation 40)
  ultimately
  have "{1/(1-?x)..tan(?x + pi/4)} \<subseteq> {1.142857139 .. 1.287426955}" by simp
  with Walter have "solution ?x \<in> {1.142857139 .. 1.287426955}" by blast
end

text {* Better approximation. *}

notepad begin
  fix solution::"real\<Rightarrow>real"
  assume Walter: "\<And>x. solution x \<in> {1/(1-x)..16 / (16 - 17*x)}"
  let ?x = "0.125::real"
  approximate "1 / (1 - ?x)"
  have "1/(1-?x) \<in> {1.142857139 .. 1.142857146}" by simp
  moreover
  approximate "16 / (16 - 17*?x)"
  have "16 / (16 - 17*?x) \<in> {1.153153151 .. 1.153153155}"
    by (approximation 40)
  ultimately
  have "{1/(1-?x)..16 / (16 - 17*?x)} \<subseteq> {1.142857139 .. 1.153153155}" by simp
  with Walter have "solution ?x \<in> {1.142857139 .. 1.153153155}" by blast
  have error: "16 / (16 - 17*?x) - 1 / (1 - ?x) \<ge> 1/10^2" by (approximation 20)
end

end


theory Eurovision_Rule
imports Scoring_Rules
        "Compositional_Structures/Basic_Modules/Scoring_Module"
        "Compositional_Structures/Basic_Modules/Eurovision_Module"
        "Compositional_Structures/Elect_Composition"

begin

lemma euro_elect:
  shows "electoral_module (elector euro)"
proof(unfold euro.simps)
  show "electoral_module (elector (max_eliminator (scoring vector_A_euro)))"
    using scoring_mod_A by blast
qed

lemma euro_hom:
  shows "homogeneity (elector euro)" unfolding euro.simps
  using scoring_rules_homogeneity
  by blast

lemma euro_reinforcement:
  shows "reinforcement (elector euro)" unfolding euro.simps
  using scoring_module_rein
  by blast

end


(*  Title:      ZF/UNITY/Follows.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2002  University of Cambridge

Theory ported from HOL.
*)

section\<open>The "Follows" relation of Charpentier and Sivilotte\<close>

theory Follows imports SubstAx Increasing begin

definition
  Follows :: "[i, i, i\<Rightarrow>i, i\<Rightarrow>i] \<Rightarrow> i"  where
  "Follows(A, r, f, g) \<equiv>
            Increasing(A, r, g) Int
            Increasing(A, r,f) Int
            Always({s \<in> state. <f(s), g(s)>:r}) Int
           (\<Inter>k \<in> A. {s \<in> state. <k, g(s)>:r} \<longmapsto>w {s \<in> state. <k,f(s)>:r})"

abbreviation
  Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
  "Incr(f) \<equiv> Increasing(list(nat), prefix(nat), f)"

abbreviation
  n_Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
  "n_Incr(f) \<equiv> Increasing(nat, Le, f)"

abbreviation
  s_Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
  "s_Incr(f) \<equiv> Increasing(Pow(nat), SetLe(nat), f)"

abbreviation
  m_Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
  "m_Incr(f) \<equiv> Increasing(Mult(nat), MultLe(nat, Le), f)"

abbreviation
  n_Fols :: "[i\<Rightarrow>i, i\<Rightarrow>i]\<Rightarrow>i"   (infixl \<open>n'_Fols\<close> 65)  where
  "f n_Fols g \<equiv> Follows(nat, Le, f, g)"

abbreviation
  Follows' :: "[i\<Rightarrow>i, i\<Rightarrow>i, i, i] \<Rightarrow> i"
        (\<open>(_ /Fols _ /Wrt (_ /'/ _))\<close> [60, 0, 0, 60] 60)  where
  "f Fols g Wrt r/A \<equiv> Follows(A,r,f,g)"

(*Does this hold for "invariant"?*)

lemma Follows_cong:
     "\<lbrakk>A=A'; r=r'; \<And>x. x \<in> state \<Longrightarrow> f(x)=f'(x); \<And>x. x \<in> state \<Longrightarrow> g(x)=g'(x)\<rbrakk> \<Longrightarrow> Follows(A, r, f, g) = Follows(A', r', f', g')"
by (simp add: Increasing_def Follows_def)

lemma subset_Always_comp:
"\<lbrakk>mono1(A, r, B, s, h); \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
   Always({x \<in> state. <f(x), g(x)> \<in> r})<=Always({x \<in> state. <(h comp f)(x), (h comp g)(x)> \<in> s})"
  unfolding mono1_def metacomp_def
apply (auto simp add: Always_eq_includes_reachable)
done

lemma imp_Always_comp:
"\<lbrakk>F \<in> Always({x \<in> state. <f(x), g(x)> \<in> r});
    mono1(A, r, B, s, h); \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
    F \<in> Always({x \<in> state. <(h comp f)(x), (h comp g)(x)> \<in> s})"
by (blast intro: subset_Always_comp [THEN subsetD])

lemma imp_Always_comp2:
"\<lbrakk>F \<in> Always({x \<in> state. <f1(x), f(x)> \<in> r});
    F \<in> Always({x \<in> state. <g1(x), g(x)> \<in> s});
    mono2(A, r, B, s, C, t, h);
    \<forall>x \<in> state. f1(x):A \<and> f(x):A \<and> g1(x):B \<and> g(x):B\<rbrakk>
  \<Longrightarrow> F \<in> Always({x \<in> state. <h(f1(x), g1(x)), h(f(x), g(x))> \<in> t})"
apply (auto simp add: Always_eq_includes_reachable mono2_def)
apply (auto dest!: subsetD)
done

(* comp LeadsTo *)

lemma subset_LeadsTo_comp:
"\<lbrakk>mono1(A, r, B, s, h); refl(A,r); trans[B](s);
        \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
  (\<Inter>j \<in> A. {s \<in> state. <j, g(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f(s)> \<in> r}) <=
 (\<Inter>k \<in> B. {x \<in> state. <k, (h comp g)(x)> \<in> s} \<longmapsto>w {x \<in> state. <k, (h comp f)(x)> \<in> s})"

apply (unfold mono1_def metacomp_def, clarify)
apply (simp_all (no_asm_use) add: INT_iff)
apply auto
apply (rule single_LeadsTo_I)
prefer 2 apply (blast dest: LeadsTo_type [THEN subsetD], auto)
apply (rotate_tac 5)
apply (drule_tac x = "g (sa) " in bspec)
apply (erule_tac [2] LeadsTo_weaken)
apply (auto simp add: part_order_def refl_def)
apply (rule_tac b = "h (g (sa))" in trans_onD)
apply blast
apply auto
done

lemma imp_LeadsTo_comp:
"\<lbrakk>F:(\<Inter>j \<in> A. {s \<in> state. <j, g(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f(s)> \<in> r});
    mono1(A, r, B, s, h); refl(A,r); trans[B](s);
    \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
   F:(\<Inter>k \<in> B. {x \<in> state. <k, (h comp g)(x)> \<in> s} \<longmapsto>w {x \<in> state. <k, (h comp f)(x)> \<in> s})"
apply (rule subset_LeadsTo_comp [THEN subsetD], auto)
done

lemma imp_LeadsTo_comp_right:
"\<lbrakk>F \<in> Increasing(B, s, g);
  \<forall>j \<in> A. F: {s \<in> state. <j, f(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f1(s)> \<in> r};
  mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t);
  \<forall>x \<in> state. f1(x):A \<and> f(x):A \<and> g(x):B; k \<in> C\<rbrakk> \<Longrightarrow>
  F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} \<longmapsto>w {x \<in> state. <k, h(f1(x), g(x))> \<in> t}"
  unfolding mono2_def Increasing_def
apply (rule single_LeadsTo_I, auto)
apply (drule_tac x = "g (sa) " and A = B in bspec)
apply auto
apply (drule_tac x = "f (sa) " and P = "\<lambda>j. F \<in> X(j) \<longmapsto>w Y(j)" for X Y in bspec)
apply auto
apply (rule PSP_Stable [THEN LeadsTo_weaken], blast, blast)
apply auto
apply (force simp add: part_order_def refl_def)
apply (force simp add: part_order_def refl_def)
apply (drule_tac x = "f1 (x)" and x1 = "f (sa) " and P2 = "\<lambda>x y. \<forall>u\<in>B. P (x,y,u)" for P in bspec [THEN bspec])
apply (drule_tac [3] x = "g (x) " and x1 = "g (sa) " and P2 = "\<lambda>x y. P (x,y) \<longrightarrow> d (x,y) \<in> t" for P d in bspec [THEN bspec])
apply auto
apply (rule_tac b = "h (f (sa), g (sa))" and A = C in trans_onD)
apply (auto simp add: part_order_def)
done

lemma imp_LeadsTo_comp_left:
"\<lbrakk>F \<in> Increasing(A, r, f);
  \<forall>j \<in> B. F: {x \<in> state. <j, g(x)> \<in> s} \<longmapsto>w {x \<in> state. <j,g1(x)> \<in> s};
  mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t);
  \<forall>x \<in> state. f(x):A \<and> g1(x):B \<and> g(x):B; k \<in> C\<rbrakk> \<Longrightarrow>
  F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} \<longmapsto>w {x \<in> state. <k, h(f(x), g1(x))> \<in> t}"
  unfolding mono2_def Increasing_def
apply (rule single_LeadsTo_I, auto)
apply (drule_tac x = "f (sa) " and P = "\<lambda>k. F \<in> Stable (X (k))" for X in bspec)
apply auto
apply (drule_tac x = "g (sa) " in bspec)
apply auto
apply (rule PSP_Stable [THEN LeadsTo_weaken], blast, blast)
apply auto
apply (force simp add: part_order_def refl_def)
apply (force simp add: part_order_def refl_def)
apply (drule_tac x = "f (x) " and x1 = "f (sa) " in bspec [THEN bspec])
apply (drule_tac [3] x = "g1 (x) " and x1 = "g (sa) " and P2 = "\<lambda>x y. P (x,y) \<longrightarrow> d (x,y) \<in> t" for P d in bspec [THEN bspec])
apply auto
apply (rule_tac b = "h (f (sa), g (sa))" and A = C in trans_onD)
apply (auto simp add: part_order_def)
done

(**  This general result is used to prove Follows Un, munion, etc. **)
lemma imp_LeadsTo_comp2:
"\<lbrakk>F \<in> Increasing(A, r, f1) \<inter>  Increasing(B, s, g);
  \<forall>j \<in> A. F: {s \<in> state. <j, f(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f1(s)> \<in> r};
  \<forall>j \<in> B. F: {x \<in> state. <j, g(x)> \<in> s} \<longmapsto>w {x \<in> state. <j,g1(x)> \<in> s};
  mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t);
  \<forall>x \<in> state. f(x):A \<and> g1(x):B \<and> f1(x):A \<and>g(x):B; k \<in> C\<rbrakk>
  \<Longrightarrow> F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} \<longmapsto>w {x \<in> state. <k, h(f1(x), g1(x))> \<in> t}"
apply (rule_tac B = "{x \<in> state. <k, h (f1 (x), g (x))> \<in> t}" in LeadsTo_Trans)
apply (blast intro: imp_LeadsTo_comp_right)
apply (blast intro: imp_LeadsTo_comp_left)
done

(* Follows type *)
lemma Follows_type: "Follows(A, r, f, g)<=program"
  unfolding Follows_def
apply (blast dest: Increasing_type [THEN subsetD])
done

lemma Follows_into_program [TC]: "F \<in> Follows(A, r, f, g) \<Longrightarrow> F \<in> program"
by (blast dest: Follows_type [THEN subsetD])

lemma FollowsD:
"F \<in> Follows(A, r, f, g)\<Longrightarrow>
  F \<in> program \<and> (\<exists>a. a \<in> A) \<and> (\<forall>x \<in> state. f(x):A \<and> g(x):A)"
  unfolding Follows_def
apply (blast dest: IncreasingD)
done

lemma Follows_constantI:
 "\<lbrakk>F \<in> program; c \<in> A; refl(A, r)\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, \<lambda>x. c, \<lambda>x. c)"
apply (unfold Follows_def, auto)
apply (auto simp add: refl_def)
done

lemma subset_Follows_comp:
"\<lbrakk>mono1(A, r, B, s, h); refl(A, r); trans[B](s)\<rbrakk>
   \<Longrightarrow> Follows(A, r, f, g) \<subseteq> Follows(B, s,  h comp f, h comp g)"
apply (unfold Follows_def, clarify)
apply (frule_tac f = g in IncreasingD)
apply (frule_tac f = f in IncreasingD)
apply (rule IntI)
apply (rule_tac [2] h = h in imp_LeadsTo_comp)
prefer 5 apply assumption
apply (auto intro: imp_Increasing_comp imp_Always_comp simp del: INT_simps)
done

lemma imp_Follows_comp:
"\<lbrakk>F \<in> Follows(A, r, f, g);  mono1(A, r, B, s, h); refl(A, r); trans[B](s)\<rbrakk>
  \<Longrightarrow>  F \<in> Follows(B, s,  h comp f, h comp g)"
apply (blast intro: subset_Follows_comp [THEN subsetD])
done

(* 2-place monotone operation \<in> this general result is used to prove Follows_Un, Follows_munion *)

(* 2-place monotone operation \<in> this general result is
   used to prove Follows_Un, Follows_munion *)
lemma imp_Follows_comp2:
"\<lbrakk>F \<in> Follows(A, r, f1, f);  F \<in> Follows(B, s, g1, g);
   mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t)\<rbrakk>
   \<Longrightarrow> F \<in> Follows(C, t, \<lambda>x. h(f1(x), g1(x)), \<lambda>x. h(f(x), g(x)))"
apply (unfold Follows_def, clarify)
apply (frule_tac f = g in IncreasingD)
apply (frule_tac f = f in IncreasingD)
apply (rule IntI, safe)
apply (rule_tac [3] h = h in imp_Always_comp2)
prefer 5 apply assumption
apply (rule_tac [2] h = h in imp_Increasing_comp2)
prefer 4 apply assumption
apply (rule_tac h = h in imp_Increasing_comp2)
prefer 3 apply assumption
apply simp_all
apply (blast dest!: IncreasingD)
apply (rule_tac h = h in imp_LeadsTo_comp2)
prefer 4 apply assumption
apply auto
  prefer 3 apply (simp add: mono2_def)
apply (blast dest: IncreasingD)+
done

lemma Follows_trans:
     "\<lbrakk>F \<in> Follows(A, r, f, g);  F \<in> Follows(A,r, g, h);
         trans[A](r)\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, f, h)"
apply (frule_tac f = f in FollowsD)
apply (frule_tac f = g in FollowsD)
apply (simp add: Follows_def)
apply (simp add: Always_eq_includes_reachable INT_iff, auto)
apply (rule_tac [2] B = "{s \<in> state. <k, g (s) > \<in> r}" in LeadsTo_Trans)
apply (rule_tac b = "g (x) " in trans_onD)
apply blast+
done

(** Destruction rules for Follows **)

lemma Follows_imp_Increasing_left:
     "F \<in> Follows(A, r, f,g) \<Longrightarrow> F \<in> Increasing(A, r, f)"
by (unfold Follows_def, blast)

lemma Follows_imp_Increasing_right:
     "F \<in> Follows(A, r, f,g) \<Longrightarrow> F \<in> Increasing(A, r, g)"
by (unfold Follows_def, blast)

lemma Follows_imp_Always:
 "F :Follows(A, r, f, g) \<Longrightarrow> F \<in> Always({s \<in> state. <f(s),g(s)> \<in> r})"
by (unfold Follows_def, blast)

lemma Follows_imp_LeadsTo:
 "\<lbrakk>F \<in> Follows(A, r, f, g); k \<in> A\<rbrakk>  \<Longrightarrow>
  F: {s \<in> state. <k,g(s)> \<in> r } \<longmapsto>w {s \<in> state. <k,f(s)> \<in> r}"
by (unfold Follows_def, blast)

lemma Follows_LeadsTo_pfixLe:
     "\<lbrakk>F \<in> Follows(list(nat), gen_prefix(nat, Le), f, g); k \<in> list(nat)\<rbrakk>
   \<Longrightarrow> F \<in> {s \<in> state. k pfixLe g(s)} \<longmapsto>w {s \<in> state. k pfixLe f(s)}"
by (blast intro: Follows_imp_LeadsTo)

lemma Follows_LeadsTo_pfixGe:
     "\<lbrakk>F \<in> Follows(list(nat), gen_prefix(nat, Ge), f, g); k \<in> list(nat)\<rbrakk>
   \<Longrightarrow> F \<in> {s \<in> state. k pfixGe g(s)} \<longmapsto>w {s \<in> state. k pfixGe f(s)}"
by (blast intro: Follows_imp_LeadsTo)

lemma Always_Follows1:
"\<lbrakk>F \<in> Always({s \<in> state. f(s) = g(s)}); F \<in> Follows(A, r, f, h);
    \<forall>x \<in> state. g(x):A\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, g, h)"
  unfolding Follows_def Increasing_def Stable_def
apply (simp add: INT_iff, auto)
apply (rule_tac [3] C = "{s \<in> state. f(s)=g(s)}"
        and A = "{s \<in> state. <k, h (s)> \<in> r}"
        and A' = "{s \<in> state. <k, f(s)> \<in> r}" in Always_LeadsTo_weaken)
apply (erule_tac A = "{s \<in> state. <k,f(s) > \<in> r}"
           and A' = "{s \<in> state. <k,f(s) > \<in> r}" in Always_Constrains_weaken)
apply auto
apply (drule Always_Int_I, assumption)
apply (erule_tac A = "{s \<in> state. f(s)=g(s)} \<inter> {s \<in> state. <f(s), h(s)> \<in> r}"
       in Always_weaken)
apply auto
done

lemma Always_Follows2:
"\<lbrakk>F \<in> Always({s \<in> state. g(s) = h(s)});
  F \<in> Follows(A, r, f, g); \<forall>x \<in> state. h(x):A\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, f, h)"
  unfolding Follows_def Increasing_def Stable_def
apply (simp add: INT_iff, auto)
apply (rule_tac [3] C = "{s \<in> state. g (s) =h (s) }"
            and A = "{s \<in> state. <k, g (s) > \<in> r}"
            and A' = "{s \<in> state. <k, f (s) > \<in> r}" in Always_LeadsTo_weaken)
apply (erule_tac A = "{s \<in> state. <k, g(s)> \<in> r}"
         and A' = "{s \<in> state. <k, g(s)> \<in> r}" in Always_Constrains_weaken)
apply auto
apply (drule Always_Int_I, assumption)
apply (erule_tac A = "{s \<in> state. g(s)=h(s)} \<inter> {s \<in> state. <f(s), g(s)> \<in> r}"
       in Always_weaken)
apply auto
done

(** Union properties (with the subset ordering) **)

lemma refl_SetLe [simp]: "refl(Pow(A), SetLe(A))"
by (unfold refl_def SetLe_def, auto)

lemma trans_on_SetLe [simp]: "trans[Pow(A)](SetLe(A))"
by (unfold trans_on_def SetLe_def, auto)

lemma antisym_SetLe [simp]: "antisym(SetLe(A))"
by (unfold antisym_def SetLe_def, auto)

lemma part_order_SetLe [simp]: "part_order(Pow(A), SetLe(A))"
by (unfold part_order_def, auto)

lemma increasing_Un:
     "\<lbrakk>F \<in> Increasing.increasing(Pow(A), SetLe(A), f);
         F \<in> Increasing.increasing(Pow(A), SetLe(A), g)\<rbrakk>
     \<Longrightarrow> F \<in> Increasing.increasing(Pow(A), SetLe(A), \<lambda>x. f(x) \<union> g(x))"
by (rule_tac h = "(Un)" in imp_increasing_comp2, auto)

lemma Increasing_Un:
     "\<lbrakk>F \<in> Increasing(Pow(A), SetLe(A), f);
         F \<in> Increasing(Pow(A), SetLe(A), g)\<rbrakk>
     \<Longrightarrow> F \<in> Increasing(Pow(A), SetLe(A), \<lambda>x. f(x) \<union> g(x))"
by (rule_tac h = "(Un)" in imp_Increasing_comp2, auto)

lemma Always_Un:
     "\<lbrakk>F \<in> Always({s \<in> state. f1(s) \<subseteq> f(s)});
     F \<in> Always({s \<in> state. g1(s) \<subseteq> g(s)})\<rbrakk>
      \<Longrightarrow> F \<in> Always({s \<in> state. f1(s) \<union> g1(s) \<subseteq> f(s) \<union> g(s)})"
by (simp add: Always_eq_includes_reachable, blast)

lemma Follows_Un:
"\<lbrakk>F \<in> Follows(Pow(A), SetLe(A), f1, f);
     F \<in> Follows(Pow(A), SetLe(A), g1, g)\<rbrakk>
     \<Longrightarrow> F \<in> Follows(Pow(A), SetLe(A), \<lambda>s. f1(s) \<union> g1(s), \<lambda>s. f(s) \<union> g(s))"
by (rule_tac h = "(Un)" in imp_Follows_comp2, auto)

(** Multiset union properties (with the MultLe ordering) **)

lemma refl_MultLe [simp]: "refl(Mult(A), MultLe(A,r))"
by (unfold MultLe_def refl_def, auto)

lemma MultLe_refl1 [simp]:
 "\<lbrakk>multiset(M); mset_of(M)<=A\<rbrakk> \<Longrightarrow> \<langle>M, M\<rangle> \<in> MultLe(A, r)"
  unfolding MultLe_def id_def lam_def
apply (auto simp add: Mult_iff_multiset)
done

lemma MultLe_refl2 [simp]: "M \<in> Mult(A) \<Longrightarrow> \<langle>M, M\<rangle> \<in> MultLe(A, r)"
by (unfold MultLe_def id_def lam_def, auto)

lemma trans_on_MultLe [simp]: "trans[Mult(A)](MultLe(A,r))"
  unfolding MultLe_def trans_on_def
apply (auto intro: trancl_trans simp add: multirel_def)
done

lemma MultLe_type: "MultLe(A, r)<= (Mult(A) * Mult(A))"
apply (unfold MultLe_def, auto)
apply (drule multirel_type [THEN subsetD], auto)
done

lemma MultLe_trans:
     "\<lbrakk>\<langle>M,K\<rangle> \<in> MultLe(A,r); \<langle>K,N\<rangle> \<in> MultLe(A,r)\<rbrakk> \<Longrightarrow> \<langle>M,N\<rangle> \<in> MultLe(A,r)"
apply (cut_tac A=A in trans_on_MultLe)
apply (drule trans_onD, assumption)
apply (auto dest: MultLe_type [THEN subsetD])
done

lemma part_order_imp_part_ord:
     "part_order(A, r) \<Longrightarrow> part_ord(A, r-id(A))"
  unfolding part_order_def part_ord_def
apply (simp add: refl_def id_def lam_def irrefl_def, auto)
apply (simp (no_asm) add: trans_on_def)
apply auto
apply (blast dest: trans_onD)
apply (simp (no_asm_use) add: antisym_def)
apply auto
done

lemma antisym_MultLe [simp]:
  "part_order(A, r) \<Longrightarrow> antisym(MultLe(A,r))"
  unfolding MultLe_def antisym_def
apply (drule part_order_imp_part_ord, auto)
apply (drule irrefl_on_multirel)
apply (frule multirel_type [THEN subsetD])
apply (drule multirel_trans)
apply (auto simp add: irrefl_def)
done

lemma part_order_MultLe [simp]:
     "part_order(A, r) \<Longrightarrow>  part_order(Mult(A), MultLe(A, r))"
apply (frule antisym_MultLe)
apply (auto simp add: part_order_def)
done

lemma empty_le_MultLe [simp]:
"\<lbrakk>multiset(M); mset_of(M)<= A\<rbrakk> \<Longrightarrow> \<langle>0, M\<rangle> \<in> MultLe(A, r)"
  unfolding MultLe_def
apply (case_tac "M=0")
apply (auto simp add: FiniteFun.intros)
apply (subgoal_tac "<0 +# 0, 0 +# M> \<in> multirel (A, r - id (A))")
apply (rule_tac [2] one_step_implies_multirel)
apply (auto simp add: Mult_iff_multiset)
done

lemma empty_le_MultLe2 [simp]: "M \<in> Mult(A) \<Longrightarrow> \<langle>0, M\<rangle> \<in> MultLe(A, r)"
by (simp add: Mult_iff_multiset)

lemma munion_mono:
"\<lbrakk>\<langle>M, N\<rangle> \<in> MultLe(A, r); \<langle>K, L\<rangle> \<in> MultLe(A, r)\<rbrakk> \<Longrightarrow>
  <M +# K, N +# L> \<in> MultLe(A, r)"
  unfolding MultLe_def
apply (auto intro: munion_multirel_mono1 munion_multirel_mono2
       munion_multirel_mono multiset_into_Mult simp add: Mult_iff_multiset)
done

lemma increasing_munion:
     "\<lbrakk>F \<in> Increasing.increasing(Mult(A), MultLe(A,r), f);
         F \<in> Increasing.increasing(Mult(A), MultLe(A,r), g)\<rbrakk>
     \<Longrightarrow> F \<in> Increasing.increasing(Mult(A),MultLe(A,r), \<lambda>x. f(x) +# g(x))"
by (rule_tac h = munion in imp_increasing_comp2, auto)

lemma Increasing_munion:
     "\<lbrakk>F \<in> Increasing(Mult(A), MultLe(A,r), f);
         F \<in> Increasing(Mult(A), MultLe(A,r), g)\<rbrakk>
     \<Longrightarrow> F \<in> Increasing(Mult(A),MultLe(A,r), \<lambda>x. f(x) +# g(x))"
by (rule_tac h = munion in imp_Increasing_comp2, auto)

lemma Always_munion:
"\<lbrakk>F \<in> Always({s \<in> state. <f1(s),f(s)> \<in> MultLe(A,r)});
          F \<in> Always({s \<in> state. <g1(s), g(s)> \<in> MultLe(A,r)});
  \<forall>x \<in> state. f1(x):Mult(A)\<and>f(x):Mult(A) \<and> g1(x):Mult(A) \<and> g(x):Mult(A)\<rbrakk>
      \<Longrightarrow> F \<in> Always({s \<in> state. <f1(s) +# g1(s), f(s) +# g(s)> \<in> MultLe(A,r)})"
apply (rule_tac h = munion in imp_Always_comp2, simp_all)
apply (blast intro: munion_mono, simp_all)
done

lemma Follows_munion:
"\<lbrakk>F \<in> Follows(Mult(A), MultLe(A, r), f1, f);
    F \<in> Follows(Mult(A), MultLe(A, r), g1, g)\<rbrakk>
  \<Longrightarrow> F \<in> Follows(Mult(A), MultLe(A, r), \<lambda>s. f1(s) +# g1(s), \<lambda>s. f(s) +# g(s))"
by (rule_tac h = munion in imp_Follows_comp2, auto)

(** Used in ClientImp **)

lemma Follows_msetsum_UN:
"\<And>f. \<lbrakk>\<forall>i \<in> I. F \<in> Follows(Mult(A), MultLe(A, r), f'(i), f(i));
  \<forall>s. \<forall>i \<in> I. multiset(f'(i, s)) \<and> mset_of(f'(i, s))<=A \<and>
                        multiset(f(i, s)) \<and> mset_of(f(i, s))<=A ;
   Finite(I); F \<in> program\<rbrakk>
        \<Longrightarrow> F \<in> Follows(Mult(A),
                        MultLe(A, r), \<lambda>x. msetsum(\<lambda>i. f'(i, x), I, A),
                                      \<lambda>x. msetsum(\<lambda>i. f(i,  x), I, A))"
apply (erule rev_mp)
apply (drule Finite_into_Fin)
apply (erule Fin_induct)
apply (simp (no_asm_simp))
apply (rule Follows_constantI)
apply (simp_all (no_asm_simp) add: FiniteFun.intros)
apply auto
apply (rule Follows_munion, auto)
done

end


theory Relpath imports Gensyn Gensyn_Descend
begin

(* some more utilities for childpaths *)
fun droplast :: "'a list \<Rightarrow> 'a list option" where
"droplast [] = None"
| "droplast [h] = Some []"
| "droplast (h#t) =
   (case droplast t of
    None \<Rightarrow> None
    | Some t' \<Rightarrow> Some (h#t'))"

(* when we are representing childpaths backwards (for easier induction) *)
type_synonym childpath_rev = "nat list"

fun droplast' :: "'a list \<Rightarrow> 'a list" where
"droplast' [] = []"
| "droplast' [h] = []"
| "droplast' (h#t) = h # droplast' t"

(* Path updates resulting from execution at a Gensyn node *)
datatype rel_update =
  Parent
  | Desc "childpath_rev"

(* NB: these are not canonical. *)
datatype relpath =
  RP (r_ancestor : "nat") (r_desc : "childpath_rev")

(* idea: relpathD captures the idea of
   - "navigate to the given childpath"
   - then "modify by the relpath"
*)
fun relpathD_rev :: "relpath \<Rightarrow> childpath_rev \<Rightarrow> childpath_rev option" where
"relpathD_rev (RP 0 desc) path = Some (desc @ path)"
| "relpathD_rev (RP (Suc n) desc) [] = None"
| "relpathD_rev (RP (Suc n) desc) (ph#pt) = relpathD_rev (RP n desc) (pt)"

fun relpath_update :: "relpath \<Rightarrow> rel_update \<Rightarrow> relpath" where
"relpath_update (RP n []) Parent = (RP (Suc n) [])"
| "relpath_update (RP n (ph#pt)) Parent = (RP n pt)"
| "relpath_update (RP n path) (Desc cp) = (RP n (cp @ path))"

fun childpath_rev_update :: "childpath_rev \<Rightarrow> rel_update \<Rightarrow> childpath_rev option" where
"childpath_rev_update [] Parent = None"
| "childpath_rev_update (ph#pt) Parent = Some (pt)"
| "childpath_rev_update path (Desc cp) = Some (cp @ path)"

lemma droplast'_suffix :
  shows "droplast' (l1 @ h # l2) = l1 @ droplast' (h # l2)"
proof(induction l1 arbitrary: h l2)
  case Nil
  then show ?case by auto
next
  case (Cons a l1)
  show ?case
  proof(cases l1)
    case Nil' : Nil
    show ?thesis using Cons Nil' by(auto)
  next
    case Cons' : (Cons a' l1')
    show ?thesis using Cons Cons' by(auto)
  qed
qed

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc l x = l @ [x]"

lemma snoc_case :
  "\<exists> l' x . (h#t) = (snoc l' x)"
proof(induction t arbitrary: h)
  case Nil
  then show ?case by auto
next
  case (Cons a t)
  obtain l1 x where L1 : "a#t = snoc l1 x" using Cons(1)[of a] by(auto)

  then show ?case by auto
qed

lemma list_induct_app :
  assumes HNil : "P []"
  assumes HSing : "\<And> x . P [x]"
  assumes HApp : "\<And> l1 l2 . P l1 \<Longrightarrow> P l2 \<Longrightarrow> P (l1 @ l2)"
  shows "P l" using assms
proof(induction l arbitrary: P)
  case Nil
  then show ?case by auto
next
  case (Cons a l)

  have Conc' : "P l" using Cons(1)[of P, OF Cons(2) Cons(3) Cons(4)] by auto

  show ?case using Cons(4)[of "[a]" l, OF Cons(3) Conc']
    by auto
qed

lemma relpath_update_correct_rev :
  assumes H : "relpathD_rev r cp = Some cp'"
  shows "relpathD_rev (relpath_update r upd) cp =
         childpath_rev_update cp' upd" using assms
proof(induction cp arbitrary: r cp' upd)
  case Nil
  obtain anc desc where R : "r = RP anc desc" by(cases r; auto)

  then show ?case using Nil  apply(cases anc; auto) apply(cases upd; auto)
    apply(cases cp'; auto)
    done
next
  case (Cons cph cpt)

  obtain anc desc where R : "r = RP anc desc" by(cases r; auto)

  show ?case
  proof(cases anc)
    case 0
    show ?thesis
    proof(cases upd)
      case Parent
      show ?thesis
      proof(cases desc)
        case Nil' : Nil
        then show ?thesis using 0 R Cons Parent by auto
      next
        case Cons' : (Cons dh dt)
        then show ?thesis using 0 R Cons Parent by auto
      qed
    next
      case (Desc up_desc)
      show ?thesis
      proof(cases desc)
        case Nil' : Nil
        then show ?thesis using 0 R Cons Desc by auto
      next
        case Cons' : (Cons dh dt)
        then show ?thesis using 0 R Cons Desc by auto
      qed
    qed
  next

    case (Suc anc')

    hence RelPath : "relpathD_rev (RP anc' desc) cpt = Some cp'" using Cons R by(auto)

    show ?thesis
    proof(cases upd)
      case Parent
      show ?thesis
      proof(cases desc)
        case Nil' : Nil
        then show ?thesis using Cons(1)[OF RelPath, of Parent] Suc R Parent
          by(auto)
      next
        case Cons' : (Cons dh dt)
        then show ?thesis using Cons(1)[OF RelPath, of Parent] Suc R Parent by(auto)
      qed
    next
      case (Desc up_desc)
      show ?thesis
      proof(cases desc)
        case Nil' : Nil
        then show ?thesis using Cons(1)[OF RelPath, of "Desc up_desc"] Suc R Desc by auto
      next
        case Cons' : (Cons dh dt)
        then show ?thesis using Cons(1)[OF RelPath, of "Desc up_desc"] Suc R Desc by auto
      qed
    qed
  qed
qed

definition relpathD :: "relpath \<Rightarrow> childpath \<Rightarrow> childpath option" where
"relpathD r cp =
  (case relpathD_rev r (rev cp) of
   None \<Rightarrow> None
   | Some cp' \<Rightarrow> Some (rev cp'))"

definition childpath_update :: "childpath \<Rightarrow> rel_update \<Rightarrow> childpath option" where
"childpath_update cp upd =
  (case childpath_rev_update (rev cp) upd of
   None \<Rightarrow> None
   | Some cp' \<Rightarrow> Some (rev cp'))"

lemma relpath_update_correct :
  assumes H : "relpathD r cp = Some cp'"
  shows "relpathD (relpath_update r upd) cp =
         childpath_update cp' upd"
proof(cases "relpathD_rev r (rev cp)")
  case None
  then show ?thesis using H
    by(auto simp add: relpathD_def childpath_update_def)
next
  case (Some cp'r)

  have Cp'_rev: "cp'r = rev cp'" using Some H by(auto simp add: relpathD_def childpath_update_def)

  show ?thesis
  proof(cases "relpathD_rev (relpath_update r upd) (rev cp)")
    case None' : None

    show ?thesis using Some None'
    proof(cases "childpath_rev_update (rev cp') upd")
      case None'' : None
      then show ?thesis using Some None' by(auto simp add: relpathD_def childpath_update_def)
    next
      case Some'' : (Some y)
      then show ?thesis using Some None' relpath_update_correct_rev[OF Some] Cp'_rev
        by(auto)
    qed
  next
    case Some' : (Some x)
    then show ?thesis using Some Some' relpath_update_correct_rev[OF Some] Cp'_rev
      by(auto simp add: relpathD_def childpath_update_def)
  qed
qed

(* OK, so now we have this utility for relative paths. The game plan now:
- store relative paths in the state
- pass around a path which is used to find the actual nodes

how does this fit into Hoare triples though?

i think we should be able to leave the original childpath concrete.

so, when we are actually looking at sub-trees, this should make it easier.

*)

end


section \<open> Serialisable Universe for Interaction Trees \<close>

theory Serialisable
  imports "Interaction_Trees.ITrees"
begin

text \<open> Aim: To support a flexible animator that can display information about the type of data that
  channels being offered accept. \<close>

type_synonym uname = String.literal

text \<open> The following universe contains types that have direct equivalents in Haskell. \<close>

datatype uval =
  UnitV |
  BoolV (ofBoolV: bool) |
  IntV (ofIntV: integer)|
  RatV (ofRatV: rat) |
  StringV (ofStringV: String.literal) |
  EnumV (ofEnums: "uname set") (ofEnumV: "uname")  |
  PairV (ofPairV: "uval \<times> uval") |
  ListV (ofListV: "uval list")

datatype utyp =
  UnitT | BoolT | IntT | RatT | StringT | EnumT "uname set" | PairT "utyp \<times> utyp" | ListT utyp

text \<open> Infer the type of a valid @{typ uval}. It's best to stick to a monomorphic type system,
  to make animation easier (i.e. each value maps to one type). \<close>

fun utyp_of :: "uval \<Rightarrow> utyp option" where
"utyp_of UnitV = Some UnitT" |
"utyp_of (BoolV _) = Some BoolT" |
"utyp_of (IntV _) = Some IntT" |
"utyp_of (RatV _) = Some RatT" |
"utyp_of (StringV _) = Some StringT" |
"utyp_of (EnumV A _) = Some (EnumT A)" |
"utyp_of (PairV p) = do { a \<leftarrow> utyp_of (fst p); b \<leftarrow> utyp_of (snd p); Some (PairT (a, b)) }" |
"utyp_of (ListV xs) = do { as \<leftarrow> those (map utyp_of xs);
                           case as of
                             [] \<Rightarrow> None
                           | (a # as) \<Rightarrow> if (\<forall> b \<in> set as. a = b) then Some a else None }"

definition uvals :: "utyp \<Rightarrow> uval set" where
"uvals a = {x. utyp_of x = Some a}"

text \<open> A class to declare injections between HOL types and parts of the universe. \<close>

class uval =
  fixes to_uval :: "'a \<Rightarrow> uval" \<comment> \<open> Inject into the universe \<close>
  and from_uval :: "uval \<Rightarrow> 'a" \<comment> \<open> Project from the universe \<close>
  and utyp :: "'a itself \<Rightarrow> utyp" \<comment> \<open> Give the equivalent universe type for the HOL type \<close>
  assumes to_uval_typ [simp]: "utyp_of (to_uval x) = Some (utyp TYPE('a))"
  and to_uval_inv [simp]: "from_uval (to_uval x) = x"

syntax "_utyp" :: "type \<Rightarrow> logic" ("UTYPE'(_')")
translations "UTYPE('a)" == "CONST utyp TYPE('a)"

instantiation unit :: uval
begin

definition to_uval_unit :: "unit \<Rightarrow> uval" where
  "to_uval_unit x = UnitV"

fun from_uval_unit :: "uval \<Rightarrow> unit" where
  "from_uval_unit x = ()"

definition utyp_unit :: "unit itself \<Rightarrow> utyp" where
  "utyp_unit a = UnitT"

instance
  by (intro_classes; simp add: to_uval_unit_def utyp_unit_def)

end

instantiation int :: uval
begin

definition to_uval_int :: "int \<Rightarrow> uval" where
  "to_uval_int x = IntV (integer_of_int x)"

fun from_uval_int :: "uval \<Rightarrow> int" where
  "from_uval_int (IntV x) = int_of_integer x" | "from_uval_int _ = 0"

definition utyp_int :: "int itself \<Rightarrow> utyp" where
  "utyp_int a = IntT"

instance
  by (intro_classes; simp add: to_uval_int_def utyp_int_def)

end

instantiation integer :: uval
begin

definition to_uval_integer :: "integer \<Rightarrow> uval" where
  "to_uval_integer x = IntV x"

fun from_uval_integer :: "uval \<Rightarrow> integer" where
  "from_uval_integer (IntV x) = x" | "from_uval_integer _ = 0"

definition utyp_integer :: "integer itself \<Rightarrow> utyp" where
  "utyp_integer a = IntT"

instance
  by (intro_classes; simp add: to_uval_integer_def utyp_integer_def)

end

instantiation prod :: (uval, uval) uval
begin

definition to_uval_prod :: "'a \<times> 'b \<Rightarrow> uval" where
  "to_uval_prod = (\<lambda> (x, y). PairV (to_uval x, to_uval y))"

definition from_uval_prod :: "uval \<Rightarrow> 'a \<times> 'b" where
  "from_uval_prod p = map_prod from_uval from_uval (ofPairV p)"

definition utyp_prod :: "('a \<times> 'b) itself \<Rightarrow> utyp" where
  "utyp_prod a = PairT (UTYPE('a), UTYPE('b))"

instance
  by (intro_classes; simp add: to_uval_prod_def from_uval_prod_def utyp_prod_def prod.case_eq_if)

end

type_synonym uevent = "uname \<times> uval"

definition uchoice :: "uname \<Rightarrow> utyp \<Rightarrow> (uval \<Rightarrow> 'a) \<Rightarrow> uname \<times> uval \<Zpfun> 'a" where
"uchoice n t f = (\<lambda> (n, x) \<in> {n} \<times> uvals t \<bullet> f x)"

text \<open> The following class characterises types that have a channel structure, i.e. a finite
  number of constructors each with a single parameter that can be represented as a @{typ uval}. \<close>

class chtype =
  fixes chans :: "'a itself \<Rightarrow> String.literal set" \<comment> \<open> The set of channel names \<close>
  and chtyp :: "'a itself \<Rightarrow> String.literal \<Zpfun> utyp" \<comment> \<open> The type of each channel \<close>
  and chbuild :: "uname \<Zpfun> (uval \<Rightarrow> 'a)"
  and chmatch :: "uname \<Rightarrow> 'a \<Zpfun> uval"
  \<comment> \<open> The match function produces a correctly typed value for each channel \<close>
  assumes "n \<in> chans TYPE('a) \<Longrightarrow> ran (chmatch n) = uvals (chtyp TYPE('a) n)"

definition chpfun :: "String.literal \<Rightarrow> (uval \<Rightarrow> 't) \<Rightarrow> ('e::chtype \<Zpfun> 't)" where
"chpfun n f = (\<lambda> x\<in>uvals(chtyp TYPE('e) n) \<bullet> f x) \<circ>\<^sub>p chmatch n"

definition chpfuns :: "(String.literal \<times> (uval \<Rightarrow> 't)) list \<Rightarrow> ('e::chtype \<Zpfun> 't)" where
"chpfuns fs = foldr (\<oplus>) (map (\<lambda> (n, f). chpfun n f) fs) {}\<^sub>p"

code_datatype chpfuns pfun_entries pfun_of_alist pfun_of_map

export_code chpfuns in Haskell

chantype buf =
  Inp :: int
  Outp :: int

lemma utyp_of_IntTE: "\<lbrakk> utyp_of x = Some IntT; \<And> n. \<lbrakk> x = IntV n \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  sorry

instantiation buf :: chtype
begin

definition chans_buf :: "buf itself \<Rightarrow> uname set"
  where "chans_buf a = {STR ''Inp'', STR ''Outp''}"

definition chtyp_buf :: "buf itself \<Rightarrow> uname \<Zpfun> utyp"
  where "chtyp_buf a = {STR ''Inp'' \<mapsto> IntT, STR ''Outp'' \<mapsto> IntT}"

definition chbuild_buf :: "uname \<Zpfun> (uval \<Rightarrow> buf)"
  where "chbuild_buf = {STR ''Inp'' \<mapsto> (\<lambda> x. build\<^bsub>Inp\<^esub> (from_uval x))
                       ,STR ''Outp'' \<mapsto> (\<lambda> x. build\<^bsub>Outp\<^esub> (from_uval x))}"

definition chmatch_buf :: "uname \<Rightarrow> buf \<Zpfun> uval"
  where "chmatch_buf = (\<lambda> x. {}\<^sub>p)(STR ''Inp'' := (\<lambda> x\<in>range build\<^bsub>Inp\<^esub> \<bullet> to_uval (the (match\<^bsub>Inp\<^esub> x)))
                                 ,STR ''Outp'' := (\<lambda> x\<in>range build\<^bsub>Outp\<^esub> \<bullet> to_uval (the (match\<^bsub>Outp\<^esub> x))))"

instance
  apply (intro_classes, auto elim!: utyp_of_IntTE simp add: chmatch_buf_def chans_buf_def chtyp_buf_def uvals_def utyp_int_def to_uval_int_def)
   apply (rename_tac n)
   apply (rule_tac x="build\<^bsub>Inp\<^esub> (int_of_integer n)" in exI)
   apply (simp)
   apply (rename_tac n)
  apply (rule_tac x="build\<^bsub>Outp\<^esub> (int_of_integer n)" in exI)
  apply (simp)
  done
end

definition myitree :: "(buf, integer) itree" where
"myitree = Vis (chpfuns [(STR ''Inp'', \<lambda> x. Ret (from_uval x))])"

export_code myitree in Haskell

end


section \<open>Simple Games\<close>

theory Simple_Game
imports
  Main
begin

text \<open>Simple games are games where player0 wins all infinite plays.\<close>
locale simple_game =
fixes
  game_move :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<longmapsto>\<heartsuit> _" [70, 70] 80) and
  player0_position :: \<open>'s \<Rightarrow> bool\<close>
begin

abbreviation player1_position :: \<open>'s \<Rightarrow> bool\<close>
  where \<open>player1_position s \<equiv> \<not> player0_position s\<close>

\<comment>\<open>plays (to be precise: play prefixes) are lists. we model them
  with the most recent move at the beginning. (for our purpose it's enough to consider finite plays)\<close>
type_synonym ('s2) play = \<open>'s2 list\<close>
type_synonym ('s2) strategy = \<open>'s2 play \<Rightarrow> 's2\<close>
type_synonym ('s2) posstrategy = \<open>'s2 \<Rightarrow> 's2\<close>

definition strategy_from_positional :: \<open>'s posstrategy \<Rightarrow> 's strategy\<close> where
  \<open>strategy_from_positional pf = (\<lambda> play. pf (hd play))\<close>

inductive_set plays :: \<open>'s \<Rightarrow> 's play set\<close>
  for initial :: 's where
  \<open>[initial] \<in> plays initial\<close> |
  \<open>p#play \<in> plays initial \<Longrightarrow> p \<longmapsto>\<heartsuit> p' \<Longrightarrow> p'#p#play \<in> plays initial\<close>

definition play_continuation :: \<open>'s play \<Rightarrow> 's play \<Rightarrow> bool\<close>
  where \<open>play_continuation p1 p2 \<equiv> (drop (length p2 - length p1) p2) = p1\<close>

\<comment>\<open>plays for a given player 0 strategy\<close>
inductive_set plays_for_0strategy :: \<open>'s strategy \<Rightarrow> 's \<Rightarrow> 's play set\<close>
  for f initial where
  init: \<open>[initial] \<in> plays_for_0strategy f initial\<close> |
  p0move: \<open>n0#play \<in> plays_for_0strategy f initial \<Longrightarrow> player0_position n0 \<Longrightarrow> n0 \<longmapsto>\<heartsuit> f (n0#play)
    \<Longrightarrow> (f (n0#play))#n0#play \<in> plays_for_0strategy f initial\<close> |
  p1move: \<open>n1#play \<in> plays_for_0strategy f initial \<Longrightarrow> player1_position n1 \<Longrightarrow> n1 \<longmapsto>\<heartsuit> n1'
    \<Longrightarrow> n1'#n1#play \<in> plays_for_0strategy f initial\<close>

lemma strategy0_step:
  assumes
    \<open>n0 # n1 # rest \<in> plays_for_0strategy f initial\<close>
    \<open>player0_position n1\<close>
  shows
    \<open>f (n1 # rest) = n0\<close>
  using assms
  by (induct rule: plays_for_0strategy.cases, auto)

\<comment>\<open>plays for a given player 1 strategy\<close>
inductive_set plays_for_1strategy :: \<open>'s strategy \<Rightarrow> 's \<Rightarrow> 's play set\<close>
  for f initial where
  init: \<open>[initial] \<in> plays_for_1strategy f initial\<close> |
  p0move: \<open>n0#play \<in> plays_for_1strategy f initial \<Longrightarrow> player0_position n0 \<Longrightarrow> n0 \<longmapsto>\<heartsuit> n0'
    \<Longrightarrow> n0'#n0#play \<in> plays_for_1strategy f initial\<close> |
  p1move: \<open>n1#play \<in> plays_for_1strategy f initial \<Longrightarrow> player1_position n1 \<Longrightarrow> n1 \<longmapsto>\<heartsuit> f (n1#play)
    \<Longrightarrow> (f (n1#play))#n1#play \<in> plays_for_1strategy f initial\<close>

definition positional_strategy :: \<open>'s strategy \<Rightarrow> bool\<close> where
  \<open>positional_strategy f \<equiv> \<forall>r1 r2 n. f (n # r1) = f (n # r2)\<close>

text \<open>a strategy is sound if it only decides on enabled transitions.\<close>
definition sound_0strategy :: \<open>'s strategy \<Rightarrow> 's \<Rightarrow> bool\<close> where
  \<open>sound_0strategy f initial \<equiv>
    \<forall> n0 play . n0#play \<in> plays_for_0strategy f initial \<and> player0_position n0 \<longrightarrow> n0 \<longmapsto>\<heartsuit> f (n0#play)\<close>

definition sound_1strategy :: \<open>'s strategy \<Rightarrow> 's \<Rightarrow> bool\<close> where
  \<open>sound_1strategy f initial \<equiv>
    \<forall> n1 play . n1#play \<in> plays_for_1strategy f initial \<and> player1_position n1 \<longrightarrow> n1 \<longmapsto>\<heartsuit> f (n1#play)\<close>

lemma strategy0_plays_subset:
  assumes \<open>play \<in> plays_for_0strategy f initial\<close>
  shows \<open>play \<in> plays initial\<close>
  using assms by (induct rule: plays_for_0strategy.induct, auto simp add: plays.intros)
lemma strategy1_plays_subset:
  assumes \<open>play \<in> plays_for_1strategy f initial\<close>
  shows \<open>play \<in> plays initial\<close>
  using assms by (induct rule: plays_for_1strategy.induct, auto simp add: plays.intros)

lemma no_empty_plays:
  assumes \<open>[] \<in> plays initial\<close>
  shows \<open>False\<close>
  using assms plays.cases by blast

text \<open>player1 wins a play if the play has reached a deadlock where it's player0's turn\<close>

definition player1_wins_immediately :: \<open>'s play \<Rightarrow> bool\<close> where
  \<open>player1_wins_immediately play \<equiv> player0_position (hd play) \<and> (\<nexists> p' . (hd play) \<longmapsto>\<heartsuit> p')\<close>

definition player0_winning_strategy :: \<open>'s strategy \<Rightarrow> 's \<Rightarrow> bool\<close> where
  \<open>player0_winning_strategy f initial \<equiv> (\<forall> play \<in> plays_for_0strategy f initial . \<not> player1_wins_immediately play)\<close>

definition player0_wins :: \<open>'s \<Rightarrow> bool\<close> where
  \<open>player0_wins s \<equiv> (\<exists> f . player0_winning_strategy f s \<and> sound_0strategy f s)\<close>

lemma stuck_player0_win:
  assumes \<open>player1_position initial\<close> \<open>(\<nexists> p' . initial \<longmapsto>\<heartsuit> p')\<close>
  shows \<open>player0_wins initial\<close>
proof -
  have \<open>\<And>pl. pl \<in> plays initial \<Longrightarrow> pl = [initial]\<close>
  proof -
    fix pl
    assume \<open>pl \<in> plays initial\<close>
    thus \<open>pl = [initial]\<close> using assms(2) by (induct, auto)
  qed
  thus ?thesis using assms(1)
    by (metis list.sel(1) player0_winning_strategy_def player0_wins_def player1_wins_immediately_def
        sound_0strategy_def strategy0_plays_subset)
qed

definition player0_wins_immediately :: \<open>'s play \<Rightarrow> bool\<close> where
  \<open>player0_wins_immediately play \<equiv> player1_position (hd play) \<and> (\<nexists> p' . (hd play) \<longmapsto>\<heartsuit> p')\<close>

\<comment> \<open>in comparison to the defender, the attacker also has to bound the depth of plays.\<close>
definition player1_winning_strategy :: \<open>'s strategy \<Rightarrow> 's \<Rightarrow> bool\<close> where
  \<open>player1_winning_strategy f initial \<equiv>
    \<exists>maxn. (\<forall> play \<in> plays_for_1strategy f initial . \<not> player0_wins_immediately play \<and> length play \<le> maxn)\<close>

definition player1_wins :: \<open>'s \<Rightarrow> bool\<close> where
  \<open>player1_wins s \<equiv> (\<exists> f . player1_winning_strategy f s \<and> sound_1strategy f s)\<close>

lemma stuck_0_all_strats_win:
  assumes \<open>player0_position initial\<close> \<open>(\<nexists> p' . initial \<longmapsto>\<heartsuit> p')\<close>
  shows  \<open>\<forall>f. player1_winning_strategy f initial\<close>
proof -
  have \<open>\<And>pl. pl \<in> plays initial \<Longrightarrow> pl = [initial]\<close>
  proof -
    fix pl
    assume \<open>pl \<in> plays initial\<close>
    thus \<open>pl = [initial]\<close> using assms(2) by (induct, auto)
  qed
  hence \<open>\<forall>f. (\<forall> play \<in> plays_for_1strategy f initial . \<not> player0_wins_immediately play \<and> length play \<le> 1)\<close>
    by (metis assms(1) butlast.simps(1) butlast_conv_take diff_is_0_eq'
       le_numeral_extra(4) length_tl list.sel(1, 2) list.size(3)
       one_eq_numeral_iff player0_wins_immediately_def
       strategy1_plays_subset take_Cons_numeral take_all_iff)
  thus ?thesis using player1_winning_strategy_def by auto
qed

lemma stuck_player1_win:
 assumes \<open>player0_position initial\<close> \<open>(\<nexists> p' . initial \<longmapsto>\<heartsuit> p')\<close>
  shows \<open>player1_wins initial\<close>
proof -
  have all_plays_stuck: \<open>\<And>pl. pl \<in> plays initial \<Longrightarrow> pl = [initial]\<close>
  proof -
    fix pl
    assume \<open>pl \<in> plays initial\<close>
    thus \<open>pl = [initial]\<close> using assms(2) by (induct, auto)
  qed
  have \<open>sound_1strategy (\<lambda>x. hd x) initial\<close>
    unfolding sound_1strategy_def
    using all_plays_stuck assms(1) strategy1_plays_subset by auto
  thus ?thesis unfolding player1_wins_def using assms stuck_0_all_strats_win by auto
qed

end

end


theory Dagstuhl
imports "HOLCF-Library.Stream"
begin

axiomatization
  y  :: "'a"

definition
  YS :: "'a stream" where
  "YS = fix\<cdot>(LAM x. y && x)"

definition
  YYS :: "'a stream" where
  "YYS = fix\<cdot>(LAM z. y && y && z)"

lemma YS_def2: "YS = y && YS"
  apply (rule trans)
  apply (rule fix_eq2)
  apply (rule YS_def [THEN eq_reflection])
  apply (rule beta_cfun)
  apply simp
  done

lemma YYS_def2: "YYS = y && y && YYS"
  apply (rule trans)
  apply (rule fix_eq2)
  apply (rule YYS_def [THEN eq_reflection])
  apply (rule beta_cfun)
  apply simp
  done

lemma lemma3: "YYS << y && YYS"
  apply (rule YYS_def [THEN eq_reflection, THEN def_fix_ind])
  apply simp_all
  apply (rule monofun_cfun_arg)
  apply (rule monofun_cfun_arg)
  apply assumption
  done

lemma lemma4: "y && YYS << YYS"
  apply (subst YYS_def2)
  back
  apply (rule monofun_cfun_arg)
  apply (rule lemma3)
  done

lemma lemma5: "y && YYS = YYS"
  apply (rule below_antisym)
  apply (rule lemma4)
  apply (rule lemma3)
  done

lemma wir_moel: "YS = YYS"
  apply (rule stream.take_lemma)
  apply (induct_tac n)
  apply (simp (no_asm))
  apply (subst YS_def2)
  apply (subst YYS_def2)
  apply simp
  apply (rule lemma5 [symmetric, THEN subst])
  apply (rule refl)
  done

(* ------------------------------------------------------------------------ *)
(* Zweite L"osung: Bernhard Möller                                          *)
(* statt Beweis von  wir_moel "uber take_lemma beidseitige Inclusion        *)
(* verwendet lemma5                                                         *)
(* ------------------------------------------------------------------------ *)

lemma lemma6: "YYS << YS"
  apply (unfold YYS_def)
  apply (rule fix_least)
  apply (subst beta_cfun)
  apply simp
  apply (simp add: YS_def2 [symmetric])
  done

lemma lemma7: "YS << YYS"
  apply (rule YS_def [THEN eq_reflection, THEN def_fix_ind])
  apply simp_all
  apply (subst lemma5 [symmetric])
  apply (erule monofun_cfun_arg)
  done

lemma wir_moel': "YS = YYS"
  apply (rule below_antisym)
  apply (rule lemma7)
  apply (rule lemma6)
  done

end


subsection \<open>IMO 2006 SL - A4\<close>

theory IMO_2006_SL_A4
imports Complex_Main
begin

theorem IMO_2006_SL_A4:
  fixes a :: "nat \<Rightarrow> real" and n :: nat
  assumes
    "\<forall> i. 1 \<le> i \<and> i \<le> n \<longrightarrow> a i > 0"
  shows
    "(\<Sum> i = 1..<n. \<Sum> j = i+1..n. (a i * a j / (a i + a j))) \<le>
     (n / (2 * (\<Sum> i = 1..n. a i)) * (\<Sum> i = 1..<n. \<Sum> j = i+1..n. (a i * a j)))"
  sorry

end


(*  Title:      Squarefree2.thy
    Author:     Klaus Weidinger, TU Muenchen
    Copyright   2020

A simproc for the predicate "prime (n::int)" from "Squarefree.thy".
*)

theory Squarefree2
  imports
    Main
    Complex_Main
    "HOL-Computational_Algebra.Primes"
    "HOL-Computational_Algebra.Nth_Powers"
    "HOL-Computational_Algebra.Squarefree"
    "HOL-Number_Theory.Prime_Powers"
    HOL.Num
    Prime
begin

text\<open>
Case distinction:
  case "n = 0": lemma 'not_squarefree_0' from 'Squarefree.thy'
  case "n > 0 & squarefree n": lemma 'squarefree_true'
  case "n > 0 & ~squarefree n": lemma 'squarefree_false'
\<close>

lemma squarefree_true:
  fixes n :: "'a :: factorial_semiring_gcd"
  assumes "list_all prime xs" "prod_list xs = n" "distinct xs"
  shows "squarefree n"
proof -
  have "squarefree (\<Prod>(set xs))"
    using assms
    by (intro squarefree_prod_coprime) (auto simp: list_all_iff squarefree_prime primes_coprime)
  also have "(\<Prod>(set xs)) = n"
    using assms by (subst prod.distinct_set_conv_list) auto
  finally show "squarefree n" by simp
qed

lemma list_all_Nil: "list_all P []"
  by simp

lemma list_all_ConsI: "P x \<Longrightarrow> list_all P xs \<Longrightarrow> list_all P (x # xs)"
  by auto

lemma squarefree_false:
  fixes sf::nat
  assumes "x^2 * k = sf" "x > 1"
  shows "\<not> squarefree sf"
proof -
  have "x^2 dvd sf \<and> x > 1" using assms by (auto simp: dvd_def)
  thus "\<not> squarefree sf" by (auto simp: not_squarefreeI)
qed

ML_file\<open>algorithms.ML\<close>
ML_file\<open>tools.ML\<close>

ML\<open>
signature SQUAREFREE =
sig

(* defines the upper (and lower) bound for the simproc *)
val limit: int Config.T

val parse: Thm.cterm -> int

(*                            n     factors                  n   square    *)
datatype cert = TRUE_CERT of int * int list | FALSE_CERT of int * int | ZERO
val mk_cert: int -> cert
val generate_proof: Proof.context -> cert -> thm option

val prove: Proof.context -> int -> thm option
val simproc: Proof.context -> Thm.cterm -> thm option

(* helper tools *)
val get_cert_number : cert -> int

end

structure Squarefree : SQUAREFREE =
struct

val limit = Attrib.setup_config_int \<^binding>\<open>limit\<close> (K 1000000);
exception LIMIT

(*                            n     factors                  n   duplicate    *)
datatype cert = TRUE_CERT of int * int list | FALSE_CERT of int * int | ZERO

fun parse ct = Tools.parse1 ct @{const_name "squarefree"}

(* "no_duplicates" assumes that factor list is ordered (here in descending order)   *)
fun mk_cert n =
    if n = 0 then ZERO else
    let
        val factors = Algorithms.factorize n
        fun no_duplicates (f1::f2::fs) = if f1 = f2 then (false, f1)
                                                    else no_duplicates (f2::fs)
          | no_duplicates _ = (true, 1)
        val result = no_duplicates factors
    in
        if fst result then TRUE_CERT (n, factors)
                      else FALSE_CERT (n, snd result)
    end

exception ERROR
fun generate_proof _ ZERO =
          SOME @{thm not_squarefree_0}
  | generate_proof ctxt (TRUE_CERT (n, fs)) =
    let
      (* initialize theorem "forall x in list. prime x" *)
      val all_fs_prime_0 = @{thm list_all_Nil[of "prime :: nat \<Rightarrow> bool"]}
      (* iteratively fill elements into theorem *)
      fun build_thm [] all_fs_prime_iter = all_fs_prime_iter
        | build_thm (f::fs) all_fs_prime_iter =
            let val prime_f = case fst (Pratt.prove_prime [] f ctxt)
                                of SOME thm => thm |
                                       NONE => raise ERROR
            in
                build_thm fs (@{thm list_all_ConsI} OF [prime_f, all_fs_prime_iter])
            end
      val all_fs_prime = build_thm fs all_fs_prime_0
    in
        @{thm squarefree_true}
            |> (fn thm => thm OF [all_fs_prime])
            |> Drule.infer_instantiate' ctxt
                  (map (Tools.nat2ct' ctxt) [n])
            |> Tools.simp ctxt 2
            |> SOME
    end
  | generate_proof ctxt (FALSE_CERT (n, x)) =
        @{thm squarefree_false}
            |> Drule.infer_instantiate' ctxt
                  (map (Tools.nat2ct' ctxt) [x, n div (x*x), n])
            |> Tools.simp ctxt 2
            |> SOME

fun prove ctxt n =                  (* n                            *)
    n     |> mk_cert                (* cert                         *)
          |> generate_proof ctxt    (* thm option                   *)
    handle ERROR => NONE

fun simproc ctxt input =            (* term            *)
    input |> parse                  (* n               *)
          |> (fn n => if abs n < Config.get ctxt limit then n else raise LIMIT)
          |> prove ctxt             (* thm option      *)
          |> Tools.wrap             (* thm option      *)
    handle LIMIT => NONE
         | TERM _ => NONE

(* helper tools *)
fun get_cert_number ZERO = 0
  | get_cert_number (TRUE_CERT (n, _)) = n
  | get_cert_number (FALSE_CERT (n, _)) = n

end
\<close>

simproc_setup squarefree_simproc ("squarefree (numeral n::nat)") = \<open>K Squarefree.simproc\<close>

end


(*<*)
theory simp2 imports Main begin
(*>*)

section\<open>Simplification\<close>

text\<open>\label{sec:simplification-II}\index{simplification|(}
This section describes features not covered until now.  It also
outlines the simplification process itself, which can be helpful
when the simplifier does not do what you expect of it.
\<close>

subsection\<open>Advanced Features\<close>

subsubsection\<open>Congruence Rules\<close>

text\<open>\label{sec:simp-cong}
While simplifying the conclusion $Q$
of $P \Imp Q$, it is legal to use the assumption $P$.
For $\Imp$ this policy is hardwired, but
contextual information can also be made available for other
operators. For example, \<^prop>\<open>xs = [] --> xs@xs = xs\<close> simplifies to \<^term>\<open>True\<close> because we may use \<^prop>\<open>xs = []\<close> when simplifying \<^prop>\<open>xs@xs =
xs\<close>. The generation of contextual information during simplification is
controlled by so-called \bfindex{congruence rules}. This is the one for
\<open>\<longrightarrow>\<close>:
@{thm[display]imp_cong[no_vars]}
It should be read as follows:
In order to simplify \<^prop>\<open>P-->Q\<close> to \<^prop>\<open>P'-->Q'\<close>,
simplify \<^prop>\<open>P\<close> to \<^prop>\<open>P'\<close>
and assume \<^prop>\<open>P'\<close> when simplifying \<^prop>\<open>Q\<close> to \<^prop>\<open>Q'\<close>.

Here are some more examples.  The congruence rules for bounded
quantifiers supply contextual information about the bound variable:
@{thm[display,eta_contract=false,margin=60]ball_cong[no_vars]}
One congruence rule for conditional expressions supplies contextual
information for simplifying the \<open>then\<close> and \<open>else\<close> cases:
@{thm[display]if_cong[no_vars]}
An alternative congruence rule for conditional expressions
actually \emph{prevents} simplification of some arguments:
@{thm[display]if_weak_cong[no_vars]}
Only the first argument is simplified; the others remain unchanged.
This makes simplification much faster and is faithful to the evaluation
strategy in programming languages, which is why this is the default
congruence rule for \<open>if\<close>. Analogous rules control the evaluation of
\<open>case\<close> expressions.

You can declare your own congruence rules with the attribute \attrdx{cong},
either globally, in the usual manner,
\begin{quote}
\isacommand{declare} \textit{theorem-name} \<open>[cong]\<close>
\end{quote}
or locally in a \<open>simp\<close> call by adding the modifier
\begin{quote}
\<open>cong:\<close> \textit{list of theorem names}
\end{quote}
The effect is reversed by \<open>cong del\<close> instead of \<open>cong\<close>.

\begin{warn}
The congruence rule @{thm[source]conj_cong}
@{thm[display]conj_cong[no_vars]}
\par\noindent
is occasionally useful but is not a default rule; you have to declare it explicitly.
\end{warn}
\<close>

subsubsection\<open>Permutative Rewrite Rules\<close>

text\<open>
\index{rewrite rules!permutative|bold}%
An equation is a \textbf{permutative rewrite rule} if the left-hand
side and right-hand side are the same up to renaming of variables.  The most
common permutative rule is commutativity: \<^prop>\<open>x+y = y+x\<close>.  Other examples
include \<^prop>\<open>(x-y)-z = (x-z)-y\<close> in arithmetic and \<^prop>\<open>insert x (insert
y A) = insert y (insert x A)\<close> for sets. Such rules are problematic because
once they apply, they can be used forever. The simplifier is aware of this
danger and treats permutative rules by means of a special strategy, called
\bfindex{ordered rewriting}: a permutative rewrite
rule is only applied if the term becomes smaller with respect to a fixed
lexicographic ordering on terms. For example, commutativity rewrites
\<^term>\<open>b+a\<close> to \<^term>\<open>a+b\<close>, but then stops because \<^term>\<open>a+b\<close> is strictly
smaller than \<^term>\<open>b+a\<close>.  Permutative rewrite rules can be turned into
simplification rules in the usual manner via the \<open>simp\<close> attribute; the
simplifier recognizes their special status automatically.

Permutative rewrite rules are most effective in the case of
associative-commutative functions.  (Associativity by itself is not
permutative.)  When dealing with an AC-function~$f$, keep the
following points in mind:
\begin{itemize}\index{associative-commutative function}

\item The associative law must always be oriented from left to right,
  namely $f(f(x,y),z) = f(x,f(y,z))$.  The opposite orientation, if
  used with commutativity, can lead to nontermination.

\item To complete your set of rewrite rules, you must add not just
  associativity~(A) and commutativity~(C) but also a derived rule, {\bf
    left-com\-mut\-ativ\-ity} (LC): $f(x,f(y,z)) = f(y,f(x,z))$.
\end{itemize}
Ordered rewriting with the combination of A, C, and LC sorts a term
lexicographically:
\[\def\maps#1{~\stackrel{#1}{\leadsto}~}
 f(f(b,c),a) \maps{A} f(b,f(c,a)) \maps{C} f(b,f(a,c)) \maps{LC} f(a,f(b,c)) \]

Note that ordered rewriting for \<open>+\<close> and \<open>*\<close> on numbers is rarely
necessary because the built-in arithmetic prover often succeeds without
such tricks.
\<close>

subsection\<open>How the Simplifier Works\<close>

text\<open>\label{sec:SimpHow}
Roughly speaking, the simplifier proceeds bottom-up: subterms are simplified
first.  A conditional equation is only applied if its condition can be
proved, again by simplification.  Below we explain some special features of
the rewriting process.
\<close>

subsubsection\<open>Higher-Order Patterns\<close>

text\<open>\index{simplification rule|(}
So far we have pretended the simplifier can deal with arbitrary
rewrite rules. This is not quite true.  For reasons of feasibility,
the simplifier expects the
left-hand side of each rule to be a so-called \emph{higher-order
pattern}~\<^cite>\<open>"nipkow-patterns"\<close>\indexbold{patterns!higher-order}.
This restricts where
unknowns may occur.  Higher-order patterns are terms in $\beta$-normal
form.  (This means there are no subterms of the form $(\lambda x. M)(N)$.)
Each occurrence of an unknown is of the form
$\Var{f}~x@1~\dots~x@n$, where the $x@i$ are distinct bound
variables. Thus all ordinary rewrite rules, where all unknowns are
of base type, for example @{thm add.assoc}, are acceptable: if an unknown is
of base type, it cannot have any arguments. Additionally, the rule
\<open>(\<forall>x. ?P x \<and> ?Q x) = ((\<forall>x. ?P x) \<and> (\<forall>x. ?Q x))\<close> is also acceptable, in
both directions: all arguments of the unknowns \<open>?P\<close> and
\<open>?Q\<close> are distinct bound variables.

If the left-hand side is not a higher-order pattern, all is not lost.
The simplifier will still try to apply the rule provided it
matches directly: without much $\lambda$-calculus hocus
pocus.  For example, \<open>(?f ?x \<in> range ?f) = True\<close> rewrites
\<^term>\<open>g a \<in> range g\<close> to \<^const>\<open>True\<close>, but will fail to match
\<open>g(h b) \<in> range(\<lambda>x. g(h x))\<close>.  However, you can
eliminate the offending subterms --- those that are not patterns ---
by adding new variables and conditions.
In our example, we eliminate \<open>?f ?x\<close> and obtain
 \<open>?y =
?f ?x \<Longrightarrow> (?y \<in> range ?f) = True\<close>, which is fine
as a conditional rewrite rule since conditions can be arbitrary
terms.  However, this trick is not a panacea because the newly
introduced conditions may be hard to solve.

There is no restriction on the form of the right-hand
sides.  They may not contain extraneous term or type variables, though.
\<close>

subsubsection\<open>The Preprocessor\<close>

text\<open>\label{sec:simp-preprocessor}
When a theorem is declared a simplification rule, it need not be a
conditional equation already.  The simplifier will turn it into a set of
conditional equations automatically.  For example, \<^prop>\<open>f x =
g x & h x = k x\<close> becomes the two separate
simplification rules \<^prop>\<open>f x = g x\<close> and \<^prop>\<open>h x = k x\<close>. In
general, the input theorem is converted as follows:
\begin{eqnarray}
\neg P &\mapsto& P = \hbox{\isa{False}} \nonumber\\
P \longrightarrow Q &\mapsto& P \Longrightarrow Q \nonumber\\
P \land Q &\mapsto& P,\ Q \nonumber\\
\forall x.~P~x &\mapsto& P~\Var{x}\nonumber\\
\forall x \in A.\ P~x &\mapsto& \Var{x} \in A \Longrightarrow P~\Var{x} \nonumber\\
\<open>if\<close>\ P\ \<open>then\<close>\ Q\ \<open>else\<close>\ R &\mapsto&
 P \Longrightarrow Q,\ \neg P \Longrightarrow R \nonumber
\end{eqnarray}
Once this conversion process is finished, all remaining non-equations
$P$ are turned into trivial equations $P =\isa{True}$.
For example, the formula
\begin{center}\<^prop>\<open>(p \<longrightarrow> t=u \<and> ~r) \<and> s\<close>\end{center}
is converted into the three rules
\begin{center}
\<^prop>\<open>p \<Longrightarrow> t = u\<close>,\quad  \<^prop>\<open>p \<Longrightarrow> r = False\<close>,\quad  \<^prop>\<open>s = True\<close>.
\end{center}
\index{simplification rule|)}
\index{simplification|)}
\<close>
(*<*)
end
(*>*)


theory CoinductiveLemmas imports Coinductive.Coinductive_List begin

lemma lSup_lappend:
  "\<lbrakk>Complete_Partial_Order.chain lprefix A; A \<noteq> {}\<rbrakk>
    \<Longrightarrow> lSup (lappend xs ` A) = lappend xs (lSup A)"
  apply (induct xs; clarsimp)
   defer
   apply (subst image_image[symmetric, where f="\<lambda>x. LCons _ x"])
   apply (clarsimp simp: lSup_LCons)
  apply (clarsimp simp: ccpo.admissible_def)
  apply (rename_tac B)
  apply (case_tac "lfinite (lSup B)")
   defer
   apply (rule lprefix_antisym)
    apply (rule chain_lSup_lprefix)
     apply (rule chainI)
     apply (fastforce simp: lappend_inf)
    apply clarsimp
   apply (rule chain_lprefix_lSup)
    apply (rule chainI)
    apply (fastforce simp: lappend_inf)
   apply (fastforce simp: lappend_inf)
  apply (erule lfinite_rev_induct)
   apply clarsimp
  by (metis mcont_contD mcont_lappend2)

lemma lSup_lmap:
  "\<lbrakk>Complete_Partial_Order.chain lprefix A; A \<noteq> {}\<rbrakk>
    \<Longrightarrow> lSup ((lmap f) ` A) = lmap f (lSup A)"
  by (metis mcont_contD mcont_lmap)

lemma lSup_lconcat:
  "\<lbrakk>Complete_Partial_Order.chain lprefix A; A \<noteq> {}\<rbrakk>
    \<Longrightarrow> lSup (lconcat ` A) = lconcat (lSup A)"
  by (metis mcont_contD mcont_lconcat)

lemma cpo_llist_of_upt:
  "Complete_Partial_Order.chain lprefix {x. \<exists>i. x = llist_of [0..<i]}"
  apply (rule chainI)
  apply clarsimp
  apply (rename_tac i i')
  apply (case_tac "i \<le> i'")
   apply (simp (no_asm) add: prefix_def)
   apply (rule_tac x="[i..<i']" in exI)
  using le_Suc_ex upt_add_eq_append apply blast
  apply (simp add: not_le)
  apply (erule notE)
  apply (drule less_imp_le)
  apply (simp (no_asm) add: prefix_def)
  apply (rule_tac x="[i'..<i]" in exI)
  using le_Suc_ex upt_add_eq_append by blast

lemma iterates_Suc_is_lSup_upt:
  "iterates Suc 0 = lSup {x. \<exists>i. x = llist_of [0..<i]}"
proof (coinduct rule : llist.coinduct
      [where R="\<lambda>x y. ltl x = lmap Suc x \<and> ltl y = lmap Suc y \<and> lnull x = lnull y
                      \<and> lhd x = lhd y"])
  case Eq_llist
  then show ?case
   apply (rule conjI)
    apply (simp add: lmap_iterates)
   apply (subst lSup_lmap[symmetric, OF cpo_llist_of_upt])
    apply fastforce
   apply clarsimp
   apply (rule conjI)
    apply (rule arg_cong[where f=lSup])
    apply (rule equalityI; clarsimp simp: subset_iff image_def)
      apply (metis Suc_pred lmap_llist_of map_Suc_upt)
    apply (rename_tac i)
    apply (rule_tac x="llist_of [0..<Suc i]" in bexI)
     apply (metis ltl_llist_of map_Suc_upt tl_upt)
     apply fastforce
   apply (rule conjI)
    apply fastforce
   apply (simp add: lSup.code)
   apply (rule conjI; clarsimp)
     apply (metis lnull_llist_of neq0_conv not_less upt_eq_Nil_conv)
    apply (rename_tac i)
   apply (rule the_equality; clarsimp simp: image_def)
   apply (rule_tac x="llist_of [0..<i]" in bexI, clarsimp)
   apply fastforce
  done
qed simp

abbreviation (input) flat :: "'a list llist \<Rightarrow> 'a llist" where
  "flat xs \<equiv> lconcat (lmap llist_of xs)"

lemma flat_inf_llist_lSup:
  "flat (inf_llist f) = lSup {x. \<exists>i. x = llist_of (concat (map f [0..<i]))}"
  apply (clarsimp simp: Coinductive_List.inf_llist_def)
  apply (subst iterates_Suc_is_lSup_upt)
  apply clarsimp
  apply (subst lSup_lmap[symmetric, OF cpo_llist_of_upt])
   apply fastforce
  apply (clarsimp simp: image_def)
  apply (subst lSup_lmap[symmetric])
    apply (rule chainI)
    apply clarsimp
    apply (metis (mono_tags, lifting) chain_def cpo_llist_of_upt lprefix_llist_of map_mono_prefix
                                      mem_Collect_eq)
   apply fastforce
  apply (clarsimp simp add: lconcat_llist_of[symmetric])
  apply (subst lmap_llist_of[symmetric])
  apply (subst llist.map_comp[symmetric])
  apply (subst lSup_lconcat[symmetric])
    apply (rule chainI)
    apply clarsimp
    using cpo_llist_of_upt
    apply (metis (no_types, opaque_lifting) le_Suc_ex less_imp_add_positive map_mono_prefix
                                            not_less prefix_def upt_add_eq_append zero_le)
   apply fastforce
  apply (rule arg_cong[of _ _ lSup])
  apply (fastforce simp: image_def)
  done

lemma upper_subset_lSup_eq:
  "\<lbrakk>Complete_Partial_Order.chain lprefix B; A \<subseteq> B;
    \<forall>x\<in>B. \<exists>y\<in>A. lprefix x y\<rbrakk> \<Longrightarrow> lSup B = lSup A"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix, simp)
   apply (rename_tac xs)
   apply (drule_tac x=xs in bspec, simp)
   apply (meson chain_subset less_imp_le llist.lub_upper lprefix_trans)
  apply (rule chain_lSup_lprefix)
  using chain_subset apply blast
  using llist.lub_upper by blast

lemma lmap_iterates_id:
  "lmap (\<lambda>z. x) (iterates Suc 0) = iterates id x"
  apply coinduction
  apply (simp add: lmap_iterates[symmetric] llist.map_comp)
  done

end


theory BitStream = Main:

use tactics

method_setup circular_coinduction = "build_tactic (circular_coinduction_fun)" "all"
method_setup coinduction = "build_tactic (coinduction_fun)" "rule_tac R=?Rzero in ga_cogenerated, instantiate_tac Rzero %s1.?R,step"
method_setup init = "build_tactic (init_fun)" "(simp|(solve,blast))?,init2_fun?"
method_setup breakup = "build_tactic (breakup_fun)" "simp,((exE|conjE)+)?,disjE"
method_setup solve= "build_tactic (solve_fun 1)" "((exE|conjE|conjI)+)?,(simp)?,((exE|conjE|conjI)+)?,(simp)?"
method_setup step = "build_tactic (step_fun)" "((disjI2)+)?,inst r (rcs union (trans r))"
method_setup close= "build_tactic (close_fun)" "((disjI1|disjI2)+)?,((exE|conjE)+)?,force_solve|solve,disji1+,blast"
method_setup close_or_step= "build_tactic (close_or_step_fun)" "close|(solve,(close|(step,solve?,disjI2?,solve?,xy_exi?,solve,close?),((disjI1+)?,blast,close)?))"
method_setup force_finish = "build_tactic (force_finish_fun)" "inst r false,solve1"

typedecl "BitStream"
datatype Bit = X0 | X1
consts
"flip" :: "BitStream => BitStream"
"flop" :: "Bit => Bit"
"tick" :: "BitStream"
"tock" :: "BitStream"
"hd" :: "BitStream => Bit"
"tl" :: "BitStream => BitStream"
"map" :: "(Bit => Bit) => BitStream => BitStream"

consts
  BinRelImage :: "('a => 'b) => ('a => 'a => bool) => ('b => 'b => bool)"
  Trans_BitStream :: "('a => 'a => bool) => ('b => 'b => bool)"
  union :: "('a => 'a => bool)  => ('a => 'a => bool) => ('a => 'a => bool)" (infixl 20)
defs
  BinRelImage_def [simp] : "BinRelImage f R == %x y . EX u v . R u v & x = f u & y = f v"
  Trans_BitStream_def [simp] : "Trans_BitStream R == (BinRelImage tl R)"
  union_def [simp] : "R union S == % x y . R x y | S x y"

axioms

map_hd [simp]: "!! f :: Bit => Bit . !! s :: BitStream . (hd (map f s)) = (f (hd s))"
map_tl [simp]: "!! f :: Bit => Bit . !! s :: BitStream . (tl (map f s)) = (map f (tl s))"

ga_generated_Bit: "True"
ga_disjoint_0_1: "(Not (X0 = X1))"
flip_hd_a [simp]: "!! b :: BitStream . (hd b) = X1 ==> (hd (flip b)) = X0"
flip_hd_b [simp]: "!! b :: BitStream . (hd b) = X0 ==> (hd (flip b)) = X1"
flip_tl [simp]: "!! b :: BitStream . (tl (flip b)) = (flip (tl b))"
flop_1 [simp]: "!! b :: Bit . (b = X0) ==> (flop b) = X1"
flop_2 [simp]: "!! b :: Bit . (b = X1) ==> (flop b) = X0"
tick_hd [simp]: "hd tick = X1"
tick_tl [simp]: "tl tick = tock"
tock_hd [simp]: "hd tock = X0"
tock_tl [simp]: "tl tock = tick"

ga_cogenerated_BitStream: "!! R :: BitStream => BitStream => bool . !! u :: BitStream . !! v :: BitStream . ! x :: BitStream . ! y :: BitStream . ((R x) y) --> ((hd x) = (hd y) & ((R (tl x)) (tl y)))  ==> ((R u) v) ==> u = v"

theorem ticktock: "tick = map flop tock"
apply(circular_coinduction)
done

theorem ticktock: "!! b :: BitStream . map flop (map flop b) = b"
apply(coinduction)
apply(init)
apply(breakup)
apply(solve)
apply(case_tac "hd y")
apply(close)
apply(close)
apply(close)
apply(force_finish)

done

theorem flipflip: "!! b :: BitStream . (flip (flip b)) = b"

apply(coinduction)
apply(init)

apply(breakup)

apply(solve)
apply(case_tac "hd y")
apply(close)
apply(close)
apply(close)

apply(force_finish)

done


theory Anti_Plurality_Rule

imports Scoring_Rules
        "Compositional_Structures/Basic_Modules/Anti_Plurality_Module"
        "Compositional_Structures/Elect_Composition"
begin

subsection \<open>Definition\<close>

fun anti_Plurality_Rule :: "'a Electoral_Module" where
  "anti_Plurality_Rule A p = elector anti_plurality A p"

lemma Borda_scoring_elect:
  shows "electoral_module (elector anti_plurality)"
  proof(unfold anti_plurality_def)
  show "electoral_module (elector (max_eliminator (scoring vector_anti_plurality)))"
    using scoring_mod_A by blast
qed

lemma borda_hom:
  shows "homogeneity (anti_Plurality_Rule)" unfolding anti_plurality_def anti_Plurality_Rule.simps
  using scoring_homogeneity elector_homogeneity by blast

lemma borda_reinforcement:
  shows "reinforcement_complete (anti_Plurality_Rule)" unfolding anti_plurality_def anti_Plurality_Rule.simps
  using scoring_module_rein
  by blast

end