theory conditions_negative
  imports conditions_positive
begin

(** We define and interrelate some useful axiomatic conditions on unary operations (operators)
having a 'w-parametric type @{type "'w \<sigma> \<Rightarrow> 'w \<sigma>"}.
Boolean algebras extended with such operators give us different sorts of topological Boolean algebras.*)

(**Anti-tonicity (ANTI).*)
definition ANTI::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ANTI")
  where "ANTI \<phi> \<equiv> \<forall>A B. A \<preceq> B \<longrightarrow> \<phi> B \<preceq> \<phi> A"

declare ANTI_def[cond]

(**ANTI is self-dual*)
lemma ANTI_dual: "ANTI \<phi> = ANTI \<phi>\<^sup>d" by (smt (verit) BA_cp ANTI_def dual_invol op_dual_def)
(**ANTI is the 'complement' of MONO*)
lemma ANTI_MONO: "MONO \<phi> = ANTI \<phi>\<^sup>c" by (metis ANTI_def BA_cp MONO_def svfun_compl_def)

(**anti-expansive/extensive (nEXPN) and its dual anti-contractive (nCNTR).*)
definition nEXPN::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nEXPN")
  where "nEXPN \<phi>  \<equiv> \<forall>A. \<phi> A \<preceq> \<^bold>\<midarrow>A"
definition nCNTR::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nCNTR")
  where "nCNTR \<phi> \<equiv> \<forall>A. \<^bold>\<midarrow>A \<preceq> \<phi> A"

declare nEXPN_def[cond] nCNTR_def[cond]

(**nEXPN and nCNTR are dual to each other *)
lemma nEXPN_nCNTR_dual1: "nEXPN \<phi> = nCNTR \<phi>\<^sup>d" unfolding cond by (metis BA_cp BA_dn op_dual_def setequ_ext)
lemma nEXPN_nCNTR_dual2: "nCNTR \<phi> = nEXPN \<phi>\<^sup>d" by (simp add: dual_invol nEXPN_nCNTR_dual1)

(**nEXPN and nCNTR are the 'complements' of EXPN and CNTR respectively*)
lemma nEXPN_CNTR_compl: "EXPN \<phi> = nEXPN \<phi>\<^sup>c" by (metis BA_cp EXPN_def nEXPN_def svfun_compl_def)
lemma nCNTR_EXPN_compl: "CNTR \<phi> = nCNTR \<phi>\<^sup>c" by (metis EXPN_CNTR_dual2 dual_compl_char1 dual_compl_char2 nEXPN_CNTR_compl nEXPN_nCNTR_dual2)

(**anti-Normality (nNORM) and its dual (nDNRM).*)
definition nNORM::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nNORM")
  where "nNORM \<phi>  \<equiv> (\<phi> \<^bold>\<bottom>) \<approx> \<^bold>\<top>"
definition nDNRM::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nDNRM")
  where "nDNRM \<phi> \<equiv> (\<phi> \<^bold>\<top>) \<approx> \<^bold>\<bottom>"

declare nNORM_def[cond] nDNRM_def[cond]

(**nNORM and nDNRM are dual to each other *)
lemma nNOR_dual1: "nNORM \<phi> = nDNRM \<phi>\<^sup>d" unfolding cond by (simp add: bottom_def compl_def op_dual_def setequ_def top_def)
lemma nNOR_dual2: "nDNRM \<phi> = nNORM \<phi>\<^sup>d" by (simp add: dual_invol nNOR_dual1)

(**nNORM and nDNRM are the 'complements' of NORM and DNRM respectively*)
lemma nNORM_NORM_compl: "NORM \<phi> = nNORM \<phi>\<^sup>c" by (simp add: NORM_def bottom_def compl_def nNORM_def setequ_def svfun_compl_def top_def)
lemma nDNRM_DNRM_compl: "DNRM \<phi> = nDNRM \<phi>\<^sup>c" by (simp add: DNRM_def bottom_def compl_def nDNRM_def setequ_def svfun_compl_def top_def)

(**nEXPN (nCNTR) entail nDNRM (nNORM).*)
lemma nEXPN_impl_nDNRM: "nEXPN \<phi> \<longrightarrow> nDNRM \<phi>" unfolding cond by (metis bottom_def compl_def setequ_def subset_def top_def)
lemma nCNTR_impl_nNORM: "nCNTR \<phi> \<longrightarrow> nNORM \<phi>" by (simp add: nEXPN_impl_nDNRM nEXPN_nCNTR_dual2 nNOR_dual1)

(**anti-Idempotence (nIDEM).*)
definition nIDEM::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nIDEM")
  where "nIDEM \<phi>  \<equiv> \<forall>A. \<phi>(\<^bold>\<midarrow>(\<phi> A)) \<approx> (\<phi> A)"
definition nIDEM_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nIDEM\<^sup>a")
  where "nIDEM_a \<phi> \<equiv> \<forall>A. (\<phi> A) \<preceq> \<phi>(\<^bold>\<midarrow>(\<phi> A))"
definition nIDEM_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nIDEM\<^sup>b")
  where "nIDEM_b \<phi> \<equiv> \<forall>A. \<phi>(\<^bold>\<midarrow>(\<phi> A)) \<preceq> (\<phi> A)"

declare nIDEM_def[cond] nIDEM_a_def[cond] nIDEM_b_def[cond]

(**nIDEM-a and nIDEM-b are dual to each other *)
lemma nIDEM_dual1: "nIDEM\<^sup>a \<phi> = nIDEM\<^sup>b \<phi>\<^sup>d" unfolding cond by (metis BA_cp BA_dn op_dual_def setequ_ext)
lemma nIDEM_dual2: "nIDEM\<^sup>b \<phi> = nIDEM\<^sup>a \<phi>\<^sup>d" by (simp add: dual_invol nIDEM_dual1)

lemma nIDEM_char: "nIDEM \<phi> = (nIDEM\<^sup>a \<phi> \<and> nIDEM\<^sup>b \<phi>)" unfolding cond setequ_char by blast
lemma nIDEM_dual: "nIDEM \<phi> = nIDEM \<phi>\<^sup>d" using nIDEM_char nIDEM_dual1 nIDEM_dual2 by blast

(**nIDEM(a/b) and IDEM(a/b) are the 'complements' each other*)
lemma nIDEM_a_compl: "IDEM\<^sup>a \<phi> = nIDEM\<^sup>a \<phi>\<^sup>c" by (metis (no_types, lifting) BA_cp IDEM_a_def nIDEM_a_def sfun_compl_invol svfun_compl_def)
lemma nIDEM_b_compl: "IDEM\<^sup>b \<phi> = nIDEM\<^sup>b \<phi>\<^sup>c" by (metis IDEM_dual2 dual_compl_char1 dual_compl_char2 nIDEM_a_compl nIDEM_dual2)
lemma nIDEM_compl: "nIDEM \<phi> = IDEM \<phi>\<^sup>c" by (simp add: IDEM_char nIDEM_a_compl nIDEM_b_compl nIDEM_char sfun_compl_invol)

(**nEXPN (nCNTR) entail nIDEM-a (nIDEM-b).*)
lemma nEXPN_impl_nIDEM_a: "nEXPN \<phi> \<longrightarrow> nIDEM\<^sup>b \<phi>" by (metis nEXPN_def nIDEM_b_def sfun_compl_invol svfun_compl_def)
lemma nCNTR_impl_nIDEM_b: "nCNTR \<phi> \<longrightarrow> nIDEM\<^sup>a \<phi>" by (simp add: nEXPN_impl_nIDEM_a nEXPN_nCNTR_dual2 nIDEM_dual1)

(**anti-distribution over joins or anti-additivity (nADDI) and its dual...*)
definition nADDI::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nADDI")
  where "nADDI \<phi>  \<equiv> \<forall>A B. \<phi>(A \<^bold>\<or> B) \<approx> (\<phi> A) \<^bold>\<and> (\<phi> B)"
definition nADDI_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nADDI\<^sup>a")
  where "nADDI\<^sup>a \<phi> \<equiv> \<forall>A B. (\<phi> A) \<^bold>\<and> (\<phi> B) \<preceq> \<phi>(A \<^bold>\<or> B)"
definition nADDI_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nADDI\<^sup>b")
  where "nADDI\<^sup>b \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<or> B) \<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)"

(**... anti-distribution over meets or anti-multiplicativity (nMULT).*)
definition nMULT::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nMULT")
  where "nMULT \<phi>  \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<approx> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition nMULT_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nMULT\<^sup>a")
  where "nMULT\<^sup>a \<phi> \<equiv> \<forall>A B. (\<phi> A) \<^bold>\<or> (\<phi> B) \<preceq> \<phi>(A \<^bold>\<and> B)"
definition nMULT_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nMULT\<^sup>b")
  where "nMULT\<^sup>b \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<preceq> (\<phi> A) \<^bold>\<or> (\<phi> B)"

declare nADDI_def[cond] nADDI_a_def[cond] nADDI_b_def[cond]
        nMULT_def[cond] nMULT_a_def[cond] nMULT_b_def[cond]

lemma nADDI_char: "nADDI \<phi> = (nADDI\<^sup>a \<phi> \<and> nADDI\<^sup>b \<phi>)" unfolding cond using setequ_char by blast
lemma nMULT_char: "nMULT \<phi> = (nMULT\<^sup>a \<phi> \<and> nMULT\<^sup>b \<phi>)" unfolding cond using setequ_char by blast

(**ANTI, nMULT-a and nADDI-b are equivalent.*)
lemma ANTI_nMULTa: "nMULT\<^sup>a \<phi> = ANTI \<phi>" unfolding cond by (smt (z3) L10 L7 join_def meet_def setequ_ext subset_def)
lemma ANTI_nADDIb: "nADDI\<^sup>b \<phi> = ANTI \<phi>" unfolding cond by (smt (verit) BA_cp BA_deMorgan1 L10 L3 L5 L8 L9 setequ_char setequ_ext)

(**Below we prove several duality relationships between nADDI(a/b) and nMULT(a/b).*)

(**Duality between nMULT-a and nADDI-b (an easy corollary from the self-duality of ANTI).*)
lemma nMULTa_nADDIb_dual1: "nMULT\<^sup>a \<phi> = nADDI\<^sup>b \<phi>\<^sup>d" using ANTI_nADDIb ANTI_nMULTa ANTI_dual by blast
lemma nMULTa_nADDIb_dual2: "nADDI\<^sup>b \<phi> = nMULT\<^sup>a \<phi>\<^sup>d" by (simp add: dual_invol nMULTa_nADDIb_dual1)
(**Duality between nADDI-a and nMULT-b.*)
lemma nADDIa_nMULTb_dual1: "nADDI\<^sup>a \<phi> = nMULT\<^sup>b \<phi>\<^sup>d" unfolding cond by (metis (no_types, lifting) BA_cp BA_deMorgan1 BA_dn op_dual_def setequ_ext)
lemma nADDIa_nMULTb_dual2: "nMULT\<^sup>b \<phi> = nADDI\<^sup>a \<phi>\<^sup>d" by (simp add: dual_invol nADDIa_nMULTb_dual1)
(**Duality between ADDI and MULT.*)
lemma nADDI_nMULT_dual1: "nADDI \<phi> = nMULT \<phi>\<^sup>d" using nADDI_char nADDIa_nMULTb_dual1 nMULT_char nMULTa_nADDIb_dual2 by blast
lemma nADDI_nMULT_dual2: "nMULT \<phi> = nADDI \<phi>\<^sup>d" by (simp add: dual_invol nADDI_nMULT_dual1)

(**nADDI and nMULT are the 'complements' of ADDI and MULT respectively*)
lemma nADDIa_compl: "ADDI\<^sup>a \<phi> = nADDI\<^sup>a \<phi>\<^sup>c" by (metis ADDI_a_def BA_cp BA_deMorgan1 nADDI_a_def setequ_ext svfun_compl_def)
lemma nADDIb_compl: "ADDI\<^sup>b \<phi> = nADDI\<^sup>b \<phi>\<^sup>c" by (simp add: ANTI_nADDIb ANTI_MONO MONO_ADDIb sfun_compl_invol)
lemma nADDI_compl: "ADDI \<phi> = nADDI \<phi>\<^sup>c" by (simp add: ADDI_char nADDI_char nADDIa_compl nADDIb_compl)
lemma nMULTa_compl: "MULT\<^sup>a \<phi> = nMULT\<^sup>a \<phi>\<^sup>c" by (simp add: ANTI_MONO ANTI_nMULTa MONO_MULTa sfun_compl_invol)
lemma nMULTb_compl: "MULT\<^sup>b \<phi> = nMULT\<^sup>b \<phi>\<^sup>c" by (metis BA_cp BA_deMorgan2 MULT_b_def nMULT_b_def setequ_ext svfun_compl_def)
lemma nMULT_compl: "MULT \<phi> = nMULT \<phi>\<^sup>c" by (simp add: MULT_char nMULT_char nMULTa_compl nMULTb_compl)

(**We verify properties regarding closure over meets/joins for fixed-points.*)

(**nMULT for an operator implies join-closedness of the set of fixed-points of its dual-complement*)
lemma nMULT_joinclosed: "nMULT \<phi> \<Longrightarrow> join_closed (fp (\<phi>\<^sup>-))" by (smt (verit, del_insts) ADDI_MULT_dual2 ADDI_joinclosed BA_deMorgan1 MULT_def dual_compl_char2 nMULT_def setequ_ext svfun_compl_def)
lemma "join_closed (fp (\<phi>\<^sup>-)) \<Longrightarrow> nMULT \<phi>" nitpick oops (*countermodel found: needs further assumptions*)
lemma joinclosed_nMULT: "ANTI \<phi> \<Longrightarrow> nCNTR \<phi> \<Longrightarrow> nIDEM\<^sup>b \<phi> \<Longrightarrow> join_closed (fp (\<phi>\<^sup>-)) \<Longrightarrow> nMULT \<phi>" by (metis ANTI_MONO ANTI_dual IDEM_char IDEM_dual dual_compl_char1 dual_compl_char2 joinclosed_ADDI nADDI_compl nADDI_nMULT_dual2 nCNTR_impl_nIDEM_b nEXPN_CNTR_compl nEXPN_nCNTR_dual2 nIDEM_char nIDEM_compl sfun_compl_invol)

(**nADDI for an operator implies meet-closedness of the set of fixed-points of its dual-complement*)
lemma nADDI_meetclosed: "nADDI \<phi> \<Longrightarrow> meet_closed (fp (\<phi>\<^sup>-))" by (smt (verit, ccfv_threshold) ADDI_MULT_dual1 ADDI_def BA_deMorgan2 MULT_meetclosed dual_compl_char2 nADDI_def setequ_ext svfun_compl_def)
lemma "meet_closed (fp (\<phi>\<^sup>-)) \<Longrightarrow> nADDI \<phi>" nitpick oops (*countermodel found: needs further assumptions*)
lemma meetclosed_nADDI: "ANTI \<phi> \<Longrightarrow> nEXPN \<phi> \<Longrightarrow> nIDEM\<^sup>a \<phi> \<Longrightarrow> meet_closed (fp (\<phi>\<^sup>-)) \<Longrightarrow> nADDI \<phi>" by (metis ADDI_MULT_dual2 ADDI_joinclosed ANTI_MONO ANTI_dual dual_compl_char1 dual_compl_char2 joinclosed_nMULT meetclosed_MULT nADDI_nMULT_dual1 nCNTR_EXPN_compl nEXPN_nCNTR_dual1 nIDEM_b_compl nIDEM_dual1 sfun_compl_invol)

(**Assuming ANTI, we have that nEXPN (nCNTR) implies meet-closed (join-closed) for the set of fixed-points.*)
lemma nEXPN_meetclosed: "ANTI \<phi> \<Longrightarrow> nEXPN \<phi> \<Longrightarrow> meet_closed (fp \<phi>)" by (metis (full_types) L10 compl_def fixpoints_def meet_closed_def nEXPN_def setequ_ext subset_def)
lemma nCNTR_joinclosed: "ANTI \<phi> \<Longrightarrow> nCNTR \<phi> \<Longrightarrow> join_closed (fp \<phi>)" by (smt (verit, ccfv_threshold) BA_impl L9 fixpoints_def impl_char join_closed_def nCNTR_def setequ_char setequ_ext)

end


(* Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Ptolemy's Theorem\<close>

theory Ptolemys_Theorem
imports
  "HOL-Analysis.Multivariate_Analysis"
begin

subsection \<open>Preliminaries\<close>

subsubsection \<open>Additions to Rat theory\<close>

hide_const (open) normalize

subsubsection \<open>Additions to Transcendental theory\<close>

text \<open>
Lemmas about @{const arcsin} and @{const arccos} commonly involve to show that their argument is
in the domain of those partial functions, i.e., the argument @{term y} is between @{term "-1::real"}
and @{term "1::real"}.
As the argumentation for @{term "(-1::real) \<le> y"} and @{term "y \<le> (1::real)"} is often very similar,
we prefer to prove @{term "\<bar>y\<bar> \<le> (1::real)"} to the two goals above.

The lemma for rewriting the term @{term "cos (arccos y)"} is already provided in the Isabelle
distribution with name @{thm [source] cos_arccos_abs}. Here, we further provide the analogue on
@{term "arcsin"} for rewriting @{term "sin (arcsin y)"}.
\<close>

lemma sin_arcsin_abs: "\<bar>y\<bar> \<le> 1 \<Longrightarrow> sin (arcsin y) = y"
  by (simp add: abs_le_iff)

text \<open>
The further lemmas are the required variants from existing lemmas @{thm [source] arccos_lbound}
and @{thm [source] arccos_ubound}.
\<close>

lemma arccos_lbound_abs [simp]:
  "\<bar>y\<bar> \<le> 1 \<Longrightarrow> 0 \<le> arccos y"
by (simp add: arccos_lbound)

lemma arccos_ubound_abs [simp]:
  "\<bar>y\<bar> \<le> 1 \<Longrightarrow> arccos y \<le> pi"
by (simp add: arccos_ubound)

text \<open>
As we choose angles to be between @{term "0::real"} between @{term "2 * pi"},
we need some lemmas to reason about the sign of @{term "sin x"}
for angles @{term "x"}.
\<close>

lemma sin_ge_zero_iff:
  assumes "0 \<le> x" "x < 2 * pi"
  shows "0 \<le> sin x \<longleftrightarrow> x \<le> pi"
proof
  assume "0 \<le> sin x"
  show "x \<le> pi"
  proof (rule ccontr)
    assume "\<not> x \<le> pi"
    from this \<open>x < 2 * pi\<close> have "sin x < 0"
      using sin_lt_zero by auto
    from this \<open>0 \<le> sin x\<close> show False by auto
  qed
next
  assume "x \<le> pi"
  from this \<open>0 \<le> x\<close> show "0 \<le> sin x" by (simp add: sin_ge_zero)
qed

lemma sin_less_zero_iff:
  assumes "0 \<le> x" "x < 2 * pi"
  shows "sin x < 0 \<longleftrightarrow> pi < x"
using assms sin_ge_zero_iff by fastforce

subsubsection \<open>Addition to Finite-Cartesian-Product theory\<close>

text \<open>
Here follow generally useful additions and specialised equations
for two-dimensional real-valued vectors.
\<close>

lemma axis_nth_eq_0 [simp]:
  assumes "i \<noteq> j"
  shows "axis i x $ j = 0"
using assms unfolding axis_def by simp

lemma norm_axis:
  fixes x :: real
  shows "norm (axis i x) = abs x"
by (simp add: norm_eq_sqrt_inner inner_axis_axis)

lemma norm_eq_on_real_2_vec:
  fixes x :: "real ^ 2"
  shows "norm x = sqrt ((x $ 1) ^ 2 + (x $ 2) ^ 2)"
by (simp add: norm_eq_sqrt_inner inner_vec_def UNIV_2 power2_eq_square)

lemma dist_eq_on_real_2_vec:
  fixes a b :: "real ^ 2"
  shows "dist a b = sqrt ((a $ 1 - b $ 1) ^ 2 + (a $ 2 - b $ 2) ^ 2)"
unfolding dist_norm norm_eq_on_real_2_vec by simp

subsection \<open>Polar Form of Two-Dimensional Real-Valued Vectors\<close>

subsubsection \<open>Definitions to Transfer to Polar Form and Back\<close>

definition of_radiant :: "real \<Rightarrow> real ^ 2"
where
  "of_radiant \<omega> = axis 1 (cos \<omega>) + axis 2 (sin \<omega>)"

definition normalize :: "real ^ 2 \<Rightarrow> real ^ 2"
where
  "normalize p = (if p = 0 then axis 1 1 else (1 / norm p) *\<^sub>R p)"

definition radiant_of :: "real ^ 2 \<Rightarrow> real"
where
  "radiant_of p = (THE \<omega>. 0 \<le> \<omega> \<and> \<omega> < 2 * pi \<and> of_radiant \<omega> = normalize p)"

text \<open>
The vector @{term "of_radiant \<omega>"} is the vector with length @{term "1::real"} and angle @{term "\<omega>"}
to the first axis.
We normalize vectors to length @{term "1::real"} keeping their orientation with the normalize function.
Conversely, @{term "radiant_of p"} is the angle of vector @{term p} to the first axis, where we
choose @{term "radiant_of"} to return angles between @{term "0::real"} and @{term "2 * pi"},
following the usual high-school convention.
With these definitions, we can express the main result
@{term "norm p *\<^sub>R of_radiant (radiant_of p) = p"}.
Note that the main result holds for any definition of @{term "radiant_of 0"}.
So, we choose to define @{term "normalize 0"} and @{term "radiant_of 0"}, such that
@{term "radiant_of 0 = 0"}.
\<close>

subsubsection \<open>Lemmas on @{const of_radiant}\<close>

lemma nth_of_radiant_1 [simp]:
  "of_radiant \<omega> $ 1 = cos \<omega>"
unfolding of_radiant_def by simp

lemma nth_of_radiant_2 [simp]:
  "of_radiant \<omega> $ 2 = sin \<omega>"
unfolding of_radiant_def by simp

lemma norm_of_radiant:
  "norm (of_radiant \<omega>) = 1"
unfolding of_radiant_def norm_eq_on_real_2_vec by simp

lemma of_radiant_plus_2pi:
  "of_radiant (\<omega> + 2 * pi) = of_radiant \<omega>"
unfolding of_radiant_def by simp

lemma of_radiant_minus_2pi:
  "of_radiant (\<omega> - 2 * pi) = of_radiant \<omega>"
proof -
  have "of_radiant (\<omega> - 2 * pi) = of_radiant (\<omega> - 2 * pi + 2 * pi)"
    by (simp only: of_radiant_plus_2pi)
  also have "\<dots> = of_radiant \<omega>" by simp
  finally show ?thesis .
qed

subsubsection \<open>Lemmas on @{const normalize}\<close>

lemma normalize_eq:
  "norm p *\<^sub>R normalize p = p"
unfolding normalize_def by simp

lemma nth_normalize [simp]:
  "\<bar>normalize p $ i\<bar> \<le> 1"
using norm_normalize component_le_norm_cart by metis

lemma normalize_square:
  "(normalize p $ 1)\<^sup>2 + (normalize p $ 2)\<^sup>2 = 1"
using dot_square_norm[of "normalize p"]
by (simp add: inner_vec_def UNIV_2 power2_eq_square norm_normalize)

lemma nth_normalize_ge_zero_iff:
  "0 \<le> normalize p $ i \<longleftrightarrow> 0 \<le> p $ i"
proof
  assume "0 \<le> normalize p $ i"
  from this show "0 \<le> p $ i"
    unfolding normalize_def by (auto split: if_split_asm simp add: zero_le_divide_iff)
next
  assume "0 \<le> p $ i"
  have "0 \<le> axis 1 (1 :: real) $ i"
    using exhaust_2[of i] by auto
  from this \<open>0 \<le> p $ i\<close> show "0 \<le> normalize p $ i"
    unfolding normalize_def by auto
qed

lemma nth_normalize_less_zero_iff:
  "normalize p $ i < 0 \<longleftrightarrow> p $ i < 0"
using nth_normalize_ge_zero_iff leD leI by metis

lemma normalize_boundary_iff:
  "\<bar>normalize p $ 1\<bar> = 1 \<longleftrightarrow> p $ 2 = 0"
proof
  assume "\<bar>normalize p $ 1\<bar> = 1"
  from this have 1: "(p $ 1) ^ 2 = norm p ^ 2"
    unfolding normalize_def by (auto split: if_split_asm simp add: power2_eq_iff)
  moreover have "(p $ 1) ^ 2 + (p $ 2) ^ 2 = norm p ^ 2"
    using norm_eq_on_real_2_vec by auto
  ultimately show "p $ 2 = 0" by simp
next
  assume "p $ 2 = 0"
  from this have "\<bar>p $ 1\<bar> = norm p"
    by (auto simp add: norm_eq_on_real_2_vec)
  from this show "\<bar>normalize p $ 1\<bar> = 1"
    unfolding normalize_def by simp
qed

lemma between_normalize_if_distant_from_0:
  assumes "norm p \<ge> 1"
  shows "between (0, p) (normalize p)"
using assms by (auto simp add: between_mem_segment closed_segment_def normalize_def)

lemma between_normalize_if_near_0:
  assumes "norm p \<le> 1"
  shows "between (0, normalize p) p"
proof -
  have "0 \<le> norm p" by simp
  from assms have "p = (norm p / norm p) *\<^sub>R p \<and> 0 \<le> norm p \<and> norm p \<le> 1" by auto
  from this have "\<exists>u. p = (u / norm p) *\<^sub>R p \<and> 0 \<le> u \<and> u \<le> 1" by blast
  from this show ?thesis
    by (auto simp add: between_mem_segment closed_segment_def normalize_def)
qed

subsubsection \<open>Lemmas on @{const radiant_of}\<close>

lemma radiant_of:
  "0 \<le> radiant_of p \<and> radiant_of p < 2 * pi \<and> of_radiant (radiant_of p) = normalize p"
proof -
  let ?a = "if 0 \<le> p $ 2 then arccos (normalize p $ 1) else pi + arccos (- (normalize p $ 1))"
  have "0 \<le> ?a \<and> ?a < 2 * pi \<and> of_radiant ?a = normalize p"
  proof -
    have "0 \<le> ?a" by auto
    moreover have "?a < 2 * pi"
    proof cases
      assume "0 \<le> p $ 2"
      from this have "?a \<le> pi" by simp
      from this show ?thesis
        using pi_gt_zero by linarith
    next
      assume "\<not> 0 \<le> p $ 2"
      have "arccos (- normalize p $ 1) < pi"
      proof -
        have "\<bar>normalize p $ 1\<bar> \<noteq> 1"
          using \<open>\<not> 0 \<le> p $ 2\<close> by (simp only: normalize_boundary_iff)
        from this have "arccos (- normalize p $ 1) \<noteq> pi"
          unfolding arccos_minus_1[symmetric] by (subst arccos_eq_iff) auto
        moreover have "arccos (- normalize p $ 1) \<le> pi" by simp
        ultimately show "arccos (- normalize p $ 1) < pi" by linarith
      qed
      from this \<open>\<not> 0 \<le> p $ 2\<close> show ?thesis by simp
    qed
    moreover have "of_radiant ?a = normalize p"
    proof -
      have "of_radiant ?a $ i = normalize p $ i" for i
      proof -
        have "of_radiant ?a $ 1 = normalize p $ 1"
          unfolding of_radiant_def by (simp add: cos_arccos_abs)
        moreover have "of_radiant ?a $ 2 = normalize p $ 2"
        proof cases
          assume "0 \<le> p $ 2"
          have "sin (arccos (normalize p $ 1)) = sqrt (1 - (normalize p $ 1) ^ 2)"
            by (simp add: sin_arccos_abs)
          also have "\<dots> = normalize p $ 2"
          proof -
            have "1 - (normalize p $ 1)\<^sup>2 = (normalize p $ 2)\<^sup>2"
              using normalize_square[of p] by auto
            from this \<open>0 \<le> p $ 2\<close> show ?thesis by (simp add: nth_normalize_ge_zero_iff)
          qed
          finally show ?thesis
            using \<open>0 \<le> p $ 2\<close> unfolding of_radiant_def by auto
        next
          assume "\<not> 0 \<le> p $ 2"
          have "- sin (arccos (- normalize p $ 1)) = - sqrt (1 - (normalize p $ 1)\<^sup>2)"
            by (simp add: sin_arccos_abs)
          also have "\<dots> = normalize p $ 2"
          proof -
            have "1 - (normalize p $ 1)\<^sup>2 = (normalize p $ 2)\<^sup>2"
              using normalize_square[of p] by auto
            from this \<open>\<not> 0 \<le> p $ 2\<close> show ?thesis
              using nth_normalize_ge_zero_iff by fastforce
          qed
          finally show ?thesis
            using \<open>\<not> 0 \<le> p $ 2\<close> unfolding of_radiant_def by auto
        qed
        ultimately show ?thesis by (metis exhaust_2[of i])
      qed
      from this show ?thesis by (simp add: vec_eq_iff)
    qed
    ultimately show ?thesis by blast
  qed
  moreover {
    fix \<omega>
    assume "0 \<le> \<omega> \<and> \<omega> < 2 * pi \<and> of_radiant \<omega> = normalize p"
    from this have "0 \<le> \<omega>" "\<omega> < 2 * pi" "normalize p = of_radiant \<omega>" by auto
    from this have "cos \<omega> = normalize p $ 1" "sin \<omega> = normalize p $ 2" by auto
    have "\<omega> = ?a"
    proof cases
      assume "0 \<le> p $ 2"
      from this have "\<omega> \<le> pi"
        using \<open>0 \<le> \<omega>\<close> \<open>\<omega> < 2 * pi\<close> \<open>sin \<omega> = normalize p $ 2\<close>
        by (simp add: sin_ge_zero_iff[symmetric] nth_normalize_ge_zero_iff)
      from \<open>0 \<le> \<omega>\<close> this have "\<omega> = arccos (cos \<omega>)" by (simp add: arccos_cos)
      from \<open>cos \<omega> = normalize p $ 1\<close> this have "\<omega> = arccos (normalize p $ 1)"
        by (simp add: arccos_eq_iff)
      from this show "\<omega> = ?a" using \<open>0 \<le> p $ 2\<close> by auto
    next
      assume "\<not> 0 \<le> p $ 2"
      from this have "\<omega> > pi"
        using \<open>0 \<le> \<omega>\<close> \<open>\<omega> < 2 * pi\<close> \<open>sin \<omega> = normalize p $ 2\<close>
        by (simp add: sin_less_zero_iff[symmetric] nth_normalize_less_zero_iff)
      from this \<open>\<omega> < 2 * pi\<close> have "\<omega> - pi = arccos (cos (\<omega> - pi))"
        by (auto simp only: arccos_cos)
      from this \<open>cos \<omega> = normalize p $ 1\<close> have "\<omega> - pi = arccos (- normalize p $ 1)" by simp
      from this have "\<omega> = pi + arccos (- normalize p $ 1)" by simp
      from this show "\<omega> = ?a" using \<open>\<not> 0 \<le> p $ 2\<close> by auto
    qed
  }
  ultimately show ?thesis
    unfolding radiant_of_def by (rule theI)
qed

lemma radiant_of_bounds [simp]:
  "0 \<le> radiant_of p" "radiant_of p < 2 * pi"
using radiant_of by auto

lemma radiant_of_weak_ubound [simp]:
  "radiant_of p \<le> 2 * pi"
using radiant_of_bounds(2)[of p] by linarith

subsubsection \<open>Main Equations for Transforming to Polar Form\<close>

lemma polar_form_eq:
  "norm p *\<^sub>R of_radiant (radiant_of p) = p"
using radiant_of normalize_eq by simp

lemma relative_polar_form_eq:
  "Q + dist P Q *\<^sub>R of_radiant (radiant_of (P - Q)) = P"
proof -
  have "norm (P - Q) *\<^sub>R of_radiant (radiant_of (P - Q)) = P - Q"
    unfolding polar_form_eq ..
  moreover have "dist P Q = norm (P - Q)" by (simp add: dist_norm)
  ultimately show ?thesis by (metis add.commute diff_add_cancel)
qed

subsection \<open>Ptolemy's Theorem\<close>

lemma dist_circle_segment:
  assumes "0 \<le> radius" "0 \<le> \<alpha>" "\<alpha> \<le> \<beta>" "\<beta> \<le> 2 * pi"
  shows "dist (center + radius *\<^sub>R of_radiant \<alpha>) (center + radius *\<^sub>R of_radiant \<beta>) = 2 * radius * sin ((\<beta> - \<alpha>) / 2)"
    (is "?lhs = ?rhs")
proof -
  have trigonometry: "(cos \<alpha> - cos \<beta>)\<^sup>2 + (sin \<alpha> - sin \<beta>)\<^sup>2 = (2 *  sin ((\<beta> - \<alpha>) / 2))\<^sup>2"
  proof -
    have sin_diff_minus: "sin ((\<alpha> - \<beta>) / 2) = - sin ((\<beta> - \<alpha>) / 2)"
      by (simp only: sin_minus[symmetric] minus_divide_left minus_diff_eq)
    have "(cos \<alpha> - cos \<beta>)\<^sup>2 + (sin \<alpha> - sin \<beta>)\<^sup>2 =
      (2 * sin ((\<alpha> + \<beta>) / 2) * sin ((\<beta> - \<alpha>) / 2))\<^sup>2 + (2 * sin ((\<alpha> - \<beta>) / 2) * cos ((\<alpha> + \<beta>) / 2))\<^sup>2"
      by (simp only: cos_diff_cos sin_diff_sin)
    also have "\<dots> = (2 * sin ((\<beta> - \<alpha>) / 2))\<^sup>2 * ((sin ((\<alpha> + \<beta>) / 2))\<^sup>2 + (cos ((\<alpha> + \<beta>) / 2))\<^sup>2)"
      unfolding sin_diff_minus by algebra
    also have "\<dots> = (2 *  sin ((\<beta> - \<alpha>) / 2))\<^sup>2" by simp
    finally show ?thesis .
  qed
  from assms have "0 \<le> sin ((\<beta> - \<alpha>) / 2)" by (simp add: sin_ge_zero)
  have "?lhs = sqrt (radius\<^sup>2 * ((cos \<alpha> - cos \<beta>)\<^sup>2 + (sin \<alpha> - sin \<beta>)\<^sup>2))"
    unfolding dist_eq_on_real_2_vec by simp algebra
  also have "\<dots> = sqrt (radius\<^sup>2 *  (2 * sin ((\<beta> - \<alpha>) / 2))\<^sup>2)" by (simp add: trigonometry)
  also have "\<dots> = ?rhs"
    using \<open>0 \<le> radius\<close> \<open>0 \<le> sin ((\<beta> - \<alpha>) / 2)\<close> by (simp add: real_sqrt_mult)
  finally show ?thesis .
qed

theorem ptolemy_trigonometric:
  fixes \<omega>\<^sub>1 \<omega>\<^sub>2 \<omega>\<^sub>3 :: real
  shows "sin (\<omega>\<^sub>1 + \<omega>\<^sub>2) * sin (\<omega>\<^sub>2 + \<omega>\<^sub>3) = sin \<omega>\<^sub>1 * sin \<omega>\<^sub>3 + sin \<omega>\<^sub>2 * sin (\<omega>\<^sub>1 + \<omega>\<^sub>2 + \<omega>\<^sub>3)"
proof -
  have "sin (\<omega>\<^sub>1 + \<omega>\<^sub>2) * sin (\<omega>\<^sub>2 + \<omega>\<^sub>3) = ((sin \<omega>\<^sub>2)\<^sup>2 + (cos \<omega>\<^sub>2)\<^sup>2) * sin \<omega>\<^sub>1 * sin \<omega>\<^sub>3 + sin \<omega>\<^sub>2 * sin (\<omega>\<^sub>1 + \<omega>\<^sub>2 + \<omega>\<^sub>3)"
    by (simp only: sin_add cos_add) algebra
  also have "\<dots> = sin \<omega>\<^sub>1 * sin \<omega>\<^sub>3 + sin \<omega>\<^sub>2 * sin (\<omega>\<^sub>1 + \<omega>\<^sub>2 + \<omega>\<^sub>3)" by simp
  finally show ?thesis .
qed

theorem ptolemy:
  fixes A B C D center :: "real ^ 2"
  assumes "dist center A = radius" and "dist center B = radius"
  assumes "dist center C = radius" and "dist center D = radius"
  assumes ordering_of_points:
    "radiant_of (A - center) \<le> radiant_of (B - center)"
    "radiant_of (B - center) \<le> radiant_of (C - center)"
    "radiant_of (C - center) \<le> radiant_of (D - center)"
  shows "dist A C * dist B D = dist A B * dist C D + dist A D * dist B C"
proof -
  from \<open>dist center A = radius\<close> have "0 \<le> radius" by auto
  define \<alpha> \<beta> \<gamma> \<delta>
    where "\<alpha> = radiant_of (A - center)" and "\<beta> = radiant_of (B - center)"
    and "\<gamma> = radiant_of (C - center)" and "\<delta> = radiant_of (D - center)"
  from ordering_of_points have angle_basics:
    "\<alpha> \<le> \<beta>" "\<beta> \<le> \<gamma>" "\<gamma> \<le> \<delta>"
    "0 \<le> \<alpha>" "\<alpha> \<le> 2 * pi" "0 \<le> \<beta>" "\<beta> \<le> 2 * pi"
    "0 \<le> \<gamma>" "\<gamma> \<le> 2 * pi" "0 \<le> \<delta>" "\<delta> \<le> 2 * pi"
    unfolding \<alpha>_def \<beta>_def \<gamma>_def \<delta>_def by auto
  from assms(1-4) have
    "A = center + radius *\<^sub>R of_radiant \<alpha>" "B = center + radius *\<^sub>R of_radiant \<beta>"
    "C = center + radius *\<^sub>R of_radiant \<gamma>" "D = center + radius *\<^sub>R of_radiant \<delta>"
    unfolding \<alpha>_def \<beta>_def \<gamma>_def \<delta>_def
    using relative_polar_form_eq dist_commute by metis+

  from this have dist_eqs:
    "dist A C = 2 * radius * sin ((\<gamma> - \<alpha>) / 2)"
    "dist B D = 2 * radius * sin ((\<delta> - \<beta>) / 2)"
    "dist A B = 2 * radius * sin ((\<beta> - \<alpha>) / 2)"
    "dist C D = 2 * radius * sin ((\<delta> - \<gamma>) / 2)"
    "dist A D = 2 * radius * sin ((\<delta> - \<alpha>) / 2)"
    "dist B C = 2 * radius * sin ((\<gamma> - \<beta>) / 2)"
    using angle_basics \<open>radius \<ge> 0\<close> dist_circle_segment by (auto)

  have "dist A C * dist B D = 4 * radius ^ 2 * sin ((\<gamma> - \<alpha>) / 2) * sin ((\<delta> - \<beta>) / 2)"
    unfolding dist_eqs by (simp add: power2_eq_square)
  also have "\<dots> = 4 * radius ^ 2 * (sin ((\<beta> - \<alpha>) / 2) * sin ((\<delta> - \<gamma>) / 2) + sin ((\<gamma> - \<beta>) / 2) * sin ((\<delta> - \<alpha>) / 2))"
  proof -
    define \<omega>\<^sub>1 \<omega>\<^sub>2 \<omega>\<^sub>3 where "\<omega>\<^sub>1 = (\<beta> - \<alpha>) / 2" and "\<omega>\<^sub>2 = (\<gamma> - \<beta>) / 2" and "\<omega>\<^sub>3 = (\<delta> - \<gamma>) / 2"
    have "(\<gamma> - \<alpha>) / 2 = \<omega>\<^sub>1 + \<omega>\<^sub>2" and "(\<delta> - \<beta>) / 2 = \<omega>\<^sub>2 + \<omega>\<^sub>3" and "(\<delta> - \<alpha>) / 2 = \<omega>\<^sub>1 + \<omega>\<^sub>2 + \<omega>\<^sub>3"
      unfolding \<omega>\<^sub>1_def \<omega>\<^sub>2_def \<omega>\<^sub>3_def by (auto simp add: field_simps)
    have "sin ((\<gamma> - \<alpha>) / 2) * sin ((\<delta> - \<beta>) / 2) = sin (\<omega>\<^sub>1 + \<omega>\<^sub>2) * sin (\<omega>\<^sub>2 + \<omega>\<^sub>3)"
      using \<open>(\<gamma> - \<alpha>) / 2 = \<omega>\<^sub>1 + \<omega>\<^sub>2\<close> \<open>(\<delta> - \<beta>) / 2 = \<omega>\<^sub>2 + \<omega>\<^sub>3\<close> by (simp only:)
    also have "\<dots> = sin \<omega>\<^sub>1 * sin \<omega>\<^sub>3 + sin \<omega>\<^sub>2 * sin (\<omega>\<^sub>1 + \<omega>\<^sub>2 + \<omega>\<^sub>3)"
      by (rule ptolemy_trigonometric)
    also have "\<dots> = (sin ((\<beta> - \<alpha>) / 2) * sin ((\<delta> - \<gamma>) / 2) + sin ((\<gamma> - \<beta>) / 2) * sin ((\<delta> - \<alpha>) / 2))"
      using \<omega>\<^sub>1_def \<omega>\<^sub>2_def \<omega>\<^sub>3_def \<open>(\<delta> - \<alpha>) / 2 = \<omega>\<^sub>1 + \<omega>\<^sub>2 + \<omega>\<^sub>3\<close> by (simp only:)
    finally show ?thesis by simp
  qed
  also have "\<dots> = dist A B * dist C D + dist A D * dist B C"
    unfolding dist_eqs by (simp add: distrib_left power2_eq_square)
  finally show ?thesis .
qed

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL

Define natural transformation, prove that the identity arrow function is one.
*)

section \<open>Natural Transformations\<close>

theory NatTrans
imports Functors
begin

(* guess the third axiom is implied by the fifth *)
locale natural_transformation = two_cats +
  fixes F and G and u
  assumes "Functor F : AA \<longrightarrow> BB"
  and "Functor G : AA \<longrightarrow> BB"
  and "u : ob AA \<rightarrow> ar BB"
  and "u \<in> extensional (ob AA)"
  and "\<forall>A\<in>Ob. u A \<in> Hom\<^bsub>BB\<^esub> (F\<^bsub>\<o>\<^esub> A) (G\<^bsub>\<o>\<^esub> A)"
  and "\<forall>A\<in>Ob. \<forall>B\<in>Ob. \<forall>f\<in>Hom A B. (G\<^bsub>\<a>\<^esub> f) \<bullet>\<^bsub>BB\<^esub> (u A) = (u B) \<bullet>\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f)"

abbreviation
  nt_syn  ("_ : _ \<Rightarrow> _ in Func '(_ , _ ')" [81]) where
  "u : F \<Rightarrow> G in Func(AA, BB) \<equiv> natural_transformation AA BB F G u"

(* is this doing what I think its doing? *)
locale endoNT = natural_transformation + one_cat

theorem (in endoNT) id_restrict_natural:
  "(\<lambda>A\<in>Ob. Id A) : (id_func AA) \<Rightarrow> (id_func AA) in Func(AA,AA)"
proof (intro natural_transformation.intro natural_transformation_axioms.intro
    two_cats.intro ballI)
  show "(\<lambda>A\<in>Ob. Id A) : Ob \<rightarrow> Ar"
    by (rule funcsetI) auto
  show "(\<lambda>A\<in>Ob. Id A) \<in> extensional (Ob)"
    by (rule restrict_extensional)
  fix A
  assume A: "A \<in> Ob"
  hence "Id A \<in> Hom A A" ..
  thus "(\<lambda>X\<in>Ob. Id X) A \<in> Hom ((id_func AA)\<^bsub>\<o>\<^esub> A)  ((id_func AA)\<^bsub>\<o>\<^esub> A)"
    using A by (simp add: id_func_def)
  fix B and f
  assume B: "B \<in> Ob"
    and "f \<in> Hom A B"
  hence "f \<in> Ar" and "A = Dom f" and "B = Cod f" and "Dom f \<in> Ob" and "Cod f \<in> Ob"
    using A by (simp_all add: hom_def)
  thus "(id_func AA)\<^bsub>\<a>\<^esub> f \<bullet> (\<lambda>A\<in>Ob. Id A) A
      = (\<lambda>A\<in>Ob. Id A) B \<bullet> (id_func AA)\<^bsub>\<a>\<^esub> f"
    by (simp add:  id_func_def)
qed (auto intro: id_func_functor, unfold_locales, unfold_locales)

end


theory Pls_ac_enat
  imports Main  "~~/src/HOL/Library/BNF_Corec" "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

primcorec pls :: "ENat Stream \<Rightarrow> ENat Stream \<Rightarrow> ENat Stream" where
  "pls s t = SCons (eplus (shd s) (shd t)) (pls (stl s) (stl t))"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(*hipster_obs Stream Lst obsStream pls*)
lemma lemma_a [thy_expl]: "eplus x EZ = x"
  apply (coinduction  arbitrary: x rule: Pls_ac_enat.ENat.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "eplus EZ x = x"
  apply (coinduction  arbitrary: x rule: Pls_ac_enat.ENat.coinduct_strong)
  by simp

lemma lemma_ab [thy_expl]: "eplus (ESuc x) y = eplus x (ESuc y)"
  apply (coinduction  arbitrary: x y rule: Pls_ac_enat.ENat.coinduct_strong)
  apply simp
  by (metis ENat.collapse(2) eplus.code)

lemma lemma_ac [thy_expl]: "ESuc (eplus x y) = eplus x (ESuc y)"
  apply (coinduction  arbitrary: x y rule: Pls_ac_enat.ENat.coinduct_strong)
  apply simp
  by (metis eplus.code)

lemma lemma_ad [thy_expl]: "eplus (eplus x y) z = eplus x (eplus y z)"
  apply (coinduction  arbitrary: x y z rule: Pls_ac_enat.ENat.coinduct_strong)
  apply simp
  by blast

lemma lemma_ae [thy_expl]: "eplus y x = eplus x y"
  apply (coinduction  arbitrary: x y rule: Pls_ac_enat.ENat.coinduct_strong)
  apply simp
  by (metis ENat.collapse(1) ENat.collapse(2) lemma_a lemma_ab)

lemma pls_ac: "pls s (pls t u) = pls t (pls s u)"
  by hipster_coinduct_sledgehammer
  (*by hipster_coinduct_sledgehammer
Failed to apply initial proof method\<here>:*)
end


theory Free_Idempotent_Monoid imports
  Main
begin

text \<open>The free idempotent monoid does not have unique normal forms if we just use the cancellation law\<close>

inductive cancel1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where cancel1: "xs \<noteq> [] \<Longrightarrow> cancel1 (gs @ xs @ xs @ gs') (gs @ xs @ gs')"

lemma cancel1_append_same1:
  assumes "cancel1 xs ys"
  shows "cancel1 (zs @ xs) (zs @ ys)"
using assms
proof cases
  case (cancel1 ys gs gs')
  from \<open>ys \<noteq> []\<close> have "cancel1 ((zs @ gs) @ ys @ ys @ gs') ((zs @ gs) @ ys @ gs')" ..
  with cancel1 show ?thesis by simp
qed

lemma cancel1_append_same2: "cancel1 xs ys \<Longrightarrow> cancel1 (xs @ zs) (ys @ zs)"
by(cases rule: cancel1.cases)(auto intro: cancel1.intros)

lemma cancel1_same:
  assumes "xs \<noteq> []"
  shows "cancel1 (xs @ xs) xs"
proof -
  have "cancel1 ([] @ xs @ xs @ []) ([] @ xs @ [])" using assms ..
  thus ?thesis by simp
qed

definition sclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where "sclp r x y \<longleftrightarrow> r x y \<or> r y x"

lemma sclpI [simp, intro?]:
  shows sclpI1: "r x y \<Longrightarrow> sclp r x y"
  and sclpI2: "r y x \<Longrightarrow> sclp r x y"
by(simp_all add: sclp_def)

lemma sclpE:
  assumes "sclp r x y"
  obtains (base) "r x y" | (sym) "r y x"
using assms by(auto simp add: sclp_def)

abbreviation eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where "eq \<equiv> (sclp cancel1)\<^sup>*\<^sup>*"

lemma eq_sym: "eq x y \<Longrightarrow> eq y x"
by(induction rule: rtranclp_induct)(auto intro: sclpI converse_rtranclp_into_rtranclp elim!: sclpE)

lemma equivp_eq: "equivp eq"
by(intro equivpI reflpI sympI transpI)(auto intro: eq_sym)

lemma eq_append_same1: "eq xs' ys' \<Longrightarrow> eq (xs @ xs') (xs @ ys')"
by(induction rule: rtranclp_induct)(auto intro: cancel1_append_same1 rtranclp.rtrancl_into_rtrancl sclpI elim!: sclpE)

lemma append_eq_cong: "\<lbrakk>eq xs ys; eq xs' ys'\<rbrakk> \<Longrightarrow> eq (xs @ xs') (ys @ ys')"
by(induction rule: rtranclp_induct)(auto intro: eq_append_same1 rtranclp.rtrancl_into_rtrancl cancel1_append_same2 elim!: sclpE intro: sclpI)

quotient_type 'a fim = "'a list" / eq
by(rule equivp_eq)

instantiation fim :: (type) monoid_add begin
lift_definition zero_fim :: "'a fim" is "[]" .
lift_definition plus_fim :: "'a fim \<Rightarrow> 'a fim \<Rightarrow> 'a fim" is "op @" by(rule append_eq_cong)
instance by(intro_classes; transfer; simp)
end

lemma plus_idem_fim [simp]: fixes x :: "'a fim" shows "x + x = x"
proof transfer
  fix xs :: "'a list"
  show "eq (xs @ xs) xs"
  proof(cases "xs = []")
    case False thus ?thesis using cancel1_same[of xs] by(auto intro: sclpI1)
  qed simp
qed

type_synonym ('a, 'b) af = "'a fim \<times> 'b"

definition pure :: "'b \<Rightarrow> ('a, 'b) af"
where "pure x = (0, x)"

fun ap :: "('a, 'b \<Rightarrow> 'c) af \<Rightarrow> ('a, 'b) af \<Rightarrow> ('a, 'c) af" (infixl "\<diamond>" 60)
where "ap (u, f) (v, x) = (u + v, f x)"

lemma af_identity: "pure id \<diamond> x = x"
unfolding pure_def by(cases x) simp

lemma af_homomorphism: "pure f \<diamond> pure x = pure (f x)"
unfolding pure_def by simp

lemma af_composition: "\<And>g f x. pure comp \<diamond> g \<diamond> f \<diamond> x = g \<diamond> (f \<diamond> x)"
unfolding pure_def by(clarsimp simp add: add_ac)

lemma af_interchange: "f \<diamond> pure x = pure (\<lambda>g. g x) \<diamond> f"
unfolding pure_def by(cases f) simp

definition W :: "('x, ('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) af"
where "W = pure (\<lambda>f x. f x x)"

lemma ap_W: "W \<diamond> f \<diamond> x = f \<diamond> x \<diamond> x"
unfolding W_def pure_def
apply(cases f)
apply(cases x)
apply(rename_tac u f' v g')
apply(simp add: add_ac)
done

text \<open> There is no combinator H because fim is the free idempotent monoid\<close>

end


theory "Denotational_Semantics"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Lib"
  "Ids"
  "Syntax"
begin
subsection \<open>Denotational Semantics\<close>
text \<open>
  The canonical dynamic semantics of dL are given as a denotational semantics.
  The important definitions for the denotational semantics are states $\nu$,
  interpretations I and the semantic functions $[[\psi]]I$, $[[\theta]]I\nu$,
  $[[\alpha]]I$, which are represented by the Isabelle functions \verb|fml_sem|,
  \verb|dterm_sem| and \verb|prog_sem|, respectively.
  \<close>
subsection \<open>States\<close>
text \<open>We formalize a state S as a pair $(S_V, S_V') : R^n \times R^n $, where $S_V$ assigns
  values to the program variables and $S_V$' assigns values to their
  differentials. Function constants are also formalized as having a fixed arity
  m \verb|(Rvec_dim)| which may differ from n. If a function does not need to
  have m arguments, any remaining arguments can be uniformly set to 0,
  which simulates the affect of having functions of less arguments.

  Most semantic proofs need to reason about states agreeing on variables.
  We say Vagree A B V if states A and B have the same values on all variables in V,
  similarly with VSagree A B V for simple states A and B and Iagree I J V for interpretations
  I and J.
  \<close>

\<comment> \<open>Vector of reals of length \<open>'a\<close>\<close>
type_synonym 'a Rvec = "real^('a::finite)"
\<comment> \<open>A state specifies one vector of values for unprimed variables \<open>x\<close> and a second vector for \<open>x'\<close>\<close>
type_synonym 'a state = "'a Rvec \<times> 'a Rvec"
\<comment> \<open>\<open>'a simple_state\<close> is half a state - either the \<open>x\<close>s or the \<open>x'\<close>s\<close>
type_synonym 'a simple_state = "'a Rvec"

definition Vagree :: "'c::finite state \<Rightarrow> 'c state \<Rightarrow> ('c + 'c) set \<Rightarrow> bool"
where "Vagree \<nu> \<nu>' V \<equiv>
   (\<forall>i. Inl i \<in> V \<longrightarrow> fst \<nu> $ i = fst \<nu>' $ i)
 \<and> (\<forall>i. Inr i \<in> V \<longrightarrow> snd \<nu> $ i = snd \<nu>' $ i)"

definition VSagree :: "'c::finite simple_state \<Rightarrow> 'c simple_state \<Rightarrow> 'c set \<Rightarrow> bool"
where "VSagree \<nu> \<nu>' V \<longleftrightarrow> (\<forall>i \<in> V. (\<nu> $ i) = (\<nu>' $ i))"

\<comment> \<open>Agreement lemmas\<close>
lemma agree_nil:"Vagree \<nu> \<omega> {}"
  by (auto simp add: Vagree_def)

lemma agree_supset:"A \<supseteq> B \<Longrightarrow> Vagree \<nu> \<nu>' A \<Longrightarrow> Vagree \<nu> \<nu>' B"
  by (auto simp add: Vagree_def)

lemma VSagree_nil:"VSagree \<nu> \<omega> {}"
  by (auto simp add: VSagree_def)

lemma VSagree_supset:"A \<supseteq> B \<Longrightarrow> VSagree \<nu> \<nu>' A \<Longrightarrow> VSagree \<nu> \<nu>' B"
  by (auto simp add: VSagree_def)

lemma VSagree_UNIV_eq:"VSagree A B UNIV \<Longrightarrow> A = B"
  unfolding VSagree_def by (auto simp add: vec_eq_iff)

lemma agree_comm:"\<And>A B V. Vagree A B V \<Longrightarrow> Vagree B A V" unfolding Vagree_def by auto

lemma agree_sub:"\<And>\<nu> \<omega> A B . A \<subseteq> B \<Longrightarrow> Vagree \<nu> \<omega> B \<Longrightarrow> Vagree \<nu> \<omega> A"
  unfolding Vagree_def by auto

lemma agree_UNIV_eq:"\<And>\<nu> \<omega>. Vagree \<nu> \<omega> UNIV \<Longrightarrow> \<nu> = \<omega>"
  unfolding Vagree_def by (auto simp add: vec_eq_iff)

lemma agree_UNIV_fst:"\<And>\<nu> \<omega>. Vagree \<nu> \<omega> (Inl ` UNIV) \<Longrightarrow> (fst \<nu>) = (fst \<omega>)"
  unfolding Vagree_def by (auto simp add: vec_eq_iff)

lemma Vagree_univ:"\<And>a b c d. Vagree (a,b) (c,d) UNIV \<Longrightarrow> a = c \<and> b = d"
  by (auto simp add: Vagree_def vec_eq_iff)

lemma agree_union:"\<And>\<nu> \<omega> A B. Vagree \<nu> \<omega> A \<Longrightarrow> Vagree \<nu> \<omega> B \<Longrightarrow> Vagree \<nu> \<omega> (A \<union> B)"
  unfolding Vagree_def by (auto simp add: vec_eq_iff)

lemma agree_refl:"Vagree \<nu> \<nu> A"
  by (auto simp add: Vagree_def)

lemma VSagree_sub:"\<And>\<nu> \<omega> A B . A \<subseteq> B \<Longrightarrow> VSagree \<nu> \<omega> B \<Longrightarrow> VSagree \<nu> \<omega> A"
  unfolding VSagree_def by auto

lemma VSagree_refl:"VSagree \<nu> \<nu> A"
  by (auto simp add: VSagree_def)

subsection Interpretations
text\<open>
    For convenience we pretend interpretations contain an extra field called
  FunctionFrechet specifying the Frechet derivative \verb|(FunctionFrechet f \<nu>)| : $R^m \rightarrow R$
  for every function in every state. The proposition \verb|(is_interp I)| says that such a
  derivative actually exists and is continuous (i.e. all functions are C1-continuous)
  without saying what the exact derivative is.

  The type parameters 'a, 'b, 'c are finite types whose cardinalities indicate the maximum number
  of functions, contexts, and <everything else defined by the interpretation>, respectively.
\<close>
record ('a, 'b, 'c) interp =
  Functions       :: "'a \<Rightarrow> 'c Rvec \<Rightarrow> real"
  Predicates      :: "'c \<Rightarrow> 'c Rvec \<Rightarrow> bool"
  Contexts        :: "'b \<Rightarrow> 'c state set \<Rightarrow> 'c state set"
  Programs        :: "'c \<Rightarrow> ('c state * 'c state) set"
  ODEs            :: "'c \<Rightarrow> 'c simple_state \<Rightarrow> 'c simple_state"
  ODEBV           :: "'c \<Rightarrow> 'c set"

fun FunctionFrechet :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> 'a \<Rightarrow> 'c Rvec \<Rightarrow> 'c Rvec \<Rightarrow> real"
  where "FunctionFrechet I i = (THE f'. \<forall> x. (Functions I i has_derivative f' x) (at x))"

\<comment> \<open>For an interpretation to be valid, all functions must be differentiable everywhere.\<close>
definition is_interp :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> bool"
  where "is_interp I \<equiv>
   \<forall>x. \<forall>i. ((FDERIV (Functions I i) x :> (FunctionFrechet I i x)) \<and> continuous_on UNIV (\<lambda>x. Blinfun (FunctionFrechet I i x)))"

lemma is_interpD:"is_interp I \<Longrightarrow> \<forall>x. \<forall>i. (FDERIV (Functions I i) x :> (FunctionFrechet I i x))"
  unfolding is_interp_def by auto

\<comment> \<open>Agreement between interpretations.\<close>
definition Iagree :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a + 'b + 'c) set \<Rightarrow> bool"
where "Iagree I J V \<equiv>
  (\<forall>i\<in>V.
    (\<forall>x. i = Inl x \<longrightarrow> Functions I x = Functions J x) \<and>
    (\<forall>x. i = Inr (Inl x) \<longrightarrow> Contexts I x = Contexts J x) \<and>
    (\<forall>x. i = Inr (Inr x) \<longrightarrow> Predicates I x = Predicates J x) \<and>
    (\<forall>x. i = Inr (Inr x) \<longrightarrow> Programs I x = Programs J x) \<and>
    (\<forall>x. i = Inr (Inr x) \<longrightarrow> ODEs I x = ODEs J x) \<and>
    (\<forall>x. i = Inr (Inr x) \<longrightarrow> ODEBV I x = ODEBV J x))"

lemma Iagree_Func:"Iagree I J V \<Longrightarrow> Inl f \<in> V \<Longrightarrow> Functions I f = Functions J f"
  unfolding Iagree_def by auto

lemma Iagree_Contexts:"Iagree I J V \<Longrightarrow> Inr (Inl C) \<in> V \<Longrightarrow> Contexts I C = Contexts J C"
  unfolding Iagree_def by auto

lemma Iagree_Pred:"Iagree I J V \<Longrightarrow> Inr (Inr p) \<in> V \<Longrightarrow> Predicates I p = Predicates J p"
  unfolding Iagree_def by auto

lemma Iagree_Prog:"Iagree I J V \<Longrightarrow> Inr (Inr a) \<in> V \<Longrightarrow> Programs I a = Programs J a"
  unfolding Iagree_def by auto

lemma Iagree_ODE:"Iagree I J V \<Longrightarrow> Inr (Inr a) \<in> V \<Longrightarrow> ODEs I a = ODEs J a"
  unfolding Iagree_def by auto

lemma Iagree_comm:"\<And>A B V. Iagree A B V \<Longrightarrow> Iagree B A V"
  unfolding Iagree_def by auto

lemma Iagree_sub:"\<And>I J A B . A \<subseteq> B \<Longrightarrow> Iagree I J B \<Longrightarrow> Iagree I J A"
  unfolding Iagree_def by auto

lemma Iagree_refl:"Iagree I I A"
  by (auto simp add: Iagree_def)

\<comment> \<open>Semantics for differential-free terms. Because there are no differentials, depends only on the \<open>x\<close> variables\<close>
\<comment> \<open>and not the \<open>x'\<close> variables.\<close>
primrec sterm_sem :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a, 'c) trm \<Rightarrow> 'c simple_state \<Rightarrow> real"
where
  "sterm_sem I (Var x) v = v $ x"
| "sterm_sem I (Function f args) v = Functions I f (\<chi> i. sterm_sem I (args i) v)"
| "sterm_sem I (Plus t1 t2) v = sterm_sem I t1 v + sterm_sem I t2 v"
| "sterm_sem I (Times t1 t2) v = sterm_sem I t1 v * sterm_sem I t2 v"
| "sterm_sem I (Const r) v = r"
| "sterm_sem I ($' c) v = undefined"
| "sterm_sem I (Differential d) v = undefined"

\<comment> \<open>\<open>frechet I \<theta> \<nu>\<close> syntactically computes the frechet derivative of the term \<open>\<theta>\<close> in the interpretation\<close>
\<comment> \<open>\<open>I\<close> at state \<open>\<nu>\<close> (containing only the unprimed variables). The frechet derivative is a\<close>
\<comment> \<open>linear map from the differential state \<open>\<nu>\<close> to reals.\<close>
primrec frechet :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a, 'c) trm \<Rightarrow> 'c simple_state \<Rightarrow> 'c simple_state \<Rightarrow> real"
where
  "frechet I (Var x) v = (\<lambda>v'. v' \<bullet> axis x 1)"
| "frechet I (Function f args) v =
    (\<lambda>v'. FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v) (\<chi> i. frechet I (args i) v v'))"
| "frechet I (Plus t1 t2) v = (\<lambda>v'. frechet I t1 v v' + frechet I t2 v v')"
| "frechet I (Times t1 t2) v =
    (\<lambda>v'. sterm_sem I t1 v * frechet I t2 v v' + frechet I t1 v v' * sterm_sem I t2 v)"
| "frechet I (Const r) v = (\<lambda>v'. 0)"
| "frechet I ($' c) v = undefined"
| "frechet I (Differential d) v = undefined"

definition directional_derivative :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a, 'c) trm \<Rightarrow> 'c state \<Rightarrow> real"
where "directional_derivative I t = (\<lambda>v. frechet I t (fst v) (snd v))"

\<comment> \<open>Sem for terms that are allowed to contain differentials.\<close>
\<comment> \<open>Note there is some duplication with \<open>sterm_sem\<close>.\<close>
primrec dterm_sem :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a, 'c) trm \<Rightarrow> 'c state \<Rightarrow> real"
where
  "dterm_sem I (Var x) = (\<lambda>v. fst v $ x)"
| "dterm_sem I (DiffVar x) = (\<lambda>v. snd v $ x)"
| "dterm_sem I (Function f args) = (\<lambda>v. Functions I f (\<chi> i. dterm_sem I (args i) v))"
| "dterm_sem I (Plus t1 t2) = (\<lambda>v. (dterm_sem I t1 v) + (dterm_sem I t2 v))"
| "dterm_sem I (Times t1 t2) = (\<lambda>v. (dterm_sem I t1 v) * (dterm_sem I t2 v))"
| "dterm_sem I (Differential t) = (\<lambda>v. directional_derivative I t v)"
| "dterm_sem I (Const c) = (\<lambda>v. c)"

text\<open> The semantics of an ODE is the vector field at a given point. ODE's are all time-independent
  so no time variable is necessary. Terms on the RHS of an ODE must be differential-free, so
  depends only on the xs.

  The safety predicate \texttt{osafe} ensures the domains of ODE1 and ODE2 are disjoint, so vector addition
  is equivalent to saying "take things defined from ODE1 from ODE1, take things defined
  by ODE2 from ODE2"\<close>
fun ODE_sem:: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a, 'c) ODE \<Rightarrow> 'c Rvec \<Rightarrow> 'c Rvec"
  where
  ODE_sem_OVar:"ODE_sem I (OVar x) = ODEs I x"
| ODE_sem_OSing:"ODE_sem I (OSing x \<theta>) =  (\<lambda>\<nu>. (\<chi> i. if i = x then sterm_sem I \<theta> \<nu> else 0))"
\<comment> \<open>Note: Could define using \<open>SOME\<close> operator in a way that more closely matches above description,\<close>
\<comment> \<open>but that gets complicated in the \<open>OVar\<close> case because not all variables are bound by the \<open>OVar\<close>\<close>
| ODE_sem_OProd:"ODE_sem I (OProd ODE1 ODE2) = (\<lambda>\<nu>. ODE_sem I ODE1 \<nu> + ODE_sem I ODE2 \<nu>)"

\<comment> \<open>The bound variables of an ODE\<close>
fun ODE_vars :: "('a,'b,'c) interp \<Rightarrow> ('a, 'c) ODE \<Rightarrow> 'c set"
  where
  "ODE_vars I (OVar c) = ODEBV I c"
| "ODE_vars I (OSing x \<theta>) = {x}"
| "ODE_vars I (OProd ODE1 ODE2) = ODE_vars I ODE1 \<union> ODE_vars I ODE2"

fun semBV ::"('a, 'b,'c) interp \<Rightarrow> ('a, 'c) ODE \<Rightarrow> ('c + 'c) set"
  where "semBV I ODE = Inl ` (ODE_vars I ODE) \<union> Inr ` (ODE_vars I ODE)"

lemma ODE_vars_lr:
  fixes x::"'sz" and ODE::"('sf,'sz) ODE" and I::"('sf,'sc,'sz) interp"
  shows "Inl x \<in> semBV I ODE \<longleftrightarrow> Inr x \<in> semBV I ODE"
  by (induction "ODE", auto)

fun mk_xode::"('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a::finite, 'c::finite) ODE \<Rightarrow> 'c::finite simple_state \<Rightarrow> 'c::finite state"
where "mk_xode I ODE sol = (sol, ODE_sem I ODE sol)"

text\<open> Given an initial state $\nu$ and solution to an ODE at some point, construct the resulting state $\omega$.
  This is defined using the SOME operator because the concrete definition is unwieldy. \<close>
definition mk_v::"('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a::finite, 'c::finite) ODE \<Rightarrow> 'c::finite state \<Rightarrow> 'c::finite simple_state \<Rightarrow> 'c::finite state"
where "mk_v I ODE \<nu> sol = (THE \<omega>.
  Vagree \<omega> \<nu> (- semBV I ODE)
\<and> Vagree \<omega> (mk_xode I ODE sol) (semBV I ODE))"

\<comment> \<open>\<open>repv \<nu> x r\<close> replaces the value of (unprimed) variable \<open>x\<close> in the state \<open>\<nu>\<close> with r\<close>
fun repv :: "'c::finite state \<Rightarrow> 'c \<Rightarrow> real \<Rightarrow> 'c state"
where "repv v x r = ((\<chi> y. if x = y then r else vec_nth (fst v) y), snd v)"

\<comment> \<open>\<open>repd \<nu> x' r\<close> replaces the value of (primed) variable \<open>x'\<close> in the state \<open>\<nu>\<close> with \<open>r\<close>\<close>
fun repd :: "'c::finite state \<Rightarrow> 'c \<Rightarrow> real \<Rightarrow> 'c state"
where "repd v x r = (fst v, (\<chi> y. if x = y then r else vec_nth (snd v) y))"

\<comment> \<open>Semantics for formulas, differential formulas, programs.\<close>
fun fml_sem  :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a::finite, 'b::finite, 'c::finite) formula \<Rightarrow> 'c::finite state set" and
  prog_sem :: "('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a::finite, 'b::finite, 'c::finite) hp \<Rightarrow> ('c::finite state * 'c::finite state) set"
where
  "fml_sem I (Geq t1 t2) = {v. dterm_sem I t1 v \<ge> dterm_sem I t2 v}"
| "fml_sem I (Prop P terms) = {\<nu>. Predicates I P (\<chi> i. dterm_sem I (terms i) \<nu>)}"
| "fml_sem I (Not \<phi>) = {v. v \<notin> fml_sem I \<phi>}"
| "fml_sem I (And \<phi> \<psi>) = fml_sem I \<phi> \<inter> fml_sem I \<psi>"
| "fml_sem I (Exists x \<phi>) = {v | v r. (repv v x r) \<in> fml_sem I \<phi>}"
| "fml_sem I (Diamond \<alpha> \<phi>) = {\<nu> | \<nu> \<omega>. (\<nu>, \<omega>) \<in> prog_sem I \<alpha> \<and> \<omega> \<in> fml_sem I \<phi>}"
| "fml_sem I (InContext c \<phi>) = Contexts I c (fml_sem I \<phi>)"

| "prog_sem I (Pvar p) = Programs I p"
| "prog_sem I (Assign x t) = {(\<nu>, \<omega>). \<omega> = repv \<nu> x (dterm_sem I t \<nu>)}"
| "prog_sem I (DiffAssign x t) = {(\<nu>, \<omega>). \<omega> = repd \<nu> x (dterm_sem I t \<nu>)}"
| "prog_sem I (Test \<phi>) = {(\<nu>, \<nu>) | \<nu>. \<nu> \<in> fml_sem I \<phi>}"
| "prog_sem I (Choice \<alpha> \<beta>) = prog_sem I \<alpha> \<union> prog_sem I \<beta>"
| "prog_sem I (Sequence \<alpha> \<beta>) = prog_sem I \<alpha> O prog_sem I \<beta>"
| "prog_sem I (Loop \<alpha>) = (prog_sem I \<alpha>)\<^sup>*"
| "prog_sem I (EvolveODE ODE \<phi>) =
  ({(\<nu>, mk_v I ODE \<nu> (sol t)) | \<nu> sol t.
      t \<ge> 0 \<and>
      (sol solves_ode (\<lambda>_. ODE_sem I ODE)) {0..t} {x. mk_v I ODE \<nu> x \<in> fml_sem I \<phi>} \<and>
      sol 0 = fst \<nu>})"

context ids begin
definition valid :: "('sf, 'sc, 'sz) formula \<Rightarrow> bool"
where "valid \<phi> \<equiv> (\<forall> I. \<forall> \<nu>. is_interp I \<longrightarrow> \<nu> \<in> fml_sem I \<phi>)"
end

text\<open> Because mk\_v is defined with the SOME operator, need to construct a state that satisfies
    ${\tt Vagree} \omega \nu (- {\tt ODE\_vars\ ODE})
     \wedge {\tt Vagree} \omega {\tt (mk\_xode\ I\ ODE\ sol)\ (ODE\_vars\ ODE)})$
    to do anything useful \<close>
fun concrete_v::"('a::finite, 'b::finite, 'c::finite) interp \<Rightarrow> ('a::finite, 'c::finite) ODE \<Rightarrow> 'c::finite state \<Rightarrow> 'c::finite simple_state \<Rightarrow> 'c::finite state"
where "concrete_v I ODE \<nu> sol =
((\<chi> i. (if Inl i \<in> semBV I ODE then sol else (fst \<nu>)) $ i),
 (\<chi> i. (if Inr i \<in> semBV I ODE then ODE_sem I ODE sol else (snd \<nu>)) $ i))"

lemma mk_v_exists:"\<exists>\<omega>. Vagree \<omega> \<nu> (- semBV I ODE)
\<and> Vagree \<omega> (mk_xode I ODE sol) (semBV I ODE)"
  by(rule exI[where x="(concrete_v I ODE \<nu> sol)"], auto simp add: Vagree_def)

lemma mk_v_agree:"Vagree (mk_v I ODE \<nu> sol) \<nu> (- semBV I ODE)
\<and> Vagree (mk_v I ODE \<nu> sol) (mk_xode I ODE sol) (semBV I ODE)"
  unfolding mk_v_def
  apply(rule theI[where a= "((\<chi> i. (if Inl i \<in> semBV I ODE then sol else (fst \<nu>)) $ i),
  (\<chi> i. (if Inr i \<in> semBV I ODE then ODE_sem I ODE sol else (snd \<nu>)) $ i))"])
   using exE[OF mk_v_exists, of \<nu> I ODE sol]
   by (auto simp add: Vagree_def vec_eq_iff)

lemma mk_v_concrete:"mk_v I ODE \<nu> sol = ((\<chi> i. (if Inl i \<in> semBV I ODE then sol else (fst \<nu>)) $ i),
  (\<chi> i. (if Inr i \<in> semBV I ODE then ODE_sem I ODE sol else (snd \<nu>)) $ i))"
  apply(rule agree_UNIV_eq)
  using mk_v_agree[of I ODE \<nu> sol]
  unfolding Vagree_def by auto

subsection \<open>Trivial Simplification Lemmas\<close>
text \<open>
 We often want to pretend the definitions in the semantics are written slightly
 differently than they are. Since the simplifier has some trouble guessing that
 these are the right simplifications to do, we write them all out explicitly as
 lemmas, even though they prove trivially.
\<close>

lemma svar_case:
  "sterm_sem I (Var x) = (\<lambda>v. v $ x)"
  by auto

lemma sconst_case:
  "sterm_sem I (Const r) = (\<lambda>v. r)"
  by auto

lemma sfunction_case:
  "sterm_sem I (Function f args) = (\<lambda>v. Functions I f (\<chi> i. sterm_sem I (args i) v))"
  by auto

lemma splus_case:
  "sterm_sem I (Plus t1 t2) = (\<lambda>v. (sterm_sem I t1 v) + (sterm_sem I t2 v))"
  by auto

lemma stimes_case:
  "sterm_sem I (Times t1 t2) = (\<lambda>v. (sterm_sem I t1 v) * (sterm_sem I t2 v))"
  by auto

lemma or_sem [simp]:
  "fml_sem I (Or \<phi> \<psi>) = fml_sem I \<phi> \<union> fml_sem I \<psi>"
  by (auto simp add: Or_def)

lemma iff_sem [simp]: "(\<nu> \<in> fml_sem I (A \<leftrightarrow> B))
  \<longleftrightarrow> ((\<nu> \<in> fml_sem I A) \<longleftrightarrow> (\<nu> \<in> fml_sem I B))"
  by (auto simp add: Equiv_def)

lemma box_sem [simp]:"fml_sem I (Box \<alpha> \<phi>) = {\<nu>. \<forall> \<omega>. (\<nu>, \<omega>) \<in> prog_sem I \<alpha> \<longrightarrow> \<omega> \<in> fml_sem I \<phi>}"
  unfolding Box_def fml_sem.simps
  using Collect_cong by (auto)

lemma forall_sem [simp]:"fml_sem I (Forall x \<phi>) = {v. \<forall>r. (repv v x r) \<in> fml_sem I \<phi>}"
  unfolding Forall_def fml_sem.simps
  using Collect_cong by (auto)

lemma greater_sem[simp]:"fml_sem I (Greater \<theta> \<theta>') = {v. dterm_sem I \<theta> v > dterm_sem I \<theta>' v}"
  unfolding Greater_def by auto

lemma loop_sem:"prog_sem I (Loop \<alpha>) = (prog_sem I \<alpha>)\<^sup>*"
  by (auto)

lemma impl_sem [simp]: "(\<nu> \<in> fml_sem I (A \<rightarrow> B))
  = ((\<nu> \<in> fml_sem I A) \<longrightarrow> (\<nu> \<in> fml_sem I B))"
  by (auto simp add: Implies_def)

lemma equals_sem [simp]: "(\<nu> \<in> fml_sem I (Equals \<theta> \<theta>'))
  = (dterm_sem I \<theta> \<nu> = dterm_sem I \<theta>' \<nu>)"
  by (auto simp add: Equals_def)

lemma diamond_sem [simp]: "fml_sem I (Diamond \<alpha> \<phi>)
  = {\<nu>. \<exists> \<omega>. (\<nu>, \<omega>) \<in> prog_sem I \<alpha> \<and> \<omega> \<in> fml_sem I \<phi>}"
  by auto

lemma tt_sem [simp]:"fml_sem I TT = UNIV" unfolding TT_def by auto
lemma ff_sem [simp]:"fml_sem I FF = {}" unfolding FF_def by auto

lemma iff_to_impl: "((\<nu> \<in> fml_sem I A) \<longleftrightarrow> (\<nu> \<in> fml_sem I B))
  \<longleftrightarrow> (((\<nu> \<in> fml_sem I A) \<longrightarrow> (\<nu> \<in> fml_sem I B))
     \<and> ((\<nu> \<in> fml_sem I B) \<longrightarrow> (\<nu> \<in> fml_sem I A)))"
  by (auto)

    fun seq2fml :: "('a,'b,'c) sequent \<Rightarrow> ('a,'b,'c) formula"
where
  "seq2fml (ante,succ) = Implies (foldr And ante TT) (foldr Or succ FF)"

context ids begin
fun seq_sem ::"('sf, 'sc, 'sz) interp \<Rightarrow> ('sf, 'sc, 'sz) sequent \<Rightarrow> 'sz state set"
where "seq_sem I S = fml_sem I (seq2fml S)"

lemma and_foldl_sem:"\<nu> \<in> fml_sem I (foldr And \<Gamma> TT) \<Longrightarrow> (\<And>\<phi>. List.member \<Gamma> \<phi> \<Longrightarrow> \<nu> \<in> fml_sem I \<phi>)"
  by(induction \<Gamma>, auto simp add: member_rec)

lemma and_foldl_sem_conv:"(\<And>\<phi>. List.member \<Gamma> \<phi> \<Longrightarrow> \<nu> \<in> fml_sem I \<phi>) \<Longrightarrow> \<nu> \<in> fml_sem I (foldr And \<Gamma> TT)"
  by(induction \<Gamma>, auto simp add: member_rec)

lemma or_foldl_sem:"List.member \<Gamma> \<phi> \<Longrightarrow> \<nu> \<in> fml_sem I \<phi> \<Longrightarrow> \<nu> \<in> fml_sem I (foldr Or \<Gamma> FF)"
  by(induction \<Gamma>, auto simp add: member_rec)

lemma or_foldl_sem_conv:"\<nu> \<in> fml_sem I (foldr Or \<Gamma> FF) \<Longrightarrow> \<exists> \<phi>. \<nu> \<in> fml_sem I \<phi> \<and> List.member \<Gamma> \<phi>"
  by(induction \<Gamma>, auto simp add: member_rec)

lemma seq_semD':"\<And>P. \<nu> \<in> seq_sem I (\<Gamma>,\<Delta>) \<Longrightarrow> ((\<nu> \<in> fml_sem I (foldr And \<Gamma> TT) \<Longrightarrow> \<nu> \<in> fml_sem I (foldr Or \<Delta> FF)) \<Longrightarrow> P) \<Longrightarrow> P"
  by simp

definition sublist::"'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where "sublist A B \<equiv> (\<forall>x. List.member A x \<longrightarrow> List.member B x)"

lemma sublistI:"(\<And>x. List.member A x \<Longrightarrow> List.member B x) \<Longrightarrow> sublist A B"
  unfolding sublist_def by auto

lemma \<Gamma>_sub_sem:"sublist \<Gamma>1 \<Gamma>2 \<Longrightarrow> \<nu> \<in> fml_sem I (foldr And \<Gamma>2 TT) \<Longrightarrow> \<nu> \<in> fml_sem I (foldr And \<Gamma>1 TT)"
  unfolding sublist_def
  by (metis and_foldl_sem and_foldl_sem_conv)

lemma seq_semI:"List.member \<Delta> \<psi> \<Longrightarrow>((\<And>\<phi>. List.member \<Gamma> \<phi> \<Longrightarrow> \<nu> \<in> fml_sem I \<phi>) \<Longrightarrow> \<nu> \<in> fml_sem I \<psi>) \<Longrightarrow> \<nu> \<in> seq_sem I (\<Gamma>,\<Delta>)"
  apply(rule seq_semI')
  using and_foldl_sem[of \<nu> I \<Gamma>] or_foldl_sem by blast

lemma seq_semD:"\<nu> \<in> seq_sem I (\<Gamma>,\<Delta>) \<Longrightarrow> (\<And>\<phi>. List.member \<Gamma> \<phi> \<Longrightarrow> \<nu> \<in> fml_sem I \<phi>) \<Longrightarrow> \<exists>\<phi>. (List.member \<Delta> \<phi>) \<and>\<nu> \<in> fml_sem I \<phi> "
  apply(rule seq_semD')
  using and_foldl_sem_conv or_foldl_sem_conv
  by blast+

lemma seq_MP:"\<nu> \<in> seq_sem I (\<Gamma>,\<Delta>) \<Longrightarrow> \<nu> \<in> fml_sem I (foldr And \<Gamma> TT) \<Longrightarrow> \<nu> \<in> fml_sem I (foldr Or \<Delta> FF)"
  by(induction \<Delta>, auto)

definition seq_valid
where "seq_valid S \<equiv> \<forall>I. is_interp I \<longrightarrow> seq_sem I S = UNIV"

text\<open> Soundness for derived rules is local soundness, i.e. if the premisses are all true in the same interpretation,
  then the conclusion is also true in that same interpretation. \<close>
definition sound :: "('sf, 'sc, 'sz) rule \<Rightarrow> bool"
where "sound R \<longleftrightarrow> (\<forall>I. is_interp I \<longrightarrow> (\<forall>i. i \<ge> 0 \<longrightarrow> i < length (fst R) \<longrightarrow> seq_sem I (nth (fst R) i) = UNIV) \<longrightarrow> seq_sem I (snd R) = UNIV)"

lemma soundI:"(\<And>I. is_interp I \<Longrightarrow> (\<And>i. i \<ge> 0 \<Longrightarrow> i < length SG \<Longrightarrow> seq_sem I (nth SG i) = UNIV) \<Longrightarrow> seq_sem I G = UNIV) \<Longrightarrow> sound (SG,G)"
  unfolding sound_def by auto

lemma soundI':"(\<And>I \<nu>. is_interp I \<Longrightarrow> (\<And>i . i \<ge> 0 \<Longrightarrow> i < length SG \<Longrightarrow> \<nu> \<in> seq_sem I (nth SG i)) \<Longrightarrow> \<nu> \<in> seq_sem I G) \<Longrightarrow> sound (SG,G)"
  unfolding sound_def by auto

lemma soundI_mem:"(\<And>I. is_interp I \<Longrightarrow> (\<And>\<phi>. List.member SG \<phi> \<Longrightarrow> seq_sem I \<phi> = UNIV) \<Longrightarrow> seq_sem I C = UNIV) \<Longrightarrow> sound (SG,C)"
  apply (auto simp add: sound_def)
  by (metis in_set_conv_nth in_set_member iso_tuple_UNIV_I seq2fml.simps)

lemma soundI_memv:"(\<And>I. is_interp I \<Longrightarrow> (\<And>\<phi> \<nu>. List.member SG \<phi> \<Longrightarrow> \<nu> \<in> seq_sem I \<phi>) \<Longrightarrow> (\<And>\<nu>. \<nu> \<in> seq_sem I C)) \<Longrightarrow> sound (SG,C)"
  apply(rule soundI_mem)
  using impl_sem by blast

lemma soundI_memv':"(\<And>I. is_interp I \<Longrightarrow> (\<And>\<phi> \<nu>. List.member SG \<phi> \<Longrightarrow> \<nu> \<in> seq_sem I \<phi>) \<Longrightarrow> (\<And>\<nu>. \<nu> \<in> seq_sem I C)) \<Longrightarrow> R = (SG,C) \<Longrightarrow> sound R"
  using  soundI_mem
  using impl_sem by blast

lemma soundD_mem:"sound (SG,C) \<Longrightarrow> (\<And>I. is_interp I \<Longrightarrow> (\<And>\<phi>. List.member SG \<phi> \<Longrightarrow> seq_sem I \<phi> = UNIV) \<Longrightarrow> seq_sem I C = UNIV)"
  apply (auto simp add: sound_def)
  using in_set_conv_nth in_set_member iso_tuple_UNIV_I seq2fml.simps
  by (metis seq2fml.elims)

lemma soundD_memv:"sound (SG,C) \<Longrightarrow> (\<And>I. is_interp I \<Longrightarrow> (\<And>\<phi> \<nu>. List.member SG \<phi> \<Longrightarrow> \<nu> \<in> seq_sem I \<phi>) \<Longrightarrow> (\<And>\<nu>. \<nu> \<in> seq_sem I C))"
  using soundD_mem
  by (metis UNIV_I UNIV_eq_I)

end
end


section \<open>Stochastic Matrices and the Perron--Frobenius Theorem\<close>

text \<open>Since a stationary distribution corresponds to a non-negative real
  eigenvector of the stochastic matrix, we can apply the Perron--Frobenius
  theorem. In this way we easily derive that every stochastic matrix has
  a stationary distribution, and moreover that this distribution is unique, if the
  matrix is irreducible, i.e., if the graph of the matrix is strongly connected.\<close>

theory Stochastic_Matrix_Perron_Frobenius
imports
  Perron_Frobenius.Perron_Frobenius_Irreducible
  Stochastic_Matrix_Markov_Models
  Eigenspace
begin

hide_const (open) Coset.order

lemma pf_nonneg_mat_st_mat: "pf_nonneg_mat (st_mat A)"
  by (unfold_locales, auto simp: non_neg_mat_st_mat)

lemma stoch_non_neg_vec_norm1: assumes "stoch_vec (v :: real ^ 'n)" "non_neg_vec v"
  shows "norm1 v = 1"
  unfolding assms(1)[unfolded stoch_vec_def, symmetric] norm1_def
  by (rule sum.cong, insert assms(2)[unfolded non_neg_vec_def], auto)

lemma stationary_distribution_exists: "\<exists> v. A *st v = v"
proof -
  let ?A = "st_mat A"
  let ?c = "complex_of_real"
  let ?B = "\<chi> i j. ?c (?A $ i $ j)"
  have "real_non_neg_mat ?B" using non_neg_mat_st_mat[of A]
    unfolding real_non_neg_mat_def elements_mat_h_def non_neg_mat_def
    by auto
  from Perron_Frobenius.perron_frobenius_both[OF this] obtain v a where
    ev: "eigen_vector ?B v (?c a)" and nn: "real_non_neg_vec v"
    and a: "a = HMA_Connect.spectral_radius ?B" by auto
  from spectral_radius_ev[of ?B, folded a] have a0: "a \<ge> 0" by auto
  define w where "w = (\<chi> i. Re (v $ i))"
  from nn have vw: "v = (\<chi> i. ?c (w $ i))" unfolding real_non_neg_vec_def w_def
    by (auto simp: vec_elements_h_def)
  from ev[unfolded eigen_vector_def] have v0: "v \<noteq> 0" and ev: "?B *v v = ?c a *s v" by auto
  from v0 have w0: "w \<noteq> 0" unfolding vw by (auto simp: Finite_Cartesian_Product.vec_eq_iff)
  {
    fix i
    from ev have "Re ((?B *v v) $ i) = Re ((?c a *s v) $ i)" by simp
    also have "Re ((?c a *s v) $ i) = (a *s w) $ i" unfolding vw by simp
    also have "Re ((?B *v v) $ i) = (?A *v w) $ i" unfolding vw
      by (simp add: matrix_vector_mult_def)
    also note calculation
  }
  hence ev: "?A *v w = a *s w" by (auto simp: Finite_Cartesian_Product.vec_eq_iff)
  from nn have nn: "non_neg_vec w"
    unfolding vw by (auto simp: real_non_neg_vec_def non_neg_vec_def vec_elements_h_def)
  (* we now mainly have to prove that a = 1 *)
  let ?n = "norm1 w"
  from w0 have n0: "?n \<noteq> 0" by auto
  hence n_pos: "?n > 0" using norm1_ge_0[of w] by linarith
  define u where "u = inverse ?n *s w"
  have nn: "non_neg_vec u" using nn n_pos unfolding u_def non_neg_vec_def by auto
  have nu: "norm1 u = 1" unfolding u_def scalar_mult_eq_scaleR norm1_scaleR using n_pos
    by (auto simp: field_simps)
  have 1: "stoch_vec u" unfolding stoch_vec_def nu[symmetric] norm1_def
    by (rule sum.cong, insert nn[unfolded non_neg_vec_def], auto)
  from arg_cong[OF ev, of "\<lambda> x. inverse ?n *s x"]
  have ev: "?A *v u = a *s u" unfolding u_def
    by (auto simp: ac_simps vector_smult_distrib matrix_vect_scaleR)
  from right_stoch_mat_mult_stoch_vec[OF right_stoch_mat_st_mat[of A] 1, unfolded ev]
  have st: "stoch_vec (a *s u)" .
  from non_neg_mat_mult_non_neg_vec[OF non_neg_mat_st_mat[of A] nn, unfolded ev]
  have nn': "non_neg_vec (a *s u)" .
  from stoch_non_neg_vec_norm1[OF st nn', unfolded scalar_mult_eq_scaleR norm1_scaleR nu] a0
  have "a = 1" by auto
  with ev st have ev: "?A *v u = u" and st: "stoch_vec u" by auto
  show ?thesis using ev st nn
    by (intro exI[of _ "to_st_vec u"], transfer, auto)
qed

lemma stationary_distribution_unique:
  assumes "fixed_mat.irreducible (st_mat A)"
  shows "\<exists>! v. A *st v = v"
proof -
  from stationary_distribution_exists obtain v where ev: "A *st v = v" by auto
  show ?thesis
  proof (intro ex1I, rule ev)
    fix w
    assume "A *st w = w"
    thus "w = v" using ev assms
    proof (transfer, goal_cases)
      case (1 A w v)
      interpret perron_frobenius A
        by (unfold_locales, insert 1, auto)
      from 1 have *: "eigen_vector A v 1" "le_vec 0 v" "eigen_vector A w 1"
        by (auto simp: eigen_vector_def stoch_vec_def non_neg_vec_def)
      from nonnegative_eigenvector_has_ev_sr[OF *(1-2)] have sr1: "sr = 1" by auto
      from multiplicity_sr_1[unfolded sr1] have "order 1 (charpoly A) = 1" .
      from unique_eigen_vector_real[OF this *(1,3)] obtain a where
        vw: "v = a *s w" by auto
      from 1(2,4)[unfolded stoch_vec_def] have "sum (($h) v) UNIV = sum (($h) w) UNIV" by auto
      also have "sum (($h) v) UNIV = a * sum (($h) w) UNIV" unfolding vw
        by (auto simp: sum_distrib_left)
      finally have "a = 1" using 1(2)[unfolded stoch_vec_def] by auto
      with vw show "v = w" by auto
    qed
  qed
qed

text \<open>Let us now convert the stationary distribution results from matrices to Markov chains.\<close>

context transition_matrix
begin

lemma stationary_distribution_exists:
  "\<exists> x. stationary_distribution (pmf_of_st_vec x)"
proof -
  from stationary_distribution_exists obtain x where ev: "A *st x = x" by auto
  show ?thesis
    by (intro exI[of _ x], unfold stationary_distribution_pmf_of_st_vec,
    simp add: ev)
qed

lemma stationary_distribution_unique: assumes "fixed_mat.irreducible (st_mat A)"
  shows "\<exists>! N. stationary_distribution N"
proof -
  from stationary_distribution_exists obtain x where
    st: "stationary_distribution (pmf_of_st_vec x)" by blast
  show ?thesis
  proof (rule ex1I, rule st)
    fix N
    assume st': "stationary_distribution N"
    from stationary_distribution_implies_pmf_of_st_vec[OF this] obtain y where
      N: "N = pmf_of_st_vec y" by auto
    from st'[unfolded N] st
    have "A *st x = x" "A *st y = y" unfolding stationary_distribution_pmf_of_st_vec by auto
    from stationary_distribution_unique[OF assms] this have "x = y" by auto
    with N show "N = pmf_of_st_vec x" by auto
  qed
qed
end
end