(*<*)
theory Code_Double
  imports IEEE_Floating_Point.IEEE_Properties
    IEEE_Floating_Point.Conversion_IEEE_Float
    "HOL-Library.Code_Target_Int"
    Containers.Collection_Eq
    Containers.Collection_Order
begin
(*>*)

section \<open>Code adaptation for IEEE double-precision floats\<close>

subsection \<open>copysign\<close>

lift_definition copysign :: "('e, 'f) float \<Rightarrow> ('e, 'f) float \<Rightarrow> ('e, 'f) float" is
  "\<lambda>(_, e::'e word, f::'f word) (s::1 word, _, _). (s, e, f)" .

subsection \<open>Additional lemmas about generic floats\<close>

lemma is_nan_some_nan[simp]: "is_nan (some_nan :: ('e, 'f) float)"
  unfolding some_nan_def
  by (rule someI[where x="Abs_float (0, -1, 1)"])
    (auto simp add: is_nan_def exponent_def fraction_def emax_def Abs_float_inverse[simplified])

lemma not_is_nan_0[simp]: "\<not> is_nan 0"
  unfolding is_nan_def by (simp add: zero_simps)

lemma not_is_nan_1[simp]: "\<not> is_nan 1"
  unfolding is_nan_def by transfer simp

lemma is_nan_plus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x + y)"
  unfolding plus_float_def fadd_def by auto

lemma is_nan_minus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x - y)"
  unfolding minus_float_def fsub_def by auto

lemma is_nan_times: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x * y)"
  unfolding times_float_def fmul_def by auto

lemma is_nan_divide: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x / y)"
  unfolding divide_float_def fdiv_def by auto

lemma is_nan_float_sqrt: "is_nan x \<Longrightarrow> is_nan (float_sqrt x)"
  unfolding float_sqrt_def fsqrt_def by simp

lemma nan_fcompare: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare x y = Und"
  unfolding fcompare_def by simp

lemma nan_not_less: "is_nan x \<or> is_nan y \<Longrightarrow> \<not> x < y"
  unfolding less_float_def flt_def fcompare_def by simp

lemma nan_not_zero: "is_nan x \<Longrightarrow> \<not> is_zero x"
  unfolding is_nan_def is_zero_def by simp

lemma nan_not_infinity: "is_nan x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_nan_def is_infinity_def by simp

lemma zero_not_infinity: "is_zero x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_zero_def is_infinity_def by simp

lemma zero_not_nan: "is_zero x \<Longrightarrow> \<not> is_nan x"
  unfolding is_zero_def is_nan_def by simp

lemma minus_one_power_one_word: "(-1 :: real) ^ unat (x :: 1 word) = (if unat x = 0 then 1 else -1)"
proof -
  have "unat x = 0 \<or> unat x = 1"
    using le_SucE[OF unat_one_word_le] by auto
  then show ?thesis by auto
qed

definition valofn :: "('e, 'f) float \<Rightarrow> real" where
  "valofn x = (2^exponent x / 2^bias TYPE(('e, 'f) float)) *
      (1 + real (fraction x) / 2^LENGTH('f))"

definition valofd :: "('e, 'f) float \<Rightarrow> real" where
  "valofd x = (2 / 2^bias TYPE(('e, 'f) float)) * (real (fraction x) / 2^LENGTH('f))"

lemma valof_alt: "valof x = (if exponent x = 0 then
    if sign x = 0 then valofd x else - valofd x
  else if sign x = 0 then valofn x else - valofn x)"
  unfolding valofn_def valofd_def
  by transfer (auto simp: minus_one_power_one_word unat_eq_0 field_simps)

lemma fraction_less_2p: "fraction (x :: ('e, 'f) float) < 2^LENGTH('f)"
  by transfer auto

lemma valofn_ge_0: "0 \<le> valofn x"
  unfolding valofn_def by simp

lemma valofn_ge_2p: "2^exponent (x :: ('e, 'f) float) / 2^bias TYPE(('e, 'f) float) \<le> valofn x"
  unfolding valofn_def by (simp add: field_simps)

lemma valofn_less_2p:
  fixes x :: "('e, 'f) float"
  assumes "exponent x < e"
  shows "valofn x < 2^e / 2^bias TYPE(('e, 'f) float)"
proof -
  have "1 + real (fraction x) / 2^LENGTH('f) < 2"
    by (simp add: fraction_less_2p)
  then have "valofn x < (2^exponent x / 2^bias TYPE(('e, 'f) float)) * 2"
    unfolding valofn_def by (simp add: field_simps)
  also have "... \<le> 2^e / 2^bias TYPE(('e, 'f) float)"
    using assms by (auto simp: less_eq_Suc_le field_simps elim: order_trans[rotated, OF exp_less])
  finally show ?thesis .
qed

lemma valofd_ge_0: "0 \<le> valofd x"
  unfolding valofd_def by simp

lemma valofd_less_2p: "valofd (x :: ('e, 'f) float) < 2 / 2^bias TYPE(('e, 'f) float)"
  unfolding valofd_def
  by (simp add: fraction_less_2p field_simps)

lemma valofn_le_imp_exponent_le:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x \<le> valofn y"
  shows "exponent x \<le> exponent y"
proof (rule ccontr)
  assume "\<not> exponent x \<le> exponent y"
  then have "valofn y < 2^exponent x / 2^bias TYPE(('e, 'f) float)"
    using valofn_less_2p[of y] by auto
  also have "... \<le> valofn x" by (rule valofn_ge_2p)
  finally show False using assms by simp
qed

lemma valofn_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x = valofn y"
  shows "exponent x = exponent y" "fraction x = fraction y"
proof -
  from assms show "exponent x = exponent y"
    by (auto intro!: antisym valofn_le_imp_exponent_le)
  with assms show "fraction x = fraction y"
    unfolding valofn_def by (simp add: field_simps)
qed

lemma valofd_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofd x = valofd y"
  shows "fraction x = fraction y"
  using assms unfolding valofd_def by (simp add: field_simps)

lemma is_zero_valof_conv: "is_zero x \<longleftrightarrow> valof x = 0"
  unfolding is_zero_def valof_alt
  using valofn_ge_2p[of x] by (auto simp: valofd_def field_simps dest: order.antisym)

lemma valofd_neq_valofn:
  fixes x y :: "('e, 'f) float"
  assumes "exponent y \<noteq> 0"
  shows "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x"
proof -
  have "valofd x < 2 / 2^bias TYPE(('e, 'f) float)" by (rule valofd_less_2p)
  also have "... \<le> 2 ^ IEEE.exponent y / 2 ^ bias TYPE(('e, 'f) IEEE.float)"
    using assms by (simp add: self_le_power field_simps)
  also have "... \<le> valofn y" by (rule valofn_ge_2p)
  finally show "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x" by simp_all
qed

lemma sign_gt_0_conv: "0 < sign x \<longleftrightarrow> sign x = 1"
  by (cases x rule: sign_cases) simp_all

lemma valof_eq:
  assumes "\<not> is_zero x \<or> \<not> is_zero y"
  shows "valof x = valof y \<longleftrightarrow> x = y"
proof
  assume *: "valof x = valof y"
  with assms have "valof y \<noteq> 0" by (simp add: is_zero_valof_conv)
  with * show "x = y"
    unfolding valof_alt
    using valofd_ge_0[of x] valofd_ge_0[of y] valofn_ge_0[of x] valofn_ge_0[of y]
    by (auto simp: valofd_neq_valofn sign_gt_0_conv split: if_splits
        intro!: float_eqI elim: valofn_eq valofd_eq)
qed simp

lemma zero_fcompare: "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> fcompare x y = ccode.Eq"
  unfolding fcompare_def by (simp add: zero_not_infinity zero_not_nan is_zero_valof_conv)

subsection \<open>Doubles with a unified NaN value\<close>

quotient_type double = "(11, 52) float" / "\<lambda>x y. is_nan x \<and> is_nan y \<or> x = y"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation double :: "{zero, one, plus, minus, uminus, times, ord}"
begin

lift_definition zero_double :: "double" is "0" .
lift_definition one_double :: "double" is "1" .

lift_definition plus_double :: "double \<Rightarrow> double \<Rightarrow> double" is plus
  by (auto simp: is_nan_plus)

lift_definition minus_double :: "double \<Rightarrow> double \<Rightarrow> double" is minus
  by (auto simp: is_nan_minus)

lift_definition uminus_double :: "double \<Rightarrow> double" is uminus
  by auto

lift_definition times_double :: "double \<Rightarrow> double \<Rightarrow> double" is times
  by (auto simp: is_nan_times)

lift_definition less_eq_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(\<le>)"
  by (auto simp: nan_not_le)

lift_definition less_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(<)"
  by (auto simp: nan_not_less)

instance ..

end

instantiation double :: inverse
begin

lift_definition divide_double :: "double \<Rightarrow> double \<Rightarrow> double" is divide
  by (auto simp: is_nan_divide)

definition inverse_double :: "double \<Rightarrow> double" where
  "inverse_double x = 1 div x"

instance ..

end

lift_definition sqrt_double :: "double \<Rightarrow> double" is float_sqrt
  by (auto simp: is_nan_float_sqrt)

no_notation plus_infinity ("\<infinity>")

lift_definition infinity :: "double" is plus_infinity .

lift_definition nan :: "double" is some_nan .

lift_definition is_zero :: "double \<Rightarrow> bool" is IEEE.is_zero
  by (auto simp: nan_not_zero)

lift_definition is_infinite :: "double \<Rightarrow> bool" is IEEE.is_infinity
  by (auto simp: nan_not_infinity)

lift_definition is_nan :: "double \<Rightarrow> bool" is IEEE.is_nan
  by auto

lemma is_nan_conv: "is_nan x \<longleftrightarrow> x = nan"
  by transfer auto

lift_definition copysign_double :: "double \<Rightarrow> double \<Rightarrow> double" is
  "\<lambda>x y. if IEEE.is_nan y then some_nan else copysign x y"
  by auto

text \<open>Note: @{const copysign_double} deviates from the IEEE standard in cases where
  the second argument is a NaN.\<close>

lift_definition fcompare_double :: "double \<Rightarrow> double \<Rightarrow> ccode" is fcompare
  by (auto simp: nan_fcompare)

lemma nan_fcompare_double: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare_double x y = Und"
  by transfer (rule nan_fcompare)

consts compare_double :: "double \<Rightarrow> double \<Rightarrow> integer"

specification (compare_double)
  compare_double_less: "compare_double x y < 0 \<longleftrightarrow> is_nan x \<and> \<not> is_nan y \<or> fcompare_double x y = ccode.Lt"
  compare_double_eq: "compare_double x y = 0 \<longleftrightarrow> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Eq"
  compare_double_greater: "compare_double x y > 0 \<longleftrightarrow> \<not> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Gt"
  by (rule exI[where x="\<lambda>x y. if is_nan x then if is_nan y then 0 else -1
    else if is_nan y then 1 else (case fcompare_double x y of ccode.Eq \<Rightarrow> 0 | ccode.Lt \<Rightarrow> -1 | ccode.Gt \<Rightarrow> 1)"],
        transfer, auto simp: fcompare_def)

lemmas compare_double_simps = compare_double_less compare_double_eq compare_double_greater

lemma compare_double_le_0: "compare_double x y \<le> 0 \<longleftrightarrow>
  is_nan x \<or> fcompare_double x y \<in> {ccode.Eq, ccode.Lt}"
  by (rule linorder_cases[of "compare_double x y" 0]; simp)
    (auto simp: compare_double_simps nan_fcompare_double)

lift_definition double_of_integer :: "integer \<Rightarrow> double" is
  "\<lambda>x. zerosign 0 (intround To_nearest (int_of_integer x))" .

definition double_of_int where [code del]: "double_of_int x = double_of_integer (integer_of_int x)"

lift_definition integer_of_double :: "double \<Rightarrow> integer" is
  "\<lambda>x. if IEEE.is_nan x \<or> IEEE.is_infinity x then undefined
     else integer_of_int \<lfloor>valof (intround float_To_zero (valof x) :: (11, 52) float)\<rfloor>"
  by auto

definition int_of_double: "int_of_double x = int_of_integer (integer_of_double x)"

subsection \<open>Linear ordering\<close>

definition lcompare_double :: "double \<Rightarrow> double \<Rightarrow> integer" where
  "lcompare_double x y = (if is_zero x \<and> is_zero y then
      compare_double (copysign_double 1 x) (copysign_double 1 y)
    else compare_double x y)"

lemma fcompare_double_swap: "fcompare_double x y = ccode.Gt \<longleftrightarrow> fcompare_double y x = ccode.Lt"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_refl: "\<not> is_nan x \<Longrightarrow> fcompare_double x x = ccode.Eq"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_Eq1: "fcompare_double x y = ccode.Eq \<Longrightarrow> fcompare_double y z = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Eq2: "fcompare_double y z = ccode.Eq \<Longrightarrow> fcompare_double x y = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Lt_trans: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y z = ccode.Lt \<Longrightarrow> fcompare_double x z = ccode.Lt"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_eq: "\<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> fcompare_double x y = ccode.Eq \<Longrightarrow> x = y"
  by transfer (auto simp: fcompare_def valof_eq IEEE.is_infinity_def split: if_splits intro!: float_eqI)

lemma fcompare_double_Lt_asym: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y x = ccode.Lt \<Longrightarrow> False"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma compare_double_swap: "0 < compare_double x y \<longleftrightarrow> compare_double y x < 0"
  by (auto simp: compare_double_simps fcompare_double_swap)

lemma compare_double_refl: "compare_double x x = 0"
  by (auto simp: compare_double_eq intro!: fcompare_double_refl)

lemma compare_double_trans: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y z \<le> 0 \<Longrightarrow> compare_double x z \<le> 0"
  by (fastforce simp: compare_double_le_0 nan_fcompare_double
      dest: fcompare_double_Eq1 fcompare_double_Eq2 fcompare_double_Lt_trans)

lemma compare_double_antisym: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y x \<le> 0 \<Longrightarrow>
  \<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> x = y"
  unfolding compare_double_le_0
  by (auto simp: nan_fcompare_double is_nan_conv
      intro: fcompare_double_eq fcompare_double_eq[symmetric]
      dest: fcompare_double_Lt_asym)

lemma zero_compare_double_copysign: "compare_double (copysign_double 1 x) (copysign_double 1 y) \<le> 0 \<Longrightarrow>
  is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> compare_double x y \<le> 0"
  unfolding compare_double_le_0
  by transfer (auto simp: nan_not_zero zero_fcompare split: if_splits)

lemma is_zero_double_cases: "is_zero x \<Longrightarrow> (x = 0 \<Longrightarrow> P) \<Longrightarrow> (x = -0 \<Longrightarrow> P) \<Longrightarrow> P"
  by transfer (auto elim!: is_zero_cases)

lemma copysign_1_0[simp]: "copysign_double 1 0 = 1" "copysign_double 1 (-0) = -1"
  by (transfer, simp, transfer, auto)+

lemma is_zero_uminus_double[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
  by transfer simp

lemma not_is_zero_one_double[simp]: "\<not> is_zero 1"
  by (transfer, unfold IEEE.is_zero_def, transfer, simp)

lemma uminus_one_neq_one_double[simp]: "- 1 \<noteq> (1 :: double)"
  by (transfer, transfer, simp)

definition lle_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lle_double x y \<longleftrightarrow> lcompare_double x y \<le> 0"

definition lless_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lless_double x y \<longleftrightarrow> lcompare_double x y < 0"

lemma lcompare_double_ge_0: "lcompare_double x y \<ge> 0 \<longleftrightarrow> lle_double y x"
  unfolding lle_double_def lcompare_double_def
  using compare_double_swap not_less by auto

lemma lcompare_double_gt_0: "lcompare_double x y > 0 \<longleftrightarrow> lless_double y x"
  unfolding lless_double_def lcompare_double_def
  using compare_double_swap by auto

lemma lcompare_double_eq_0: "lcompare_double x y = 0 \<longleftrightarrow> x = y"
proof
  assume *: "lcompare_double x y = 0"
  show "x = y" proof (cases "is_zero x \<and> is_zero y")
    case True
    with * show ?thesis
      by (fastforce simp: lcompare_double_def compare_double_simps is_nan_conv
          elim: is_zero_double_cases dest!: fcompare_double_eq[rotated])
  next
    case False
    with * show ?thesis
      by (auto simp: lcompare_double_def linorder_not_less[symmetric] compare_double_swap
          intro!: compare_double_antisym)
  qed
next
  assume "x = y"
  then show "lcompare_double x y = 0"
    by (simp add: lcompare_double_def compare_double_refl)
qed

lemmas lcompare_double_0_folds = lle_double_def[symmetric] lless_double_def[symmetric]
  lcompare_double_ge_0 lcompare_double_gt_0 lcompare_double_eq_0

interpretation double_linorder: linorder lle_double lless_double
proof
  fix x y z :: double
  show "lless_double x y \<longleftrightarrow> lle_double x y \<and> \<not> lle_double y x"
    unfolding lless_double_def lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
  show "lle_double x x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_refl)
  show "lle_double x z" if "lle_double x y" and "lle_double y z"
    using that
    by (auto 0 3 simp: lle_double_def lcompare_double_def not_le compare_double_swap
        split: if_splits dest: compare_double_trans zero_compare_double_copysign
        zero_compare_double_copysign[OF less_imp_le] compare_double_antisym)
  show "x = y" if "lle_double x y" and "lle_double y x"
  proof (cases "is_zero x \<and> is_zero y")
    case True
    with that show ?thesis
      by (auto 0 3 simp: lle_double_def lcompare_double_def elim: is_zero_double_cases
          dest!: compare_double_antisym)
  next
    case False
    with that show ?thesis
      by (auto simp: lle_double_def lcompare_double_def elim!: compare_double_antisym)
  qed
  show "lle_double x y \<or> lle_double y x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
qed

instantiation double :: equal
begin

definition equal_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "equal_double x y \<longleftrightarrow> lcompare_double x y = 0"

instance by intro_classes (simp add: equal_double_def lcompare_double_eq_0)

end

derive (eq) ceq double

definition comparator_double :: "double comparator" where
  "comparator_double x y = (let c = lcompare_double x y in
    if c = 0 then order.Eq else if c < 0 then order.Lt else order.Gt)"

lemma comparator_double: "comparator comparator_double"
  unfolding comparator_double_def
  by (auto simp: lcompare_double_0_folds split: if_splits intro!: comparator.intro)

local_setup \<open>
  Comparator_Generator.register_foreign_comparator @{typ double}
    @{term comparator_double}
    @{thm comparator_double}
\<close>

derive ccompare double

subsubsection \<open>Code setup\<close>

declare [[code drop:
      "0 :: double"
      "1 :: double"
      "plus :: double \<Rightarrow> _"
      "minus :: double \<Rightarrow> _"
      "uminus :: double \<Rightarrow> _"
      "times :: double \<Rightarrow> _"
      "less_eq :: double \<Rightarrow> _"
      "less :: double \<Rightarrow> _"
      "divide :: double \<Rightarrow> _"
      "Code_Evaluation.term_of :: double \<Rightarrow> _"
      sqrt_double infinity nan is_zero is_infinite is_nan copysign_double fcompare_double
      double_of_integer integer_of_double
      ]]

code_printing
  code_module FloatUtil \<rightharpoonup> (OCaml)
\<open>module FloatUtil : sig
  val iszero : float -> bool
  val isinfinite : float -> bool
  val isnan : float -> bool
  val copysign : float -> float -> float
  val compare : float -> float -> Z.t
end = struct
  let iszero x = (Stdlib.classify_float x = Stdlib.FP_zero);;
  let isinfinite x = (Stdlib.classify_float x = Stdlib.FP_infinite);;
  let isnan x = (Stdlib.classify_float x = Stdlib.FP_nan);;
  let copysign x y = if isnan y then Stdlib.nan else Stdlib.copysign x y;;
  let compare x y = Z.of_int (Stdlib.compare x y);;
end;;\<close>

code_reserved OCaml Stdlib FloatUtil

code_printing
  type_constructor double \<rightharpoonup> (OCaml) "float"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(~-.)"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(+.)"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.( *. )"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.('/.)"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(-.)"
  | constant "0 :: double" \<rightharpoonup> (OCaml) "0.0"
  | constant "1 :: double" \<rightharpoonup> (OCaml) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<=)"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<)"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (OCaml) "Stdlib.infinity"
  | constant "nan :: double" \<rightharpoonup> (OCaml) "Stdlib.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isnan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "FloatUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "FloatUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (OCaml) "Z.to'_float"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "Z.of'_float"

ML \<open>
if Real.precision <> 53 then
  error "SML real type must be double precision for Eval code adaptation"
else ();

signature REALUTIL = sig
  val nan : real
  val iszero : real -> bool
  val isinfinite : real -> bool
  val copysign : real -> real -> real
  val compare : real -> real -> int
  val toInt : real -> int
  val toTerm : real -> term
end
structure RealUtil : REALUTIL = struct
  val nan = 1.0 / 0.0;
  fun iszero x = (Real.class x = IEEEReal.ZERO);
  fun isinfinite x = (Real.class x = IEEEReal.INF);
  fun copysign x y = if Real.isNan y then nan else Real.copySign (x, y);

  fun compare x y = (case Real.compare (x, y) of
      LESS => ~1
    | EQUAL => 0
    | GREATER => 1);

  fun toInt x = Real.toInt IEEEReal.TO_ZERO x;

  fun toTerm x =
    (case Real.class x of
      IEEEReal.NAN => @{const nan}
    | IEEEReal.INF => if Real.signBit x then @{term "- infinity"} else @{term "infinity"}
    | IEEEReal.ZERO => if Real.signBit x then @{term "-0 :: double"} else @{term "0 :: double"}
    | _ => case Real.toManExp x of {man = m, exp = e} =>
      let
        val i = Real.floor (m * Math.pow (2.0, 53.0));
        val e = e - 53;
      in
        @{term abs_double} $ (@{term "of_finite_Float :: Float.float \<Rightarrow> (11, 52) float"} $
          (@{term Float} $ HOLogic.mk_number @{typ int} i $ HOLogic.mk_number @{typ int} e))
      end);
end\<close>

code_printing
  type_constructor double \<rightharpoonup> (Eval) "real"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.~"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.+ ((_), (_))"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.* ((_), (_))"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.'/ ((_), (_))"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.- ((_), (_))"
  | constant "0 :: double" \<rightharpoonup> (Eval) "0.0"
  | constant "1 :: double" \<rightharpoonup> (Eval) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.<= ((_), (_))"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.< ((_), (_))"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (Eval) "Math.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (Eval) "Real.posInf"
  | constant "nan :: double" \<rightharpoonup> (Eval) "RealUtil.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "RealUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "RealUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.isNan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "RealUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (Eval) "RealUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.fromInt"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (Eval) "RealUtil.toInt"
  | constant "Code_Evaluation.term_of :: double \<Rightarrow> term" \<rightharpoonup> (Eval) "RealUtil.toTerm"

hide_const (open) fcompare_double

(*<*)
end
(*>*)


theory Resolution_Compl_SC_Full
imports LSC_Resolution Resolution SC_Sema Compactness
begin

theorem Resolution_complete:
  fixes S :: "'a :: countable formula set"
  assumes val: "S \<TTurnstile> F"
  shows "\<Union>((cnf \<circ> nnf) ` ({\<^bold>\<not>F} \<union> S)) \<turnstile> \<box>"
  (* look: S may be infinite. *)
proof -
  let ?mun = "\<lambda>s. \<Union>((cnf \<circ> nnf) ` s)"
  (* note: there's an alternate version of this proof with CSC_Resolution_pre and the CNF_Semantics *)
  from compact_entailment[OF val] obtain S'' where fin: "finite S''" and su: "S'' \<subseteq> S" and val': " S'' \<TTurnstile> F" by blast
  from fin obtain S' where S: "S'' = set_mset S'" using finite_set_mset_mset_set by blast
  have cnf: "\<forall>F \<in> set_mset (image_mset (cnf_form_of \<circ> nnf) (\<^bold>\<not> F, S')). is_cnf F" by(simp add: cnf_form_of_is is_nnf_nnf)
  note entailment_def[simp]
  from val' have "S'' \<TTurnstile> \<^bold>\<not>(\<^bold>\<not>F)" by simp
  hence "S' \<Rightarrow> {#\<^bold>\<not>(\<^bold>\<not>F)#}"
    unfolding SC_sound_complete sequent_intuitonistic_semantics S .
  hence "\<^bold>\<not>F, S' \<Rightarrow> {#}" by (simp add: NotR_inv)
  hence "image_mset nnf (\<^bold>\<not>F, S') \<Rightarrow> {#}" using LSC_NNF SC_LSC by blast
  hence "image_mset nnf (\<^bold>\<not>F, S') \<Rightarrow>\<^sub>n" by (simp add: SC_LSC is_nnf_nnf)
  with LSC_Resolution have "\<Union>(cnf ` nnf ` set_mset (image_mset nnf (\<^bold>\<not> F, S'))) \<turnstile> \<box>"  .
  hence "?mun ({\<^bold>\<not> F} \<union> S'') \<turnstile> \<box>"
    unfolding set_image_mset image_comp comp_def S is_nnf_nnf_id[OF is_nnf_nnf] by simp
  from Resolution_weaken[OF this, of "?mun S"] show ?thesis using su by (metis UN_Un Un_left_commute sup.order_iff)
qed

end


theory ODE_Solve_Keyword
  imports
    "verification/ODE_extra"
  keywords "ode_solve" :: diag and "ode_solve_thm" :: thy_decl
begin

ML_file "config.sml"
ML_file "wolfram-integration/lex_mathematica.ML"
ML_file "wolfram-integration/parse_mathematica.ML"
ML_file "wolfram-integration/isabelle_to_mathematica.ML"
ML_file "wolfram-integration/mathematica_to_isabelle.ML"
ML_file "wolfram-integration/solve_ODE.ML"
ML_file "sage-integration/ConvertToSage.ML"

ML ‹
local

fun cartesian_power 1 = "ℝ" |
    cartesian_power n = cartesian_power (n-1) ^ " × ℝ"

val ODE_solver_val = Attrib.setup_config_string @{binding "preprocess_ODE_solver"} (K "fricas");
val preprocess_SODEs_val = Attrib.setup_config_bool @{binding "preprocess_SODEs"} (K true);

(*NOTE: I can't get this function to work when it's in in ConvertToSage.ML, so I'm putting it here*)
(*
get_ode_prop: Given the string of an ODE, return a proposition of the solution, using Sage to solve
the SODE
*)
fun get_ode_prop ctxt ode solver_name specified_domain specified_codomain =
  let
    val ode_str = Syntax.pretty_term ctxt ode |> Pretty.string_of |> YXML.content_of;
    val (solution, max_domain) = Convert_To_Sage.desolve ode solver_name
        (Config.get ctxt ODE_solver_val) (Config.get ctxt preprocess_SODEs_val);
    val domain = if specified_domain = "" then max_domain else specified_domain;
    val codomain = if specified_codomain = "" then cartesian_power(Convert_To_Sage.getNumOutEqs ode) else specified_codomain;
    val final = "((" ^ solution ^ ") solves_ode (" ^ ode_str ^ ")) (" ^ domain ^ ") (" ^ codomain ^ ")"
  in final
end;

val SODE_solver_val = Attrib.setup_config_string @{binding "SODE_solver"} (K "fricas");

fun print_thm thm thm_name ctxt =
  Proof_Display.print_results true (Position.thread_data ()) ctxt ((Thm.theoremK, thm_name), [("", [thm])]);

fun get_all_vars (Var ((name, _), _)) = [name]
  | get_all_vars (Const (_, _)) = []
  | get_all_vars (Free (name, _)) = [name]
  | get_all_vars (Bound _) = []
  | get_all_vars (Abs (name, _, t)) = cons name (get_all_vars t)
  | get_all_vars (t $ u) = append (get_all_vars t) (get_all_vars u);

fun prop_to_thm ctxt prop_str d_vars =
  let
    val prop = Syntax.read_prop ctxt prop_str
    val ode_cert_tac = Context_Tactic.NO_CONTEXT_TACTIC ctxt (
      Method_Closure.apply_method ctxt @{method ode_cert} [] [] [] ctxt [])
    val raw_thm = Goal.prove ctxt [] [] prop (K ode_cert_tac)
    val (_, ctxt1) = Variable.add_fixes d_vars ctxt
    val final_thm = singleton (Proof_Context.export ctxt1 ctxt) raw_thm
    in final_thm
end;

val _ = prop_to_thm @{context} "((λ t.((C0 :: real) * exp((t :: real)))) solves_ode (λt x. x)) (UNIV) (ℝ) " [];

fun generate_lemma lemma_txt binding attribs lthy =
  let
    val ctxt = Local_Theory.target_of lthy
    val _ = writeln lemma_txt
    val vars = (Syntax.read_prop ctxt lemma_txt) |> get_all_vars |> distinct (op =)
    val thm = prop_to_thm ctxt (lemma_txt |> YXML.content_of) vars
    val _  = print_thm thm (Binding.name_of binding) ctxt
    in lthy |> (Local_Theory.note ((binding, []), [thm])) |> snd
  end;

fun do_ode_solve ctxt sode_text specified_domain specified_codomain =
  let val sode = Syntax.read_term ctxt sode_text in
  if (Config.get ctxt SODE_solver_val) = "wolfram" then
    Solve_ODE.solution_lemma sode specified_domain specified_codomain |> Pretty.string_of |> Active.sendback_markup_command |> writeln
  else
    let val main_prop = get_ode_prop ctxt sode (Config.get ctxt SODE_solver_val) specified_domain specified_codomain in
    "lemma \"" ^ main_prop ^ "\" by ode_cert" |> Active.sendback_markup_command |> writeln end
end;

fun do_ode_solve_thm sode_text binding attribs specified_domain specified_codomain constraint lthy =
  let val ctxt = Local_Theory.target_of lthy
  val sode = Syntax.read_term ctxt sode_text
  val lemma_text =
    (if constraint = "" then "" else constraint ^ " ==> ") ^
    (if (Config.get ctxt SODE_solver_val) = "wolfram" then
      let val full_text = Solve_ODE.solution_lemma sode specified_domain specified_codomain |> Pretty.string_of |> YXML.content_of in
      String.substring (full_text, 7, (String.size full_text - 22)) end (*get rid of the first and last parts of the theorem*)
    else
      (get_ode_prop ctxt sode (Config.get ctxt SODE_solver_val) specified_domain specified_codomain) ^ "")
  in generate_lemma lemma_text binding attribs lthy
end;

(*Test ode_solve_thm*)
val stm = "((λ t.(t^2 * 1/2 + x(0), y(0))) solves_ode (λ (t::real) (x, y). (t, 0))) {0..l} UNIV";
val _ = prop_to_thm @{context} stm;

val _ = Outer_Syntax.command \<^command_keyword>‹ode_solve› "Solves the input ode and prints a lemma with the solution"
    (Parse.term >> (fn sode_text => Toplevel.keep (fn st =>
      (do_ode_solve (Toplevel.context_of st) sode_text "" ""))));

val _ = Outer_Syntax.local_theory \<^command_keyword>‹ode_solve_thm› "Solves the input ode and proves the solution as a theorem"
    (((Parse_Spec.opt_thm_name ":") -- Parse.term -- (Scan.optional Parse.term "") -- (Scan.optional Parse.term "") -- (Scan.optional Parse.prop "")) >>
    (fn (((((binding, attribs), sode_text), domain), codomain), constraint) =>
      (do_ode_solve_thm sode_text binding attribs (domain |> YXML.content_of) (codomain |> YXML.content_of) (constraint |> YXML.content_of))));

in end;
›

end


(* Author: Tobias Nipkow *)

section "Abstract State with Computable Ordering"

theory Abs_State
imports Abs_Int0
  "HOL-Library.Char_ord" "HOL-Library.List_Lexorder"
  (* Library import merely to allow string lists to be sorted for output *)
begin

text\<open>A concrete type of state with computable \<open>\<sqsubseteq>\<close>:\<close>

datatype 'a st = FunDom "vname \<Rightarrow> 'a" "vname list"

fun "fun" where "fun (FunDom f xs) = f"
fun dom where "dom (FunDom f xs) = xs"

definition [simp]: "inter_list xs ys = [x\<leftarrow>xs. x \<in> set ys]"

definition "show_st S = [(x,fun S x). x \<leftarrow> sort(dom S)]"

definition "show_acom = map_acom (map_option show_st)"
definition "show_acom_opt = map_option show_acom"

definition "lookup F x = (if x : set(dom F) then fun F x else \<top>)"

definition "update F x y =
  FunDom ((fun F)(x:=y)) (if x \<in> set(dom F) then dom F else x # dom F)"

lemma lookup_update: "lookup (update S x y) = (lookup S)(x:=y)"
by(rule ext)(auto simp: lookup_def update_def)

definition "\<gamma>_st \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(lookup F x)}"

instantiation st :: (SL_top) SL_top
begin

definition "le_st F G = (\<forall>x \<in> set(dom G). lookup F x \<sqsubseteq> fun G x)"

definition
"join_st F G =
 FunDom (\<lambda>x. fun F x \<squnion> fun G x) (inter_list (dom F) (dom G))"

definition "\<top> = FunDom (\<lambda>x. \<top>) []"

instance
proof (standard, goal_cases)
  case 2 thus ?case
    apply(auto simp: le_st_def)
    by (metis lookup_def preord_class.le_trans top)
qed (auto simp: le_st_def lookup_def join_st_def Top_st_def)

end

lemma mono_lookup: "F \<sqsubseteq> F' \<Longrightarrow> lookup F x \<sqsubseteq> lookup F' x"
by(auto simp add: lookup_def le_st_def)

lemma mono_update: "a \<sqsubseteq> a' \<Longrightarrow> S \<sqsubseteq> S' \<Longrightarrow> update S x a \<sqsubseteq> update S' x a'"
by(auto simp add: le_st_def lookup_def update_def)

locale Gamma = Val_abs where \<gamma>=\<gamma> for \<gamma> :: "'av::SL_top \<Rightarrow> val set"
begin

abbreviation \<gamma>\<^sub>f :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>f == \<gamma>_st \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>f"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_f_Top[simp]: "\<gamma>\<^sub>f Top = UNIV"
by(auto simp: Top_st_def \<gamma>_st_def lookup_def)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o Top = UNIV"
by (simp add: Top_option_def)

(* FIXME (maybe also le \<rightarrow> sqle?) *)

lemma mono_gamma_f: "f \<sqsubseteq> g \<Longrightarrow> \<gamma>\<^sub>f f \<subseteq> \<gamma>\<^sub>f g"
apply(simp add:\<gamma>_st_def subset_iff lookup_def le_st_def split: if_splits)
by (metis UNIV_I mono_gamma gamma_Top subsetD)

lemma mono_gamma_o:
  "sa \<sqsubseteq> sa' \<Longrightarrow> \<gamma>\<^sub>o sa \<subseteq> \<gamma>\<^sub>o sa'"
by(induction sa sa' rule: le_option.induct)(simp_all add: mono_gamma_f)

lemma mono_gamma_c: "ca \<sqsubseteq> ca' \<Longrightarrow> \<gamma>\<^sub>c ca \<le> \<gamma>\<^sub>c ca'"
by (induction ca ca' rule: le_acom.induct) (simp_all add:mono_gamma_o)

lemma in_gamma_option_iff:
  "x : \<gamma>_option r u \<longleftrightarrow> (\<exists>u'. u = Some u' \<and> x : r u')"
by (cases u) auto

end

end


theory Datatypes

imports inc.Prelude

begin

default_sort type

datatype channel = cab | cin | cout

section \<open>Message Definition\<close>

text\<open>The same is true for the "Message" Datatype. Every kind of message has to be described here:\<close>
datatype M_pure = \<N> nat | \<B> bool

text \<open>Instantiate @{type M_pure} as countable. This is necessary for using @{type M_pure} streams. }\<close>
instance M_pure::countable
  apply(countable_datatype)
  done

lemma inj_B[simp]:"inj \<B>"
  by (simp add: inj_def)

lemma inj_Bopt[simp]:"inj (map_option \<B>)"
  by (simp add: option.inj_map)

text \<open>Then one describes the types of each channel. Only Messages included are allowed to be
  transmitted\<close>
fun cMsg :: "channel \<Rightarrow> M_pure set" where
"cMsg cin = range \<N>" |
"cMsg cout = range \<B>" |
"cMsg _ = {}"

text\<open>Timing properties of each channel\<close>
fun cTime :: "channel \<Rightarrow> timeType" where
"cTime cin = TUntimed" |
"cTime cout = TUntimed" |
"cTime _ = undefined"

lemma cmsgempty_ex:"\<exists>c. cMsg c = {}"
  using cMsg.simps by blast

end


theory IMP_Minus_Minus_To_SAS_Plus_Plus_State_Translations_Nat
  imports IMP_Minus_Minus_To_SAS_Plus_Plus_State_Translations
          Primitives
begin

definition imp_minus_state_to_sas_plus_list::
      "(com * (vname*bit) list) \<Rightarrow> (variable*domain_element) list" where
"imp_minus_state_to_sas_plus_list ci =(PC,PCV (fst ci))#
        map  (\<lambda>(x,y). (x, EV y)) (map (\<lambda>(x,y). (VN x, y)) (snd ci))"

lemma inj_vn: "inj VN"
  by (meson injI variable.inject)

lemma sublist_imp_minus_state_to_sas_plus_apply:
  "map_of (imp_minus_state_to_sas_plus_list ci) k =
          imp_minus_state_to_sas_plus (cilist_to_map ci) k"
  apply (cases ci)
  apply (cases k)
  apply (auto simp add: imp_minus_state_to_sas_plus_list_def imp_minus_state_to_sas_plus_def
        map_comp_def map_of_map simp del:map_map)
  subgoal for a b x
    apply (cases "map_of b x")
     apply auto
    subgoal
    proof -
      assume "k = VN x" "map_of b x = None"
      hence "\<forall>y. (x,y) \<notin> set b"
        using weak_map_of_SomeI by force
      hence "\<forall>y. (VN x, y) \<notin> set (map (\<lambda>(x, y). (VN x, y)) b)"
        by auto
      thus ?thesis
        by (metis (no_types, lifting) imageE map_of_eq_None_iff prod.collapse)
    qed
    using map_of_mapk_SomeI inj_vn by fast
  done

lemma sublist_imp_minus_state_to_sas_plus:
  "map_of (imp_minus_state_to_sas_plus_list ci) =
          imp_minus_state_to_sas_plus (cilist_to_map ci)"
  using sublist_imp_minus_state_to_sas_plus_apply by blast

fun map_impms_sp:: " nat \<Rightarrow> nat" where
"map_impms_sp n = (if n =0 then 0 else (prod_encode (Suc(fst_nat (hd_nat n)) , prod_encode(0,snd_nat (hd_nat n))))## map_impms_sp (tl_nat n))"

fun map_impms_sp_acc:: " nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_impms_sp_acc acc n = (if n = 0 then acc else map_impms_sp_acc ((prod_encode (Suc(fst_nat (hd_nat n)) , prod_encode(0,snd_nat (hd_nat n))))  ## acc) (tl_nat n) )"

lemma map_impms_sp_induct:
"map_impms_sp_acc acc n = map_acc (\<lambda>x. prod_encode (Suc(fst_nat x) , prod_encode(0,snd_nat x)) ) acc n"
  apply(induct acc n rule: map_impms_sp_acc.induct)
  apply auto
  done

definition map_impms_sp_tail :: "nat \<Rightarrow> nat" where
"map_impms_sp_tail n = reverse_nat (map_impms_sp_acc 0 n)"

lemma submap_immpms_sp:
"map_impms_sp n = map_nat (\<lambda>x. prod_encode (Suc(fst_nat x) , prod_encode(0,snd_nat x)) ) n "
  apply (induct n rule:map_impms_sp.induct)
  apply auto
  done

lemma subtail_map_impms_sp:
"map_impms_sp_tail n = map_impms_sp n"
  using subtail_map map_impms_sp_tail_def map_impms_sp_induct submap_immpms_sp
  by presburger

definition imp_minus_state_to_sas_plus_nat :: "nat \<Rightarrow> nat" where
"imp_minus_state_to_sas_plus_nat ci = (prod_encode (0,prod_encode(1,fst_nat ci)))##
(map_impms_sp (snd_nat ci))"

definition imp_minus_state_to_sas_plus_tail :: "nat \<Rightarrow> nat" where
"imp_minus_state_to_sas_plus_tail ci = (prod_encode (0,prod_encode(1,fst_nat ci)))##
(map_impms_sp_tail (snd_nat ci))"

lemma subtail_imp_minus_state_to_sas_plus:
"imp_minus_state_to_sas_plus_tail ci = imp_minus_state_to_sas_plus_nat ci"
  apply(auto simp only: imp_minus_state_to_sas_plus_nat_def imp_minus_state_to_sas_plus_tail_def
      subtail_map_impms_sp)
  done

lemma subnat_imp_minus_state_to_sas_plus:
"imp_minus_state_to_sas_plus_nat   (cilist_encode ci)
  = list_encode (map sas_assignment_encode (imp_minus_state_to_sas_plus_list ci))  "
  apply (cases ci)
  apply (auto simp only: cilist_encode.simps imp_assignment_list_encode_def
submap_immpms_sp
      imp_minus_state_to_sas_plus_nat_def sub_cons cons0 sub_map sub_snd
                snd_def sub_fst fst_def map_map comp_def imp_assignment_encode.simps
                   imp_minus_state_to_sas_plus_list_def list.map
                          list_encode_eq
                        split:prod.splits
                  simp flip: variable_encode.simps domain_element_encode.simps
                            sas_assignment_encode.simps)
  apply(auto simp add: prod_encode_eq sub_fst sub_snd)
  done

lemma sub_imp_minus_state_to_sas_plus:
"sas_state_decode (imp_minus_state_to_sas_plus_nat (cilist_encode ci)) =
      imp_minus_state_to_sas_plus (cilist_to_map ci)"

  apply (auto simp only: subnat_imp_minus_state_to_sas_plus
      sas_state_decode_def list_encode_inverse map_map comp_def sas_assignment_id map_idI
 sublist_imp_minus_state_to_sas_plus)
  done

end


theory FunctorComposition

imports
  Main
  "Category2/Category"
  "Category2/Functors"

begin

(* Compostion of two functors *)
definition FtorComp' :: "
  ('o2, 'o3, 'm2, 'm3, 'b, 'c, 'e) Functor_scheme \<Rightarrow>
  ('o1, 'o2, 'm1, 'm2, 'a, 'b, 'd) Functor_scheme \<Rightarrow>
  ('o1, 'o3, 'm1, 'm3, 'a, 'c) Functor
  " where
  "FtorComp' G F \<equiv> \<lparr>
    CatDom = CatDom F,
    CatCod = CatCod G,
    MapM = \<lambda>f. (G ## (F ## f))
  \<rparr>"

definition FtorComp (infixl "\<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r" 55) where
  "G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F = MakeFtor (FtorComp' G F)"

(* Step 0: Simplification rules for dom and cod over functor composition *)
lemma DomFtorComp:
  assumes "Functor F"
  and "Functor G"
  and "CatCod F = CatDom G"
  shows "CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) = CatDom F"
unfolding FtorComp_def MakeFtor_def FtorComp'_def
by (auto)

lemma CodFtorComp:
  assumes "Functor F"
  and "Functor G"
  and "CatCod F = CatDom G"
  shows "CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) = CatCod G"
unfolding FtorComp_def MakeFtor_def FtorComp'_def
by (auto)

(* Step 1: Proof that (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) is prefunctor *)
lemma FtorComp'PreFunctor:
  assumes "Functor F"
  and "Functor G"
  and "CatCod F = CatDom G"
  shows "PreFunctor (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)"
unfolding PreFunctor_def
proof (intro conjI)
  show "\<forall>f g. f \<approx>>\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> g \<longrightarrow>
          (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f ;;\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> g =
          (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f ;;\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub>
          ((G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## g)"
    using assms by (smt Category.MapsToMorDomCod(1) CompDefinedE FtorComp'_def FtorComp_def Functor.FunctorCompDef Functor.select_convs(1) Functor.select_convs(2) Functor.select_convs(3) MakeFtorMor MakeFtor_def PreFunctor.CatDom PreFunctor.FunctorComp PreFunctorFunctor)
  next show "\<forall>X. X \<in> obj\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> \<longrightarrow>
        (\<exists>Y\<in>obj\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub>.
            (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## id\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> X =
            id\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> Y)"
    using assms by (smt Category.CatIdInMor FtorComp'_def FtorComp_def Functor.select_convs(1) Functor.select_convs(2) Functor.select_convs(3) MakeFtorMor MakeFtor_def PreFunctor.CatDom PreFunctor.FunctorId2 PreFunctorFunctor)
  next show "Category (CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F))"
    using assms by (simp add: FtorComp'_def FtorComp_def MakeFtor_def)
  next show "Category (CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F))"
    using assms by (simp add: FtorComp'_def FtorComp_def MakeFtor_def)
qed

(* Step 2: Show that functors applied to arrows are distributed over dom and cod of arrow *)
lemma FtorComp'FtorM:
  assumes "Functor F"
  and "Functor G"
  and "CatCod F = CatDom G"
  shows "FunctorM (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)"
proof (auto simp add: FunctorM_def IdFtor'PreFunctor assms FunctorM_axioms_def)
  {
    fix f X Y
    assume hi:"f maps\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> X to Y"
    show "(G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f maps\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) @@ X to (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) @@ Y"
      proof -
        have "CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) = CatCod (G)" using assms CodFtorComp by blast
        moreover have "f \<in> mor\<^bsub>CatDom (F)\<^esub>" using assms DomFtorComp hi by fastforce
        moreover have "(G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f \<in> mor\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub>" using assms hi
          proof -
            have "F ## f \<in> mor\<^bsub>CatCod (F)\<^esub>" using assms by (meson Functor.FunctorCompPreserved calculation)
            moreover have "F ## f \<in> mor\<^bsub>CatDom (G)\<^esub>" using assms using calculation by auto
            moreover have "G ## (F ## f) \<in> mor\<^bsub>CatCod (G)\<^esub>" using assms by (simp add: Functor.FunctorCompPreserved calculation)
            moreover have "G ## (F ## f) \<in> mor\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub>" using assms by (simp add: `CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) = CatCod G` calculation(3))
            moreover have "G ## (F ## f) = (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f" using assms by (simp add: FtorComp'_def FtorComp_def MakeFtorMor `f \<in> mor\<^bsub>CatDom F\<^esub>`)
            ultimately show ?thesis by simp
          qed
        moreover have "dom\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> ((G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f) = (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) @@ X" using assms CodFtorComp
          by (smt Category.CatIdInMor Category.Cdom DomFtorComp FtorComp'PreFunctor FtorComp'_def FtorComp_def Functor.FunctorCompPreserved Functor.FunctorId3Dom Functor.select_convs(1) Functor.select_convs(3) MakeFtorMor MapsToE PreFunctor.CatCod PreFunctor.CatDom PreFunctor.FmToFo hi)
        moreover have "cod\<^bsub>CatCod (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub> ((G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f) = (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) @@ Y"
          by (smt Category.CatIdInMor Category.Ccod DomFtorComp FtorComp'PreFunctor FtorComp'_def FtorComp_def Functor.FunctorCompPreserved Functor.FunctorId3Cod Functor.select_convs(1) Functor.select_convs(3) MakeFtorMor MapsToE PreFunctor.CatCod PreFunctor.CatDom PreFunctor.FmToFo assms(1) assms(2) assms(3) calculation(1) hi)
        ultimately show ?thesis using assms hi by blast
      qed
  }
  show "PreFunctor (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)" using assms by (rule FtorComp'PreFunctor)
qed

value "{ undefined }"

lemma FtorCompElim:
  assumes Ftor_F: "Functor F"
  and     Ftor_G: "Functor G"
  and     CodDom_FG: "CatCod F = CatDom G"
  shows "(G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f = G ## F ## f"
unfolding Functor_def
proof -
  have "undefined \<notin> Mor (CatDom G)" using assms
    proof (intro notI)
      assume "undefined \<in> Mor (CatDom G)"
      show "False" sorry
    qed
  next {
    fix f
    assume hi: "f \<in> mor\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub>"
    have "f \<in> mor\<^bsub>CatDom (F)\<^esub>" using assms DomFtorComp hi by fastforce
    moreover have "G ## (F ## f) = (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f" using assms by (simp add: FtorComp'_def FtorComp_def MakeFtorMor `f \<in> mor\<^bsub>CatDom F\<^esub>`)
  }
  next {
    fix f
    assume hi: "f \<notin> mor\<^bsub>CatDom (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)\<^esub>"
    have "f \<notin> mor\<^bsub>CatDom (F)\<^esub>" using assms DomFtorComp hi by fastforce
    moreover have "G ## (F ## f) = (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## f" using assms hi
      proof -

      sorry
  }
  then show ?thesis (*  by (metis (no_types, lifting) FtorComp'_def FtorComp_def Functor.select_convs(1) Functor.select_convs(3) MakeFtorMor MakeFtor_def) *)
qed

(* Step 3 : Final gather *)
theorem FtorCompositionFtor:
  assumes Ftor_F: "Functor F"
  and     Ftor_G: "Functor G"
  and     CodDom_FG: "CatCod F = CatDom G"
  shows "Functor (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)"
unfolding Functor_def
proof -
  have "FunctorM (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)" using assms by (rule FtorComp'FtorM)
  moreover have "FunctorExt (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F)" using assms
    proof - (* (auto simp add: FunctorExt_def)  *)
      (* have FunctorMapExt_F: "(MapM F) \<in> extensional (Mor (CatDom F))"
        using Ftor_F unfolding Functor_def by (simp add: FunctorExt.FunctorMapExt) *)
      have "\<forall>m. m \<notin> (Mor (CatDom F)) \<longrightarrow> (MapM F) m = undefined"
        using Ftor_F unfolding Functor_def (* by (meson FunctorExt.FunctorMapExt extensional_arb) *)
      have "undefined \<notin> Mor (CatDom G)"
        sorry
      have "\<forall>m. (G \<circ>\<^sub>F\<^sub>t\<^sub>o\<^sub>r F) ## m = G ## F ## m" using assms unfolding FtorComp using assms FtorComp'_def FtorComp_def MakeFtorMor sledgehamme
      moreover have FunctorMapExt_G: "(MapM G) \<in> extensional (Mor (CatDom G))"
        using Ftor_G unfolding Functor_def by (simp add: FunctorExt.FunctorMapExt)
      ultimately show ?thesis unfolding FtorComp_def sledgehamme
qed

end


theory Kruskal_Time
  imports MaxNode_Impl
    Union_Find_Disjoint_Sets
begin

(* TODO *)

lemma uf_cmp_time_bound[asym_bound]:
  "uf_cmp_time \<in> \<Theta>(\<lambda>n. ln n)" \<comment>\<open> it is actually @{term "\<Theta>(\<lambda>n. \<alpha> n)"} \<close>
  unfolding uf_cmp_time_def sorry

lemma uf_union_time_bound[asym_bound]:
 "uf_union_time \<in> \<Theta>(\<lambda>n. ln n)" \<comment>\<open> it is actually @{term "\<Theta>(\<lambda>n. \<alpha> n)"} \<close>
  unfolding uf_union_time_def sorry

lemma sortEdges'_time_bound[asym_bound]: "sortEdges'_time \<in> \<Theta>(\<lambda>n. n * ln n)"
  unfolding sortEdges'_time_def
  by(auto2)

locale Kruskal_final = Kruskal_intermediate  E forest connected path weight
  for E :: "nat uprod set" and forest connected path
      and weight :: "nat uprod \<Rightarrow> int"
    + fixes getEdges getEdges_time getEdges_impl
  assumes E: "E \<noteq>{}"
    and getEdges_Spec: "getEdges \<le> \<Down> Id (getEdges' weight E (enat (getEdges_time (card E))))"
    and getEdges_impl_refines:
          "(uncurry0 getEdges_impl, uncurry0 getEdges) \<in> unit_assn\<^sup>k
                   \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
begin

sublocale  Kruskal_intermediate_Impl E forest connected path weight getEdges getEdges_impl
      "getEdges_time (card E)" "sortEdges'_time (card E)" "uf_init_time (Suc (Max V))"
      "uf_cmp_time (Suc (Max V))" "uf_union_time (Suc (Max V))"
      is_uf uf_init uf_init_time uf_cmp uf_cmp_time uf_union uf_union_time
      sortEdges' sortEdges'_time
  apply(unfold_locales)
        apply (fact E)
       apply(fact getEdges_Spec)
      apply(fact getEdges_impl_refines)
  by auto

thm kruskal_correct_forest

term minBasis_time
thm minBasis_time_def

definition (in -) "kruskal_time gt  \<equiv> \<lambda>(cE, M). gt cE + sortEdges'_time cE + (12 + uf_init_time (Suc M)) + cE * (uf_cmp_time (Suc M) + (23 + uf_union_time (Suc M)))"
definition (in -) "kruskal_time'  \<equiv> \<lambda>(cE, M). sortEdges'_time cE + (12 + uf_init_time (M + 1)) + cE * (uf_cmp_time (M + 1) + (23 + uf_union_time (M + 1)))"

term minBasis_time

lemma mBT: "minBasis_time = kruskal_time getEdges_time (card E, Max V)"
  unfolding minBasis_time_def kruskal_time_def by simp

definition "kruskal_final = kruskal' getEdges_impl uf_init uf_cmp uf_union sortEdges'"

  concrete_definition (in -) kruskal_final
    uses Kruskal_final.kruskal_final_def

lemma k_c: "<timeCredit_assn (kruskal_time getEdges_time (card E, Max V))> kruskal <\<lambda>r. \<exists>\<^sub>Ara. hr_comp (da_assn id_assn) lst_graph_rel ra r * \<up> (MST ra)>\<^sub>t"
  unfolding mBT[symmetric] using kruskal_correct_forest by simp

thm sortEdges'_time_bound uf_init_bound uf_cmp_time_bound uf_union_time_bound

lemma (in -) kruskal_time'_bound:
  shows "kruskal_time'  \<in> \<Theta>\<^sub>2(\<lambda>(E::nat,M::nat). E * ln E + M + E * ln M )"
  unfolding kruskal_time'_def
  by (auto2)

(* TODO

lemma (in -) kruskal_time'_bound:
  shows "kruskal_time'  \<in> \<Theta>\<^sub>2(\<lambda>(E::nat,M::nat). E * ln E + M + E * \<alpha> M )"
  unfolding kruskal_time'_def
  by (auto2)

*)

lemma (in -) kruskal_time_split: "kruskal_time gt  = (\<lambda>(cE,M). gt cE) +  kruskal_time'"
  apply(rule ext) apply (simp add: kruskal_time'_def kruskal_time_def) by auto

lemma (in -) polylog00: "polylog 0 0 m = 1" unfolding polylog_def by simp

lemma (in -) kruskal_time_plus_linear:
  assumes "gt \<in> \<Theta>(\<lambda>n. n)"
  shows "kruskal_time gt \<in> \<Theta>\<^sub>2(\<lambda>(E::nat,M::nat). E * ln E + M + E * ln M )" (is "_ \<in> ?T")
proof -
  have A: "(\<lambda>x. real (gt (fst x))) \<in> \<Theta>\<^sub>2 (\<lambda>(n::nat, m::nat). real n)"
    using mult_Theta_bivariate1[unfolded polylog2_def polylog_def, of gt 1 0 ]
    apply auto using assms by simp

  have split: "\<And>x. gt (fst x) + kruskal_time' x = kruskal_time gt x"
    unfolding kruskal_time'_def kruskal_time_def by auto

  have r: "(\<lambda>x. real (gt (fst x) + kruskal_time' x)) \<in> \<Theta>\<^sub>2 ((\<lambda>x. case x of (n, m) \<Rightarrow> real n) + (\<lambda>x. case x of (E, M) \<Rightarrow> real E * ln (real E) + real M + real E * ln (real M)))"
    apply(rule bigtheta_add[OF _ _ A kruskal_time'_bound ])
    subgoal apply(auto simp: eventually_nonneg_def eventually_sequentially)

      using eventually_prod_same by force
    subgoal apply(auto simp: eventually_nonneg_def eventually_sequentially)
      apply(subst eventually_prod_same) apply auto apply(rule exI[where x="\<lambda>x. x\<ge>1"])
      by simp
    done

  { fix x y :: nat and c
    assume t: "y\<ge>1 " " x\<ge>1 " " 1 \<le> c * ln (real x)" "c>0"
    then have t': "real y + real x * ln (real y) \<ge> 0"
      by simp
    from t have "real x \<le> c * real x * ln (real x)" by auto
    also have "\<dots> \<le> c * (real x * ln (real x) + real y + real x * ln (real y)) "
      using t' t by auto
    finally
    have "real x \<le> c * (real x * ln (real x) + real y + real x * ln (real y)) " .
  } note blub = this

  have 2: "?T = \<Theta>\<^sub>2 ((\<lambda>x. case x of (n, m) \<Rightarrow> real n) + (\<lambda>x. case x of (E, M) \<Rightarrow> real E * ln (real E) + real M + real E * ln (real M)))"
    apply(subst plus_absorb1')
    subgoal apply(rule landau_o.smallI) apply(subst eventually_prod_same)
      subgoal for c apply(rule exI[where x="\<lambda>x::nat. real x \<le> c * \<bar>real x * ln (real x)\<bar> \<and> x\<ge>1"])
        apply safe subgoal apply(simp add: eventually_sequentially) apply (rule exI[where x="max (max 1 (nat (ceiling (exp (1/c))))) (nat (ceiling (1/c)))"])
          apply auto
          by (metis exp_gt_zero exp_le_cancel_iff exp_ln less_le_trans mult.commute pos_divide_le_eq)
          apply auto  apply(rule blub) by auto
        done
    by simp

  show ?thesis
    unfolding split[symmetric] 2
    using r .
qed

end

end