\<^marker>\<open>creator Mohammad Abdulaziz, Bilel Ghorbel, Florian Kessler\<close>
section "Big step semantics of IMP-"
theory Big_StepT imports Main Max_Constant Com "HOL-Eisbach.Eisbach_Tools" begin

paragraph "Summary"
text\<open>We define big step semantics with time for IMP-.
Based on the big step semantics definition with time of IMP\<close>

subsection "Big step semantics definition:"

text "In IMP- Branching is only based on whether a variable's value equals 0."

inductive
  big_step_t :: "com \<times> state \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> bool"  ("_ \<Rightarrow>\<^bsup> _ \<^esup> _" 55)
where
Skip: "(SKIP,s) \<Rightarrow>\<^bsup> Suc (0::nat) \<^esup> s"|
Assign: "(x ::= a,s) \<Rightarrow>\<^bsup> Suc (Suc 0) \<^esup> s(x := aval a s)" |
Seq: "\<lbrakk> (c1,s1) \<Rightarrow>\<^bsup> x \<^esup> s2;  (c2,s2) \<Rightarrow>\<^bsup> y \<^esup> s3 ; z=x+y \<rbrakk> \<Longrightarrow> (c1;;c2, s1) \<Rightarrow>\<^bsup> z \<^esup> s3" |
IfTrue: "\<lbrakk> s b \<noteq> 0;  (c1,s) \<Rightarrow>\<^bsup> x \<^esup> t; y=x+1 \<rbrakk> \<Longrightarrow> (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> y \<^esup> t" |
IfFalse: "\<lbrakk> s b = 0; (c2,s) \<Rightarrow>\<^bsup> x \<^esup> t; y=x+1  \<rbrakk> \<Longrightarrow> (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> y \<^esup> t" |
WhileFalse: "\<lbrakk> s b = 0 \<rbrakk> \<Longrightarrow> (WHILE b \<noteq>0 DO c,s) \<Rightarrow>\<^bsup> Suc (Suc 0) \<^esup> s" |
WhileTrue: "\<lbrakk> s1 b \<noteq> 0;  (c,s1) \<Rightarrow>\<^bsup> x \<^esup> s2;  (WHILE b \<noteq>0 DO c, s2) \<Rightarrow>\<^bsup> y \<^esup> s3; 1+x+y=z  \<rbrakk>
    \<Longrightarrow> (WHILE b \<noteq>0 DO c, s1) \<Rightarrow>\<^bsup> z \<^esup> s3"

bundle big_step_syntax
begin
notation big_step_t ("_ \<Rightarrow>\<^bsup> _ \<^esup> _" 55)
end

bundle no_big_step_syntax
begin
no_notation big_step_t ("_ \<Rightarrow>\<^bsup> _ \<^esup> _" 55)
end

code_pred big_step_t .

text "Some examples using the big step semantics"
experiment
begin

text "finding out the final state and running time of a command:"
schematic_goal ex: "(''x'' ::= A (N 5);; ''y'' ::= A (V ''x''), s) \<Rightarrow>\<^bsup> ?t \<^esup> ?s"
  apply(rule Seq)
    apply(rule Assign)
   apply simp
   apply(rule Assign)
  apply simp
  done

values "{(t, x). big_step_t (SKIP, \<lambda>_. 0) x t}"

values "{map t [''x''] |t x. (SKIP, <''x'' := 42>) \<Rightarrow>\<^bsup> x \<^esup> t}"

values "{map t [''x''] |t x. (''x'' ::=A (N 2), <''x'' := 42>) \<Rightarrow>\<^bsup> x \<^esup> t}"

values "{(map t [''x''],x) |t x. (WHILE ''x''\<noteq>0 DO ''x''::= Sub (V ''x'') (N 1),<''x'':=5>) \<Rightarrow>\<^bsup> x \<^esup> t }"

end

text "proof automation:"

text "Introduction rules:"
declare big_step_t.intros [intro]

text "Induction rules with pair splitting"
lemmas big_step_t_induct = big_step_t.induct[split_format(complete)]

subsection "Rule inversion"
inductive_cases Skip_tE[elim!]: "(SKIP,s) \<Rightarrow>\<^bsup> x \<^esup> t"
inductive_cases Assign_tE[elim!]: "(x ::= a,s) \<Rightarrow>\<^bsup> p \<^esup> t"
inductive_cases Seq_tE[elim!]: "(c1;;c2,s1) \<Rightarrow>\<^bsup> p \<^esup> s3"
inductive_cases If_tE[elim!]: "(IF b \<noteq>0 THEN c1 ELSE c2,s) \<Rightarrow>\<^bsup> x \<^esup> t"
inductive_cases While_tE[elim]: "(WHILE b \<noteq>0 DO c,s) \<Rightarrow>\<^bsup> x \<^esup> t"
lemma Seq': "\<lbrakk> (c1,s1) \<Rightarrow>\<^bsup> x \<^esup> s2;  (c2,s2) \<Rightarrow>\<^bsup> y \<^esup> s3  \<rbrakk> \<Longrightarrow> (c1;;c2, s1) \<Rightarrow>\<^bsup> x + y \<^esup> s3"
  by auto

text "Rule inversion use examples:"
lemma "(IF b \<noteq>0 THEN SKIP ELSE SKIP, s) \<Rightarrow>\<^bsup> x \<^esup> t \<Longrightarrow> t = s"
  by blast

lemma assumes "(IF b \<noteq>0 THEN SKIP ELSE SKIP, s) \<Rightarrow>\<^bsup> x \<^esup> t"
  shows "t = s"
  using assms apply cases by auto

subsection "Determinism of Big semantics of IMP-"
theorem big_step_t_determ2: "\<lbrakk> (c,s) \<Rightarrow>\<^bsup> p \<^esup> t; (c,s) \<Rightarrow>\<^bsup> q \<^esup> u \<rbrakk> \<Longrightarrow> (u = t \<and> p=q)"
  apply  (induction arbitrary: u q rule: big_step_t_induct)
    apply(elim Skip_tE) apply(simp)
    apply(elim Assign_tE) apply(simp)
  apply blast
    apply(elim If_tE) apply(simp) apply blast
    apply(elim If_tE)  apply (linarith) apply simp
    apply(erule While_tE) apply(simp) apply simp
  subgoal premises p for s1 b c x s2 y s3 z u q
    using p(7) apply(safe)
      apply(erule While_tE)
        using p(1-6) apply fast
        using p(1-6) apply (simp)
      apply(erule While_tE)
        using p(1-6) apply fast
        using p(1-6) by (simp)
done

lemma bigstep_det: "(c1, s) \<Rightarrow>\<^bsup> p1 \<^esup> t1 \<Longrightarrow> (c1, s) \<Rightarrow>\<^bsup> p \<^esup> t \<Longrightarrow> p1=p \<and> t1=t"
  using big_step_t_determ2 by simp

lemma seq_assign_t_simp:
  "((c ;; x ::= a, s) \<Rightarrow>\<^bsup> Suc(Suc t) \<^esup>  s')
  \<longleftrightarrow> (\<exists>s''. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'' \<and> s' = s''(x := aval a s''))"
proof
  assume "(c;; x ::= a, s) \<Rightarrow>\<^bsup> Suc (Suc t) \<^esup> s'"
  then obtain s'' where "(c, s) \<Rightarrow>\<^bsup> t \<^esup> s''" by auto
  have "s' = s''(x := aval a s'')" using \<open>(c;; x ::= a, s) \<Rightarrow>\<^bsup> Suc (Suc t) \<^esup> s'\<close>
    using bigstep_det \<open>(c, s) \<Rightarrow>\<^bsup> t \<^esup> s''\<close>
    by blast
  thus "\<exists>s''. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'' \<and> s' = s''(x := aval a s'')"
    using \<open>(c, s) \<Rightarrow>\<^bsup> t \<^esup> s''\<close>
    by blast
qed auto

lemma seq_assign_t_intro: "(c, s) \<Rightarrow>\<^bsup> t \<^esup> s'' \<Longrightarrow> s' = s''(x := aval a s'')
  \<Longrightarrow>(c ;; x ::= a, s) \<Rightarrow>\<^bsup> Suc(Suc t) \<^esup>  s'"
  using seq_assign_t_simp
  by auto

lemma seq_is_noop[simp]: "(SKIP, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<longleftrightarrow> (t = Suc 0 \<and> s = s')" by auto

lemma seq_skip[simp]: "(c ;; SKIP, s) \<Rightarrow>\<^bsup>Suc t\<^esup> s' \<longleftrightarrow> (c, s) \<Rightarrow>\<^bsup>t\<^esup> s'" by auto

subsection "Progress property"
text "every command costs time"
lemma bigstep_progress: "(c, s) \<Rightarrow>\<^bsup> p \<^esup> t \<Longrightarrow> p > 0"
  apply(induct rule: big_step_t.induct, auto) done

subsection "abbreviations and properties"
abbreviation terminates ("\<down>") where "terminates cs \<equiv> (\<exists>n a. (cs \<Rightarrow>\<^bsup> n \<^esup> a))"
abbreviation thestate ("\<down>\<^sub>s") where "thestate cs \<equiv> (THE a. \<exists>n. (cs \<Rightarrow>\<^bsup> n \<^esup> a))"
abbreviation thetime ("\<down>\<^sub>t") where "thetime cs \<equiv> (THE n. \<exists>a. (cs \<Rightarrow>\<^bsup> n \<^esup> a))"

lemma bigstepT_the_cost: "(c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<Longrightarrow> \<down>\<^sub>t(c, s) = t"
  using bigstep_det by blast

lemma bigstepT_the_state: "(c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<Longrightarrow> \<down>\<^sub>s(c, s) = s'"
  using bigstep_det by blast

lemma SKIPnot: "(\<not> (SKIP, s) \<Rightarrow>\<^bsup> p \<^esup> t) \<longleftrightarrow> (s\<noteq>t \<or> p\<noteq>Suc 0)" by blast

lemma SKIPp: "\<down>\<^sub>t(SKIP,s) = Suc 0"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma SKIPt: "\<down>\<^sub>s(SKIP,s) = s"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma ASSp: "(THE p. Ex (big_step_t (x ::= e, s) p)) = Suc(Suc 0)"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma ASSt: "(THE t. \<exists>p. (x ::= e, s) \<Rightarrow>\<^bsup> p \<^esup> t) = s(x := aval e s)"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma ASSnot: "( \<not> (x ::= e, s) \<Rightarrow>\<^bsup> p \<^esup> t ) = (p\<noteq>Suc(Suc 0) \<or> t\<noteq>s(x := aval e s))"
  apply auto done

lemma If_THE_True: "Suc (THE n. \<exists>a. (c1, s) \<Rightarrow>\<^bsup> n \<^esup> a) =  (THE n. \<exists>a. (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> n \<^esup> a)"
     if T: "s b \<noteq> 0" and c1_t: "terminates (c1,s)" for s l
proof -
  from c1_t obtain p t where a: "(c1, s) \<Rightarrow>\<^bsup> p \<^esup> t" by blast
  with T have b: "(IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> p+1 \<^esup> t"  using IfTrue by simp
  from a bigstepT_the_cost have "(THE n. \<exists>a. (c1, s) \<Rightarrow>\<^bsup> n \<^esup> a) = p" by simp
  moreover from b bigstepT_the_cost have "(THE n. \<exists>a. (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> n \<^esup> a) = p+1" by simp
  ultimately show ?thesis by simp
qed

lemma If_THE_False:
 "Suc (THE n. \<exists>a. (c2, s) \<Rightarrow>\<^bsup> n \<^esup> a) =  (THE n. \<exists>a. (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> n \<^esup> a)"
     if T: "s b = 0" and c2_t: "\<down> (c2,s)" for s l
proof -
  from c2_t obtain p t where a: "(c2, s) \<Rightarrow>\<^bsup> p \<^esup> t"  by blast
  with T have b: "(IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> p+1 \<^esup> t"  using IfFalse by simp
  from a bigstepT_the_cost have "(THE n. \<exists>a. (c2, s) \<Rightarrow>\<^bsup> n \<^esup> a) = p" by simp
  moreover from b bigstepT_the_cost have "(THE n. \<exists>a. (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> n \<^esup> a) = p+1" by simp
  ultimately show ?thesis by simp
qed

lemma terminates_in_state_intro: "(c, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow> s' = s'' \<Longrightarrow> (c, s) \<Rightarrow>\<^bsup>t\<^esup> s''"
  by simp

lemma terminates_in_time_state_intro: "(c, s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow> t = t' \<Longrightarrow> s' = s''
  \<Longrightarrow> (c, s) \<Rightarrow>\<^bsup>t'\<^esup> s''"
  by simp

lemma terminates_in_time_state_intro': "(c', s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow> t = t' \<Longrightarrow> s' = s'' \<Longrightarrow> c' = c
  \<Longrightarrow> (c, s) \<Rightarrow>\<^bsup>t'\<^esup> s''"
  by simp

method dest_com  =
  (match premises in a: "\<lbrakk>loop_cond; state_upd\<rbrakk> \<Longrightarrow> (_, s) \<Rightarrow>\<^bsup>t\<^esup> s'"
    for s s' t loop_cond state_upd \<Rightarrow> \<open>rule terminates_in_time_state_intro'[OF a]\<close>)

method dest_com' =
  (match premises in a[thin]: "\<lbrakk>loop_cond; state_upd; (_, s) \<Rightarrow>\<^bsup>t\<^esup> s'\<rbrakk> \<Longrightarrow> P"
    for s s' t loop_cond state_upd P  \<Rightarrow>
   \<open>match premises in b[thin]: "(While _ _, s2) \<Rightarrow>\<^bsup>t2\<^esup> s2'"
      for s2 s2' t2 \<Rightarrow> \<open>insert a[OF _ _ b]\<close>\<close>)

method dest_com_init_while =
  (match premises in a[thin]: "\<lbrakk>loop_cond; state_upd; ((_ ;; While _ _), s) \<Rightarrow>\<^bsup>t\<^esup> s'\<rbrakk> \<Longrightarrow> P"
    for s s' t loop_cond state_upd P  \<Rightarrow>
   \<open>match premises in b[thin]: "((_ ;; While _ _), s2) \<Rightarrow>\<^bsup>t2\<^esup> s2'"
      for s2 s2' t2 \<Rightarrow> \<open>insert a[OF _ _ b]\<close>\<close>)

(*method dest_com_init_while =
  (match premises in a[thin]: "\<lbrakk>loop_cond; state_upd; (v ::= a;; WHILE v \<noteq>0 DO _, s) \<Rightarrow>\<^bsup>t\<^esup> s'\<rbrakk> \<Longrightarrow> P"
    for v a s s' t loop_cond state_upd P  \<Rightarrow>
   \<open>match premises in b[thin]: "(v ::= a;; WHILE v \<noteq>0 DO _, s2) \<Rightarrow>\<^bsup>t2\<^esup> s2'"
      for s2 s2' t2 \<Rightarrow> \<open>insert a\<close>\<close>)*)

lemma terminates_split_if : "(P s \<Longrightarrow> (c, s) \<Rightarrow>\<^bsup>t1\<^esup> s1 ) \<Longrightarrow>
(\<not> P s \<Longrightarrow> (c, s) \<Rightarrow>\<^bsup>t2\<^esup> s2 ) \<Longrightarrow> (c,s) \<Rightarrow>\<^bsup>if P s then t1 else t2\<^esup>  if P s then s1 else s2"
  by auto

lemma AssignD':
"(x ::= a, s) \<Rightarrow>\<^bsup> 2 \<^esup> s' \<Longrightarrow> s' = s (x:= aval a s)"
  by (auto simp add: eval_nat_numeral)

lemma com_only_vars: "\<lbrakk>(c, s) \<Rightarrow>\<^bsup> t \<^esup> s'; x \<notin> set (Max_Constant.all_variables c)\<rbrakk> \<Longrightarrow> s x = s' x"
  by (induction arbitrary: t rule: big_step_t_induct)  auto

lemma Seq'': "\<lbrakk> (c1,s1) \<Rightarrow>\<^bsup> x \<^esup> s2 \<and> P s2; P s2 \<Longrightarrow> (c2,s2) \<Rightarrow>\<^bsup> y \<^esup> s3 \<and> Q s3; Q s3 \<Longrightarrow> R s3 \<rbrakk>
             \<Longrightarrow> (c1;;c2, s1) \<Rightarrow>\<^bsup> x + y \<^esup> s3 \<and> R s3"
  by auto

lemma WhileI:
"\<lbrakk>(s1 b \<noteq> 0 \<Longrightarrow> (c,s1) \<Rightarrow>\<^bsup> x \<^esup> s2 \<and> (WHILE b \<noteq>0 DO c, s2) \<Rightarrow>\<^bsup> y \<^esup> s3);
  (s1 b = 0 \<Longrightarrow> s1 = s3);
  z = (if s1 b \<noteq> 0 then 1+x+y else 2)\<rbrakk>
        \<Longrightarrow> (WHILE b \<noteq>0 DO c, s1) \<Rightarrow>\<^bsup> z \<^esup> s3"
  by (auto simp add: WhileTrue WhileFalse numeral_2_eq_2)

lemma IfI:
"\<lbrakk>s b \<noteq> 0 \<Longrightarrow> (c1,s) \<Rightarrow>\<^bsup> x1 \<^esup> t1;
  s b = 0 \<Longrightarrow> (c2,s) \<Rightarrow>\<^bsup> x2 \<^esup> t2;
  y = (if s b \<noteq> 0 then x1 else x2) + 1;
  t = (if s b \<noteq> 0 then t1 else t2)\<rbrakk>
        \<Longrightarrow> (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> y \<^esup> t"
  by (auto simp add: IfTrue IfFalse)

lemma IfE:
"(IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> (if s b \<noteq> 0 then x1 else x2) + 1 \<^esup> (if s b \<noteq> 0 then s1 else s2) \<Longrightarrow>
 \<lbrakk>\<lbrakk>s b \<noteq> 0; (if s b \<noteq> 0 then x1 else x2) + 1 = x1 + 1;
  (if s b \<noteq> 0 then s1 else s2) = s1; (c1,s) \<Rightarrow>\<^bsup> x1 \<^esup> s1\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>s b = 0; (if s b \<noteq> 0 then x1 else x2) + 1 = x2 + 1;
   (if s b \<noteq> 0 then s1 else s2) = s2; (c2,s) \<Rightarrow>\<^bsup> x2 \<^esup> s2\<rbrakk> \<Longrightarrow> P\<rbrakk>
        \<Longrightarrow> P"
  by (auto simp add: IfTrue IfFalse)

thm Seq_tE

lemma IfD:
"(IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> (if s b \<noteq> 0 then x1 else x2) + 1 \<^esup> (if s b \<noteq> 0 then t1 else t2) \<Longrightarrow>
 \<lbrakk>\<lbrakk>s b \<noteq> 0; (c1,s) \<Rightarrow>\<^bsup> x1 \<^esup> t1\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>s b = 0; (c2,s) \<Rightarrow>\<^bsup> x2 \<^esup> t2\<rbrakk> \<Longrightarrow> P\<rbrakk>
        \<Longrightarrow> P"
  by (auto simp add: IfTrue IfFalse)

lemma AssignI:
"\<lbrakk>s' = s (x:= aval a s)\<rbrakk>
        \<Longrightarrow> (x ::= a, s) \<Rightarrow>\<^bsup> Suc (Suc 0) \<^esup> s'"
  by (auto simp add: Assign)

lemma AssignI':
"\<lbrakk>s' = s (x:= aval a s)\<rbrakk>
        \<Longrightarrow> (x ::= a, s) \<Rightarrow>\<^bsup> 2 \<^esup> s'"
  by (auto simp add: Assign eval_nat_numeral)

lemma AssignI'':
"\<lbrakk>s' = s (x:= aval a s)\<rbrakk>
        \<Longrightarrow> (x ::= a, s) \<Rightarrow>\<^bsup> 2 \<^esup> s' \<and> s' = s'"
  by (auto simp add: Assign eval_nat_numeral)

lemma AssignD: "(x ::= a, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<Longrightarrow> t = 2 \<and> s' = s(x := aval a s)"
  by auto

lemma compose_programs_1:
  "(c2, s2) \<Rightarrow>\<^bsup> y \<^esup> s3 \<Longrightarrow> (c1, s1) \<Rightarrow>\<^bsup> x \<^esup> s2 \<Longrightarrow>
    ((c1;; c2, s1) \<Rightarrow>\<^bsup> x + y \<^esup> s3 \<Longrightarrow> P)
   \<Longrightarrow> P"
  by auto

lemma compose_programs_2:
  "(c1, s1) \<Rightarrow>\<^bsup> x \<^esup> s2 \<Longrightarrow> (c2, s2) \<Rightarrow>\<^bsup> y \<^esup> s3 \<Longrightarrow>
    ((c1;; c2, s1) \<Rightarrow>\<^bsup> x + y \<^esup> s3 \<Longrightarrow> P)
   \<Longrightarrow> P"
  by auto

lemma While_tE_time:
"(WHILE b\<noteq>0 DO c, s) \<Rightarrow>\<^bsup> x \<^esup> t \<Longrightarrow>
  (x = Suc (Suc 0) \<Longrightarrow> t = s \<Longrightarrow> s b = 0 \<Longrightarrow> P) \<Longrightarrow>
  (\<And>x' s2 y. 0 < s b \<Longrightarrow> (c, s) \<Rightarrow>\<^bsup> x' \<^esup> s2 \<Longrightarrow> (WHILE b\<noteq>0 DO c, s2) \<Rightarrow>\<^bsup> y \<^esup> t \<Longrightarrow> x = Suc (x' + y) \<Longrightarrow> P) \<Longrightarrow> P"
  by auto

lemma Seq_tE_While_init:
  "(WHILE v \<noteq>0 DO c2, s2) \<Rightarrow>\<^bsup> y \<^esup> s3 \<Longrightarrow> (c1, s1) \<Rightarrow>\<^bsup> x \<^esup> s2 \<Longrightarrow>
    ((c1;; WHILE v \<noteq>0 DO c2, s1) \<Rightarrow>\<^bsup> x + y \<^esup> s3 \<Longrightarrow> P)
   \<Longrightarrow> P"
  by auto

method dest_com_gen =
  (erule compose_programs_1[where ?c2.0 = "(Com.While _ _)"], assumption,
    erule compose_programs_2[where ?c1.0 = "(_;; Com.While _ _)"], assumption,
    (match premises
      in a[thin]:
      "(init_while_cond;;
                WHILE _ \<noteq>0 DO (loop_body;; init_while_cond);;
                after_loop, _) \<Rightarrow>\<^bsup>_\<^esup> _"
    for init_while_cond loop_body after_loop  \<Rightarrow>
      \<open>match premises in b[thin]: "\<lbrakk>loop_cond; state_upd; _\<rbrakk> \<Longrightarrow> P"
       for loop_cond state_upd P \<Rightarrow> \<open>subst b[OF _ _ a]\<close>\<close>))

method dest_com_gen_time =
  (erule compose_programs_1[where ?c2.0 = "(Com.While _ _)"], assumption,
    erule compose_programs_2[where ?c1.0 = "(_;; Com.While _ _)"], assumption,
    (match premises
      in a[thin]:
      "(init_while_cond;;
                WHILE _ \<noteq>0 DO (loop_body;; init_while_cond);;
                after_loop, _) \<Rightarrow>\<^bsup>_\<^esup> _"
    for init_while_cond loop_body after_loop  \<Rightarrow>
      \<open>match premises in b[thin]: "\<lbrakk>loop_cond; state_upd; _\<rbrakk> \<Longrightarrow> P"
       for loop_cond state_upd P \<Rightarrow> \<open>subst b[OF _ _ a, simplified add.assoc]\<close>\<close>))

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Fixed-points\<close>

theory OrdinalFix
  imports OrdinalInverse
begin

primrec iter :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  where
    "iter 0       F x = x"
  | "iter (Suc n) F x = F (iter n F x)"

definition
  oFix :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oFix F a = oLimit (\<lambda>n. iter n F a)"

lemma oFix_fixed:
  assumes "continuous F" "a \<le> F a"
  shows "F (oFix F a) = oFix F a"
proof -
  have "a \<le> oLimit (\<lambda>n. F (iter n F a))"
    by (metis OrdinalFix.iter.simps(1) \<open>a \<le> F a\<close> le_oLimitI)
  then have "iter k F a \<le> oLimit (\<lambda>n. F (iter n F a))" for k
    by (induction k) auto
  then have "oLimit (\<lambda>n. F (iter n F a)) = oLimit (\<lambda>n. iter n F a)"
    by (metis (no_types, lifting) OrdinalFix.iter.simps(2) le_oLimit nle_le oLimit_leI)
  then show ?thesis
    by (simp add: assms(1) continuousD oFix_def)
qed

lemma oFix_least:
  assumes "mono F" "F x = x" "a \<le> x" shows "oFix F a \<le> x"
proof -
  have "iter n F a \<le> x" for n
  proof (induction n)
    case (Suc n)
    with assms monotoneD show ?case by fastforce
  qed (use assms in auto)
  then show ?thesis
    by (simp add: oFix_def oLimit_leI)
qed

lemma mono_oFix:
  assumes "mono F"  shows "mono (oFix F)"
proof -
  have "iter n F x \<le> iter n F y" if "x \<le> y" for n x y
    using that assms
    by (induction n) (auto simp: monoD)
  then show ?thesis
    by (metis le_oLimitI monoI oFix_def oLimit_leI)
qed

lemma less_oFixD: "\<lbrakk>x < oFix F a; mono F; F x = x\<rbrakk> \<Longrightarrow> x < a"
  by (meson linorder_not_le oFix_least)

lemma less_oFixI: "a < F a \<Longrightarrow> a < oFix F a"
  by (metis OrdinalFix.iter.simps leD le_oLimit oFix_def order_neq_le_trans)

lemma le_oFix: "a \<le> oFix F a"
  by (metis OrdinalFix.iter.simps(1) le_oLimit oFix_def)

lemma le_oFix1: "F a \<le> oFix F a"
  by (metis OrdinalFix.iter.simps le_oLimit oFix_def)

lemma less_oFix_0D:
  assumes "x < oFix F 0" "mono F" shows "x < F x"
proof -
  have "x < iter n F 0 \<Longrightarrow> x < F x" for n
  proof (induction n)
    case 0 then show ?case by auto
  next
    case (Suc n)
    with \<open>mono F\<close> show ?case
      using monotoneD order.strict_trans2 by fastforce
  qed
  then show ?thesis
    using assms(1) less_oLimitD oFix_def by fastforce
qed

lemma zero_less_oFix_eq: "(0 < oFix F 0) = (0 < F 0)"
proof -
  have "F 0 \<le> 0 \<Longrightarrow> iter n F 0 \<le> 0" for n
    by (induction n) auto
  then show ?thesis
    using less_oFixI oFix_def by fastforce
qed

lemma oFix_eq_self:
  assumes "F a = a" shows "oFix F a = a"
proof -
  have "iter n F a = a" for n
    by (induction n) (auto simp: assms)
  then show ?thesis
    by (simp add: oFix_def)
qed

subsection \<open>Derivatives of ordinal functions\<close>

text "The derivative of F enumerates all the fixed-points of F"

definition
  oDeriv :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oDeriv F = ordinal_rec (oFix F 0) (\<lambda>p x. oFix F (oSuc x))"

lemma oDeriv_0 [simp]:
  "oDeriv F 0 = oFix F 0"
  by (simp add: oDeriv_def)

lemma oDeriv_oSuc [simp]:
  "oDeriv F (oSuc x) = oFix F (oSuc (oDeriv F x))"
  by (simp add: oDeriv_def)

lemma oDeriv_oLimit [simp]:
  "oDeriv F (oLimit f) = oLimit (\<lambda>n. oDeriv F (f n))"
  by (metis dual_order.trans le_oFix less_oSuc oDeriv_def order_le_less ordinal_rec_oLimit)

lemma oDeriv_fixed:
  assumes "normal F" shows "F (oDeriv F n) = oDeriv F n"
proof (induction n rule: oLimit_induct)
  case zero
  then show ?case
    by (simp add: assms normal.continuous oFix_fixed)
next
  case (suc x)
  then show ?case
    by (simp add: assms normal.continuous normal.increasing oFix_fixed)
next
  case (lim f)
  then show ?case
    by (simp add: assms continuousD normal.continuous)
qed

lemma oDeriv_fixedD: "\<lbrakk>oDeriv F x = x; normal F\<rbrakk> \<Longrightarrow> F x = x"
  by (metis oDeriv_fixed)

lemma normal_oDeriv: "normal (oDeriv F)"
  by (metis le_oFix normal_ordinal_rec oDeriv_def oSuc_le_eq_less)

lemma oDeriv_increasing:
  assumes "continuous F" shows "F n \<le> oDeriv F n"
proof (induction n rule: oLimit_induct)
  case zero
  then show ?case
    by (simp add: le_oFix1)
next
  case (suc x)
  with continuous.monoD [OF assms] show ?case
    by (metis dual_order.trans le_oFix1 normal.increasing normal_oDeriv oDeriv_oSuc oSuc_le_oSuc)
next
  case (lim f)
  then show ?case
    by (metis assms continuousD le_oLimitI oDeriv_oLimit oLimit_leI)
qed

lemma oDeriv_total:
  assumes "normal F" "F x = x" shows "\<exists>n. x = oDeriv F n"
proof -
  have "\<exists>n. oDeriv F n \<le> x \<and> x < oDeriv F (oSuc n)"
    by (metis assms normal.mono normal.oInv_ex normal_oDeriv oDeriv_0 oFix_least ordinal_0_le)
  then show ?thesis
    by (metis assms leD normal.mono oDeriv_oSuc oFix_least oSuc_leI order_neq_le_trans)
qed

lemma range_oDeriv: "normal F \<Longrightarrow> range (oDeriv F) = {x. F x = x}"
  by (auto intro: oDeriv_fixed dest: oDeriv_total)

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.*)
  theory TIP_sort_nat_StoogeSortCount
  imports "../../Test_Base"
begin

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

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

datatype Nat = Z | S "Nat"

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

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

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "Nat list => Nat list"
  and stoogesort :: "Nat list => Nat list"
  and stooge1sort1 :: "Nat list => Nat list" where
  "stooge1sort2 y =
   (case splitAt (idiv (length y) (S (S (S Z)))) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

theorem property0 :
  "((count y (stoogesort xs)) = (count y xs))"
  oops

end


(* Author: Andreas Lochbihler, ETH Zurich
   Author: Peter Gammie *)

section \<open> The Bird tree \<close>

text \<open>
  We define the Bird tree following \<^cite>\<open>"Hinze2009JFP"\<close> and prove that it is a
  permutation of the Stern-Brocot tree. As a corollary, we derive that the Bird tree also
  contains all rational numbers in lowest terms exactly once.
\<close>

theory Bird_Tree imports Stern_Brocot_Tree begin

corec bird :: "fraction tree"
where
  "bird = Node (1, 1) (map_tree recip (map_tree succ bird)) (map_tree succ (map_tree recip bird))"

lemma bird_unfold:
  "bird = Node (1, 1) (pure recip \<diamondop> (pure succ \<diamondop> bird)) (pure succ \<diamondop> (pure recip \<diamondop> bird))"
using bird.code unfolding map_tree_ap_tree_pure_tree[symmetric] .

lemma bird_simps [simp]:
  "root bird = (1, 1)"
  "left bird = pure recip \<diamondop> (pure succ \<diamondop> bird)"
  "right bird = pure succ \<diamondop> (pure recip \<diamondop> bird)"
by(subst bird_unfold, simp)+

lemma mirror_bird: "mirror bird = pure recip \<diamondop> bird" (is "?lhs = ?rhs")
proof(rule sym)
  let ?F = "\<lambda>t. Node (1, 1) (map_tree succ (map_tree recip t)) (map_tree recip (map_tree succ t))"
  have *: "mirror bird = ?F (mirror bird)"
    by(rule tree.expand; simp add: mirror_ap_tree mirror_pure map_tree_ap_tree_pure_tree[symmetric])
  show "t = mirror bird" when "t = ?F t" for t using that by corec_unique (fact *)
  show "pure recip \<diamondop> bird = ?F (pure recip \<diamondop> bird)"
    by(rule tree.expand; simp add: map_tree_ap_tree_pure_tree; applicative_lifting; simp add: split_beta)
qed

primcorec even_odd_mirror :: "bool \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
  "\<And>even. root (even_odd_mirror even t) = root t"
| "\<And>even. left (even_odd_mirror even t) = even_odd_mirror (\<not> even) (if even then right t else left t)"
| "\<And>even. right (even_odd_mirror even t) = even_odd_mirror (\<not> even) (if even then left t else right t)"

definition even_mirror :: "'a tree \<Rightarrow> 'a tree"
where "even_mirror = even_odd_mirror True"

definition odd_mirror :: "'a tree \<Rightarrow> 'a tree"
where "odd_mirror = even_odd_mirror False"

lemma even_mirror_simps [simp]:
  "root (even_mirror t) = root t"
  "left (even_mirror t) = odd_mirror (right t)"
  "right (even_mirror t) = odd_mirror (left t)"
  and odd_mirror_simps [simp]:
  "root (odd_mirror t) = root t"
  "left (odd_mirror t) = even_mirror (left t)"
  "right (odd_mirror t) = even_mirror (right t)"
by(simp_all add: even_mirror_def odd_mirror_def)

lemma even_odd_mirror_pure [simp]: fixes even shows
  "even_odd_mirror even (pure_tree x) = pure_tree x"
by(coinduction arbitrary: even) auto

lemma even_odd_mirror_ap_tree [simp]: fixes even shows
  "even_odd_mirror even (f \<diamondop> x) = even_odd_mirror even f \<diamondop> even_odd_mirror even x"
by(coinduction arbitrary: even f x) auto

lemma [simp]:
  shows even_mirror_ap_tree: "even_mirror (f \<diamondop> x) = even_mirror f \<diamondop> even_mirror x"
  and odd_mirror_ap_tree: "odd_mirror (f \<diamondop> x) = odd_mirror f \<diamondop> odd_mirror x"
by(simp_all add: even_mirror_def odd_mirror_def)

fun even_mirror_path :: "path \<Rightarrow> path"
  and odd_mirror_path :: "path \<Rightarrow> path"
where
  "even_mirror_path [] = []"
| "even_mirror_path (d # ds) = (case d of L \<Rightarrow> R | R \<Rightarrow> L) # odd_mirror_path ds"
| "odd_mirror_path [] = []"
| "odd_mirror_path (d # ds) = d # even_mirror_path ds"

lemma even_mirror_traverse_tree [simp]:
  "root (traverse_tree path (even_mirror t)) = root (traverse_tree (even_mirror_path path) t)"
  and odd_mirror_traverse_tree [simp]:
  "root (traverse_tree path (odd_mirror t)) = root (traverse_tree (odd_mirror_path path) t)"
by (induct path arbitrary: t) (simp_all split: dir.splits)

lemma even_odd_mirror_path_involution [simp]:
  "even_mirror_path (even_mirror_path path) = path"
  "odd_mirror_path (odd_mirror_path path) = path"
by (induct path) (simp_all split: dir.splits)

lemma even_odd_mirror_path_injective [simp]:
  "even_mirror_path path = even_mirror_path path' \<longleftrightarrow> path = path'"
  "odd_mirror_path path = odd_mirror_path path' \<longleftrightarrow> path = path'"
by (induct path arbitrary: path') (case_tac path', simp_all split: dir.splits)+

lemma odd_mirror_bird_stern_brocot:
  "odd_mirror bird = stern_brocot_recurse"
proof -
  let ?rsrs = "map_tree (recip \<circ> succ \<circ> recip \<circ> succ)"
  let ?rssr = "map_tree (recip \<circ> succ \<circ> succ \<circ> recip)"
  let ?srrs = "map_tree (succ \<circ> recip \<circ> recip \<circ> succ)"
  let ?srsr = "map_tree (succ \<circ> recip \<circ> succ \<circ> recip)"
  let ?R = "\<lambda>t. Node (1, 1) (Node (1, 2) (?rssr t) (?rsrs t)) (Node (2, 1) (?srsr t) (?srrs t))"

  have *: "stern_brocot_recurse = ?R stern_brocot_recurse"
    by(rule tree.expand; simp; intro conjI; rule tree.expand; simp; intro conjI) \<comment> \<open>Expand the tree twice\<close>
      (applicative_lifting, simp add: split_beta)+
  show "f = stern_brocot_recurse" when "f = ?R f" for f using that * by corec_unique
  show "odd_mirror bird = ?R (odd_mirror bird)"
    by(rule tree.expand; simp; intro conjI; rule tree.expand; simp; intro conjI) \<comment> \<open>Expand the tree twice\<close>
      (applicative_lifting; simp)+
qed

theorem bird_rationals:
  assumes "m > 0" "n > 0"
  shows "root (traverse_tree (odd_mirror_path (mk_path m n)) (pure rat_of \<diamondop> bird)) = Fract (int m) (int n)"
using stern_brocot_rationals[OF assms]
by (simp add: odd_mirror_bird_stern_brocot[symmetric])

theorem bird_rationals_not_repeated:
  "root (traverse_tree path (pure rat_of \<diamondop> bird)) = root (traverse_tree path' (pure rat_of \<diamondop> bird))
  \<Longrightarrow> path = path'"
using stern_brocot_rationals_not_repeated[where path="odd_mirror_path path" and path'="odd_mirror_path path'"]
by (simp add: odd_mirror_bird_stern_brocot[symmetric])

end


theory E2_4
  imports Main
begin

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] x = [x]" |
  "snoc (y # ys) x = y # (snoc ys x)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []" |
  "reverse (x # xs) = snoc (reverse xs) x"

value "reverse [1::nat, 2, 3, 4, 5]"

lemma reverse_02 [simp] : "reverse(snoc xs x) = x # (reverse xs)"
  apply(induction xs)
  apply(auto)
  done

(*
reverse (snoc (a # xs) x) = x # reverse (a # xs)
reverse (a # (snoc xs x)) = x # reverse (a # xs)
snoc (reverse (snoc xs x)) a = x # reverse (a # xs)
snoc (reverse (snoc xs x)) a = x # (snoc (reverse xs) a)
snoc (reverse (snoc xs x)) a = snoc (x # (reverse xs)) a
reverse (snoc xs x) = x # (reverse xs)
*)

lemma reverse_rr : "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto)
  done

end


(*
  File:       Bernoulli.thy
  Author:     Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
  Author:     Manuel Eberl <eberlm@in.tum.de>
*)
section \<open>Bernoulli numbers\<close>

theory Bernoulli
imports Complex_Main
begin

subsection \<open>Preliminaries\<close>

lemma power_numeral_reduce: "a ^ numeral n = a * a ^ pred_numeral n"
  by (simp only: numeral_eq_Suc power_Suc)

lemma fact_diff_Suc: "n < Suc m \<Longrightarrow> fact (Suc m - n) = of_nat (Suc m - n) * fact (m - n)"
  by (subst fact_reduce) auto

lemma of_nat_binomial_Suc:
  assumes "k \<le> n"
  shows   "(of_nat (Suc n choose k) :: 'a :: field_char_0) =
             of_nat (Suc n) / of_nat (Suc n - k) * of_nat (n choose k)"
  using assms by (simp add: binomial_fact divide_simps fact_diff_Suc of_nat_diff del: of_nat_Suc)

lemma integrals_eq:
  assumes "f 0 = g 0"
  assumes "\<And> x. ((\<lambda>x. f x - g x) has_real_derivative 0) (at x)"
  shows "f x = g x"
proof -
  show "f x = g x"
  proof (cases "x \<noteq> 0")
    case True
    from assms DERIV_const_ratio_const[OF this, of "\<lambda>x. f x - g x" 0]
    show ?thesis by auto
  qed (simp add: assms)
qed

lemma sum_diff: "((\<Sum>i\<le>n::nat. f (i + 1) - f i)::'a::field) = f (n + 1) - f 0"
  by (induct n) (auto simp add: field_simps)

lemma Rats_sum: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<rat>) \<Longrightarrow> sum f A \<in> \<rat>"
  by (induction A rule: infinite_finite_induct) simp_all

subsection \<open>Bernoulli Numbers and Bernoulli Polynomials\<close>

declare sum.cong [fundef_cong]

fun bernoulli :: "nat \<Rightarrow> real"
where
  "bernoulli 0 = (1::real)"
| "bernoulli (Suc n) =  (-1 / (n + 2)) * (\<Sum>k \<le> n. ((n + 2 choose k) * bernoulli k))"

declare bernoulli.simps[simp del]

lemmas bernoulli_0 [simp] = bernoulli.simps(1)
lemmas bernoulli_Suc = bernoulli.simps(2)
lemma bernoulli_1 [simp]: "bernoulli 1 = -1/2" by (simp add: bernoulli_Suc)
lemma bernoulli_Suc_0 [simp]: "bernoulli (Suc 0) = -1/2" by (simp add: bernoulli_Suc)

text \<open>
  The ``normal'' Bernoulli numbers are the negative Bernoulli numbers $B_n^{-}$ we just defined
  (so called because $B_1^{-} = -\frac{1}{2}$). There is also another convention, the
  positive Bernoulli numbers $B_n^{+}$, which differ from the negative ones only in that
  $B_1^{+} = \frac{1}{2}$. Both conventions have their justification, since a number of theorems
  are easier to state with one than the other.
\<close>
definition bernoulli' where
  "bernoulli' n = (if n = 1 then 1/2 else bernoulli n)"

lemma bernoulli'_0 [simp]: "bernoulli' 0 = 1" by (simp add: bernoulli'_def)

lemma bernoulli'_1 [simp]: "bernoulli' (Suc 0) = 1/2"
  by (simp add: bernoulli'_def)

lemma bernoulli_conv_bernoulli': "n \<noteq> 1 \<Longrightarrow> bernoulli n = bernoulli' n"
  by (simp add: bernoulli'_def)

lemma bernoulli'_conv_bernoulli: "n \<noteq> 1 \<Longrightarrow> bernoulli' n = bernoulli n"
  by (simp add: bernoulli'_def)

lemma bernoulli_conv_bernoulli'_if:
    "n \<noteq> 1 \<Longrightarrow> bernoulli n = (if n = 1 then -1/2 else bernoulli' n)"
  by (simp add: bernoulli'_def)

lemma bernoulli_in_Rats: "bernoulli n \<in> \<rat>"
proof (induction n rule: less_induct)
  case (less n)
  thus ?case
    by (cases n) (auto simp: bernoulli_Suc intro!: Rats_sum Rats_divide)
qed

lemma bernoulli'_in_Rats: "bernoulli' n \<in> \<rat>"
  by (simp add: bernoulli'_def bernoulli_in_Rats)

definition bernpoly :: "nat \<Rightarrow> 'a \<Rightarrow> 'a :: real_algebra_1" where
  "bernpoly n = (\<lambda>x. \<Sum>k \<le> n. of_nat (n choose k) * of_real (bernoulli k) * x ^ (n - k))"

lemma bernoulli_Suc':
  "bernoulli (Suc n) = -1/(real n + 2) * (\<Sum>k\<le>n. real (n + 2 choose (k + 2)) * bernoulli (n - k))"
proof -
  have "bernoulli (Suc n) = - 1 / (real n + 2) * (\<Sum>k\<le>n. real (n + 2 choose k) * bernoulli k)"
    unfolding bernoulli.simps ..
  also have "(\<Sum>k\<le>n. real (n + 2 choose k) * bernoulli k) =
               (\<Sum>k\<le>n. real (n + 2 choose (n - k)) * bernoulli (n - k))"
    by (rule sum.reindex_bij_witness[of _ "\<lambda>k. n - k" "\<lambda>k. n - k"]) simp_all
  also have "\<dots> = (\<Sum>k\<le>n. real (n + 2 choose (k + 2)) * bernoulli (n - k))"
    by (intro sum.cong refl, subst binomial_symmetric) simp_all
  finally show ?thesis .
qed

subsection \<open>Basic Observations on Bernoulli Polynomials\<close>

lemma bernpoly_0 [simp]: "bernpoly n 0 = (of_real (bernoulli n) :: 'a :: real_algebra_1)"
proof (cases n)
  case 0
  then show "bernpoly n 0 = of_real (bernoulli n)"
    unfolding bernpoly_def bernoulli.simps by auto
next
  case (Suc n')
  have "(\<Sum>k\<le>n'. of_nat (Suc n' choose k) * of_real (bernoulli k) * 0 ^ (Suc n' - k)) = (0::'a)"
  proof (intro sum.neutral ballI)
    fix k assume "k \<in> {..n'}"
    thus "of_nat (Suc n' choose k) * of_real (bernoulli k) * (0::'a) ^ (Suc n' - k) = 0"
      by (cases "Suc n' - k") auto
  qed
  with Suc show ?thesis
    unfolding bernpoly_def by simp
qed

lemma continuous_on_bernpoly [continuous_intros]:
  "continuous_on A (bernpoly n :: 'a \<Rightarrow> 'a :: real_normed_algebra_1)"
  unfolding bernpoly_def by (auto intro!: continuous_intros)

lemma isCont_bernpoly [continuous_intros]:
  "isCont (bernpoly n :: 'a \<Rightarrow> 'a :: real_normed_algebra_1) x"
  unfolding bernpoly_def by (auto intro!: continuous_intros)

lemma has_field_derivative_bernpoly:
  "(bernpoly (Suc n) has_field_derivative
     (of_nat (n + 1) * bernpoly n x :: 'a :: real_normed_field)) (at x)"
proof -
  have "(bernpoly (Suc n) has_field_derivative
          (\<Sum>k\<le>n. of_nat (Suc n - k) * x ^ (n - k) * (of_nat (Suc n choose k) *
            of_real (bernoulli k)))) (at x)" (is "(_ has_field_derivative ?D) _")
    unfolding bernpoly_def by (rule DERIV_cong) (fast intro!: derivative_intros, simp)
  also have "?D = of_nat (n + 1) * bernpoly n x" unfolding bernpoly_def
    by (subst sum_distrib_left, intro sum.cong refl, subst of_nat_binomial_Suc) simp_all
  ultimately show ?thesis by (auto simp del: of_nat_Suc One_nat_def)
qed

lemmas has_field_derivative_bernpoly' [derivative_intros] =
  DERIV_chain'[OF _ has_field_derivative_bernpoly]

lemma sum_binomial_times_bernoulli:
  "(\<Sum>k\<le>n. ((Suc n) choose k) * bernoulli k) = (if n = 0 then 1 else 0)"
proof (cases n)
  case (Suc m)
  then show ?thesis
    by (simp add: bernoulli_Suc)
       (simp add: field_simps add_2_eq_Suc'[symmetric] del: add_2_eq_Suc add_2_eq_Suc')
qed simp_all

lemma sum_binomial_times_bernoulli':
  "(\<Sum>k<n. real (n choose k) * bernoulli k) = (if n = 1 then 1 else 0)"
proof (cases n)
  case (Suc m)
  have "(\<Sum>k<n. real (n choose k) * bernoulli k) =
           (\<Sum>k\<le>m. real (Suc m choose k) * bernoulli k)"
    unfolding Suc lessThan_Suc_atMost ..
  also have "\<dots> = (if n = 1 then 1 else 0)"
    by (subst sum_binomial_times_bernoulli) (simp add: Suc)
  finally show ?thesis .
qed simp_all

lemma binomial_unroll:
  "n > 0 \<Longrightarrow> (n choose k) = (if k = 0 then 1 else (n - 1) choose (k - 1) + ((n - 1) choose k))"
  by (auto simp add: gr0_conv_Suc)

lemma sum_unroll:
  "(\<Sum>k\<le>n::nat. f k) = (if n = 0 then f 0 else f n + (\<Sum>k\<le>n - 1. f k))"
  by (cases n) (simp_all add: add_ac)

lemma bernoulli_unroll:
  "n > 0 \<Longrightarrow> bernoulli n = - 1 / (real n + 1) * (\<Sum>k\<le>n - 1. real (n + 1 choose k) * bernoulli k)"
by (cases n) (simp add: bernoulli_Suc)+

lemmas bernoulli_unroll_all = binomial_unroll bernoulli_unroll sum_unroll bernpoly_def

lemma bernpoly_1_1: "bernpoly 1 1 = of_real (1/2)"
proof -
  have *: "(1 :: 'a) = of_real 1" by simp
  have "bernpoly 1 (1::'a) = 1 - of_real (1 / 2)"
    by (simp add: bernoulli_unroll_all)
  also have "\<dots> = of_real (1 - 1 / 2)"
    by (simp only: *  of_real_diff)
  also have "1 - 1 / 2 = (1 / 2 :: real)"
    by simp
  finally show ?thesis .
qed

subsection \<open>Sum of Powers with Bernoulli Polynomials\<close>

(* TODO: Generalisation not possible here because mean-value theorem
   is only available for reals *)
lemma diff_bernpoly:
  fixes x :: real
  shows "bernpoly n (x + 1) - bernpoly n x = of_nat n * x ^ (n - 1)"
proof (induct n arbitrary: x)
  case 0
  show ?case unfolding bernpoly_def by auto
next
  case (Suc n)
  have "bernpoly (Suc n) (0 + 1) - bernpoly (Suc n) (0 :: real) =
          (\<Sum>k\<le>n. of_real (real (Suc n choose k) * bernoulli k))"
    unfolding bernpoly_0 unfolding bernpoly_def by simp
  also have "\<dots> = of_nat (Suc n) * 0 ^ n"
    by (simp only: of_real_sum [symmetric] sum_binomial_times_bernoulli) simp
  finally have const: "bernpoly (Suc n) (0 + 1) - bernpoly (Suc n) 0 = \<dots>"
    by simp

  have hyps': "of_nat (Suc n) * bernpoly n (x + 1) -
                  of_nat (Suc n) * bernpoly n x =
                  of_nat n * of_nat (Suc n) * x ^ (n - Suc 0)" for x :: real
    unfolding right_diff_distrib[symmetric]
    by (subst Suc) (simp_all add: algebra_simps)
  have "((\<lambda>x. bernpoly (Suc n) (x + 1) - bernpoly (Suc n) x - of_nat (Suc n) * x ^ n)
           has_field_derivative 0) (at x)" for x :: real
    by (rule derivative_eq_intros refl)+ (insert hyps'[of x], simp add: algebra_simps)
  from integrals_eq[OF const this] show ?case by simp
qed

lemma bernpoly_of_real: "bernpoly n (of_real x) = of_real (bernpoly n x)"
  by (simp add: bernpoly_def)

lemma bernpoly_1:
  assumes "n \<noteq> 1"
  shows   "bernpoly n 1 = of_real (bernoulli n)"
proof -
  have "bernpoly n 1 = bernoulli n"
  proof (cases "n \<ge> 2")
    case False
    with assms have "n = 0" by auto
    thus ?thesis by (simp add: bernpoly_def)
  next
    case True
    with diff_bernpoly[of n 0] show ?thesis
      by (simp add: power_0_left bernpoly_0)
  qed
  hence "bernpoly n (of_real 1) = of_real (bernoulli n)"
    by (simp only: bernpoly_of_real)
  thus ?thesis by simp
qed

lemma bernpoly_1': "bernpoly n 1 = of_real (bernoulli' n)"
  using bernpoly_1_1 [where ?'a = 'a]
  by (cases "n = 1") (simp_all add: bernpoly_1 bernoulli'_def)

theorem sum_of_powers:
  "(\<Sum>k\<le>n::nat. (real k) ^ m) = (bernpoly (Suc m) (n + 1) - bernpoly (Suc m) 0) / (m + 1)"
proof -
  from diff_bernpoly[of "Suc m", simplified] have "(m + (1::real)) * (\<Sum>k\<le>n. (real k) ^ m) = (\<Sum>k\<le>n. bernpoly (Suc m) (real k + 1) - bernpoly (Suc m) (real k))"
    by (auto simp add: sum_distrib_left intro!: sum.cong)
  also have "... = (\<Sum>k\<le>n. bernpoly (Suc m) (real (k + 1)) - bernpoly (Suc m) (real k))"
    by (simp add: add_ac)
  also have "... = bernpoly (Suc m) (n + 1) - bernpoly (Suc m) 0"
    by (simp only: sum_diff[where f="\<lambda>k. bernpoly (Suc m) (real k)"]) simp
  finally show ?thesis by (auto simp add: field_simps intro!: eq_divide_imp)
qed

subsection \<open>Instances for Square And Cubic Numbers\<close>

theorem sum_of_squares: "real (\<Sum>k\<le>n::nat. k ^ 2) = real (2 * n ^ 3 + 3 * n ^ 2 + n) / 6"
  by (simp only: of_nat_sum of_nat_power sum_of_powers)
     (simp add: bernoulli_unroll_all field_simps power2_eq_square power_numeral_reduce)

corollary sum_of_squares_nat: "(\<Sum>k\<le>n::nat. k ^ 2) = (2 * n ^ 3 + 3 * n ^ 2 + n) div 6"
  by (rule sum_of_powers_nat_aux[OF sum_of_squares]) simp_all

theorem sum_of_cubes: "real (\<Sum>k\<le>n::nat. k ^ 3) = real (n ^ 2 + n) ^ 2 / 4"
  by (simp only: of_nat_sum of_nat_power sum_of_powers)
     (simp add: bernoulli_unroll_all field_simps power2_eq_square power_numeral_reduce)

corollary sum_of_cubes_nat: "(\<Sum>k\<le>n::nat. k ^ 3) = (n ^ 2 + n) ^ 2 div 4"
  by (rule sum_of_powers_nat_aux[OF sum_of_cubes]) simp_all

end


(* Author: Andreas Lochbihler, ETH Zurich *)

theory Rel_PMF_Characterisation imports
  Matrix_For_Marginals
begin

section \<open>Characterisation of @{const rel_pmf}\<close>

proposition rel_pmf_measureI:
  fixes p :: "'a pmf" and q :: "'b pmf"
  assumes le: "\<And>A. measure (measure_pmf p) A \<le> measure (measure_pmf q) {y. \<exists>x\<in>A. R x y}"
  shows "rel_pmf R p q"
proof -
  let ?A = "set_pmf p" and ?f = "\<lambda>x. ennreal (pmf p x)"
    and ?B = "set_pmf q" and ?g = "\<lambda>y. ennreal (pmf q y)"
  define R' where "R' = {(x, y)\<in>?A \<times> ?B. R x y}"

  have "(\<Sum>\<^sup>+ x\<in>?A. ?f x) = (\<Sum>\<^sup>+ y\<in>?B. ?g y)" (is "?lhs = ?rhs")
    and "(\<Sum>\<^sup>+ y\<in>?B. ?g y) \<noteq> \<top>" (is ?bounded)
  proof -
    have "?lhs = (\<Sum>\<^sup>+ x. ?f x)" "?rhs = (\<Sum>\<^sup>+ y. ?g y)"
      by(auto simp add: nn_integral_count_space_indicator pmf_eq_0_set_pmf intro!: nn_integral_cong split: split_indicator)
    then show "?lhs = ?rhs" ?bounded by(simp_all add: nn_integral_pmf_eq_1)
  qed
  moreover
  have "(\<Sum>\<^sup>+ x\<in>X. ?f x) \<le> (\<Sum>\<^sup>+ y\<in>R' `` X. ?g y)" (is "?lhs \<le> ?rhs") if "X \<subseteq> set_pmf p" for X
  proof -
    have "?lhs = measure (measure_pmf p) X"
      by(simp add: nn_integral_pmf measure_pmf.emeasure_eq_measure)
    also have "\<dots> \<le> measure (measure_pmf q) {y. \<exists>x\<in>X. R x y}" by(simp add: le)
    also have "\<dots> = measure (measure_pmf q) (R' `` X)" using that
      by(auto 4 3 simp add: R'_def AE_measure_pmf_iff intro!: measure_eq_AE)
    also have "\<dots> = ?rhs" by(simp add: nn_integral_pmf measure_pmf.emeasure_eq_measure)
    finally show ?thesis .
  qed
  moreover have "countable ?A" "countable ?B" by simp_all
  moreover have "R' \<subseteq> ?A \<times> ?B" by(auto simp add: R'_def)
  ultimately obtain h
    where supp: "\<And>x y. 0 < h x y \<Longrightarrow> (x, y) \<in> R'"
    and bound: "\<And>x y. h x y \<noteq> \<top>"
    and p: "\<And>x. x \<in> ?A \<Longrightarrow> (\<Sum>\<^sup>+ y\<in>?B. h x y) = ?f x"
    and q: "\<And>y. y \<in> ?B \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>?A. h x y) = ?g y"
    by(rule bounded_matrix_for_marginals_ennreal) blast+

  let ?z = "\<lambda>(x, y). enn2real (h x y)"
  define z where "z = embed_pmf ?z"
  have nonneg: "\<And>xy. 0 \<le> ?z xy" by clarsimp
  have outside: "h x y = 0" if "x \<notin> set_pmf p \<or> y \<notin> set_pmf q \<or> \<not> R x y" for x y
    using supp[of x y] that by(cases "h x y > 0")(auto simp add: R'_def)
  have prob: "(\<Sum>\<^sup>+ xy. ?z xy) = 1"
  proof -
    have "(\<Sum>\<^sup>+ xy. ?z xy) = (\<Sum>\<^sup>+ x. \<Sum>\<^sup>+ y. (ennreal \<circ> ?z) (x, y))"
      unfolding nn_integral_fst_count_space by(simp add: split_def o_def)
    also have "\<dots> = (\<Sum>\<^sup>+ x. (\<Sum>\<^sup>+y. h x y))" using bound
      by(simp add: nn_integral_count_space_reindex ennreal_enn2real_if)
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>?A. (\<Sum>\<^sup>+y\<in>?B. h x y))"
      by(auto intro!: nn_integral_cong nn_integral_zero' simp add: nn_integral_count_space_indicator outside split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>?A. ?f x)" by(auto simp add: p intro!: nn_integral_cong)
    also have "\<dots> = (\<Sum>\<^sup>+ x. ?f x)"
      by(auto simp add: nn_integral_count_space_indicator pmf_eq_0_set_pmf intro!: nn_integral_cong split: split_indicator)
    finally show ?thesis by(simp add: nn_integral_pmf_eq_1)
  qed
  note z = nonneg prob
  have z_sel [simp]: "pmf z (x, y) = enn2real (h x y)" for x y
    by(simp add: z_def pmf_embed_pmf[OF z])

  show ?thesis
  proof
    show "R x y" if "(x, y) \<in> set_pmf z" for x y using that
      using that outside[of x y] unfolding set_pmf_iff
      by(auto simp add: enn2real_eq_0_iff)

    show "map_pmf fst z = p"
    proof(rule pmf_eqI)
      fix x
      have "pmf (map_pmf fst z) x = (\<Sum>\<^sup>+ e\<in>range (Pair x). pmf z e)"
        by(auto simp add: ennreal_pmf_map nn_integral_measure_pmf nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ y. h x y)"
        using bound by(simp add: nn_integral_count_space_reindex ennreal_enn2real_if)
      also have "\<dots> = (\<Sum>\<^sup>+y\<in>?B. h x y)" using outside
        by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = ?f x" using p[of x] apply(cases "x \<in> set_pmf p")
        by(auto simp add: set_pmf_iff AE_count_space outside intro!: nn_integral_zero')
      finally show "pmf (map_pmf fst z) x = pmf p x" by simp
    qed

    show "map_pmf snd z = q"
    proof(rule pmf_eqI)
      fix y
      have "pmf (map_pmf snd z) y = (\<Sum>\<^sup>+ e\<in>range (\<lambda>x. (x, y)). pmf z e)"
        by(auto simp add: ennreal_pmf_map nn_integral_measure_pmf nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ x. h x y)"
        using bound by(simp add: nn_integral_count_space_reindex ennreal_enn2real_if)
      also have "\<dots> = (\<Sum>\<^sup>+x\<in>?A. h x y)" using outside
        by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = ?g y" using q[of y] apply(cases "y \<in> set_pmf q")
        by(auto simp add: set_pmf_iff AE_count_space outside intro!: nn_integral_zero')
      finally show "pmf (map_pmf snd z) y = pmf q y" by simp
    qed
  qed
qed

corollary rel_pmf_distr_mono: "rel_pmf R OO rel_pmf S \<le> rel_pmf (R OO S)"
\<comment> \<open>This fact has already been proven for the registration of @{typ "'a pmf"} as a BNF,
  but this proof is much shorter and more elegant. See @{cite HoelzlLochbihlerTraytel2015ITP} for a
  comparison of formalisations.\<close>
proof(intro le_funI le_boolI rel_pmf_measureI, elim relcomppE)
  fix p q r A
  assume pq: "rel_pmf R p q" and qr: "rel_pmf S q r"
  have "measure (measure_pmf p) A \<le> measure (measure_pmf q) {y. \<exists>x\<in>A. R x y}"
    (is "_ \<le> measure _ ?B") using pq by(rule rel_pmf_measureD)
  also have "\<dots> \<le> measure (measure_pmf r) {z. \<exists>y\<in>?B. S y z}"
    using qr by(rule rel_pmf_measureD)
  also have "{z. \<exists>y\<in>?B. S y z} = {z. \<exists>x\<in>A. (R OO S) x z}" by auto
  finally show "measure (measure_pmf p) A \<le> measure (measure_pmf r) \<dots>" .
qed

subsection \<open>Code generation for @{const rel_pmf}\<close>

proposition rel_pmf_measureI':
  fixes p :: "'a pmf" and q :: "'b pmf"
  assumes le: "\<And>A. A \<subseteq> set_pmf p \<Longrightarrow> measure_pmf.prob p A \<le> measure_pmf.prob q {y \<in> set_pmf q. \<exists>x\<in>A. R x y}"
  shows "rel_pmf R p q"
proof(rule rel_pmf_measureI)
  fix A
  let ?A = "A \<inter> set_pmf p"
  have "measure_pmf.prob p A = measure_pmf.prob p ?A" by(simp add: measure_Int_set_pmf)
  also have "\<dots> \<le> measure_pmf.prob q {y \<in> set_pmf q. \<exists>x\<in>?A. R x y}" by(rule le) simp
  also have "\<dots> \<le> measure_pmf.prob q {y. \<exists>x\<in>A. R x y}"
    by(rule measure_pmf.finite_measure_mono) auto
  finally show "measure_pmf.prob p A \<le> \<dots>" .
qed

lemma rel_pmf_code [code]:
  "rel_pmf R p q \<longleftrightarrow>
   (let B = set_pmf q in
    \<forall>A\<in>Pow (set_pmf p). measure_pmf.prob p A \<le> measure_pmf.prob q (snd ` Set.filter (case_prod R) (A \<times> B)))"
  unfolding Let_def
proof(intro iffI strip)
  have eq: "snd ` Set.filter (case_prod R) (A \<times> set_pmf q) = {y. \<exists>x\<in>A. R x y} \<inter> set_pmf q" for A
    by(auto intro: rev_image_eqI simp add: Set.filter_def)
  show "measure_pmf.prob p A \<le> measure_pmf.prob q (snd ` Set.filter (case_prod R) (A \<times> set_pmf q))"
    if "rel_pmf R p q" and "A \<in> Pow (set_pmf p)" for A
    using that by(auto dest: rel_pmf_measureD simp add: eq measure_Int_set_pmf)
  show "rel_pmf R p q" if "\<forall>A\<in>Pow (set_pmf p). measure_pmf.prob p A \<le> measure_pmf.prob q (snd ` Set.filter (case_prod R) (A \<times> set_pmf q))"
    using that by(intro rel_pmf_measureI')(auto intro: ord_le_eq_trans arg_cong2[where f=measure] simp add: eq)
qed

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.*)
  theory TIP_sort_nat_NMSortTDPermutes
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "Nat => Nat" where
  "nmsorttdhalf1 x =
   (if (x = (S Z)) then Z else
      (case x of
         Z => Z
         | S y => plus (S Z) (nmsorttdhalf1 (minus x (S (S Z))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
  "take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

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

fun drop :: "Nat => 'a list => 'a list" where
  "drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function nmsorttd :: "Nat list => Nat list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (nmsorttd xs) xs"
  oops

end


(*  Based on HOL/Real_Vector_Spaces.thy by Brian Huffman
    Adapted to the complex case by Dominique Unruh *)

section \<open>\<open>Complex_Inner_Product0\<close> -- Inner Product Spaces and Gradient Derivative\<close>

theory Complex_Inner_Product0
  imports
    Complex_Main Complex_Vector_Spaces
    "HOL-Analysis.Inner_Product"
    "Complex_Bounded_Operators.Extra_Ordered_Fields"
begin

subsection \<open>Complex inner product spaces\<close>

text \<open>
  Temporarily relax type constraints for \<^term>\<open>open\<close>, \<^term>\<open>uniformity\<close>,
  \<^term>\<open>dist\<close>, and \<^term>\<open>norm\<close>.
\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>open\<close>, SOME \<^typ>\<open>'a::open set \<Rightarrow> bool\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>dist\<close>, SOME \<^typ>\<open>'a::dist \<Rightarrow> 'a \<Rightarrow> real\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>uniformity\<close>, SOME \<^typ>\<open>('a::uniformity \<times> 'a) filter\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>norm\<close>, SOME \<^typ>\<open>'a::norm \<Rightarrow> real\<close>)\<close>

class complex_inner = complex_vector + sgn_div_norm + dist_norm + uniformity_dist + open_uniformity +
  fixes cinner :: "'a \<Rightarrow> 'a \<Rightarrow> complex"
  assumes cinner_commute: "cinner x y = cnj (cinner y x)"
    and cinner_add_left: "cinner (x + y) z = cinner x z + cinner y z"
    and cinner_scaleC_left [simp]: "cinner (scaleC r x) y = (cnj r) * (cinner x y)"
    and cinner_ge_zero [simp]: "0 \<le> cinner x x"
    and cinner_eq_zero_iff [simp]: "cinner x x = 0 \<longleftrightarrow> x = 0"
    and norm_eq_sqrt_cinner: "norm x = sqrt (cmod (cinner x x))"
begin

lemma cinner_zero_left [simp]: "cinner 0 x = 0"
  using cinner_add_left [of 0 0 x] by simp

lemma cinner_minus_left [simp]: "cinner (- x) y = - cinner x y"
  using cinner_add_left [of x "- x" y]
  by (simp add: group_add_class.add_eq_0_iff)

lemma cinner_diff_left: "cinner (x - y) z = cinner x z - cinner y z"
  using cinner_add_left [of x "- y" z] by simp

lemma cinner_sum_left: "cinner (\<Sum>x\<in>A. f x) y = (\<Sum>x\<in>A. cinner (f x) y)"
  by (cases "finite A", induct set: finite, simp_all add: cinner_add_left)

lemma call_zero_iff [simp]: "(\<forall>u. cinner x u = 0) \<longleftrightarrow> (x = 0)"
  by auto (use cinner_eq_zero_iff in blast)

text \<open>Transfer distributivity rules to right argument.\<close>

lemma cinner_add_right: "cinner x (y + z) = cinner x y + cinner x z"
  using cinner_add_left [of y z x]
  by (metis complex_cnj_add local.cinner_commute)

lemma cinner_scaleC_right [simp]: "cinner x (scaleC r y) = r * (cinner x y)"
  using cinner_scaleC_left [of r y x]
  by (metis complex_cnj_cnj complex_cnj_mult local.cinner_commute)

lemma cinner_zero_right [simp]: "cinner x 0 = 0"
  using cinner_zero_left [of x]
  by (metis (mono_tags, opaque_lifting) complex_cnj_zero local.cinner_commute)

lemma cinner_minus_right [simp]: "cinner x (- y) = - cinner x y"
  using cinner_minus_left [of y x]
  by (metis complex_cnj_minus local.cinner_commute)

lemma cinner_diff_right: "cinner x (y - z) = cinner x y - cinner x z"
  using cinner_diff_left [of y z x]
  by (metis complex_cnj_diff local.cinner_commute)

lemma cinner_sum_right: "cinner x (\<Sum>y\<in>A. f y) = (\<Sum>y\<in>A. cinner x (f y))"
proof (subst cinner_commute)
  have "(\<Sum>y\<in>A. cinner (f y) x) = (\<Sum>y\<in>A. cinner (f y) x)"
    by blast
  hence "cnj (\<Sum>y\<in>A. cinner (f y) x) = cnj (\<Sum>y\<in>A. (cinner (f y) x))"
    by simp
  hence "cnj (cinner (sum f A) x) = (\<Sum>y\<in>A. cnj (cinner (f y) x))"
    by (simp add: cinner_sum_left)
  thus "cnj (cinner (sum f A) x) = (\<Sum>y\<in>A. (cinner x (f y)))"
    by (subst (2) cinner_commute)
qed

lemmas cinner_add [algebra_simps] = cinner_add_left cinner_add_right
lemmas cinner_diff [algebra_simps]  = cinner_diff_left cinner_diff_right
lemmas cinner_scaleC = cinner_scaleC_left cinner_scaleC_right

(* text \<open>Legacy theorem names\<close>
lemmas cinner_left_distrib = cinner_add_left
lemmas cinner_right_distrib = cinner_add_right
lemmas cinner_distrib = cinner_left_distrib cinner_right_distrib *)

lemma cinner_gt_zero_iff [simp]: "0 < cinner x x \<longleftrightarrow> x \<noteq> 0"
  by (smt (verit) less_irrefl local.cinner_eq_zero_iff local.cinner_ge_zero order.not_eq_order_implies_strict)

(* In Inner_Product, we have
  lemma power2_norm_eq_cinner: "(norm x)\<^sup>2 = cinner x x"
The following are two ways of inserting the conversions between real and complex into this:
*)

lemma power2_norm_eq_cinner:
  shows "(complex_of_real (norm x))\<^sup>2 = (cinner x x)"
  by (smt (verit, del_insts) Im_complex_of_real Re_complex_of_real cinner_gt_zero_iff cinner_zero_right cmod_def complex_eq_0 complex_eq_iff less_complex_def local.norm_eq_sqrt_cinner of_real_power real_sqrt_abs real_sqrt_pow2_iff zero_complex.sel(1))

lemma power2_norm_eq_cinner':
  shows "(norm x)\<^sup>2 = Re (cinner x x)"
  by (metis Re_complex_of_real of_real_power power2_norm_eq_cinner)

text \<open>Identities involving real multiplication and division.\<close>

lemma cinner_mult_left: "cinner (of_complex m * a) b = cnj m * (cinner a b)"
  by (simp add: of_complex_def)

lemma cinner_mult_right: "cinner a (of_complex m * b) = m * (cinner a b)"
  by (metis complex_inner_class.cinner_scaleC_right scaleC_conv_of_complex)

lemma cinner_mult_left': "cinner (a * of_complex m) b = cnj m * (cinner a b)"
  by (metis cinner_mult_left mult.right_neutral mult_scaleC_right scaleC_conv_of_complex)

lemma cinner_mult_right': "cinner a (b * of_complex m) = (cinner a b) * m"
  by (simp add: complex_inner_class.cinner_scaleC_right of_complex_def)

(* In Inner_Product, we have

lemma Cauchy_Schwarz_ineq:
  "(cinner x y) * (cinner y x) \<le> cinner x x * cinner y y"
proof (cases)
  assume "y = 0"
  thus ?thesis by simp
next
  assume y: "y \<noteq> 0"
  have [simp]: "cnj (cinner y y) = cinner y y" for y
    by (metis cinner_commute)
  define r where "r = cnj (cinner x y) / cinner y y"
  have "0 \<le> cinner (x - scaleC r y) (x - scaleC r y)"
    by (rule cinner_ge_zero)
  also have "\<dots> = cinner x x - r * cinner x y - cnj r * cinner y x + r * cnj r * cinner y y"
    unfolding cinner_diff_left cinner_diff_right cinner_scaleC_left cinner_scaleC_right
    by (smt (z3) cancel_comm_monoid_add_class.diff_cancel cancel_comm_monoid_add_class.diff_zero complex_cnj_divide group_add_class.diff_add_cancel local.cinner_commute local.cinner_eq_zero_iff local.cinner_scaleC_left mult.assoc mult.commute mult_eq_0_iff nonzero_eq_divide_eq r_def y)
  also have "\<dots> = cinner x x - cinner y x * cnj r"
    unfolding r_def by auto
  also have "\<dots> = cinner x x - cinner x y * cnj (cinner x y) / cinner y y"
    unfolding r_def
    by (metis complex_cnj_divide local.cinner_commute mult.commute times_divide_eq_left)
  finally have "0 \<le> cinner x x - cinner x y * cnj (cinner x y) / cinner y y" .
  hence "cinner x y * cnj (cinner x y) / cinner y y \<le> cinner x x"
    by (simp add: le_diff_eq)
  thus "cinner x y * cinner y x \<le> cinner x x * cinner y y"
    by (metis cinner_gt_zero_iff local.cinner_commute nice_ordered_field_class.pos_divide_le_eq y)
qed

lemma Cauchy_Schwarz_ineq2:
  shows "norm (cinner x y) \<le> norm x * norm y"
proof (rule power2_le_imp_le)
  have "(norm (cinner x y))^2 = Re (cinner x y * cinner y x)"
    by (metis (full_types) Re_complex_of_real complex_norm_square local.cinner_commute)
  also have "\<dots> \<le> Re (cinner x x * cinner y y)"
    using Cauchy_Schwarz_ineq by (rule Re_mono)
  also have "\<dots> = Re (complex_of_real ((norm x)^2) * complex_of_real ((norm y)^2))"
    by (simp add: power2_norm_eq_cinner)
  also have "\<dots> = (norm x * norm y)\<^sup>2"
    by (simp add: power_mult_distrib)
  finally show "(cmod (cinner x y))^2 \<le> (norm x * norm y)\<^sup>2" .
  show "0 \<le> norm x * norm y"
    by (simp add: local.norm_eq_sqrt_cinner)
qed

(* The following variant does not hold in the complex case: *)
(* lemma norm_cauchy_schwarz: "cinner x y \<le> norm x * norm y"
  using Cauchy_Schwarz_ineq2 [of x y] by auto *)

subclass complex_normed_vector
proof
  fix a :: complex and r :: real and x y :: 'a
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_eq_sqrt_cinner by simp
  show "norm (x + y) \<le> norm x + norm y"
  proof (rule power2_le_imp_le)
    have "Re (cinner x y) \<le> cmod (cinner x y)"
      if "\<And>x. Re x \<le> cmod x" and
        "\<And>x y. x \<le> y \<Longrightarrow> complex_of_real x \<le> complex_of_real y"
      using that by simp
    hence a1: "2 * Re (cinner x y) \<le> 2 * cmod (cinner x y)"
      if "\<And>x. Re x \<le> cmod x" and
        "\<And>x y. x \<le> y \<Longrightarrow> complex_of_real x \<le> complex_of_real y"
      using that by simp
    have "cinner x y + cinner y x = complex_of_real (2 * Re (cinner x y))"
      by (metis complex_add_cnj local.cinner_commute)
    also have "\<dots> \<le> complex_of_real (2 * cmod (cinner x y))"
      using complex_Re_le_cmod complex_of_real_mono a1
      by blast
    also have "\<dots> = 2 * abs (cinner x y)"
      unfolding abs_complex_def by simp
    also have "\<dots> \<le> 2 * complex_of_real (norm x) * complex_of_real (norm y)"
      using Cauchy_Schwarz_ineq2 unfolding abs_complex_def less_eq_complex_def by auto
    finally have xyyx: "cinner x y + cinner y x \<le> complex_of_real (2 * norm x * norm y)"
      by auto
    have "complex_of_real ((norm (x + y))\<^sup>2) = cinner (x+y) (x+y)"
      by (simp add: power2_norm_eq_cinner)
    also have "\<dots> = cinner x x + cinner x y + cinner y x + cinner y y"
      by (simp add: cinner_add)
    also have "\<dots> = complex_of_real ((norm x)\<^sup>2) + complex_of_real ((norm y)\<^sup>2) + cinner x y + cinner y x"
      by (simp add: power2_norm_eq_cinner)
    also have "\<dots> \<le> complex_of_real ((norm x)\<^sup>2) + complex_of_real ((norm y)\<^sup>2) + complex_of_real (2 * norm x * norm y)"
      using xyyx by auto
    also have "\<dots> = complex_of_real ((norm x + norm y)\<^sup>2)"
      unfolding power2_sum by auto
    finally show "(norm (x + y))\<^sup>2 \<le> (norm x + norm y)\<^sup>2"
      using complex_of_real_mono_iff by blast
    show "0 \<le> norm x + norm y"
      unfolding norm_eq_sqrt_cinner by simp
  qed
  show norm_scaleC: "norm (a *\<^sub>C x) = cmod a * norm x" for a
  proof (rule power2_eq_imp_eq)
    show "(norm (a *\<^sub>C x))\<^sup>2 = (cmod a * norm x)\<^sup>2"
      by (simp_all add: norm_eq_sqrt_cinner norm_mult power2_eq_square)
    show "0 \<le> norm (a *\<^sub>C x)"
      by (simp_all add: norm_eq_sqrt_cinner)
    show "0 \<le> cmod a * norm x"
      by (simp_all add: norm_eq_sqrt_cinner)
  qed
  show "norm (r *\<^sub>R x) = \<bar>r\<bar> * norm x"
    unfolding scaleR_scaleC norm_scaleC by auto
qed

end

(* Does not hold in the complex case *)
(* lemma csquare_bound_lemma:
  fixes x :: complex
  shows "x < (1 + x) * (1 + x)" *)

lemma csquare_continuous:
  fixes e :: real
  shows "e > 0 \<Longrightarrow> \<exists>d. 0 < d \<and> (\<forall>y. cmod (y - x) < d \<longrightarrow> cmod (y * y - x * x) < e)"
  using isCont_power[OF continuous_ident, of x, unfolded isCont_def LIM_eq, rule_format, of e 2]
  by (force simp add: power2_eq_square)

lemma cnorm_le: "norm x \<le> norm y \<longleftrightarrow> cinner x x \<le> cinner y y"
  by (smt (verit) complex_of_real_mono_iff norm_eq_sqrt_cinner norm_ge_zero of_real_power power2_norm_eq_cinner real_sqrt_le_mono real_sqrt_pow2)

lemma cnorm_lt: "norm x < norm y \<longleftrightarrow> cinner x x < cinner y y"
  by (meson cnorm_le less_le_not_le)

lemma cnorm_eq: "norm x = norm y \<longleftrightarrow> cinner x x = cinner y y"
  by (metis norm_eq_sqrt_cinner power2_norm_eq_cinner)

lemma cnorm_eq_1: "norm x = 1 \<longleftrightarrow> cinner x x = 1"
  by (metis cinner_ge_zero complex_of_real_cmod norm_eq_sqrt_cinner norm_one of_real_1 real_sqrt_eq_iff real_sqrt_one)

lemma cinner_divide_left:
  fixes a :: "'a :: {complex_inner,complex_div_algebra}"
  shows "cinner (a / of_complex m) b = (cinner a b) / cnj m"
  by (metis cinner_mult_left' complex_cnj_inverse divide_inverse mult.commute of_complex_inverse)

lemma cinner_divide_right:
  fixes a :: "'a :: {complex_inner,complex_div_algebra}"
  shows "cinner a (b / of_complex m) = (cinner a b) / m"
  by (metis cinner_mult_right' divide_inverse of_complex_inverse)

text \<open>
  Re-enable constraints for \<^term>\<open>open\<close>, \<^term>\<open>uniformity\<close>,
  \<^term>\<open>dist\<close>, and \<^term>\<open>norm\<close>.
\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>open\<close>, SOME \<^typ>\<open>'a::topological_space set \<Rightarrow> bool\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>uniformity\<close>, SOME \<^typ>\<open>('a::uniform_space \<times> 'a) filter\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>dist\<close>, SOME \<^typ>\<open>'a::metric_space \<Rightarrow> 'a \<Rightarrow> real\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>norm\<close>, SOME \<^typ>\<open>'a::real_normed_vector \<Rightarrow> real\<close>)\<close>

lemma bounded_sesquilinear_cinner:
  "bounded_sesquilinear (cinner::'a::complex_inner \<Rightarrow> 'a \<Rightarrow> complex)"
proof
  fix x y z :: 'a and r :: complex
  show "cinner (x + y) z = cinner x z + cinner y z"
    by (rule cinner_add_left)
  show "cinner x (y + z) = cinner x y + cinner x z"
    by (rule cinner_add_right)
  show "cinner (scaleC r x) y = scaleC (cnj r) (cinner x y)"
    unfolding complex_scaleC_def by (rule cinner_scaleC_left)
  show "cinner x (scaleC r y) = scaleC r (cinner x y)"
    unfolding complex_scaleC_def by (rule cinner_scaleC_right)
  have "\<forall>x y::'a. norm (cinner x y) \<le> norm x * norm y * 1"
    by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)
  thus "\<exists>K. \<forall>x y::'a. norm (cinner x y) \<le> norm x * norm y * K"
    by metis
qed

lemmas tendsto_cinner [tendsto_intros] =
  bounded_bilinear.tendsto [OF bounded_sesquilinear_cinner[THEN bounded_sesquilinear.bounded_bilinear]]

lemmas isCont_cinner [simp] =
  bounded_bilinear.isCont [OF bounded_sesquilinear_cinner[THEN bounded_sesquilinear.bounded_bilinear]]

lemmas has_derivative_cinner [derivative_intros] =
  bounded_bilinear.FDERIV [OF bounded_sesquilinear_cinner[THEN bounded_sesquilinear.bounded_bilinear]]

lemmas bounded_antilinear_cinner_left =
  bounded_sesquilinear.bounded_antilinear_left [OF bounded_sesquilinear_cinner]

lemmas bounded_clinear_cinner_right =
  bounded_sesquilinear.bounded_clinear_right [OF bounded_sesquilinear_cinner]

lemmas bounded_antilinear_cinner_left_comp = bounded_antilinear_cinner_left[THEN bounded_antilinear_o_bounded_clinear]

lemmas bounded_clinear_cinner_right_comp = bounded_clinear_cinner_right[THEN bounded_clinear_compose]

lemmas has_derivative_cinner_right [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_clinear_cinner_right[THEN bounded_clinear.bounded_linear]]

lemmas has_derivative_cinner_left [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_antilinear_cinner_left[THEN bounded_antilinear.bounded_linear]]

lemma differentiable_cinner [simp]:
  "f differentiable (at x within s) \<Longrightarrow> g differentiable at x within s \<Longrightarrow> (\<lambda>x. cinner (f x) (g x)) differentiable at x within s"
  unfolding differentiable_def by (blast intro: has_derivative_cinner)

subsection \<open>Class instances\<close>

instantiation complex :: complex_inner
begin

definition cinner_complex_def [simp]: "cinner x y = cnj x * y"

instance
proof
  fix x y z r :: complex
  show "cinner x y = cnj (cinner y x)"
    unfolding cinner_complex_def by auto
  show "cinner (x + y) z = cinner x z + cinner y z"
    unfolding cinner_complex_def
    by (simp add: ring_class.ring_distribs(2))
  show "cinner (scaleC r x) y = cnj r * cinner x y"
    unfolding cinner_complex_def complex_scaleC_def by simp
  show "0 \<le> cinner x x"
    by simp
  show "cinner x x = 0 \<longleftrightarrow> x = 0"
    unfolding cinner_complex_def by simp
  have "cmod (Complex x1 x2) = sqrt (cmod (cinner (Complex x1 x2) (Complex x1 x2)))"
    for x1 x2
    unfolding cinner_complex_def complex_cnj complex_mult complex_norm
    by (simp add: power2_eq_square)
  thus "norm x = sqrt (cmod (cinner x x))"
    by (cases x, hypsubst_thin)
qed

end

lemma
  shows complex_inner_1_left[simp]: "cinner 1 x = x"
    and complex_inner_1_right[simp]: "cinner x 1 = cnj x"
  by simp_all

(* No analogue to \<open>instantiation complex :: real_inner\<close> or to
lemma complex_inner_1 [simp]: "inner 1 x = Re x"
lemma complex_inner_1_right [simp]: "inner x 1 = Re x"
lemma complex_inner_i_left [simp]: "inner \<i> x = Im x"
lemma complex_inner_i_right [simp]: "inner x \<i> = Im x"
 *)

lemma cdot_square_norm: "cinner x x = complex_of_real ((norm x)\<^sup>2)"
  by (metis Im_complex_of_real Re_complex_of_real cinner_ge_zero complex_eq_iff less_eq_complex_def power2_norm_eq_cinner' zero_complex.simps(2))

lemma cnorm_eq_square: "norm x = a \<longleftrightarrow> 0 \<le> a \<and> cinner x x = complex_of_real (a\<^sup>2)"
  by (metis cdot_square_norm norm_ge_zero of_real_eq_iff power2_eq_iff_nonneg)

lemma cnorm_le_square: "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> cinner x x \<le> complex_of_real (a\<^sup>2)"
  by (smt (verit) cdot_square_norm complex_of_real_mono_iff norm_ge_zero power2_le_imp_le)

lemma cnorm_ge_square: "norm x \<ge> a \<longleftrightarrow> a \<le> 0 \<or> cinner x x \<ge> complex_of_real (a\<^sup>2)"
  by (smt (verit, best) antisym_conv cnorm_eq_square cnorm_le_square complex_of_real_nn_iff nn_comparable zero_le_power2)

lemma norm_lt_square: "norm x < a \<longleftrightarrow> 0 < a \<and> cinner x x < complex_of_real (a\<^sup>2)"
  by (meson cnorm_ge_square cnorm_le_square less_le_not_le)

lemma norm_gt_square: "norm x > a \<longleftrightarrow> a < 0 \<or> cinner x x > complex_of_real (a\<^sup>2)"
  by (smt (verit, ccfv_SIG) cdot_square_norm complex_of_real_strict_mono_iff norm_ge_zero power2_eq_imp_eq power_mono)

text\<open>Dot product in terms of the norm rather than conversely.\<close>

lemmas cinner_simps = cinner_add_left cinner_add_right cinner_diff_right cinner_diff_left
  cinner_scaleC_left cinner_scaleC_right

(* Analogue to both dot_norm and dot_norm_neg *)
lemma cdot_norm: "cinner x y = ((norm (x+y))\<^sup>2 - (norm (x-y))\<^sup>2 - \<i> * (norm (x + \<i> *\<^sub>C y))\<^sup>2 + \<i> * (norm (x - \<i> *\<^sub>C y))\<^sup>2) / 4"
  unfolding power2_norm_eq_cinner
  by (simp add: power2_norm_eq_cinner cinner_add_left cinner_add_right
      cinner_diff_left cinner_diff_right ring_distribs)

lemma of_complex_inner_1 [simp]:
  "cinner (of_complex x) (1 :: 'a :: {complex_inner, complex_normed_algebra_1}) = cnj x"
  by (metis Complex_Inner_Product0.complex_inner_1_right cinner_complex_def cinner_mult_left complex_cnj_one norm_one of_complex_def power2_norm_eq_cinner scaleC_conv_of_complex)

lemma summable_of_complex_iff:
  "summable (\<lambda>x. of_complex (f x) :: 'a :: {complex_normed_algebra_1,complex_inner}) \<longleftrightarrow> summable f"
proof
  assume *: "summable (\<lambda>x. of_complex (f x) :: 'a)"
  have "bounded_clinear (cinner (1::'a))"
    by (rule bounded_clinear_cinner_right)
  then interpret bounded_linear "\<lambda>x::'a. cinner 1 x"
    by (rule bounded_clinear.bounded_linear)
  from summable [OF *] show "summable f"
    apply (subst (asm) cinner_commute) by simp
next
  assume sum: "summable f"
  thus "summable (\<lambda>x. of_complex (f x) :: 'a)"
    by (rule summable_of_complex)
qed

subsection \<open>Gradient derivative\<close>

definition\<^marker>\<open>tag important\<close>
  cgderiv :: "['a::complex_inner \<Rightarrow> complex, 'a, 'a] \<Rightarrow> bool"
  ("(cGDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
  where
    (* Must be "cinner D" not "\<lambda>h. cinner h D", otherwise not even "cGDERIV id x :> 1" holds *)
    "cGDERIV f x :> D \<longleftrightarrow> FDERIV f x :> cinner D"

lemma cgderiv_deriv [simp]: "cGDERIV f x :> D \<longleftrightarrow> DERIV f x :> cnj D"
  by (simp only: cgderiv_def has_field_derivative_def cinner_complex_def[THEN ext])

lemma cGDERIV_DERIV_compose:
  assumes "cGDERIV f x :> df" and "DERIV g (f x) :> cnj dg"
  shows "cGDERIV (\<lambda>x. g (f x)) x :> scaleC dg df"
proof (insert assms)
  show "cGDERIV (\<lambda>x. g (f x)) x :> dg *\<^sub>C df"
    if "cGDERIV f x :> df"
      and "(g has_field_derivative cnj dg) (at (f x))"
    unfolding cgderiv_def has_field_derivative_def cinner_scaleC_left complex_cnj_cnj
    using that
    by (simp add: cgderiv_def has_derivative_compose has_field_derivative_imp_has_derivative)

qed

(* Not specific to complex/real *)
(* lemma has_derivative_subst: "\<lbrakk>FDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> FDERIV f x :> d" *)

lemma cGDERIV_subst: "\<lbrakk>cGDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> cGDERIV f x :> d"
  by simp

lemma cGDERIV_const: "cGDERIV (\<lambda>x. k) x :> 0"
  unfolding cgderiv_def cinner_zero_left[THEN ext] by (rule has_derivative_const)

lemma cGDERIV_add:
  "\<lbrakk>cGDERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. f x + g x) x :> df + dg"
  unfolding cgderiv_def cinner_add_left[THEN ext] by (rule has_derivative_add)

lemma cGDERIV_minus:
  "cGDERIV f x :> df \<Longrightarrow> cGDERIV (\<lambda>x. - f x) x :> - df"
  unfolding cgderiv_def cinner_minus_left[THEN ext] by (rule has_derivative_minus)

lemma cGDERIV_diff:
  "\<lbrakk>cGDERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. f x - g x) x :> df - dg"
  unfolding cgderiv_def cinner_diff_left by (rule has_derivative_diff)

lemma cGDERIV_scaleC:
  "\<lbrakk>DERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. scaleC (f x) (g x)) x
      :> (scaleC (cnj (f x)) dg + scaleC (cnj df) (cnj (g x)))"
  unfolding cgderiv_def has_field_derivative_def cinner_add_left cinner_scaleC_left
  apply (rule has_derivative_subst)
   apply (erule (1) has_derivative_scaleC)
  by (simp add: ac_simps)

lemma GDERIV_mult:
  "\<lbrakk>cGDERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. f x * g x) x :> cnj (f x) *\<^sub>C dg + cnj (g x) *\<^sub>C df"
  unfolding cgderiv_def
  apply (rule has_derivative_subst)
   apply (erule (1) has_derivative_mult)
  apply (rule ext)
  by (simp add: cinner_add ac_simps)

lemma cGDERIV_inverse:
  "\<lbrakk>cGDERIV f x :> df; f x \<noteq> 0\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. inverse (f x)) x :> - cnj ((inverse (f x))\<^sup>2) *\<^sub>C df"
  by (metis DERIV_inverse cGDERIV_DERIV_compose complex_cnj_cnj complex_cnj_minus numerals(2))

(* Don't know if this holds: *)
(* lemma cGDERIV_norm:
  assumes "x \<noteq> 0" shows "cGDERIV (\<lambda>x. norm x) x :> sgn x"
*)

lemma has_derivative_norm[derivative_intros]:
  fixes x :: "'a::complex_inner"
  assumes "x \<noteq> 0"
  shows "(norm has_derivative (\<lambda>h. Re (cinner (sgn x) h))) (at x)"
  thm has_derivative_norm
proof -
  have Re_pos: "0 < Re (cinner x x)"
    using assms
    by (metis Re_strict_mono cinner_gt_zero_iff zero_complex.simps(1))
  have Re_plus_Re: "Re (cinner x y) + Re (cinner y x) = 2 * Re (cinner x y)"
    for x y :: 'a
    by (metis cinner_commute cnj.simps(1) mult_2_right semiring_normalization_rules(7))
  have norm: "norm x = sqrt (Re (cinner x x))" for x :: 'a
    apply (subst norm_eq_sqrt_cinner, subst cmod_Re)
    using cinner_ge_zero by auto
  have v2:"((\<lambda>x. sqrt (Re (cinner x x))) has_derivative
          (\<lambda>xa. (Re (cinner x xa) + Re (cinner xa x)) * (inverse (sqrt (Re (cinner x x))) / 2))) (at x)"
    by (rule derivative_eq_intros | simp add: Re_pos)+
  have v1: "((\<lambda>x. sqrt (Re (cinner x x))) has_derivative (\<lambda>y. Re (cinner x y) / sqrt (Re (cinner x x)))) (at x)"
    if "((\<lambda>x. sqrt (Re (cinner x x))) has_derivative (\<lambda>xa. Re (cinner x xa) * inverse (sqrt (Re (cinner x x))))) (at x)"
    using that apply (subst divide_real_def)
    by simp
  have \<open>(norm has_derivative (\<lambda>y. Re (cinner x y) / norm x)) (at x)\<close>
    using v2
    apply (auto simp: Re_plus_Re norm [abs_def])
    using v1 by blast
  then show ?thesis
    by (auto simp: power2_eq_square sgn_div_norm scaleR_scaleC)
qed

bundle cinner_syntax begin
notation cinner (infix "\<bullet>\<^sub>C" 70)
end

bundle no_cinner_syntax begin
no_notation cinner (infix "\<bullet>\<^sub>C" 70)
end

end


section \<open>Auxiliaries\<close>

theory Term_Aux
  imports
    Subterm_and_Context
    "HOL-Library.Multiset"
begin

text \<open>
  This theory contains material about terms that is required for KBO,
  but does not belong to @{theory Knuth_Bendix_Order.Subterm_and_Context}.

  We plan to merge this material into the theory @{theory First_Order_Terms.Term}
  at some point.
\<close>

text \<open>The variables of a term as multiset.\<close>
fun vars_term_ms :: "('f, 'v) term \<Rightarrow> 'v multiset"
  where
    "vars_term_ms (Var x) = {#x#}" |
    "vars_term_ms (Fun f ts) = \<Union># (mset (map vars_term_ms ts))"

lemma vars_term_ms_subst [simp]:
  "vars_term_ms (t \<cdot> \<sigma>) =
    \<Union># (image_mset (\<lambda> x. vars_term_ms (\<sigma> x)) (vars_term_ms t))" (is "_ = ?V t")
proof (induct t)
  case (Fun f ts)
  have IH: "map (\<lambda> t. vars_term_ms (t \<cdot> \<sigma>)) ts = map (\<lambda> t. ?V t) ts"
    by (rule map_cong[OF refl Fun])
  show ?case by (simp add: o_def IH, induct ts, auto)
qed simp

lemma vars_term_ms_subst_mono:
  assumes "vars_term_ms s \<subseteq># vars_term_ms t"
  shows "vars_term_ms (s \<cdot> \<sigma>) \<subseteq># vars_term_ms (t \<cdot> \<sigma>)"
proof -
  from assms[unfolded mset_subset_eq_exists_conv] obtain u where t: "vars_term_ms t = vars_term_ms s + u" by auto
  show ?thesis unfolding vars_term_ms_subst unfolding t by auto
qed

lemma set_mset_vars_term_ms [simp]:
  "set_mset (vars_term_ms t) = vars_term t"
  by (induct t) auto

text \<open>A term is called \<^emph>\<open>ground\<close> if it does not contain any variables.\<close>
fun ground :: "('f, 'v) term \<Rightarrow> bool"
  where
    "ground (Var x) \<longleftrightarrow> False" |
    "ground (Fun f ts) \<longleftrightarrow> (\<forall>t \<in> set ts. ground t)"

lemma ground_vars_term_empty:
  "ground t \<longleftrightarrow> vars_term t = {}"
  by (induct t) simp_all

lemma ground_subst [simp]:
  "ground (t \<cdot> \<sigma>) \<longleftrightarrow> (\<forall>x \<in> vars_term t. ground (\<sigma> x))"
  by (induct t) simp_all

lemma ground_subst_apply:
  assumes "ground t"
  shows "t \<cdot> \<sigma> = t"
proof -
  have "t = t \<cdot> Var" by simp
  also have "\<dots> = t \<cdot> \<sigma>"
    by (rule term_subst_eq, insert assms[unfolded ground_vars_term_empty], auto)
  finally show ?thesis by simp
qed

text \<open>
  A \<^emph>\<open>signature\<close> is a set of function symbol/arity pairs, where the arity of a function symbol,
  denotes the number of arguments it expects.
\<close>
type_synonym 'f sig = "('f \<times> nat) set"

text \<open>The set of all function symbol/ arity pairs occurring in a term.\<close>
fun funas_term :: "('f, 'v) term \<Rightarrow> 'f sig"
  where
    "funas_term (Var _) = {}" |
    "funas_term (Fun f ts) = {(f, length ts)} \<union> \<Union>(set (map funas_term ts))"

lemma supt_imp_funas_term_subset:
  assumes "s \<rhd> t"
  shows "funas_term t \<subseteq> funas_term s"
  using assms by (induct) auto

lemma supteq_imp_funas_term_subset[simp]:
  assumes "s \<unrhd> t"
  shows "funas_term t \<subseteq> funas_term s"
  using assms by (induct) auto

text \<open>The set of all function symbol/arity pairs occurring in a context.\<close>
fun funas_ctxt :: "('f, 'v) ctxt \<Rightarrow> 'f sig"
  where
    "funas_ctxt Hole = {}" |
    "funas_ctxt (More f ss1 D ss2) = {(f, Suc (length (ss1 @ ss2)))}
     \<union> funas_ctxt D \<union> \<Union>(set (map funas_term (ss1 @ ss2)))"

lemma funas_term_ctxt_apply [simp]:
  "funas_term (C\<langle>t\<rangle>) = funas_ctxt C \<union> funas_term t"
proof (induct t)
  case (Var x) show ?case by (induct C) auto
next
  case (Fun f ts) show ?case by (induct C arbitrary: f ts) auto
qed

lemma funas_term_subst:
  "funas_term (t \<cdot> \<sigma>) = funas_term t \<union> \<Union>(funas_term ` \<sigma> ` vars_term t)"
  by (induct t) auto

lemma funas_ctxt_compose [simp]:
  "funas_ctxt (C \<circ>\<^sub>c D) = funas_ctxt C \<union> funas_ctxt D"
  by (induct C) auto

lemma funas_ctxt_subst [simp]:
  "funas_ctxt (C \<cdot>\<^sub>c \<sigma>) = funas_ctxt C \<union> \<Union>(funas_term ` \<sigma> ` vars_ctxt C)"
  by (induct C, auto simp: funas_term_subst)

end


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

Well-order embeddings.
*)

section \<open>Well-Order Embeddings\<close>

theory Wellorder_Embedding
  imports Fun_More Wellorder_Relation
begin

subsection \<open>Auxiliaries\<close>

lemma UNION_bij_betw_ofilter:
  assumes WELL: "Well_order r" and
    OF: "\<And> i. i \<in> I \<Longrightarrow> ofilter r (A i)" and
    BIJ: "\<And> i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
  shows "bij_betw f (\<Union>i \<in> I. A i) (\<Union>i \<in> I. A' i)"
proof-
  have "wo_rel r" using WELL by (simp add: wo_rel_def)
  hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i \<le> A j \<or> A j \<le> A i"
    using wo_rel.ofilter_linord[of r] OF by blast
  with WELL BIJ show ?thesis
    by (auto simp add: bij_betw_UNION_chain)
qed

subsection \<open>(Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
functions\<close>

lemma embed_halfcong:
  assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a" and "embed r r' f"
  shows "embed r r' g"
  by (smt (verit, del_insts) assms bij_betw_cong embed_def in_mono under_Field)

lemma embed_cong[fundef_cong]:
  assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
  shows "embed r r' f = embed r r' g"
  by (metis assms embed_halfcong)

lemma embedS_cong[fundef_cong]:
  assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
  shows "embedS r r' f = embedS r r' g"
  unfolding embedS_def using assms
    embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma iso_cong[fundef_cong]:
  assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
  shows "iso r r' f = iso r r' g"
  unfolding iso_def using assms
    embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma id_compat: "compat r r id"
  by(auto simp add: id_def compat_def)

lemma comp_compat:
  "\<lbrakk>compat r r' f; compat r' r'' f'\<rbrakk> \<Longrightarrow> compat r r'' (f' o f)"
  by(auto simp add: comp_def compat_def)

corollary one_set_greater:
  "(\<exists>f::'a \<Rightarrow> 'a'. f ` A \<le> A' \<and> inj_on f A) \<or> (\<exists>g::'a' \<Rightarrow> 'a. g ` A' \<le> A \<and> inj_on g A')"
proof-
  obtain r where "well_order_on A r" by (fastforce simp add: well_order_on)
  hence 1: "A = Field r \<and> Well_order r"
    using well_order_on_Well_order by auto
  obtain r' where 2: "well_order_on A' r'" by (fastforce simp add: well_order_on)
  hence 2: "A' = Field r' \<and> Well_order r'"
    using well_order_on_Well_order by auto
  hence "(\<exists>f. embed r r' f) \<or> (\<exists>g. embed r' r g)"
    using 1 2 by (auto simp add: wellorders_totally_ordered)
  moreover
  {fix f assume "embed r r' f"
    hence "f`A \<le> A' \<and> inj_on f A"
      using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  moreover
  {fix g assume "embed r' r g"
    hence "g`A' \<le> A \<and> inj_on g A'"
      using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  ultimately show ?thesis by blast
qed

corollary one_type_greater:
  "(\<exists>f::'a \<Rightarrow> 'a'. inj f) \<or> (\<exists>g::'a' \<Rightarrow> 'a. inj g)"
  using one_set_greater[of UNIV UNIV] by auto

subsection \<open>Uniqueness of embeddings\<close>

lemma comp_embedS:
  assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
    and  EMB: "embedS r r' f" and EMB': "embedS r' r'' f'"
  shows "embedS r r'' (f' o f)"
  using EMB EMB' WELL WELL' embedS_comp_embed embedS_def by blast

lemma iso_iff4:
  assumes WELL: "Well_order r"  and WELL': "Well_order r'"
  shows "iso r r' f = (embed r r' f \<and> embed r' r (inv_into (Field r) f))"
  using assms embed_bothWays_iso
  by(unfold iso_def, auto simp add: inv_into_Field_embed_bij_betw)

lemma embed_embedS_iso:
  "embed r r' f = (embedS r r' f \<or> iso r r' f)"
  unfolding embedS_def iso_def by blast

lemma not_embedS_iso:
  "\<not> (embedS r r' f \<and> iso r r' f)"
  unfolding embedS_def iso_def by blast

lemma embed_embedS_iff_not_iso:
  assumes "embed r r' f"
  shows "embedS r r' f = (\<not> iso r r' f)"
  using assms unfolding embedS_def iso_def by blast

lemma iso_inv_into:
  assumes WELL: "Well_order r" and ISO: "iso r r' f"
  shows "iso r' r (inv_into (Field r) f)"
  by (meson ISO WELL bij_betw_inv_into inv_into_Field_embed_bij_betw iso_def iso_iff iso_iff2)

lemma embedS_or_iso:
  assumes WELL: "Well_order r" and WELL': "Well_order r'"
  shows "(\<exists>g. embedS r r' g) \<or> (\<exists>h. embedS r' r h) \<or> (\<exists>f. iso r r' f)"
  by (metis WELL WELL' embed_embedS_iso embed_embedS_iso iso_iff4 wellorders_totally_ordered)

end