theory "Frechet_Correctness"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Lib"
  "Syntax"
  "Denotational_Semantics"
  "Ids"
begin
context ids begin
section \<open>Characterization of Term Derivatives\<close>
text \<open>
 This section builds up to a proof that in well-formed interpretations, all
 terms have derivatives, and those derivatives agree with the expected rules
 of derivatives. In particular, we show the [frechet] function given in the
 denotational semantics is the true Frechet derivative of a term. From this
 theorem we can recover all the standard derivative identities as corollaries.
\<close>

lemma inner_prod_eq:
  fixes i::"'a::finite"
  shows "(\<lambda>(v::'a Rvec). v \<bullet> axis i 1) = (\<lambda>(v::'a Rvec). v $ i)"
  unfolding cart_eq_inner_axis axis_def by (simp add: eq_commute)

theorem svar_deriv:
  fixes x:: "'sv::finite" and \<nu>:: "'sv Rvec" and F::"real filter"
  shows "((\<lambda>v. v $ x) has_derivative (\<lambda>v'. v' \<bullet> (\<chi> i. if i = x then 1 else 0))) (at \<nu>)"
proof -
  let ?f = "(\<lambda>v. v)"
  let ?f' = "(\<lambda>v'. v')"
  let ?g = "(\<lambda>v. axis x 1)"
  let ?g' = "(\<lambda>v. 0)"
  have id_deriv: "(?f has_derivative ?f') (at \<nu>) "
    by (rule has_derivative_ident)
  have const_deriv: "(?g has_derivative ?g') (at \<nu>)"
    by (rule has_derivative_const)
  have inner_deriv:"((\<lambda>x. inner (?f x) (?g x)) has_derivative
                     (\<lambda>h. inner (?f \<nu>) (?g' h) + inner (?f' h) (?g \<nu>))) (at \<nu>)"
    by (intro has_derivative_inner [OF id_deriv const_deriv])
  from inner_prod_eq
  have left_eq: "(\<lambda>x. inner (?f x) (?g x)) = (\<lambda>v. vec_nth v x)"
    by (auto)
  from inner_deriv and inner_prod_eq
  have better_deriv:"((\<lambda>v. vec_nth v x) has_derivative
                     (\<lambda>h. inner (?f \<nu>) (?g' h) + inner (?f' h) (?g \<nu>))) (at \<nu>)"
    by (metis (no_types, lifting) UNIV_I has_derivative_transform)
  have vec_eq:"(\<chi> i. if i = x then 1 else 0) = (\<chi> i. if x = i then 1 else 0)"
    by(rule vec_extensionality, auto)
  have deriv_eq:"(\<lambda>h. \<nu> \<bullet> 0 + h \<bullet> axis x 1) = (\<lambda>v'. v' \<bullet> (\<chi> i. if i = x then 1 else 0))"
    by(rule ext, auto simp add: axis_def vec_eq)
  show ?thesis
    apply(rule has_derivative_eq_rhs[where f'= "(\<lambda>h. \<nu> \<bullet> 0 + h \<bullet> axis x 1)"])
    using better_deriv deriv_eq  by auto
qed

lemma function_case_inner:
  assumes good_interp:
    "(\<forall>x i. (Functions I i has_derivative FunctionFrechet I i x) (at x))"
  assumes IH:"((\<lambda>v. \<chi> i. sterm_sem I (args i) v)
             has_derivative (\<lambda> v. (\<chi> i. frechet I (args i) \<nu> v))) (at \<nu>)"
  shows  "((\<lambda>v. Functions I f (\<chi> i. sterm_sem I (args i) v))
            has_derivative (\<lambda>v. frechet I ($f f args) \<nu> v)) (at \<nu>)"
proof -
  let ?h = "(\<lambda>v. Functions I f (\<chi> i. sterm_sem I (args i) v))"
  let ?h' = "frechet I ($f f args) \<nu>"
  let ?g = "(\<lambda>v. \<chi> i. sterm_sem I (args i) v)"
  let ?g' = "(\<lambda>v. \<chi> i. frechet I (args i) \<nu> v)"
  let ?f = "(\<lambda>y. Functions I f y)"
  let ?f' = "FunctionFrechet I f (?g \<nu>)"
  have hEqFG:  "?h  = ?f  o ?g" by (auto)
  have hEqFG': "?h' = ?f' o ?g'"
  proof -
    have frechet_def:"frechet I (Function f args) \<nu>
        = (\<lambda>v'. FunctionFrechet I f (?g \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))"
      by (auto)
    have composition:
      "(\<lambda>v'. FunctionFrechet I f (?g \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))
       = (FunctionFrechet I f (?g \<nu>)) o (\<lambda> v'. \<chi> i. frechet I (args i) \<nu> v')"
      by (auto)
    from frechet_def and composition show ?thesis by (auto)
  qed
  have fDeriv: "(?f has_derivative ?f') (at (?g \<nu>))"
    using good_interp is_interp_def by blast
  from IH have gDeriv: "(?g has_derivative ?g') (at \<nu>)" by (auto)
  from fDeriv and gDeriv
  have composeDeriv: "((?f o ?g) has_derivative (?f' o ?g')) (at \<nu>)"
    using diff_chain_at good_interp by blast
  from hEqFG hEqFG' composeDeriv show ?thesis by (auto)
qed

lemma func_lemma2:"(\<forall>x i. (Functions I i has_derivative (THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x) (at x) \<and>
          continuous_on UNIV (\<lambda>x. Blinfun ((THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x))) \<Longrightarrow>
    (\<And>\<theta>. \<theta> \<in> range args \<Longrightarrow> (sterm_sem I \<theta> has_derivative frechet I \<theta> \<nu>) (at \<nu>)) \<Longrightarrow>
    ((\<lambda>v. Functions I f (vec_lambda(\<lambda>i. sterm_sem I (args i) v))) has_derivative (\<lambda>v'. (THE f'. \<forall>x. (Functions I f has_derivative f' x) (at x)) (\<chi> i. sterm_sem I (args i) \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))) (at \<nu>)"
proof -
  assume a1: "\<forall>x i. (Functions I i has_derivative (THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x) (at x) \<and>
          continuous_on UNIV (\<lambda>x. Blinfun ((THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x))"
  then have a1':"\<forall>x i. (Functions I i has_derivative (THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x) (at x)" by auto
  assume a2: "\<And>\<theta>. \<theta> \<in> range args \<Longrightarrow> (sterm_sem I \<theta> has_derivative frechet I \<theta> \<nu>) (at \<nu>)"
  have "\<forall>f fa v. (\<exists>fb. \<not> (f (fb::'a) has_derivative fa fb (v::(real, 'a) vec)) (at v)) \<or> ((\<lambda>v. (\<chi> fa. (f fa v::real))) has_derivative (\<lambda>va. (\<chi> f. fa f v va))) (at v)"
    using has_derivative_vec by force
  then have "((\<lambda>v. \<chi> f. sterm_sem I (args f) v) has_derivative (\<lambda>v. \<chi> f. frechet I (args f) \<nu> v)) (at \<nu>)"
    by (auto simp add: a2 has_derivative_vec)
  then show "((\<lambda>v. Functions I f (vec_lambda(\<lambda>f. sterm_sem I (args f) v))) has_derivative (\<lambda>v'. (THE f'. \<forall>x. (Functions I f has_derivative f' x) (at x)) (\<chi> i. sterm_sem I (args i) \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))) (at \<nu>)"
    using a1' function_case_inner by auto
qed

lemma func_lemma:
  "is_interp I \<Longrightarrow>
  (\<And>\<theta> :: ('a::finite, 'c::finite) trm. \<theta> \<in> range args \<Longrightarrow> (sterm_sem I \<theta> has_derivative frechet I \<theta> \<nu>) (at \<nu>)) \<Longrightarrow>
  (sterm_sem I ($f f args) has_derivative frechet I ($f f args) \<nu>) (at \<nu>)"
  apply(auto simp add: sfunction_case is_interp_def function_case_inner)
  apply(erule func_lemma2)
  apply(auto)
  done

text \<open> The syntactic definition of term derivatives agrees with the semantic definition.
  Since the syntactic definition of derivative is total, this gives us that derivatives are "decidable" for
  terms (modulo computations on reals) and that they obey all the expected identities, which gives
  us the axioms we want for differential terms essentially for free.
 \<close>
lemma frechet_correctness:
  fixes I :: "('a::finite, 'b::finite, 'c::finite) interp" and \<nu>
  assumes good_interp: "is_interp I"
  shows "dfree \<theta> \<Longrightarrow> FDERIV (sterm_sem I \<theta>) \<nu> :> (frechet I \<theta> \<nu>)"
proof (induct rule: dfree.induct)
  case (dfree_Var i) then show ?case
    by (auto simp add: svar_case svar_deriv axis_def)
next
  case (dfree_Fun args i) with good_interp show ?case
    by (intro func_lemma) auto
qed auto

text \<open>If terms are semantically equivalent in all states, so are their derivatives\<close>
lemma sterm_determines_frechet:
  fixes I ::"('a1::finite, 'b1::finite, 'c::finite) interp"
    and J ::"('a2::finite, 'b2::finite, 'c::finite) interp"
    and \<theta>1 :: "('a1::finite, 'c::finite) trm"
    and \<theta>2 :: "('a2::finite, 'c::finite) trm"
    and \<nu>
  assumes good_interp1:"is_interp I"
  assumes good_interp2:"is_interp J"
  assumes free1:"dfree \<theta>1"
  assumes free2:"dfree \<theta>2"
  assumes sem:"sterm_sem I \<theta>1 = sterm_sem J \<theta>2"
  shows "frechet I \<theta>1 (fst \<nu>) (snd \<nu>) = frechet J \<theta>2 (fst \<nu>) (snd \<nu>)"
proof -
  have d1:"(sterm_sem I \<theta>1 has_derivative (frechet I \<theta>1 (fst \<nu>))) (at (fst \<nu>))"
    using frechet_correctness[OF good_interp1 free1] by auto
  have d2:"(sterm_sem J \<theta>2 has_derivative (frechet J \<theta>2 (fst \<nu>))) (at (fst \<nu>))"
    using frechet_correctness[OF good_interp2 free2] by auto
  then have d1':"(sterm_sem I \<theta>1 has_derivative (frechet J \<theta>2 (fst \<nu>))) (at (fst \<nu>))"
    using sem by auto
  thus "?thesis" using has_derivative_unique d1 d1' by metis
qed

lemma the_deriv:
  assumes deriv:"(f has_derivative F) (at x)"
  shows "(THE G. (f has_derivative G) (at x)) = F"
  apply(rule the_equality)
   subgoal by (rule deriv)
  subgoal for G by (auto simp add: deriv has_derivative_unique)
  done

lemma the_all_deriv:
  assumes deriv:"\<forall>x. (f has_derivative F x) (at x)"
  shows "(THE G. \<forall> x. (f has_derivative G x) (at x)) = F"
    apply(rule the_equality)
     subgoal by (rule deriv)
    subgoal for G
      apply(rule ext)
      subgoal for x
        apply(erule allE[where x=x])
        by (auto simp add: deriv has_derivative_unique)
      done
    done

typedef ('a, 'c) strm = "{\<theta>:: ('a,'c) trm. dfree \<theta>}"
  morphisms raw_term simple_term
  by(rule exI[where x= "Const 0"], auto simp add: dfree_Const)

typedef ('a, 'b, 'c) good_interp = "{I::('a::finite,'b::finite,'c::finite) interp. is_interp I}"
  morphisms raw_interp good_interp
  apply(rule exI[where x="\<lparr> Functions = (\<lambda>f x. 0), Predicates = (\<lambda>p x. True), Contexts = (\<lambda>C S. S), Programs = (\<lambda>a. {}), ODEs = (\<lambda>c v. (\<chi> i. 0)), ODEBV = \<lambda>c. {}\<rparr>"])
  apply(auto simp add: is_interp_def)
proof -
  fix x ::real
  have eq:"(THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) = (\<lambda>_ _. 0)"
    by(rule the_all_deriv, auto)
  have eq':"(THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x = (\<lambda>_. 0)"
    by (simp add: eq)
  have deriv:"((\<lambda>x.0) has_derivative (\<lambda>x. 0)) (at x)"
    by auto
  then show "\<And>x. ((\<lambda>x. 0) has_derivative (THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x) (at x)"
    by (auto simp add: eq eq' deriv)
next
  have eq:"(THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) = (\<lambda>_ _. 0)"
    by(rule the_all_deriv, auto)
  have eq':"\<forall>x. (THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x = (\<lambda>_. 0)"
    by (simp add: eq)
  have deriv:"\<And>x. ((\<lambda>x.0) has_derivative (\<lambda>x. 0)) (at x)"
    by auto
  have blin:"\<And>x. bounded_linear ((THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x)"
    by (simp add: eq')
  show " continuous_on UNIV (\<lambda>x. Blinfun ((THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x))"
    apply(clarsimp simp add: continuous_on_topological[of UNIV "(\<lambda>x. Blinfun ((THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x))"])
    apply(rule exI[where x = UNIV])
    by(auto simp add: eq' blin)
 qed

lemma frechet_linear:
  assumes good_interp:"is_interp I"
  fixes v \<theta>
  shows " dfree \<theta> \<Longrightarrow> bounded_linear (frechet I \<theta> v)"
proof(induction rule: dfree.induct)
  case (dfree_Var i)
  then show ?case by(auto)
next
  case (dfree_Const r)
  then show ?case by auto
next
  case (dfree_Fun args i)
  have blin1:"\<And>x. bounded_linear(FunctionFrechet I i x)"
    using good_interp unfolding is_interp_def using has_derivative_bounded_linear
    by blast
  have blin2:"bounded_linear (\<lambda> a. (\<chi> i. frechet I (args i) v a))"
    using dfree_Fun.IH by(rule bounded_linear_vec)
  then show ?case
    using bounded_linear_compose[of "FunctionFrechet I i (\<chi> i. sterm_sem I (args i) v)" "(\<lambda>a. (\<chi> i. frechet I (args i) v a))", OF blin1 blin2]
    by auto
next
  case (dfree_Plus \<theta>\<^sub>1 \<theta>\<^sub>2)
  then show ?case
    apply auto
    using bounded_linear_add by (blast)
next
  case (dfree_Times \<theta>\<^sub>1 \<theta>\<^sub>2)
  then show ?case
    by (auto simp add: bounded_linear_add bounded_linear_const_mult bounded_linear_mult_const)
qed

setup_lifting type_definition_good_interp

setup_lifting type_definition_strm

lift_definition blin_frechet::"('sf, 'sc, 'sz) good_interp \<Rightarrow> ('sf,'sz) strm \<Rightarrow> (real, 'sz) vec  \<Rightarrow> (real, 'sz) vec \<Rightarrow>\<^sub>L real" is "frechet"
  using frechet_linear by auto

lemmas [simp] = blin_frechet.rep_eq

lemma frechet_blin:"is_interp I \<Longrightarrow> dfree \<theta> \<Longrightarrow> (\<lambda>v. Blinfun (\<lambda>v'. frechet I \<theta> v v')) = blin_frechet (good_interp I) (simple_term \<theta>)"
  apply(rule ext)
  apply(rule blinfun_eqI)
  by (simp add: bounded_linear_Blinfun_apply frechet_linear good_interp_inverse simple_term_inverse)

lemma sterm_continuous:
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> continuous_on UNIV (sterm_sem I \<theta>)"
proof(induction rule: dfree.induct)
  case (dfree_Fun args i)
  assume IH:"\<And>i. continuous_on UNIV (sterm_sem I (args i))"
  have con1:"continuous_on UNIV (Functions I i)"
    using good_interp unfolding is_interp_def
    using continuous_on_eq_continuous_within has_derivative_continuous by blast
  have con2:"continuous_on UNIV (\<lambda> x. (\<chi> i. sterm_sem I (args i) x))"
    apply(rule continuous_on_vec_lambda)
    using IH by auto
  have con:"continuous_on UNIV ((Functions I i) \<circ> (\<lambda>x.  (\<chi> i. sterm_sem I (args i) x)))"
    apply(rule continuous_on_compose)
     using con1 con2 apply auto
    using continuous_on_subset by blast
  show ?case
    using con comp_def by(simp)
qed (auto intro: continuous_intros)

lemma sterm_continuous':
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> continuous_on S (sterm_sem I \<theta>)"
  using sterm_continuous continuous_on_subset good_interp by blast

lemma frechet_continuous:
  fixes I :: "('sf, 'sc, 'sz) interp"
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>))"
proof (induction rule: dfree.induct)
  case (dfree_Var i)
  have free:"dfree (Var i)" by (rule dfree_Var)
  have bounded_linear:"bounded_linear (\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1)"
    by (auto simp add: bounded_linear_vec_nth)
  have cont:"continuous_on UNIV (\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1))"
    using continuous_on_const by blast
  have eq:"\<And>\<nu> \<nu>'. (\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1)) \<nu> \<nu>' = (blin_frechet (good_interp I) (simple_term (Var i))) \<nu> \<nu>'"
    unfolding axis_def apply(auto)
    by (metis (no_types) axis_def blinfun_inner_left.abs_eq blinfun_inner_left.rep_eq dfree_Var_simps frechet.simps(1) mem_Collect_eq simple_term_inverse)
  have eq':"(\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1)) = (blin_frechet (good_interp I) (simple_term (Var i)))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    using eq by auto
  then show ?case by (metis cont)
next
  case (dfree_Const r)
  have free:"dfree (Const r)" by (rule dfree_Const)
  have bounded_linear:"bounded_linear (\<lambda> \<nu>'. 0)" by (simp)
  have cont:"continuous_on UNIV (\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. 0))"
    using continuous_on_const by blast
  have eq':"(\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. 0)) = (blin_frechet (good_interp I) (simple_term (Const r)))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    apply auto
    using zero_blinfun.abs_eq zero_blinfun.rep_eq free
    by (metis frechet.simps(5) mem_Collect_eq simple_term_inverse)
  then show ?case by (metis cont)
next
  case (dfree_Fun args f)
  assume IH:"\<And>i. continuous_on UNIV (blin_frechet (good_interp I) (simple_term (args i)))"
  assume frees:"(\<And>i. dfree (args i))"
  then have free:"dfree ($f f args)" by (auto)
  have great_interp:"\<And>f. continuous_on UNIV (\<lambda>x. Blinfun (FunctionFrechet I f x))" using good_interp unfolding is_interp_def by auto
  have cont1:"\<And>v. continuous_on UNIV (\<lambda>v'. (\<chi> i. frechet I (args i) v v'))"
    apply(rule continuous_on_vec_lambda)
    using IH by (simp add: frechet_linear frees good_interp linear_continuous_on)
  have eq:"(\<lambda>v. Blinfun(\<lambda>v'. FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v) (\<chi> i. frechet I (args i) v v')))
    = (blin_frechet (good_interp I) (simple_term (Function f args)))"
    using frechet_blin[OF good_interp free] by auto
  have bounded_linears:"\<And>x. bounded_linear (FunctionFrechet I f x)" using good_interp unfolding is_interp_def by blast
  let ?blin_ff ="(\<lambda>x. Blinfun (FunctionFrechet I f x))"
  have some_eq:"(\<lambda>x. Blinfun (FunctionFrechet I f (\<chi> i. sterm_sem I (args i) x))) =
                ((?blin_ff) \<circ> (\<lambda>x. (\<chi> i. sterm_sem I (args i) x)))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    unfolding comp_def by blast
  have sub_cont:"continuous_on UNIV ((?blin_ff) \<circ> (\<lambda>x. (\<chi> i. sterm_sem I (args i) x)))"
    apply(rule continuous_intros)+
     apply (simp add: frees good_interp sterm_continuous')
    using continuous_on_subset great_interp by blast
  have blin_frech_vec:"\<And>x. bounded_linear (\<lambda>v'. \<chi> i. frechet I (args i) x v')"
    by (simp add: bounded_linear_vec frechet_linear frees good_interp)
  have frech_vec_eq:"(\<lambda>x. Blinfun (\<lambda>v'. \<chi> i. frechet I (args i) x v')) = (\<lambda>x. blinfun_vec (\<lambda> i. blin_frechet (good_interp I) (simple_term (args i)) x))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    apply(rule vec_extensionality)
    subgoal for x i j
      using blin_frech_vec[of x]
      apply auto
      by (metis (no_types, lifting) blin_frechet.rep_eq bounded_linear_Blinfun_apply frechet_blin frechet_linear frees good_interp vec_lambda_beta)
    done
  have cont_frech_vec:"continuous_on UNIV (\<lambda>x. blinfun_vec (\<lambda> i. blin_frechet (good_interp I) (simple_term (args i)) x))"
    apply(rule continuous_blinfun_vec')
    using IH by blast
  have cont_intro:"\<And> s f g. continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> continuous_on s (\<lambda>x. f x o\<^sub>L g x)"
    by (auto intro: continuous_intros)
  have cont:"continuous_on UNIV (\<lambda>v. blinfun_compose (Blinfun (FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v))) (Blinfun(\<lambda>v'.  (\<chi> i. frechet I (args i) v v'))))"
    apply(rule cont_intro)
     subgoal using  sub_cont by simp
    using frech_vec_eq cont_frech_vec by presburger
  have best_eq:"(blin_frechet (good_interp I) (simple_term ($f f args))) = (\<lambda>v. blinfun_compose (Blinfun (FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v))) (Blinfun(\<lambda>v'.  (\<chi> i. frechet I (args i) v v')))) "
    apply(rule ext)
    apply(rule blinfun_eqI)
  proof -
    fix v :: "(real, 'sz) vec" and i :: "(real, 'sz) vec"
    have "frechet I ($f f args) v i = blinfun_apply (blin_frechet (good_interp I) (simple_term ($f f args)) v) i"
      by (metis (no_types) bounded_linear_Blinfun_apply dfree_Fun_simps frechet_blin frechet_linear frees good_interp)
    then have "FunctionFrechet I f (\<chi> s. sterm_sem I (args s) v) (blinfun_apply (Blinfun (\<lambda>va. \<chi> s. frechet I (args s) v va)) i) = blinfun_apply (blin_frechet (good_interp I) (simple_term ($f f args)) v) i"
      by (simp add: blin_frech_vec bounded_linear_Blinfun_apply)
    then show "blinfun_apply (blin_frechet (good_interp I) (simple_term ($f f args)) v) i = blinfun_apply (Blinfun (FunctionFrechet I f (\<chi> s. sterm_sem I (args s) v)) o\<^sub>L Blinfun (\<lambda>va. \<chi> s. frechet I (args s) v va)) i"
      by (metis (no_types) blinfun_apply_blinfun_compose bounded_linear_Blinfun_apply bounded_linears)
  qed
  then show ?case using cont best_eq by auto
next
  case (dfree_Plus \<theta>\<^sub>1 \<theta>\<^sub>2)
  assume IH1:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1))"
  assume IH2:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2))"
  assume free1:"dfree \<theta>\<^sub>1"
  assume free2:"dfree \<theta>\<^sub>2"
  have free:"dfree (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)" using free1 free2 by auto
  have bounded_linear:"\<And>v. bounded_linear (\<lambda>v'. frechet I \<theta>\<^sub>1 v v' + frechet I \<theta>\<^sub>2 v v')"
    subgoal for v
      using frechet_linear[OF good_interp free] by auto
    done
  have eq2:"(\<lambda>v. blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v + blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) = blin_frechet (good_interp I) (simple_term (Plus \<theta>\<^sub>1 \<theta>\<^sub>2))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    by (simp add: blinfun.add_left free1 free2 simple_term_inverse)
  have cont:"continuous_on UNIV (\<lambda>v. blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v + blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v)"
    using continuous_on_add dfree_Plus.IH(1) dfree_Plus.IH(2) by blast
  then show ?case using cont eq2 by metis
next
  case (dfree_Times \<theta>\<^sub>1 \<theta>\<^sub>2)
  assume IH1:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1))"
  assume IH2:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2))"
  assume free1:"dfree \<theta>\<^sub>1"
  assume free2:"dfree \<theta>\<^sub>2"
  have free:"dfree (Times \<theta>\<^sub>1 \<theta>\<^sub>2)" using free1 free2 by auto
  have bounded_linear:"\<And>v. bounded_linear (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v)"
    apply(rule bounded_linear_add)
    apply(rule bounded_linear_const_mult)
    using frechet_linear[OF good_interp free2] apply auto
    apply(rule bounded_linear_mult_const)
    using frechet_linear[OF good_interp free1] by auto
  then have blin':"\<And>v. (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v) \<in> {f. bounded_linear f}" by auto
  have blinfun_eq:"\<And>v. Blinfun (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v)
    =  scaleR (sterm_sem I \<theta>\<^sub>1 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) + scaleR (sterm_sem I \<theta>\<^sub>2 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v)"
    apply(rule blinfun_eqI)
    subgoal for v i
      using Blinfun_inverse[OF blin', of v] apply auto
      using blinfun.add_left[of "sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v" "sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v"]
        blinfun.scaleR_left[of "sterm_sem I \<theta>\<^sub>1 v" "blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v"]
        blinfun.scaleR_left[of "sterm_sem I \<theta>\<^sub>2 v" "blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v"]
        bounded_linear_Blinfun_apply
        frechet_blin[OF good_interp free1]
        frechet_blin[OF good_interp free2]
        frechet_linear[OF good_interp free1]
        frechet_linear[OF good_interp free2]
        mult.commute
        real_scaleR_def
    proof -
      have f1: "\<And>v. blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) = frechet I \<theta>\<^sub>1 v"
        by (metis (no_types) \<open>(\<lambda>v. Blinfun (frechet I \<theta>\<^sub>1 v)) = blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1)\<close> \<open>\<And>v. bounded_linear (frechet I \<theta>\<^sub>1 v)\<close> bounded_linear_Blinfun_apply)
      have "\<And>v. blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) = frechet I \<theta>\<^sub>2 v"
      by (metis (no_types) \<open>(\<lambda>v. Blinfun (frechet I \<theta>\<^sub>2 v)) = blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2)\<close> \<open>\<And>v. bounded_linear (frechet I \<theta>\<^sub>2 v)\<close> bounded_linear_Blinfun_apply)
      then show "sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v i + frechet I \<theta>\<^sub>1 v i * sterm_sem I \<theta>\<^sub>2 v = blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v + sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) i"
        using f1 by (simp add: \<open>\<And>b. blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v + sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b = blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) b + blinfun_apply (sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b\<close> \<open>\<And>b. blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) b = sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) b\<close> \<open>\<And>b. blinfun_apply (sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b = sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b\<close>)
    qed
    done
  have cont':"continuous_on UNIV
    (\<lambda>v. scaleR (sterm_sem I \<theta>\<^sub>1 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v)
       + scaleR (sterm_sem I \<theta>\<^sub>2 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v))"
    apply(rule continuous_on_add)
     apply(rule continuous_on_scaleR)
      apply(rule sterm_continuous[OF good_interp free1])
     apply(rule IH2)
    apply(rule continuous_on_scaleR)
     apply(rule sterm_continuous[OF good_interp free2])
    by(rule IH1)
  have cont:"continuous_on UNIV (\<lambda>v. Blinfun (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v))"
    using cont' blinfun_eq by auto
  have eq:"(\<lambda>v. Blinfun (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v)) = blin_frechet (good_interp I) (simple_term (Times \<theta>\<^sub>1 \<theta>\<^sub>2))"
    using frechet_blin[OF good_interp free]
    by auto
  then show ?case by (metis cont)
qed
end end


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


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


theory Chap12 imports Main Chap7_2
begin

lemma helper:
assumes a1: "wsum = WHILE Less (N 0) (V ''x'') DO csum"
and a2: "csum = ''y'' ::= Plus (V ''y'') (V ''x'');; ''x'' ::= Plus (V ''x'') (N (-1))"
shows "(wsum, s) \<Rightarrow> t \<Longrightarrow> t ''y'' = s ''y'' + (\<Sum>i=0..s ''x''. i)"
proof (cases "s ''x''")
  let ?b = "Less (N 0) (V ''x'')"
  case (neg n)
  assume "(wsum, s) \<Rightarrow> t"
  hence "(WHILE ?b DO csum, s) \<Rightarrow> t" using a1 by simp
  moreover have "\<not>(bval ?b s)" using neg by simp
  ultimately have "s = t" using WhileE by blast
  moreover have "\<Sum>{0..s ''x''} = 0" using neg by simp
  ultimately show ?thesis by simp
next
  let ?b = "Less (N 0) (V ''x'')"
  case (nonneg n)
  assume "(wsum, s) \<Rightarrow> t"
  have "\<lbrakk> s ''x'' = int n; (wsum, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> t ''y'' = s ''y'' + \<Sum> {0..s ''x''}"
  proof (induct n arbitrary: s t)
    case 0
    hence "s = t" using a1 WhileE by auto
    with 0 show ?case by simp
  next
    case (Suc n)
    hence "bval ?b s" by simp
    moreover have "(WHILE ?b DO csum, s) \<Rightarrow> t" using a1 Suc by simp
    ultimately obtain u where f2: "(csum, s) \<Rightarrow> u" and f3: "(wsum, u) \<Rightarrow> t" using WhileE a1 by auto
    from f2 have f4: "u = s(''y'' := s ''y'' + s ''x'', ''x'' := s ''x'' - 1)"
      apply (subst (asm) a2)
      apply (erule SeqE)
      apply (erule AssignE)+
      by simp
    hence f5: "u ''x'' = int n" using Suc by simp
    with Suc f2 f3 have "t ''y'' = u ''y'' + \<Sum> {0..u ''x''}" by simp
    moreover from f4 have "u ''y'' = s ''y'' + int (Suc n)"
      by (simp add: Suc.prems(1))
    ultimately have "t ''y'' = s ''y'' + int (Suc n) + \<Sum> {0..u ''x''}" by simp
    hence "t ''y'' = s ''y'' + s ''x'' + \<Sum> {0..u ''x''}" using Suc by simp
    moreover have "1 + u ''x'' = s ''x''" using f4 by simp
    ultimately show ?case apply clarsimp
      by (smt (verit) Suc.prems(1) f5 int_ops(1) o_apply sum.atLeast0_atMost_Suc sum.atLeast_int_atMost_int_shift)
  qed
  thus ?thesis
    using \<open>(wsum, s) \<Rightarrow> t\<close> nonneg by blast
qed

lemma
assumes a1: "wsum = WHILE Less (N 0) (V ''x'') DO csum"
and a2: "csum = ''y'' ::= Plus (V ''y'') (V ''x'');; ''x'' ::= Plus (V ''x'') (N (-1))"
shows "(''y'' ::= N 0;; wsum, s) \<Rightarrow> t \<Longrightarrow> t ''y'' = (\<Sum>i=0..s ''x''. i)"
apply (erule SeqE)
apply (erule AssignE)
apply simp
using helper a1 a2 by fastforce

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_relaxedprefix_is_prefix_2
imports "../../Test_Base"
begin

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

datatype It = A | B | C

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

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) z = True"
| "isPrefix (cons2 z2 x2) (nil2) = False"
| "isPrefix (cons2 z2 x2) (cons2 x3 x4) =
     ((z2 = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) z = True"
| "isRelaxedPrefix (cons2 z2 (nil2)) z = True"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z2 = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

theorem property0 :
  "isRelaxedPrefix (x xs (x (cons2 y (nil2)) ys)) (x xs (x ys zs))"
  oops

end


header {* Concrete setting *}

theory Concrete
imports Syntactic_Criteria
begin

(* We instatiate the parameters according to Examples 1 and 2 from the paper. *)

(* Security levels: *)
datatype level = Lo | Hi

lemma [dest]: "\<And> l A. \<lbrakk>l \<in> A; Lo \<notin> A\<rbrakk> \<Longrightarrow> l = Hi" and
      [dest]: "\<And> l A. \<lbrakk>l \<in> A; Hi \<notin> A\<rbrakk> \<Longrightarrow> l = Lo"
by (metis level.exhaust)+

declare level.split[split]

instantiation level :: complete_lattice
begin
  definition top_level: "top \<equiv> Hi"
  definition bot_level: "bot \<equiv> Lo"
  definition inf_level: "inf l1 l2 \<equiv> if Lo \<in> {l1,l2} then Lo else Hi"
  definition sup_level: "sup l1 l2 \<equiv> if Hi \<in> {l1,l2} then Hi else Lo"
  definition less_eq_level: "less_eq l1 l2 \<equiv> (l1 = Lo \<or> l2 = Hi)"
  definition less_level: "less l1 l2 \<equiv> l1 = Lo \<and> l2 = Hi"
  definition Inf_level: "Inf L \<equiv> if Lo \<in> L then Lo else Hi"
  definition Sup_level: "Sup L \<equiv> if Hi \<in> L then Hi else Lo"
instance
  proof qed (auto simp: top_level bot_level inf_level sup_level
                        less_eq_level less_level Inf_level Sup_level)
end

lemma sup_eq_Lo[simp]: "sup a b = Lo \<longleftrightarrow> a = Lo \<and> b = Lo"
  by (auto simp: sup_level)

datatype var = h | h' | l | l'
datatype exp = Ct nat | Var var | Plus exp exp | Minus exp exp
datatype test = Tr | Eq exp exp | Gt exp exp | Non test
datatype atom = Assign var exp
type_synonym choice = "real + test"
type_synonym state = "var \<Rightarrow> nat"

syntax
 "_assign" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("_ ::= _" [1000, 61] 61)

translations
  "x ::= expr" == "CONST Atm (CONST Assign x expr)"

primrec sec where
  "sec h  = Hi"
| "sec h' = Hi"
| "sec l  = Lo"
| "sec l' = Lo"

fun eval where
 "eval (Ct n) s = n"
|"eval (Var x) s = s x"
|"eval (Plus e1 e2) s = eval e1 s + eval e2 s"
|"eval (Minus e1 e2) s = eval e1 s - eval e2 s"

fun tval where
 "tval Tr s = True"
|"tval (Eq e1 e2) s = (eval e1 s = eval e2 s)"
|"tval (Gt e1 e2) s = (eval e1 s > eval e2 s)"
|"tval (Non e) s = (\<not> tval e s)"

fun aval where
"aval (Assign x e) s = (s (x := eval e s))"

fun cval where
 "cval (Inl p) s = min 1 (max 0 p)"
|"cval (Inr tst) s = (if tval tst s then 1 else 0)"

definition indis :: "(state * state) set"where
"indis \<equiv> {(s,t). ALL x. sec x = Lo \<longrightarrow> s x = t x}"

interpretation Example_PL!: PL_Indis aval tval cval indis
proof
  fix ch :: choice and  s show "0 \<le> cval ch s \<and> cval ch s \<le> 1"
    by (cases ch) auto
next
  show "equiv UNIV indis"
    unfolding refl_on_def sym_def trans_def equiv_def indis_def by auto
qed

(* The security level of expressions: *)
fun exprSec where
 "exprSec (Ct n) = Lo"
|"exprSec (Var x) = sec x"
|"exprSec (Plus e1 e2) = sup (exprSec e1) (exprSec e2)"
|"exprSec (Minus e1 e2) = sup (exprSec e1) (exprSec e2)"

(* The security level of tests: *)
fun tstSec where
 "tstSec Tr = Lo"
|"tstSec (Eq e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Gt e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Non e) = tstSec e"

lemma exprSec_Lo_eval_eq: "exprSec expr = Lo \<Longrightarrow> (s, t) \<in> indis \<Longrightarrow> eval expr s = eval expr t"
  by (induct expr) (auto simp: indis_def)

lemma compatAtmSyntactic[simp]: "exprSec expr = Lo \<or> sec v = Hi \<Longrightarrow> Example_PL.compatAtm (Assign v expr)"
  unfolding Example_PL.compatAtm_def
  by (induct expr)
     (auto simp: indis_def intro!: arg_cong2[where f="op +"] arg_cong2[where f="op -"] exprSec_Lo_eval_eq)

lemma presAtmSyntactic[simp]: "sec v = Hi \<Longrightarrow> Example_PL.presAtm (Assign v expr)"
  unfolding Example_PL.presAtm_def by (simp add: indis_def)

lemma compatTstSyntactic[simp]: "tstSec tst = Lo \<Longrightarrow> Example_PL.compatTst tst"
  unfolding Example_PL.compatTst_def
  by (induct tst)
     (simp_all, safe del: iffI
              intro!: arg_cong2[where f="op ="] arg_cong2[where f="op < :: nat \<Rightarrow> nat \<Rightarrow> bool"] exprSec_Lo_eval_eq)

(* Stateless choices are always compatible: *)
lemma compatPrchSyntactic[simp]: "Example_PL.compatCh (Inl p)"
  unfolding Example_PL.compatCh_def by auto

(* A test-choice is compatible iff its test is compatible: *)
lemma compatIfchSyntactic[simp]: "Example_PL.compatCh (Inr tst) \<longleftrightarrow> Example_PL.compatTst tst"
  unfolding Example_PL.compatCh_def Example_PL.compatTst_def by auto

abbreviation Ch_half ("Ch\<^sub>\<onehalf>") where "Ch\<^sub>\<onehalf> \<equiv> Ch (Inl (1/2))"
abbreviation If where "If tst \<equiv> Ch (Inr tst)"

abbreviation "siso c \<equiv> Example_PL.siso c"
abbreviation "discr c \<equiv> Example_PL.discr c"
abbreviation Sbis_abbrev (infix "\<approx>s" 55) where "c1 \<approx>s c2 \<equiv> (c1,c2) \<in> Example_PL.Sbis"
abbreviation ZObis_abbrev (infix "\<approx>01" 55) where "c1 \<approx>01 c2 \<equiv> (c1,c2) \<in> Example_PL.ZObis"

abbreviation "SC_siso c \<equiv> Example_PL.SC_siso c"
abbreviation "SC_discr c \<equiv> Example_PL.SC_discr c"
abbreviation "SC_Sbis c \<equiv> Example_PL.SC_Sbis c"
abbreviation "SC_ZObis c \<equiv> Example_PL.SC_ZObis c"

subsection {* The secure programs from the paper's Example 3 *}

definition [simp]: "d0 =
  h' ::= Ct 0 ;;
  While (Gt (Var h) (Ct 0))
    (Ch\<^sub>\<onehalf> (h ::= Ct 0)
         (h' ::= Plus (Var h') (Ct 1)))"

definition [simp]: "d1 =
  While (Gt (Var h) (Ct 0))
    (Ch\<^sub>\<onehalf> (h ::= Minus (Var h) (Ct 1))
         (h ::= Plus (Var h) (Ct 1)))"

definition [simp]: "d2 =
  If (Eq (Var l) (Ct 0))
    (l' ::= Ct 1)
    d0"

definition [simp]: "d3 =
  h ::= Ct 5 ;;
  ParT [d0, (l ::= Ct 1)]"

(* The syntactic criteria are checked automatically: *)
theorem "SC_discr d0"
        "SC_discr d1"
        "SC_Sbis d2"
        "SC_ZObis d2"
  by (auto simp: Example_PL.SC_discr.simps Example_PL.SC_Sbis.simps Example_PL.SC_ZObis.simps)

(* Alternatively, the semantic notions follow directly from the compositionality facts
used as intro rules: *)
theorem "discr d0"
        "discr d1"
        "d2 \<approx>s d2"
        "d3 \<approx>01 d3"
  by (auto intro!: compatAtmSyntactic
                   Example_PL.ZObis Example_PL.proper_intros
                   Example_PL.Atm_Sbis)

end


section\<open>Word Upto\<close>
theory Word_Upto
imports Main
  IP_Addresses.Hs_Compat
  Word_Lib.Word_Lemmas
begin

text\<open>Enumerate a range of machine words.\<close>

text\<open>enumerate from the back (inefficient)\<close>
function word_upto :: "'a word \<Rightarrow> 'a word \<Rightarrow> ('a::len0) word list" where
"word_upto a b = (if a = b then [a] else word_upto a (b - 1) @ [b])"
by pat_completeness auto

(*by the way: does not terminate practically if b < a; will terminate after it
  reaches the word wrap-around!*)

termination word_upto
apply(relation "measure (unat \<circ> uncurry (-) \<circ> prod.swap)")
 apply(rule wf_measure; fail)
apply(simp)
apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
 apply(simp add: diff_right_commute; fail)
apply(rule measure_unat)
apply auto
done

declare word_upto.simps[simp del]

text\<open>enumerate from the front (more inefficient)\<close>
function word_upto' :: "'a word \<Rightarrow> 'a word \<Rightarrow> ('a::len0) word list" where
"word_upto' a b = (if a = b then [a] else a # word_upto' (a + 1) b)"
by pat_completeness auto

termination word_upto'
apply(relation "measure (\<lambda> (a, b). unat (b - a))")
 apply(rule wf_measure; fail)
apply(simp)
apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
 apply (simp add: diff_diff_add; fail)
apply(rule measure_unat)
apply auto
done

declare word_upto'.simps[simp del]

lemma word_upto_cons_front[code]:
 "word_upto a b = word_upto' a b"
 proof(induction a b rule:word_upto'.induct)
 case (1 a b)
   have hlp1: "a \<noteq> b \<Longrightarrow> a # word_upto (a + 1) b = word_upto a b"
   apply(induction a b rule:word_upto.induct)
   apply simp
   apply(subst(1) word_upto.simps)
   apply(simp)
   apply safe
    apply(subst(1) word_upto.simps)
    apply (simp)
    apply(subst(1) word_upto.simps)
    apply (simp; fail)
   apply(case_tac "a \<noteq> b - 1")
    apply(simp)
    apply (metis Cons_eq_appendI word_upto.simps)
   apply(simp)
   done

   from 1[symmetric] show ?case
     apply(cases "a = b")
      subgoal
      apply(subst word_upto.simps)
      apply(subst word_upto'.simps)
      by(simp)
     apply(subst word_upto'.simps)
     by(simp add: hlp1)
 qed

(* Most of the lemmas I show about word_upto hold without a \<le> b,
   but I don't need that right now and it's giving me a headache *)

lemma word_upto_set_eq: "a \<le> b \<Longrightarrow> x \<in> set (word_upto a b) \<longleftrightarrow> a \<le> x \<and> x \<le> b"
proof
  show "a \<le> b \<Longrightarrow> x \<in> set (word_upto a b) \<Longrightarrow> a \<le> x \<and> x \<le> b"
    apply(induction a b rule: word_upto.induct)
    apply(case_tac "a = b")
     apply(subst(asm) word_upto.simps)
     apply(simp; fail)
    apply(subst(asm) word_upto.simps)
    apply(simp)
    apply(erule disjE)
     apply(simp; fail)
    proof(goal_cases)
     case (1 a b)
     from 1(2-3) have "b \<noteq> 0" by force
     from 1(2,3) have "a \<le> b - 1" by (metis \<open>b \<noteq> 0\<close> eq_iff le_step_down_nat unat_arith_simps(1) unat_minus_one)
     from 1(1)[OF this 1(4)] show ?case by (metis dual_order.trans 1(2,3) less_imp_le measure_unat word_le_0_iff word_le_nat_alt)
    qed
next
  show "a \<le> x \<and> x \<le> b \<Longrightarrow> x \<in> set (word_upto a b)"
    apply(induction a b rule: word_upto.induct)
    apply(case_tac "a = b")
     apply(subst word_upto.simps)
     apply(simp; force)
    apply(subst word_upto.simps)
    apply(simp)
    apply(case_tac "x = b")
     apply(simp;fail)
    proof(goal_cases)
       case (1 a b)
       from 1(2-4) have "b \<noteq> 0" by force
       from 1(2,4) have "x \<le> b - 1" by (metis \<open>b \<noteq> 0\<close> dual_order.antisym le_step_down_nat unat_minus_one word_le_nat_alt)
       from 1(1) this show ?case by simp
    qed
qed

lemma word_upto_distinct_hlp: "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> b \<notin> set (word_upto a (b - 1))"
   apply(rule ccontr, unfold not_not)
   apply(subgoal_tac "a \<le> b - 1")
    apply(drule iffD1[OF word_upto_set_eq[of a "b -1" b]])
     apply(simp add: word_upto.simps; fail)
    apply(subgoal_tac "b \<noteq> 0")
     apply(meson leD measure_unat word_le_nat_alt)
    apply(blast intro: iffD1[OF word_le_0_iff])
   apply(metis antisym_conv le_step_down_nat unat_minus_one word_le_0_iff word_le_nat_alt)
done

lemma distinct_word_upto: "a \<le> b \<Longrightarrow> distinct (word_upto a b)"
apply(induction a b rule: word_upto.induct)
apply(case_tac "a = b")
 apply(subst word_upto.simps)
 apply(simp; force)
apply(subst word_upto.simps)
apply(case_tac "a \<le> b - 1")
 apply(simp)
 apply(rule word_upto_distinct_hlp; simp; fail)
apply(simp)
apply(rule ccontr)
apply(metis le_step_down_nat less_le not_le unat_minus_one word_le_nat_alt word_not_simps(1))
done

lemma word_upto_eq_upto: "s \<le> e \<Longrightarrow> e \<le> unat (max_word :: 'l word) \<Longrightarrow>
       word_upto ((of_nat :: nat \<Rightarrow> ('l :: len) word) s) (of_nat e) = map of_nat (upt s (Suc e))"
proof(induction e)
  let ?mwon = "of_nat :: nat \<Rightarrow> 'l word"
  let ?mmw = "max_word :: 'l word"
  case (Suc e)
  show ?case
  proof(cases "?mwon s = ?mwon (Suc e)")
    case True
    have "s = Suc e" using le_unat_uoi Suc.prems True by metis
    with True show ?thesis by(subst word_upto.simps) (simp)
  next
    case False
    hence le: "s \<le> e" using le_SucE Suc.prems by blast
    have lm: "e \<le> unat ?mmw" using Suc.prems by simp
    have sucm: "(of_nat :: nat \<Rightarrow> ('l :: len) word) (Suc e) - 1 = of_nat e" using Suc.prems(2) by simp
    note mIH = Suc.IH[OF le lm]
    show ?thesis by(subst word_upto.simps) (simp add: False[simplified] Suc.prems mIH sucm)
  qed
qed(simp add: word_upto.simps)

lemma word_upto_alt: "(a :: ('l :: len) word) \<le> b \<Longrightarrow>
  word_upto a b = map of_nat (upt (unat a) (Suc (unat b)))"
proof -
   let ?mmw = "max_word :: 'l word"
   assume le: "a \<le> b"
   hence nle: "unat a \<le> unat b" by(unat_arith)
   have lem: "unat b \<le> unat ?mmw" by (simp add: word_unat_less_le)
   note word_upto_eq_upto[OF nle lem, unfolded word_unat.Rep_inverse]
   thus "word_upto a b = map of_nat [unat a..<Suc (unat b)]" .
qed

lemma word_upto_upt:
  "word_upto a b = (if a \<le> b then map of_nat (upt (unat a) (Suc (unat b))) else word_upto a b)"
  using word_upto_alt by metis

lemma sorted_word_upto:
   fixes a b :: "('l :: len) word"
   assumes "a \<le> b"
   shows "sorted (word_upto a b)"
using assms
proof(induction b)
  fix b
  assume le_prem: "a \<le> 1 + b"
  assume nmax_prem: "1 + b \<noteq> 0"
  assume IH: "a \<le> b \<Longrightarrow> sorted (word_upto a b)"
  show "sorted (word_upto a (1 + b))"
  proof(cases "a = 1 + b")
    case True thus ?thesis by(simp add: word_upto.simps)
  next
    case False
    have fprem: "a \<le> b" using le_prem False by (metis add.commute antisym_conv1 plus_one_helper)
    note mIH = IH[OF this]
    show ?thesis by(subst word_upto.simps)
                   (simp add: fprem lt1_neq0 nmax_prem word_le_plus_either word_upto_set_eq False sorted_append mIH)
    qed
qed(simp add: word_upto.simps)

end


(*  Title:      CoW/Periodicity_Lemma.thy
    Author:     Štěpán Holub, Charles University
*)

theory Periodicity_Lemma
  imports CoWBasic
begin

chapter "The Periodicity Lemma"

text\<open>The Periodicity Lemma says that if a sufficiently long word has two periods p and q,
then the period can be refined to @{term "gcd p q"}.
The consequence is equivalent to the fact that the corresponding periodic roots commute.
``Sufficiently long'' here means at least @{term "p + q - gcd p q"}.
It is also known as the Fine and Wilf theorem due to its authors @{cite FineWilf}.\<close>

text\<open>
If we relax the requirement to @{term "p + q"}, then the claim becomes easy, and it is proved in theory @{theory Combinatorics_Words.CoWBasic} as @{term two_pers}: @{thm[names_long] two_pers[no_vars]}.
\<close>

theorem per_lemma_relaxed:
  assumes "periodN w p" and  "periodN w q" and  "p + q \<le> \<^bold>|w\<^bold>|"
  shows "(take p w)\<cdot>(take q w) = (take q w)\<cdot>(take p w)"
  using   two_pers[OF
      \<open>periodN w p\<close>[unfolded periodN_def[of w p]]
      \<open>periodN w q\<close>[unfolded periodN_def[of w q]], unfolded
      take_len[OF add_leD1[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]]
      take_len[OF add_leD2[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]], OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>].

text\<open>Also in terms of the numeric period:\<close>

thm two_periodsN

section \<open>Main claim\<close>

text\<open>We first formulate the claim of the Periodicity lemma in terms of commutation of two periodic roots.
For trivial reasons we can also drop the requirement that the roots are nonempty.
\<close>
lemma per_lemma_comm:
  assumes "w \<le>p r \<cdot> w" and "w \<le>p s \<cdot> w"
    and len: "\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|"
  shows "s \<cdot> r = r \<cdot> s"
  using assms
proof (induction "\<^bold>|s\<^bold>| + \<^bold>|s\<^bold>| + \<^bold>|r\<^bold>|" arbitrary: w r s rule: less_induct)
  case less
  consider (empty) "s = \<epsilon>" | (short)  "\<^bold>|r\<^bold>| < \<^bold>|s\<^bold>|" | (step) "s \<noteq> \<epsilon> \<and> \<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|" by force
  then show ?case
  proof (cases)
    case (empty)
    thus "s \<cdot> r = r \<cdot> s" by fastforce
  next
    case (short)
    thus "s \<cdot> r = r \<cdot> s"
      using  "less.hyps"[OF  _ \<open> w \<le>p s \<cdot> w\<close> \<open> w \<le>p r \<cdot> w\<close>
      \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close>[unfolded gcd.commute[of "\<^bold>|s\<^bold>|"] add.commute[of "\<^bold>|s\<^bold>|"]]] by fastforce
   next
     case (step)
    hence  "s \<noteq> \<epsilon>" and "\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|" by blast+
    from le_add_diff[OF gcd_le2_nat[OF \<open>s \<noteq> \<epsilon>\<close>[folded length_0_conv], of "\<^bold>|r\<^bold>|"], unfolded gcd.commute[of "\<^bold>|r\<^bold>|"]]
    have "\<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>|"
      using  \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close> order.trans by fast
    hence "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|"
      using \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close> order.trans by blast
    from pref_prod_long[OF  \<open>w \<le>p s \<cdot> w\<close> this]
    have "s \<le>p w".

    obtain w' where "s \<cdot> w' = w" and "\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|" using \<open>s \<noteq> \<epsilon>\<close> \<open>s \<le>p w\<close> by auto
    have "w' \<le>p w"
      using \<open>w \<le>p s \<cdot> w\<close> unfolding \<open>s \<cdot> w' = w\<close>[symmetric] pref_cancel_conv.
    from this[folded \<open>s \<cdot> w' = w\<close>]
    have "w' \<le>p s\<cdot>w'".

    have "s \<le>p r"
      using pref_prod_short[OF prefix_order.trans[OF \<open>s \<le>p w\<close> \<open>w \<le>p r \<cdot> w\<close>] \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close>].
    hence  "w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'"
      using \<open>w \<le>p r \<cdot> w\<close> \<open>s \<cdot> w' = w\<close> pref_prod_pref[OF _ \<open>w' \<le>p w\<close>, of "s\<inverse>\<^sup>>r"]  by fastforce

    have ind_len: "\<^bold>|s\<^bold>| + \<^bold>|s\<inverse>\<^sup>>r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|s\<inverse>\<^sup>>r\<^bold>|) \<le> \<^bold>|w'\<^bold>|"
      using \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close> \<open>s \<cdot> w' = w\<close> \<open>s \<le>p r\<close> by auto

    have "s \<cdot> s\<inverse>\<^sup>>r = s\<inverse>\<^sup>>r \<cdot> s"
      using "less.hyps"[OF  _ \<open>w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'\<close>  \<open>w' \<le>p s \<cdot> w'\<close> ind_len] \<open>s \<le>p r\<close> \<open>\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|\<close>  by force

    thus "s \<cdot> r = r \<cdot> s"
       using \<open>s \<le>p r\<close> by auto
  qed
qed

text\<open>We can now prove the numeric version.\<close>

theorem per_lemma: assumes "periodN w p" and "periodN w q" and len: "p + q - gcd p q \<le> \<^bold>|w\<^bold>|"
  shows  "periodN w (gcd p q)"
proof-
  have takep: "w \<le>p (take p w) \<cdot> w" and takeq: "w \<le>p (take q w) \<cdot> w"
    using \<open>periodN w p\<close> \<open>periodN w q\<close> periodN_D3 by blast+
  have lenp: "\<^bold>|take p w\<^bold>| = p"
    using gcd_le2_nat[OF per_positive[OF \<open>periodN w q\<close>], of p] len take_len
    by auto
  have lenq: "\<^bold>|take q w\<^bold>| = q"
    using gcd_le1_nat[OF per_positive[OF \<open>periodN w p\<close>], of q] len take_len
    by simp
  obtain t where "take p w \<in> t*" and "take q w \<in> t*"
    using comm_rootE[OF per_lemma_comm[OF takeq takep, unfolded lenp lenq, OF len], of thesis] by blast
  hence "w \<le>p t\<^sup>\<omega>"
    using \<open>periodN w p\<close> periodN_def per_root_trans by blast
  have "periodN w \<^bold>|t\<^bold>|"
    using  root_periodN[OF  per_nemp[OF \<open>periodN w p\<close>] \<open>w \<le>p t\<^sup>\<omega>\<close>].
  have "\<^bold>|t\<^bold>| dvd (gcd p q)"
    using  common_root_len_gcd[OF \<open>take p w \<in> t*\<close> \<open>take q w \<in> t*\<close>] unfolding  lenp lenq.
  from dvd_div_mult_self[OF this]
  have "gcd p q div \<^bold>|t\<^bold>| * \<^bold>|t\<^bold>| = gcd p q".
  have "gcd p q \<noteq> 0"
    using \<open>periodN w p\<close> by auto
  from this[folded dvd_div_eq_0_iff[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]]
  show "periodN w (gcd p q)"
    using  per_mult[OF \<open>periodN w \<^bold>|t\<^bold>|\<close>, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]] by blast
qed

section \<open>Optimality\<close>

text\<open>@{term "FW_word"} (where FW stands for  Fine and Wilf) yields a word which show the optimality of the bound in the Periodicity lemma.
    Moreover, the obtained word has maximum possible letters (each equality of letters is forced by periods). The latter is not proved here.\<close>

term "butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))\<cdot>[gcd p q]\<cdot>(butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q))))"

\<comment> \<open>an auxiliary claim\<close>
lemma ext_per_sum: assumes "periodN w p" and "periodN w q" and  "p \<le> \<^bold>|w\<^bold>|"
  shows "periodN ((take p w) \<cdot> w) (p+q)"
proof-
  have nemp: "take p w \<cdot> take q w \<noteq> \<epsilon>"
    using \<open>periodN w p\<close> by auto
  have "take (p + q) (take p w \<cdot> w) = take p (take p w \<cdot> w) \<cdot> take q (drop p (take p w \<cdot> w))"
    using take_add by blast
  also have "... = take p w \<cdot> take q w"
    by (simp add: \<open>p \<le> \<^bold>|w\<^bold>|\<close>)
  ultimately have sum: "take (p + q) (take p w \<cdot> w) = take p w \<cdot> take q w"
    by simp
  show ?thesis
    using assms(1) assms(2) nemp
    unfolding periodN_def period_root_def sum rassoc same_prefix_prefix
    using pref_prolong  by blast
qed

abbreviation "fw_p_per p q \<equiv> butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))"
abbreviation "fw_base p q \<equiv> fw_p_per p q \<cdot> [gcd p q]\<cdot> fw_p_per p q"

fun FW_word :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  FW_word_def: "FW_word p q =
\<comment>\<open>symmetry\<close>           (if q < p then  FW_word q p else
\<comment>\<open>artificial value\<close>   if p = 0 \<or> p = q then \<epsilon> else
\<comment>\<open>base case\<close>          if gcd p q = q - p then fw_base p q
\<comment>\<open>step\<close>               else (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p)    )"

lemma FW_sym: "FW_word p q = FW_word q p"
  by (cases rule: linorder_cases[of p q], simp+)

theorem fw_word': "\<not> p dvd q \<Longrightarrow> \<not> q dvd p \<Longrightarrow>
 \<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1 \<and> periodN (FW_word p q) p \<and> periodN (FW_word p q) q \<and> \<not> periodN (FW_word p q) (gcd p q)"
proof (induction "p + p + q" arbitrary: p q rule: less_induct)
  case less
  have "p \<noteq> 0"
    using  \<open>\<not> q dvd p\<close> dvd_0_right[of q] by meson
  have "p \<noteq> q"
    using \<open>\<not> p dvd q\<close> by auto
  then consider "q < p" | "p < q"
    by linarith
  then show ?case
  proof (cases)
    assume "q < p"
    have less: "q + q + p < p + p + q"
      by (simp add: \<open>q < p\<close>)
    thus ?case
      using "less.hyps"[OF _ \<open>\<not> q dvd p\<close> \<open>\<not> p dvd q\<close>]
      unfolding FW_sym[of p q] gcd.commute[of p q] add.commute[of p q] by blast
  next
    let ?d = "gcd p q"
    let ?dw = "[0..<(gcd p q)]"
    let ?pd = "p div (gcd p q)"
    assume "p < q"
    thus ?thesis
    proof (cases "?d = q - p")
      assume "?d = q - p" hence "p + ?d = q" using \<open>p < q\<close> by auto
      have fw: "FW_word p q = fw_base p q"
        using FW_word_def \<open>p \<noteq> 0\<close> \<open>gcd p q = q - p\<close> \<open>p < q\<close> by auto

      have ppref: "\<^bold>|butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<^bold>| = p"
        using length_append \<open>p \<noteq> 0\<close> pow_len[of "?dw" "?pd"]
        by auto
      note ppref' = this[unfolded length_append]
      have qpref: "\<^bold>|butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<cdot>?dw\<^bold>| = q"
        unfolding lassoc length_append ppref' using  \<open>p + gcd p q = q\<close> by simp
      have "butlast (?dw\<^sup>@?pd)\<cdot>[?d] \<le>p FW_word p q"
        unfolding fw by force
      from pref_take[OF this]
      have takep: "take p (FW_word p q) = butlast (?dw\<^sup>@?pd)\<cdot>[?d]"
        unfolding ppref.

      have "?dw \<noteq> \<epsilon>" and "\<^bold>|?dw\<^bold>| = ?d"
        using \<open>p \<noteq> 0\<close> by auto
      have "?pd \<noteq> 0"
        by (simp add: \<open>p \<noteq> 0\<close> dvd_div_eq_0_iff)
      from not0_implies_Suc[OF this]
      obtain e where "?pd = Suc e"  by blast
      have "gcd p q \<noteq> p"
        using \<open>\<not> p dvd q\<close> gcd_dvd2[of p q] by force
      hence "Suc e \<noteq> 1"
        using dvd_mult_div_cancel[OF gcd_dvd1[of p q], unfolded \<open>?pd = Suc e\<close>] by force
      hence "e \<noteq> 0" by simp

      have "[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>"
        using \<open>[0..<gcd p q] \<noteq> \<epsilon>\<close> \<open>e \<noteq> 0\<close> nonzero_pow_emp by blast
      hence but_dec: "butlast (?dw\<^sup>@?pd) = ?dw \<cdot> butlast (?dw\<^sup>@e)"
        unfolding \<open>?pd = Suc e\<close> pow_Suc_list butlast_append  if_not_P[OF \<open>[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>\<close>] by blast
      have but_dec_b: "butlast (?dw\<^sup>@?pd) = ?dw\<^sup>@e \<cdot> butlast ?dw"
        unfolding \<open>?pd = Suc e\<close> pow_Suc2_list butlast_append if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>] by blast
      have "butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<cdot>?dw \<le>p FW_word p q"
        using fw but_dec by auto
      note takeq = pref_take[OF this, unfolded qpref]

      have "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1"
      proof-
        have "\<^bold>|?dw\<^bold>| = ?d"
          by auto
        have "gcd p q dvd p"
          by auto
        hence "\<^bold>|?dw\<^sup>@?pd\<^bold>| = p"
          using pow_len[of "?dw" "?pd"]
          by auto
        hence "\<^bold>|butlast (?dw\<^sup>@?pd)\<^bold>| = p - 1"
          by simp
        hence "\<^bold>|FW_word p q\<^bold>| = (p - 1) + 1 +  (p - 1)"
          using fw unfolding length_append
          by auto
        thus "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1"
          unfolding \<open>gcd p q = q - p\<close> using \<open>p + gcd p q = q\<close> \<open>p \<noteq> 0\<close> add.assoc by auto
      qed

      have "periodN (FW_word p q) p"
      proof-
        have "take p (FW_word p q) \<noteq> \<epsilon>"
          using \<open>p \<noteq> 0\<close>  unfolding length_0_conv[symmetric] ppref[folded takep].
        thus "periodN (FW_word p q) p"
          unfolding periodN_def period_root_def  takep unfolding fw lassoc by auto
      qed

      have "periodN (FW_word p q) q"
        unfolding periodN_def period_root_def
      proof
        show "take q (FW_word p q) \<noteq> \<epsilon>"
          unfolding length_0_conv[symmetric] qpref[folded takeq] using \<open>p \<noteq> 0\<close> \<open>p < q\<close> by linarith
      next
        show "FW_word p q \<le>p take q (FW_word p q) \<cdot> FW_word p q"
          unfolding takeq
          unfolding fw rassoc pref_cancel_conv but_dec but_dec_b \<open>?pd = Suc e\<close> pow_Suc2_list butlast_append pow_Suc_list if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>]
          unfolding lassoc power_commutes[symmetric] unfolding rassoc pref_cancel_conv
          using pref_ext[OF prefixeq_butlast, of "?dw"] by blast
      qed

      have "\<not> periodN (FW_word p q) ?d"
      proof-
        have last_a: "last (take p (FW_word p q)) = ?d"
          unfolding takep nth_append_length[of "butlast (?dw \<^sup>@ ?pd)" "?d" \<epsilon>]
            last_snoc by blast
        have "?dw \<le>p FW_word p q"
          using fw but_dec  by simp
        from pref_take[OF this, unfolded \<open>\<^bold>|?dw\<^bold>| = ?d\<close>]
        have takegcd:  "take (gcd p q) (FW_word p q) = [0..<gcd p q]".
        have fw_dec_b: "FW_word p q = [0..<gcd p q]\<^sup>@e \<cdot> butlast ([0..<gcd p q]) \<cdot> [?d] \<cdot> (butlast ([0..<gcd p q]\<^sup>@(p div gcd p q)))"
          using fw but_dec_b  by simp
        hence gcdepref:  "[0..<gcd p q]\<^sup>@ Suc e \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q"
          using takegcd  by simp
        have "\<^bold>|[0..<gcd p q]\<^sup>@ Suc e\<^bold>| = p"
          unfolding pow_len \<open>\<^bold>|?dw\<^bold>| = ?d\<close> \<open>?pd = Suc e\<close>[symmetric] using
            dvd_div_mult_self[OF gcd_dvd1].
        from pref_take[OF gcdepref, unfolded this]
        have takegcdp:  "take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q)) = [0..<gcd p q]\<^sup>@e \<cdot> [0..<gcd p q]"
          unfolding pow_Suc2_list.
        have "0 < gcd p q" by (simp add: \<open>p \<noteq> 0\<close>)
        from last_upt[OF this]
        have last_b: "last (take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q))) = gcd p q - 1"
          unfolding takegcdp  last_appendR[of "[0..<gcd p q]" "[0..<gcd p q]\<^sup>@e", OF \<open>[0..<gcd p q] \<noteq> \<epsilon>\<close>].
        have "p \<le> \<^bold>|FW_word p q\<^bold>|"
          using \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>gcd p q = q - p\<close> \<open>p < q\<close> by linarith
        have "gcd p q \<noteq> gcd p q - 1"
          using \<open>gcd p q = q - p\<close> \<open>p < q\<close> by linarith
        hence "take p (FW_word p q) \<noteq> take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q))"
          unfolding last_b[symmetric] unfolding last_a[symmetric] using arg_cong[of _ _ last] by blast
        hence "\<not> FW_word p q \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q "
          using pref_share_take[OF _ \<open>p \<le> \<^bold>|FW_word p q\<^bold>|\<close>, of "take (gcd p q) (FW_word p q) \<cdot> FW_word p q"] by blast
        thus "\<not> periodN (FW_word p q) (gcd p q)"
          unfolding periodN_def period_root_def by blast
      qed

      show ?thesis
        using \<open>periodN (FW_word p q) p\<close> \<open>periodN (FW_word p q) q\<close>
          \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>\<not> periodN (FW_word p q) (gcd p q)\<close> by blast
    next
      let ?d' = "gcd p (q-p)"
      assume "gcd p q \<noteq> q - p"
      hence fw: "FW_word p q = (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p)"
        using FW_word_def \<open>p \<noteq> 0\<close> \<open>p \<noteq> q\<close> \<open>p < q\<close> by (meson less_Suc_eq not_less_eq)

      have divhyp1: "\<not> p dvd q - p"
        using \<open>\<not> p dvd q\<close> \<open>p < q\<close> dvd_minus_self by auto

      have divhyp2: "\<not> q - p dvd p"
      proof (rule notI)
        assume "q - p dvd p"
        have "q = p + (q - p)"
          by (simp add: \<open>p < q\<close> less_or_eq_imp_le)
        from gcd_add2[of p "q - p", folded  this, unfolded gcd_nat.absorb2[of "q - p" p, OF \<open>q - p dvd p\<close>]]
        show "False"
          using \<open>gcd p q \<noteq> q - p\<close> by blast
      qed

      have lenhyp: "p + p + (q - p) < p + p + q"
        using \<open>p < q\<close> \<open>p \<noteq> 0\<close> by linarith

\<comment> \<open>induction assumption\<close>
      have "\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1" and "periodN (FW_word p (q-p)) p" and "periodN (FW_word p (q-p)) (q-p)" and
        "\<not> periodN (FW_word p (q-p)) (gcd p (q-p))"
        using "less.hyps"[OF _ divhyp1 divhyp2] lenhyp
        by blast+

\<comment> \<open>auxiliary facts\<close>
      have "p + (q - p) = q"
         using divhyp1 dvd_minus_self by auto
      have "?d = ?d'"
        using  gcd_add2[of p "q-p", unfolded le_add_diff_inverse[OF less_imp_le[OF \<open>p < q\<close>]]].
      have "?d \<noteq> q"
        using  \<open>\<not> q dvd p\<close>  gcd_dvd2[of q p, unfolded gcd.commute[of q]] by force
      from this[unfolded nat_neq_iff]
      have "?d < q"
        using  gr_implies_not0 \<open>p < q\<close> nat_dvd_not_less by blast
      hence "1 \<le> q - ?d"
        by linarith
      have "?d' < q - p"
        using  gcd_le2_nat[OF per_positive[OF \<open>periodN (FW_word p (q - p)) (q - p)\<close>], of p]  divhyp2[unfolded  gcd_nat.absorb_iff2] nat_less_le by blast
      hence "p \<le> \<^bold>|(FW_word p (q - p))\<^bold>|"
        unfolding  \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close>  diff_diff_left discrete by linarith
      have "FW_word p (q - p) \<noteq> \<epsilon>"
        unfolding length_0_conv[symmetric] using  \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close> \<open>p \<noteq> 0\<close>[folded le_zero_eq]
        by linarith

\<comment> \<open>claim 1\<close>
      have "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1"
      proof-
        have "\<^bold>|FW_word p q\<^bold>| = \<^bold>|take p (FW_word p (q - p))\<^bold>| + \<^bold>|FW_word p (q - p)\<^bold>|"
          using fw length_append[of "take p (FW_word p (q - p))" "FW_word p (q - p)"]
          by presburger
        also have "... = p + (p + (q - p) - ?d' - 1)"
          unfolding \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close>
            take_len[OF \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>] by blast
        also have "... = p + (q - ?d  - 1)"
          unfolding \<open>?d = ?d'\<close> using  \<open>p < q\<close> by auto
        also have "... = p + (q - ?d) - 1"
          using Nat.add_diff_assoc[OF \<open>1 \<le> q - ?d\<close>].
        also have "... = p + q - ?d - 1"
          by (simp add: \<open>?d < q\<close> less_or_eq_imp_le)
        finally show "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1"
          by presburger
      qed

\<comment> \<open>claim 2\<close>
      have "periodN (FW_word p q) p"
        using fw  ext_per_left[OF \<open>periodN (FW_word p (q-p)) p\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>]
        by presburger

\<comment> \<open>claim 3\<close>
      have "periodN (FW_word p q) q"
        using ext_per_sum[OF \<open>periodN (FW_word p (q - p)) p\<close> \<open>periodN (FW_word p (q - p)) (q - p)\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>, folded fw, unfolded \<open>p + (q-p) = q\<close>].

\<comment> \<open>claim 4\<close>
      have "\<not> periodN (FW_word p q) ?d"
        using \<open>\<not> periodN (FW_word p (q -p)) (gcd p (q-p))\<close>
        unfolding \<open>?d = ?d'\<close>[symmetric]
        using periodN_fac[of "take p (FW_word p (q - p))" "FW_word p (q - p)" \<epsilon> "?d", unfolded append_Nil2,
                          OF _ \<open>FW_word p (q - p) \<noteq> \<epsilon>\<close>, folded fw] by blast
      thus ?thesis
        using \<open>periodN (FW_word p q) p\<close> \<open>periodN (FW_word p q) q\<close> \<open>\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1\<close> by blast
    qed
  qed
qed

theorem fw_word: assumes "\<not> p dvd q" "\<not> q dvd p"
  shows "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1" and "periodN (FW_word p q) p" and  "periodN (FW_word p q) q" and "\<not> periodN (FW_word p q) (gcd p q)"
  using fw_word'[OF assms] by blast+

text\<open>Calculation examples\<close>

value "FW_word 3 7"
value "FW_word 5 7"
value "FW_word 5 13"
value "FW_word 4 6"
value "FW_word 12 18"

section "Other variants of the periodicity lemma"

text \<open>Periodicity lemma is one of the most frequent tools in Combinatorics on words.
   Here are some useful variants.\<close>

lemma fac_two_conjug_prim_root:
  assumes facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l" and nemps: "r \<noteq> \<epsilon>" "s \<noteq> \<epsilon>" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
  shows "\<rho> r \<sim> \<rho> s"
proof -
  obtain r' s' where prefr': "u \<le>p r'\<^sup>@k" and prefs': "u \<le>p s'\<^sup>@l"
               and   conjugs: "r \<sim> r'" "s \<sim> s'"
    using facs by (elim fac_pow_pref_conjug)
  have rootr': "u \<le>p r' \<cdot> u" and roots': "u \<le>p s' \<cdot> u"
    using pref_prod_root[OF prefr'] pref_prod_root[OF prefs'].
  have nemps': "r' \<noteq> \<epsilon>" "s'\<noteq> \<epsilon>" using nemps conjugs conjug_nemp_iff by blast+
  have "\<^bold>|r'\<^bold>| + \<^bold>|s'\<^bold>| - gcd (\<^bold>|r'\<^bold>|) (\<^bold>|s'\<^bold>|) \<le> \<^bold>|u\<^bold>|" using len
    unfolding conjug_len[OF \<open>r \<sim> r'\<close>] conjug_len[OF \<open>s \<sim> s'\<close>].
  from per_lemma_comm[OF roots' rootr' this]  have "r' \<cdot> s' = s' \<cdot> r'".
  then have "\<rho> r' = \<rho> s'" using comm_primroots[OF nemps'] by force
  also have "\<rho> s \<sim> \<rho> s'" using conjug_prim_root[OF \<open>s \<sim> s'\<close> \<open>s \<noteq> \<epsilon>\<close>].
  also have [symmetric]: "\<rho> r \<sim> \<rho> r'" using conjug_prim_root[OF \<open>r \<sim> r'\<close> \<open>r \<noteq> \<epsilon>\<close>].
  finally show "\<rho> r \<sim> \<rho> s"..
qed

lemma fac_two_conjug_prim_root':
  assumes facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l" and "u \<noteq> \<epsilon>" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
  shows "\<rho> r \<sim> \<rho> s"
proof -
  have nemps: "r \<noteq> \<epsilon>" "s \<noteq> \<epsilon>" using facs \<open>u \<noteq> \<epsilon>\<close> by auto
  show "conjugate (\<rho> r) (\<rho> s)" using fac_two_conjug_prim_root[OF facs nemps len].
qed

lemma fac_two_nconj_prim_pow:
  assumes prims: "primitive r" "primitive s" and "\<not> r \<sim> s"
      and facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l"
  shows "\<^bold>|u\<^bold>| < \<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|)"
  using \<open>\<not> r \<sim> s\<close> fac_two_conjug_prim_root[OF facs prim_nemp prim_nemp leI, OF prims]
  unfolding prim_self_root[OF \<open>primitive r\<close>] prim_self_root[OF \<open>primitive s\<close>]
  by (rule contrapos_np)

end


section \<open>Product Operator for Commutative Monoids\<close>

(*
  Finite products in group theory. This theory is largely based on HOL/Algebra/FiniteProduct.thy.
  --L C Paulson
*)

theory FiniteProduct
  imports
    "Jacobson_Basic_Algebra.Group_Theory"

begin

subsection \<open>Products over Finite Sets\<close>

context commutative_monoid begin

definition "M_ify x \<equiv> if x \<in> M then x else \<one>"

definition "fincomp f A \<equiv> if finite A then Finite_Set.fold (\<lambda>x y. f x \<cdot> M_ify y) \<one> A else \<one>"

lemma fincomp_empty [simp]: "fincomp f {} = \<one>"
  by (simp add: fincomp_def)

lemma fincomp_infinite[simp]: "infinite A \<Longrightarrow> fincomp f A = \<one>"
  by (simp add: fincomp_def)

lemma left_commute: "\<lbrakk> a \<in> M; b \<in> M; c \<in> M \<rbrakk> \<Longrightarrow> b \<cdot> (a \<cdot> c) = a \<cdot> (b \<cdot> c)"
  using commutative by force

lemma comp_fun_commute_onI:
  assumes "f \<in> F \<rightarrow> M"
  shows "comp_fun_commute_on F (\<lambda>x y. f x \<cdot> M_ify y)"
  using assms
  by (auto simp add: comp_fun_commute_on_def Pi_iff M_ify_def left_commute)

lemma fincomp_closed [simp]:
  assumes "f \<in> F \<rightarrow> M"
  shows "fincomp f F \<in> M"
proof -
  interpret comp_fun_commute_on F "\<lambda>x y. f x \<cdot> M_ify y"
    by (simp add: assms comp_fun_commute_onI)
  show ?thesis
    unfolding fincomp_def
    by (smt (verit, ccfv_threshold) M_ify_def Pi_iff fold_graph_fold assms composition_closed equalityE fold_graph_closed_lemma unit_closed)
qed

lemma fincomp_insert [simp]:
  assumes F: "finite F" "a \<notin> F" and f: "f \<in> F \<rightarrow> M" "f a \<in> M"
  shows "fincomp f (insert a F) = f a \<cdot> fincomp f F"
proof -
  interpret comp_fun_commute_on "insert a F" "\<lambda>x y. f x \<cdot> M_ify y"
    by (simp add: comp_fun_commute_onI f)
  show ?thesis
    using assms fincomp_closed commutative_monoid.M_ify_def commutative_monoid_axioms
    by (fastforce simp add: fincomp_def)
qed

lemma fincomp_unit_eqI: "(\<And>x. x \<in> A \<Longrightarrow> f x = \<one>) \<Longrightarrow> fincomp f A = \<one>"
proof (induct A rule: infinite_finite_induct)
  case empty show ?case by simp
next
  case (insert a A)
  have "(\<lambda>i. \<one>) \<in> A \<rightarrow> M" by auto
  with insert show ?case by simp
qed simp

lemma fincomp_unit [simp]: "fincomp (\<lambda>i. \<one>) A = \<one>"
  by (simp add: fincomp_unit_eqI)

lemma funcset_Int_left [simp, intro]:
  "\<lbrakk>f \<in> A \<rightarrow> C; f \<in> B \<rightarrow> C\<rbrakk> \<Longrightarrow> f \<in> A Int B \<rightarrow> C"
  by fast

lemma funcset_Un_left [iff]:
  "(f \<in> A Un B \<rightarrow> C) = (f \<in> A \<rightarrow> C \<and> f \<in> B \<rightarrow> C)"
  by fast

lemma fincomp_Un_Int:
  "\<lbrakk>finite A; finite B; g \<in> A \<rightarrow> M; g \<in> B \<rightarrow> M\<rbrakk> \<Longrightarrow>
     fincomp g (A \<union> B) \<cdot> fincomp g (A \<inter> B) =
     fincomp g A \<cdot> fincomp g B"
  \<comment> \<open>The reversed orientation looks more natural, but LOOPS as a simprule!\<close>
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert a A)
  then have "g a \<in> M" "g \<in> A \<rightarrow> M" by blast+
  with insert show ?case
    by (simp add: Int_insert_left associative insert_absorb left_commute)
qed

lemma fincomp_Un_disjoint:
  "\<lbrakk>finite A; finite B; A \<inter> B = {}; g \<in> A \<rightarrow> M; g \<in> B \<rightarrow> M\<rbrakk>
   \<Longrightarrow> fincomp g (A \<union> B) = fincomp g A \<cdot> fincomp g B"
  by (metis Pi_split_domain fincomp_Un_Int fincomp_closed fincomp_empty right_unit)

lemma fincomp_comp:
  "\<lbrakk>f \<in> A \<rightarrow> M; g \<in> A \<rightarrow> M\<rbrakk> \<Longrightarrow> fincomp (\<lambda>x. f x \<cdot> g x) A = (fincomp f A \<cdot> fincomp g A)"
proof (induct A rule: infinite_finite_induct)
  case empty show ?case by simp
next
  case (insert a A)
  then have "f a \<in> M" "g \<in> A \<rightarrow> M" "g a \<in> M" "f \<in> A \<rightarrow> M" "(\<lambda>x. f x \<cdot> g x) \<in> A \<rightarrow> M"
    by blast+
  then show ?case
    by (simp add: insert associative left_commute)
qed simp

lemma fincomp_cong':
  assumes "A = B" "g \<in> B \<rightarrow> M" "\<And>i. i \<in> B \<Longrightarrow> f i = g i"
  shows "fincomp f A = fincomp g B"
proof (cases "finite B")
  case True
  then have ?thesis
    using assms
  proof (induct arbitrary: A)
    case empty thus ?case by simp
  next
    case (insert x B)
    then have "fincomp f A = fincomp f (insert x B)" by simp
    also from insert have "... = f x \<cdot> fincomp f B"
      by (simp add: Pi_iff)
    also from insert have "... = g x \<cdot> fincomp g B" by fastforce
    also from insert have "... = fincomp g (insert x B)"
      by (intro fincomp_insert [THEN sym]) auto
    finally show ?case .
  qed
  with assms show ?thesis by simp
next
  case False with assms show ?thesis by simp
qed

lemma fincomp_cong:
  assumes "A = B" "g \<in> B \<rightarrow> M" "\<And>i. i \<in> B =simp=> f i = g i"
  shows "fincomp f A = fincomp g B"
  using assms unfolding simp_implies_def by (blast intro: fincomp_cong')

text \<open>Usually, if this rule causes a failed congruence proof error,
  the reason is that the premise \<open>g \<in> B \<rightarrow> M\<close> cannot be shown.
  Adding @{thm [source] Pi_def} to the simpset is often useful.
  For this reason, @{thm [source] fincomp_cong}
  is not added to the simpset by default.
\<close>

lemma fincomp_0 [simp]:
  "f \<in> {0::nat} \<rightarrow> M \<Longrightarrow> fincomp f {..0} = f 0"
  by (simp add: Pi_def)

lemma fincomp_0': "f \<in> {..n} \<rightarrow> M \<Longrightarrow> (f 0) \<cdot> fincomp f {Suc 0..n} = fincomp f {..n}"
  by (metis Pi_split_insert_domain Suc_n_not_le_n atLeastAtMost_iff atLeastAtMost_insertL atMost_atLeast0 finite_atLeastAtMost fincomp_insert le0)

lemma fincomp_Suc [simp]:
  "f \<in> {..Suc n} \<rightarrow> M \<Longrightarrow> fincomp f {..Suc n} = (f (Suc n) \<cdot> fincomp f {..n})"
  by (simp add: Pi_def atMost_Suc)

lemma fincomp_Suc2:
  "f \<in> {..Suc n} \<rightarrow> M \<Longrightarrow> fincomp f {..Suc n} = (fincomp (%i. f (Suc i)) {..n} \<cdot> f 0)"
proof (induct n)
  case 0 thus ?case by (simp add: Pi_def)
next
  case Suc thus ?case
    by (simp add: associative Pi_def)
qed

lemma fincomp_Suc3:
  assumes "f \<in> {..n :: nat} \<rightarrow> M"
  shows "fincomp f {.. n} = (f n) \<cdot> fincomp f {..< n}"
proof (cases "n = 0")
  case True thus ?thesis
    using assms atMost_Suc by simp
next
  case False
  then obtain k where "n = Suc k"
    using not0_implies_Suc by blast
  thus ?thesis
    using fincomp_Suc[of f k] assms atMost_Suc lessThan_Suc_atMost by simp
qed

lemma fincomp_reindex: \<^marker>\<open>contributor \<open>Jeremy Avigad\<close>\<close>
  "f \<in> (h ` A) \<rightarrow> M \<Longrightarrow>
        inj_on h A \<Longrightarrow> fincomp f (h ` A) = fincomp (\<lambda>x. f (h x)) A"
proof (induct A rule: infinite_finite_induct)
  case (infinite A)
  hence "\<not> finite (h ` A)"
    using finite_imageD by blast
  with \<open>\<not> finite A\<close> show ?case by simp
qed (auto simp add: Pi_def)

lemma fincomp_const: \<^marker>\<open>contributor \<open>Jeremy Avigad\<close>\<close>
  assumes a [simp]: "a \<in> M"
  shows "fincomp (\<lambda>x. a) A = rec_nat \<one> (\<lambda>u. (\<cdot>) a) (card A)"
  by (induct A rule: infinite_finite_induct) auto

lemma fincomp_singleton: \<^marker>\<open>contributor \<open>Jesus Aransay\<close>\<close>
  assumes i_in_A: "i \<in> A" and fin_A: "finite A" and f_Pi: "f \<in> A \<rightarrow> M"
  shows "fincomp (\<lambda>j. if i = j then f j else \<one>) A = f i"
  using i_in_A fincomp_insert [of "A - {i}" i "(\<lambda>j. if i = j then f j else \<one>)"]
    fin_A f_Pi fincomp_unit [of "A - {i}"]
    fincomp_cong [of "A - {i}" "A - {i}" "(\<lambda>j. if i = j then f j else \<one>)" "(\<lambda>i. \<one>)"]
  unfolding Pi_def simp_implies_def by (force simp add: insert_absorb)

lemma fincomp_singleton_swap:
  assumes i_in_A: "i \<in> A" and fin_A: "finite A" and f_Pi: "f \<in> A \<rightarrow> M"
  shows "fincomp (\<lambda>j. if j = i then f j else \<one>) A = f i"
  using fincomp_singleton [OF assms] by (simp add: eq_commute)

lemma fincomp_mono_neutral_cong_left:
  assumes "finite B"
    and "A \<subseteq> B"
    and 1: "\<And>i. i \<in> B - A \<Longrightarrow> h i = \<one>"
    and gh: "\<And>x. x \<in> A \<Longrightarrow> g x = h x"
    and h: "h \<in> B \<rightarrow> M"
  shows "fincomp g A = fincomp h B"
proof-
  have eq: "A \<union> (B - A) = B" using \<open>A \<subseteq> B\<close> by blast
  have d: "A \<inter> (B - A) = {}" using \<open>A \<subseteq> B\<close> by blast
  from \<open>finite B\<close> \<open>A \<subseteq> B\<close> have f: "finite A" "finite (B - A)"
    by (auto intro: finite_subset)
  have "h \<in> A \<rightarrow> M" "h \<in> B - A \<rightarrow> M"
    using assms by (auto simp: image_subset_iff_funcset)
  moreover have "fincomp g A = fincomp h A \<cdot> fincomp h (B - A)"
  proof -
    have "fincomp h (B - A) = \<one>"
      using "1" fincomp_unit_eqI by blast
    moreover have "fincomp g A = fincomp h A"
      using \<open>h \<in> A \<rightarrow> M\<close> fincomp_cong' gh by blast
    ultimately show ?thesis
      by (simp add: \<open>h \<in> A \<rightarrow> M\<close>)
  qed
  ultimately show ?thesis
    by (simp add: fincomp_Un_disjoint [OF f d, unfolded eq])
qed

lemma fincomp_mono_neutral_cong_right:
  assumes "finite B"
    and "A \<subseteq> B" "\<And>i. i \<in> B - A \<Longrightarrow> g i = \<one>" "\<And>x. x \<in> A \<Longrightarrow> g x = h x" "g \<in> B \<rightarrow> M"
  shows "fincomp g B = fincomp h A"
  using assms  by (auto intro!: fincomp_mono_neutral_cong_left [symmetric])

lemma fincomp_mono_neutral_cong:
  assumes [simp]: "finite B" "finite A"
    and *: "\<And>i. i \<in> B - A \<Longrightarrow> h i = \<one>" "\<And>i. i \<in> A - B \<Longrightarrow> g i = \<one>"
    and gh: "\<And>x. x \<in> A \<inter> B \<Longrightarrow> g x = h x"
    and g: "g \<in> A \<rightarrow> M"
    and h: "h \<in> B \<rightarrow> M"
  shows "fincomp g A = fincomp h B"
proof-
  have "fincomp g A = fincomp g (A \<inter> B)"
    by (rule fincomp_mono_neutral_cong_right) (use assms in auto)
  also have "\<dots> = fincomp h (A \<inter> B)"
    by (rule fincomp_cong) (use assms in auto)
  also have "\<dots> = fincomp h B"
    by (rule fincomp_mono_neutral_cong_left) (use assms in auto)
  finally show ?thesis .
qed

lemma fincomp_UN_disjoint:
  assumes
    "finite I" "\<And>i. i \<in> I \<Longrightarrow> finite (A i)" "pairwise (\<lambda>i j. disjnt (A i) (A j)) I"
    "\<And>i x. i \<in> I \<Longrightarrow> x \<in> A i \<Longrightarrow> g x \<in> M"
  shows "fincomp g (\<Union>(A ` I)) = fincomp (\<lambda>i. fincomp g (A i)) I"
  using assms
proof (induction set: finite)
  case empty
  then show ?case
    by force
next
  case (insert i I)
  then show ?case
    unfolding pairwise_def disjnt_def
    apply clarsimp
    apply (subst fincomp_Un_disjoint)
         apply (fastforce intro!: funcsetI fincomp_closed)+
    done
qed

lemma fincomp_Union_disjoint:
  "\<lbrakk>finite C; \<And>A. A \<in> C \<Longrightarrow> finite A \<and> (\<forall>x\<in>A. f x \<in> M); pairwise disjnt C\<rbrakk> \<Longrightarrow>
    fincomp f (\<Union>C) = fincomp (fincomp f) C"
  by (frule fincomp_UN_disjoint [of C id f]) auto

end

subsection \<open>Results for Abelian Groups\<close>

context abelian_group begin

lemma fincomp_inverse:
  "f \<in> A \<rightarrow> G \<Longrightarrow> fincomp (\<lambda>x. inverse (f x)) A = inverse (fincomp f A)"
proof (induct A rule: infinite_finite_induct)
  case empty show ?case by simp
next
  case (insert a A)
  then have "f a \<in> G" "f \<in> A \<rightarrow> G" "(\<lambda>x. inverse (f x)) \<in> A \<rightarrow> G"
    by blast+
  with insert show ?case
    by (simp add: commutative inverse_composition_commute)
qed simp

text \<open> Jeremy Avigad. This should be generalized to arbitrary groups, not just Abelian
   ones, using Lagrange's theorem.\<close>
lemma power_order_eq_one:
  assumes fin [simp]: "finite G"
    and a [simp]: "a \<in> G"
  shows "rec_nat \<one> (\<lambda>u. (\<cdot>) a) (card G) = \<one>"
proof -
  have rec_G: "rec_nat \<one> (\<lambda>u. (\<cdot>) a) (card G) \<in> G"
    by (metis Pi_I' a fincomp_closed fincomp_const)
  have "\<And>x. x \<in> G \<Longrightarrow> x \<in> (\<cdot>) a ` G"
    by (metis a composition_closed imageI invertible invertible_inverse_closed invertible_right_inverse2)
  with a have "(\<cdot>) a ` G = G" by blast
  then have "\<one> \<cdot> fincomp (\<lambda>x. x) G = fincomp (\<lambda>x. x) ((\<cdot>) a ` G)"
    by simp
  also have "\<dots> = fincomp (\<lambda>x. a \<cdot> x) G"
    using fincomp_reindex
    by (subst (2) fincomp_reindex [symmetric]) (auto simp: inj_on_def)
  also have "\<dots> = fincomp (\<lambda>x. a) G \<cdot> fincomp (\<lambda>x. x) G"
    by (simp add: fincomp_comp)
  also have "fincomp (\<lambda>x. a) G = rec_nat \<one> (\<lambda>u. (\<cdot>) a) (card G)"
    by (simp add: fincomp_const)
  finally show ?thesis
    by (metis commutative fincomp_closed funcset_id invertible invertible_left_cancel rec_G unit_closed)
qed

end

end


theory Chap3_3ex11
imports Main Chap3_1 Chap3_2
begin

type_synonym reg = nat
type_synonym reg_state = "nat \<Rightarrow> int"

datatype instr = LDI int reg | LD vname reg | ADD reg reg

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> reg_state \<Rightarrow> reg_state" where
"exec1 (LDI n r) _ rs = rs(r := n)"
| "exec1 (LD x r) s rs = rs(r := s x)"
| "exec1 (ADD r1 r2) _ rs = rs(r1 := rs r1 + rs r2)"

definition exec :: "instr list \<Rightarrow> state \<Rightarrow> reg_state \<Rightarrow> reg_state" where
"exec is s = fold (\<lambda>i. exec1 i s) is"

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
"comp (N n) r = [LDI n r]"
| "comp (V x) r = [LD x r]"
| "comp (Plus e1 e2) r = comp e1 r @ comp e2 (r + 1) @ [ADD r (r+1)]"

lemma comp_no_clobber:
"r' < r \<Longrightarrow> exec (comp a1 r) s rs r' = rs r'"
  apply (induction a1 r arbitrary: rs rule: comp.induct)
  unfolding exec_def by simp+

lemma "exec (comp a r) s rs r = aval a s"
  apply (induction a arbitrary: r rs)
  unfolding exec_def using comp_no_clobber exec_def
  by auto

end


theory tree_SwapAB
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil2

fun swap :: "int => int => int Tree => int Tree" where
"swap x y (Node p x2 q) =
   (if x2 = x then Node (swap x y p) y (swap x y q) else
      (if x2 = y then Node (swap x y p) x (swap x y q) else
         Node (swap x y p) x2 (swap x y q)))"
| "swap x y (Nil2) = Nil2"

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

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun flatten0 :: "'a Tree => 'a list" where
"flatten0 (Node p y q) =
   append (append (flatten0 p) (Cons2 y (Nil2))) (flatten0 q)"
| "flatten0 (Nil2) = Nil2"

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

(*hipster swap or2 elem append flatten0 and2 *)

theorem x0 :
  "!! (p :: int Tree) (a :: int) (b :: int) .
     (and2 (elem a (flatten0 p)) (elem b (flatten0 p))) ==>
       (and2
          (elem a (flatten0 (swap a b p))) (elem b (flatten0 (swap a b p))))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Dualities0
imports Main
begin

(*
lemma "(\<forall> w. (A \<^bold>\<rightarrow> \<C>[R](\<C>[R] A)) w) = (\<forall>a b c. R a b \<and> R b c \<longrightarrow> R a c)"
  oops
lemma "((\<forall> w. (A \<^bold>\<rightarrow> \<C>[R](\<C>[R] A) ) w) \<and> (\<forall> w. (A \<^bold>\<rightarrow> \<C>[R] A ) w)) = (\<forall>a b c. R a b \<and> R b c \<longrightarrow> R a c)"
*)

(* Relation type *)

type_synonym 'a \<rho> = \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close>

(* accessibility relation properties and correspondence formula *)

definition reflexive :: "'a \<rho> \<Rightarrow> bool" where
\<open>reflexive R \<equiv> \<forall>w. R w w\<close> (* \<box>p \<rightarrow> p *)
definition transitive :: "'a \<rho> \<Rightarrow> bool" where
\<open>transitive R \<equiv> \<forall>a b c. R a b \<and> R b c \<longrightarrow> R a c\<close> (* \<box>p \<rightarrow> \<box>\<box>p *)
definition symmetric :: "'a \<rho> \<Rightarrow> bool" where
\<open>symmetric R \<equiv> \<forall>u v. R u v \<longrightarrow> R v u\<close> (* p \<rightarrow> \<box>\<diamondsuit>p *)
definition serial :: "'a \<rho> \<Rightarrow> bool" where
\<open>serial R \<equiv> \<forall>u. \<exists>v. R u v\<close> (* \<box>p \<rightarrow> \<diamondsuit>p *)
definition euclidean :: "'a \<rho> \<Rightarrow> bool" where
\<open>euclidean R \<equiv> \<forall>r s t. R r s \<and> R r t \<longrightarrow> R s t\<close> (* \<diamondsuit>p \<rightarrow> \<box>\<diamondsuit>p *)

(* modal logic embedding *)

(*type for propositions as
(characteristic functions of) sets*)
type_synonym 'w \<sigma> = \<open>'w \<Rightarrow> bool\<close>

definition top::"'w \<sigma>"
("\<^bold>\<top>") where
"\<^bold>\<top> \<equiv> \<lambda> w. True"
definition neg::"'w \<sigma> \<Rightarrow> 'w \<sigma>"
("\<^bold>\<not>_"[52]53) where
"\<^bold>\<not> \<phi> \<equiv> \<lambda> w. \<not> (\<phi> w)"
definition conj::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"
(infixr"\<^bold>\<and>"51) where
"\<phi> \<^bold>\<and> \<psi> \<equiv> \<lambda>w. (\<phi> w) \<and> (\<psi> w)"
definition disj::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"
(infixr"\<^bold>\<or>"50)  where
"\<phi> \<^bold>\<or> \<psi> \<equiv> \<lambda> w. (\<phi> w) \<or> (\<psi> w)"
definition impl::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"
(infixr"\<^bold>\<rightarrow>"49)  where
"\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<lambda> w. (\<phi> w) \<longrightarrow> (\<psi> w)"
definition equ::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"
(infixr"\<^bold>\<leftrightarrow>"49)  where
"\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> \<lambda> w. (\<phi> w) \<longleftrightarrow> (\<psi> w)"
definition box::"'w \<rho> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"
("\<^bold>\<box>\<^sub>_ _") where
"\<^bold>\<box>\<^sub>R \<phi> \<equiv> \<lambda> w. \<forall> v. (R w v) \<longrightarrow> (\<phi> v)"
definition dia::"'w \<rho> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"
("\<^bold>\<diamondsuit>\<^sub>_ _") where
"\<^bold>\<diamondsuit>\<^sub>R \<phi> \<equiv> \<lambda> w. \<exists> q. (R w q) \<and> (\<phi> q)"

end


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


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


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


theory MDP_Aux
  imports "Markov_Models.Markov_Decision_Process"
begin

lemma sets_stream_space_cylinder:
  "sets (stream_space M) = sigma_sets (streams (space M)) (scylinder (space M) ` lists (sets M))"
proof (rule antisym)
  have closed[simp]: "scylinder (space M) ` lists (sets M) \<subseteq> Pow (streams (space M))"
    using scylinder_streams[of "space M" _] by auto
  have [simp]: "(\<lambda>s. s !! i) \<in> streams (space M) \<rightarrow> space M" for i
    by (auto simp: snth_in)

  interpret sigma_algebra "streams (space M)" "sigma_sets (streams (space M)) (scylinder (space M) ` lists (sets M))"
    by (intro sigma_algebra_sigma_sets) fact

  have *: "(\<lambda>s. s !! i) -` A \<inter> streams (space M) = scylinder (space M) (replicate i (space M) @ [A])"
    if "A \<in> sets M" for i A
  proof (induction i)
    case (Suc n) show ?case
      apply (intro set_eqI)
      subgoal for \<omega> by (cases \<omega>) (auto simp: streams_Stream Suc[symmetric])
      done
  qed (auto simp: streams_stl)

  have "sets (stream_space M) \<le> sets (sigma (streams (space M)) (scylinder (space M) ` lists (sets M)))"
    unfolding sets_stream_space_eq
    by (rule sets_Sup_in_sets)
       (auto simp: sets_vimage_algebra2 PiE_UNIV_domain space_PiM * intro!: sigma_sets.Basic imageI)
  also have "\<dots> = sigma_sets (streams (space M)) (scylinder (space M) ` lists (sets M))"
    by (rule sets_measure_of) fact
  finally show "sets (stream_space M) \<le> sigma_sets (streams (space M)) (scylinder (space M) ` lists (sets M))" .
next
  show "sigma_sets (streams (space M)) (scylinder (space M) ` lists (sets M)) \<subseteq> sets (stream_space M)"
    unfolding space_stream_space[symmetric]
    by (rule sets.sigma_sets_subset) (auto intro!: sets_scylinder)
qed

end


theory Exe2p2
  imports Main
begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc (add m n)"

lemma [simp]: "add b (Suc a) = Suc (add b a)"
  apply(induction b)
   apply(auto)
  done

lemma add_comm: "add a b = add b a"
  apply(induction a)
   apply(auto)
  done

end