(*  Title:      HOL/Quotient_Examples/Lift_Fun.thy
    Author:     Ondrej Kuncar
*)

section {* Example of lifting definitions with contravariant or co/contravariant type variables *}

theory Lift_Fun
imports Main "~~/src/HOL/Library/Quotient_Syntax"
begin

text {* This file is meant as a test case.
  It contains examples of lifting definitions with quotients that have contravariant
  type variables or type variables which are covariant and contravariant in the same time. *}

subsection {* Contravariant type variables *}

text {* 'a is a contravariant type variable and we are able to map over this variable
  in the following four definitions. This example is based on HOL/Fun.thy. *}

quotient_type
('a, 'b) fun' (infixr "\<rightarrow>" 55) = "'a \<Rightarrow> 'b" / "op ="
  by (simp add: identity_equivp)

quotient_definition "comp' :: ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c"  is
  "comp :: ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" done

quotient_definition "fcomp' :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c" is
  fcomp done

quotient_definition "map_fun' :: ('c \<rightarrow> 'a) \<rightarrow> ('b \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'c \<rightarrow> 'd"
  is "map_fun::('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd" done

quotient_definition "inj_on' :: ('a \<rightarrow> 'b) \<rightarrow> 'a set \<rightarrow> bool" is inj_on done

quotient_definition "bij_betw' :: ('a \<rightarrow> 'b) \<rightarrow> 'a set \<rightarrow> 'b set \<rightarrow> bool" is bij_betw done

subsection {* Co/Contravariant type variables *}

text {* 'a is a covariant and contravariant type variable in the same time.
  The following example is a bit artificial. We haven't had a natural one yet. *}

quotient_type 'a endofun = "'a \<Rightarrow> 'a" / "op =" by (simp add: identity_equivp)

definition map_endofun' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('a => 'a) \<Rightarrow> ('b => 'b)"
  where "map_endofun' f g e = map_fun g f e"

quotient_definition "map_endofun :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a endofun \<Rightarrow> 'b endofun" is
  map_endofun' done

text {* Registration of the map function for 'a endofun. *}

functor map_endofun : map_endofun
proof -
  have "\<forall> x. abs_endofun (rep_endofun x) = x" using Quotient3_endofun by (auto simp: Quotient3_def)
  then show "map_endofun id id = id"
    by (auto simp: map_endofun_def map_endofun'_def map_fun_def fun_eq_iff)

  have a:"\<forall> x. rep_endofun (abs_endofun x) = x" using Quotient3_endofun
    Quotient3_rep_abs[of "(op =)" abs_endofun rep_endofun] by blast
  show "\<And>f g h i. map_endofun f g \<circ> map_endofun h i = map_endofun (f \<circ> h) (i \<circ> g)"
    by (auto simp: map_endofun_def map_endofun'_def map_fun_def fun_eq_iff) (simp add: a o_assoc)
qed

text {* Relator for 'a endofun. *}

definition
  rel_endofun' :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "rel_endofun' R = (\<lambda>f g. (R ===> R) f g)"

quotient_definition "rel_endofun :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a endofun \<Rightarrow> 'b endofun \<Rightarrow> bool" is
  rel_endofun' done

lemma endofun_quotient:
assumes a: "Quotient3 R Abs Rep"
shows "Quotient3 (rel_endofun R) (map_endofun Abs Rep) (map_endofun Rep Abs)"
proof (intro Quotient3I)
  show "\<And>a. map_endofun Abs Rep (map_endofun Rep Abs a) = a"
    by (metis (hide_lams, no_types) a abs_o_rep id_apply map_endofun.comp map_endofun.id o_eq_dest_lhs)
next
  show "\<And>a. rel_endofun R (map_endofun Rep Abs a) (map_endofun Rep Abs a)"
  using fun_quotient3[OF a a, THEN Quotient3_rep_reflp]
  unfolding rel_endofun_def map_endofun_def map_fun_def o_def map_endofun'_def rel_endofun'_def id_def
    by (metis (mono_tags) Quotient3_endofun rep_abs_rsp)
next
  have abs_to_eq: "\<And> x y. abs_endofun x = abs_endofun y \<Longrightarrow> x = y"
  by (drule arg_cong[where f=rep_endofun]) (simp add: Quotient3_rep_abs[OF Quotient3_endofun])
  fix r s
  show "rel_endofun R r s =
          (rel_endofun R r r \<and>
           rel_endofun R s s \<and> map_endofun Abs Rep r = map_endofun Abs Rep s)"
    apply(auto simp add: rel_endofun_def rel_endofun'_def map_endofun_def map_endofun'_def)
    using fun_quotient3[OF a a,THEN Quotient3_refl1]
    apply metis
    using fun_quotient3[OF a a,THEN Quotient3_refl2]
    apply metis
    using fun_quotient3[OF a a, THEN Quotient3_rel]
    apply metis
    by (auto intro: fun_quotient3[OF a a, THEN Quotient3_rel, THEN iffD1] simp add: abs_to_eq)
qed

declare [[mapQ3 endofun = (rel_endofun, endofun_quotient)]]

quotient_definition "endofun_id_id :: ('a endofun) endofun" is "id :: ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" done

term  endofun_id_id
thm  endofun_id_id_def

quotient_type 'a endofun' = "'a endofun" / "op =" by (simp add: identity_equivp)

text {* We have to map "'a endofun" to "('a endofun') endofun", i.e., mapping (lifting)
  over a type variable which is a covariant and contravariant type variable. *}

quotient_definition "endofun'_id_id :: ('a endofun') endofun'" is endofun_id_id done

term  endofun'_id_id
thm  endofun'_id_id_def

end


section \<open>Ordered Euclidean Space\<close>

theory Ordered_Euclidean_Space
imports
  Convex_Euclidean_Space
  "HOL-Library.Product_Order"
begin

text \<open>An ordering on euclidean spaces that will allow us to talk about intervals\<close>

class ordered_euclidean_space = ord + inf + sup + abs + Inf + Sup + euclidean_space +
  assumes eucl_le: "x \<le> y \<longleftrightarrow> (\<forall>i\<in>Basis. x \<bullet> i \<le> y \<bullet> i)"
  assumes eucl_less_le_not_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
  assumes eucl_inf: "inf x y = (\<Sum>i\<in>Basis. inf (x \<bullet> i) (y \<bullet> i) *\<^sub>R i)"
  assumes eucl_sup: "sup x y = (\<Sum>i\<in>Basis. sup (x \<bullet> i) (y \<bullet> i) *\<^sub>R i)"
  assumes eucl_Inf: "Inf X = (\<Sum>i\<in>Basis. (INF x\<in>X. x \<bullet> i) *\<^sub>R i)"
  assumes eucl_Sup: "Sup X = (\<Sum>i\<in>Basis. (SUP x\<in>X. x \<bullet> i) *\<^sub>R i)"
  assumes eucl_abs: "\<bar>x\<bar> = (\<Sum>i\<in>Basis. \<bar>x \<bullet> i\<bar> *\<^sub>R i)"
begin

subclass order
  by standard
    (auto simp: eucl_le eucl_less_le_not_le intro!: euclidean_eqI antisym intro: order.trans)

subclass ordered_ab_group_add_abs
  by standard (auto simp: eucl_le inner_add_left eucl_abs abs_leI)

subclass ordered_real_vector
  by standard (auto simp: eucl_le intro!: mult_left_mono mult_right_mono)

subclass lattice
  by standard (auto simp: eucl_inf eucl_sup eucl_le)

subclass distrib_lattice
  by standard (auto simp: eucl_inf eucl_sup sup_inf_distrib1 intro!: euclidean_eqI)

subclass conditionally_complete_lattice
proof
  fix z::'a and X::"'a set"
  assume "X \<noteq> {}"
  hence "\<And>i. (\<lambda>x. x \<bullet> i) ` X \<noteq> {}" by simp
  thus "(\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X" "(\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
    by (auto simp: eucl_Inf eucl_Sup eucl_le
      intro!: cInf_greatest cSup_least)
qed (force intro!: cInf_lower cSup_upper
      simp: bdd_below_def bdd_above_def preorder_class.bdd_below_def preorder_class.bdd_above_def
        eucl_Inf eucl_Sup eucl_le)+

lemma inner_Basis_inf_left: "i \<in> Basis \<Longrightarrow> inf x y \<bullet> i = inf (x \<bullet> i) (y \<bullet> i)"
  and inner_Basis_sup_left: "i \<in> Basis \<Longrightarrow> sup x y \<bullet> i = sup (x \<bullet> i) (y \<bullet> i)"
  by (simp_all add: eucl_inf eucl_sup inner_sum_left inner_Basis if_distrib
      cong: if_cong)

lemma inner_Basis_INF_left: "i \<in> Basis \<Longrightarrow> (INF x\<in>X. f x) \<bullet> i = (INF x\<in>X. f x \<bullet> i)"
  and inner_Basis_SUP_left: "i \<in> Basis \<Longrightarrow> (SUP x\<in>X. f x) \<bullet> i = (SUP x\<in>X. f x \<bullet> i)"
  using eucl_Sup [of "f ` X"] eucl_Inf [of "f ` X"] by (simp_all add: image_comp)

lemma abs_inner: "i \<in> Basis \<Longrightarrow> \<bar>x\<bar> \<bullet> i = \<bar>x \<bullet> i\<bar>"
  by (auto simp: eucl_abs)

lemma
  abs_scaleR: "\<bar>a *\<^sub>R b\<bar> = \<bar>a\<bar> *\<^sub>R \<bar>b\<bar>"
  by (auto simp: eucl_abs abs_mult intro!: euclidean_eqI)

lemma interval_inner_leI:
  assumes "x \<in> {a .. b}" "0 \<le> i"
  shows "a\<bullet>i \<le> x\<bullet>i" "x\<bullet>i \<le> b\<bullet>i"
  using assms
  unfolding euclidean_inner[of a i] euclidean_inner[of x i] euclidean_inner[of b i]
  by (auto intro!: ordered_comm_monoid_add_class.sum_mono mult_right_mono simp: eucl_le)

lemma inner_nonneg_nonneg:
  shows "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a \<bullet> b"
  using interval_inner_leI[of a 0 a b]
  by auto

lemma inner_Basis_mono:
  shows "a \<le> b \<Longrightarrow> c \<in> Basis  \<Longrightarrow> a \<bullet> c \<le> b \<bullet> c"
  by (simp add: eucl_le)

lemma Basis_nonneg[intro, simp]: "i \<in> Basis \<Longrightarrow> 0 \<le> i"
  by (auto simp: eucl_le inner_Basis)

lemma Sup_eq_maximum_componentwise:
  fixes s::"'a set"
  assumes i: "\<And>b. b \<in> Basis \<Longrightarrow> X \<bullet> b = i b \<bullet> b"
  assumes sup: "\<And>b x. b \<in> Basis \<Longrightarrow> x \<in> s \<Longrightarrow> x \<bullet> b \<le> X \<bullet> b"
  assumes i_s: "\<And>b. b \<in> Basis \<Longrightarrow> (i b \<bullet> b) \<in> (\<lambda>x. x \<bullet> b) ` s"
  shows "Sup s = X"
  using assms
  unfolding eucl_Sup euclidean_representation_sum
  by (auto intro!: conditionally_complete_lattice_class.cSup_eq_maximum)

lemma Inf_eq_minimum_componentwise:
  assumes i: "\<And>b. b \<in> Basis \<Longrightarrow> X \<bullet> b = i b \<bullet> b"
  assumes sup: "\<And>b x. b \<in> Basis \<Longrightarrow> x \<in> s \<Longrightarrow> X \<bullet> b \<le> x \<bullet> b"
  assumes i_s: "\<And>b. b \<in> Basis \<Longrightarrow> (i b \<bullet> b) \<in> (\<lambda>x. x \<bullet> b) ` s"
  shows "Inf s = X"
  using assms
  unfolding eucl_Inf euclidean_representation_sum
  by (auto intro!: conditionally_complete_lattice_class.cInf_eq_minimum)

end

proposition  compact_attains_Inf_componentwise:
  fixes b::"'a::ordered_euclidean_space"
  assumes "b \<in> Basis" assumes "X \<noteq> {}" "compact X"
  obtains x where "x \<in> X" "x \<bullet> b = Inf X \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> x \<bullet> b \<le> y \<bullet> b"
proof atomize_elim
  let ?proj = "(\<lambda>x. x \<bullet> b) ` X"
  from assms have "compact ?proj" "?proj \<noteq> {}"
    by (auto intro!: compact_continuous_image continuous_intros)
  from compact_attains_inf[OF this]
  obtain s x
    where s: "s\<in>(\<lambda>x. x \<bullet> b) ` X" "\<And>t. t\<in>(\<lambda>x. x \<bullet> b) ` X \<Longrightarrow> s \<le> t"
      and x: "x \<in> X" "s = x \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> x \<bullet> b \<le> y \<bullet> b"
    by auto
  hence "Inf ?proj = x \<bullet> b"
    by (auto intro!: conditionally_complete_lattice_class.cInf_eq_minimum)
  hence "x \<bullet> b = Inf X \<bullet> b"
    by (auto simp: eucl_Inf inner_sum_left inner_Basis if_distrib \<open>b \<in> Basis\<close>
      cong: if_cong)
  with x show "\<exists>x. x \<in> X \<and> x \<bullet> b = Inf X \<bullet> b \<and> (\<forall>y. y \<in> X \<longrightarrow> x \<bullet> b \<le> y \<bullet> b)" by blast
qed

proposition
  compact_attains_Sup_componentwise:
  fixes b::"'a::ordered_euclidean_space"
  assumes "b \<in> Basis" assumes "X \<noteq> {}" "compact X"
  obtains x where "x \<in> X" "x \<bullet> b = Sup X \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> y \<bullet> b \<le> x \<bullet> b"
proof atomize_elim
  let ?proj = "(\<lambda>x. x \<bullet> b) ` X"
  from assms have "compact ?proj" "?proj \<noteq> {}"
    by (auto intro!: compact_continuous_image continuous_intros)
  from compact_attains_sup[OF this]
  obtain s x
    where s: "s\<in>(\<lambda>x. x \<bullet> b) ` X" "\<And>t. t\<in>(\<lambda>x. x \<bullet> b) ` X \<Longrightarrow> t \<le> s"
      and x: "x \<in> X" "s = x \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> y \<bullet> b \<le> x \<bullet> b"
    by auto
  hence "Sup ?proj = x \<bullet> b"
    by (auto intro!: cSup_eq_maximum)
  hence "x \<bullet> b = Sup X \<bullet> b"
    by (auto simp: eucl_Sup[where 'a='a] inner_sum_left inner_Basis if_distrib \<open>b \<in> Basis\<close>
      cong: if_cong)
  with x show "\<exists>x. x \<in> X \<and> x \<bullet> b = Sup X \<bullet> b \<and> (\<forall>y. y \<in> X \<longrightarrow> y \<bullet> b \<le> x \<bullet> b)" by blast
qed

lemma tendsto_sup[tendsto_intros]:
  fixes X :: "'a \<Rightarrow> 'b::ordered_euclidean_space"
  assumes "(X \<longlongrightarrow> x) net" "(Y \<longlongrightarrow> y) net"
  shows "((\<lambda>i. sup (X i) (Y i)) \<longlongrightarrow> sup x y) net"
   unfolding sup_max eucl_sup by (intro assms tendsto_intros)

lemma tendsto_inf[tendsto_intros]:
  fixes X :: "'a \<Rightarrow> 'b::ordered_euclidean_space"
  assumes "(X \<longlongrightarrow> x) net" "(Y \<longlongrightarrow> y) net"
  shows "((\<lambda>i. inf (X i) (Y i)) \<longlongrightarrow> inf x y) net"
   unfolding inf_min eucl_inf by (intro assms tendsto_intros)

lemma tendsto_componentwise_max:
  assumes f: "(f \<longlongrightarrow> l) F" and g: "(g \<longlongrightarrow> m) F"
  shows "((\<lambda>x. (\<Sum>i\<in>Basis. max (f x \<bullet> i) (g x \<bullet> i) *\<^sub>R i)) \<longlongrightarrow> (\<Sum>i\<in>Basis. max (l \<bullet> i) (m \<bullet> i) *\<^sub>R i)) F"
  by (intro tendsto_intros assms)

lemma tendsto_componentwise_min:
  assumes f: "(f \<longlongrightarrow> l) F" and g: "(g \<longlongrightarrow> m) F"
  shows "((\<lambda>x. (\<Sum>i\<in>Basis. min (f x \<bullet> i) (g x \<bullet> i) *\<^sub>R i)) \<longlongrightarrow> (\<Sum>i\<in>Basis. min (l \<bullet> i) (m \<bullet> i) *\<^sub>R i)) F"
  by (intro tendsto_intros assms)

lemma (in order) atLeastatMost_empty'[simp]:
  "(\<not> a \<le> b) \<Longrightarrow> {a..b} = {}"
  by (auto)

instance real :: ordered_euclidean_space
  by standard auto

lemma in_Basis_prod_iff:
  fixes i::"'a::euclidean_space*'b::euclidean_space"
  shows "i \<in> Basis \<longleftrightarrow> fst i = 0 \<and> snd i \<in> Basis \<or> snd i = 0 \<and> fst i \<in> Basis"
  by (cases i) (auto simp: Basis_prod_def)

instantiation\<^marker>\<open>tag unimportant\<close> prod :: (abs, abs) abs
begin

definition "\<bar>x\<bar> = (\<bar>fst x\<bar>, \<bar>snd x\<bar>)"

instance ..

end

instance prod :: (ordered_euclidean_space, ordered_euclidean_space) ordered_euclidean_space
  by standard
    (auto intro!: add_mono simp add: euclidean_representation_sum'  Ball_def inner_prod_def
      in_Basis_prod_iff inner_Basis_inf_left inner_Basis_sup_left inner_Basis_INF_left Inf_prod_def
      inner_Basis_SUP_left Sup_prod_def less_prod_def less_eq_prod_def eucl_le[where 'a='a]
      eucl_le[where 'a='b] abs_prod_def abs_inner)

text\<open>Instantiation for intervals on \<open>ordered_euclidean_space\<close>\<close>

proposition
  fixes a :: "'a::ordered_euclidean_space"
  shows cbox_interval: "cbox a b = {a..b}"
    and interval_cbox: "{a..b} = cbox a b"
    and eucl_le_atMost: "{x. \<forall>i\<in>Basis. x \<bullet> i <= a \<bullet> i} = {..a}"
    and eucl_le_atLeast: "{x. \<forall>i\<in>Basis. a \<bullet> i <= x \<bullet> i} = {a..}"
  by (auto simp: eucl_le[where 'a='a] eucl_less_def box_def cbox_def)

lemma sums_vec_nth :
  assumes "f sums a"
  shows "(\<lambda>x. f x $ i) sums a $ i"
  using assms unfolding sums_def
  by (auto dest: tendsto_vec_nth [where i=i])

lemma summable_vec_nth :
  assumes "summable f"
  shows "summable (\<lambda>x. f x $ i)"
  using assms unfolding summable_def
  by (blast intro: sums_vec_nth)

lemma closed_eucl_atLeastAtMost[simp, intro]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "closed {a..b}"
  by (simp add: cbox_interval[symmetric] closed_cbox)

lemma closed_eucl_atMost[simp, intro]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "closed {..a}"
  by (simp add: closed_interval_left eucl_le_atMost[symmetric])

lemma closed_eucl_atLeast[simp, intro]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "closed {a..}"
  by (simp add: closed_interval_right eucl_le_atLeast[symmetric])

lemma bounded_closed_interval [simp]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "bounded {a .. b}"
  using bounded_cbox[of a b]
  by (metis interval_cbox)

lemma convex_closed_interval [simp]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "convex {a .. b}"
  using convex_box[of a b]
  by (metis interval_cbox)

lemma image_smult_interval:"(\<lambda>x. m *\<^sub>R (x::_::ordered_euclidean_space)) ` {a .. b} =
  (if {a .. b} = {} then {} else if 0 \<le> m then {m *\<^sub>R a .. m *\<^sub>R b} else {m *\<^sub>R b .. m *\<^sub>R a})"
  using image_smult_cbox[of m a b]
  by (simp add: cbox_interval)

lemma connected_interval [simp]:
  fixes a b::"'a::ordered_euclidean_space"
  shows "connected {a..b}"
  using is_interval_cc is_interval_connected by blast

lemma compact_interval [simp]:
  fixes a b::"'a::ordered_euclidean_space"
  shows "compact {a .. b}"
  by (metis compact_cbox interval_cbox)

no_notation
  eucl_less (infix "<e" 50)

lemma One_nonneg: "0 \<le> (\<Sum>Basis::'a::ordered_euclidean_space)"
  by (auto intro: sum_nonneg)

lemma
  fixes a b::"'a::ordered_euclidean_space"
  shows bdd_above_cbox[intro, simp]: "bdd_above (cbox a b)"
    and bdd_below_cbox[intro, simp]: "bdd_below (cbox a b)"
    and bdd_above_box[intro, simp]: "bdd_above (box a b)"
    and bdd_below_box[intro, simp]: "bdd_below (box a b)"
  unfolding atomize_conj
  by (metis bdd_above_Icc bdd_above_mono bdd_below_Icc bdd_below_mono bounded_box
            bounded_subset_cbox_symmetric interval_cbox)

instantiation vec :: (ordered_euclidean_space, finite) ordered_euclidean_space
begin

definition\<^marker>\<open>tag important\<close> "inf x y = (\<chi> i. inf (x $ i) (y $ i))"
definition\<^marker>\<open>tag important\<close> "sup x y = (\<chi> i. sup (x $ i) (y $ i))"
definition\<^marker>\<open>tag important\<close> "Inf X = (\<chi> i. (INF x\<in>X. x $ i))"
definition\<^marker>\<open>tag important\<close> "Sup X = (\<chi> i. (SUP x\<in>X. x $ i))"
definition\<^marker>\<open>tag important\<close> "\<bar>x\<bar> = (\<chi> i. \<bar>x $ i\<bar>)"

instance
  apply standard
  unfolding euclidean_representation_sum'
  apply (auto simp: less_eq_vec_def inf_vec_def sup_vec_def Inf_vec_def Sup_vec_def inner_axis
    Basis_vec_def inner_Basis_inf_left inner_Basis_sup_left inner_Basis_INF_left
    inner_Basis_SUP_left eucl_le[where 'a='a] less_le_not_le abs_vec_def abs_inner)
  done

end

end


section \<open>Transformation to Language-Equivalent Prime FSMs\<close>

text \<open>This theory describes the transformation of FSMs into language-equivalent FSMs
      that are prime, that is: observable, minimal and initially connected.\<close>

theory Prime_Transformation
imports Minimisation Observability State_Cover OFSM_Tables_Refined "HOL-Library.List_Lexorder" Native_Word.Uint64
begin

subsection \<open>Helper Functions\<close>

text \<open>The following functions transform FSMs whose states are Sets or FSets into
      language-equivalent fsms whose states are lists.
      These steps are required in the chosen implementation of the transformation function,
      as Sets or FSets are not instances of linorder.\<close>

lemma linorder_fset_list_bij : "bij_betw sorted_list_of_fset xs (sorted_list_of_fset ` xs)"
  unfolding bij_betw_def inj_on_def
  by (metis sorted_list_of_fset_simps(2))

lemma linorder_set_list_bij :
  assumes "\<And> x . x \<in> xs \<Longrightarrow> finite x"
  shows "bij_betw sorted_list_of_set xs (sorted_list_of_set ` xs)"
proof -
  have "\<And> x . x \<in> xs \<Longrightarrow> set (sorted_list_of_set x) = x"
    by (simp add: assms)
  then show ?thesis
    unfolding bij_betw_def inj_on_def
    by metis
qed

definition fset_states_to_list_states :: "(('a::linorder) fset,'b,'c) fsm \<Rightarrow> ('a list,'b,'c) fsm" where
  "fset_states_to_list_states M = rename_states M sorted_list_of_fset"

definition set_states_to_list_states :: "(('a::linorder) set,'b,'c) fsm \<Rightarrow> ('a list,'b,'c) fsm" where
  "set_states_to_list_states M = rename_states M sorted_list_of_set"

lemma fset_states_to_list_states_language :
  "L (fset_states_to_list_states M) = L M"
  using rename_states_isomorphism_language[OF linorder_fset_list_bij]
  unfolding fset_states_to_list_states_def .

lemma set_states_to_list_states_language :
  assumes "\<And> x . x \<in> states M \<Longrightarrow> finite x"
  shows "L (set_states_to_list_states M) = L M"
  using rename_states_isomorphism_language[OF linorder_set_list_bij[OF assms]]
  unfolding set_states_to_list_states_def .

lemma fset_states_to_list_states_observable :
  assumes "observable M"
  shows "observable (fset_states_to_list_states M)"
  using rename_states_observable[OF linorder_fset_list_bij assms]
  unfolding fset_states_to_list_states_def .

lemma set_states_to_list_states_observable :
  assumes "\<And> x . x \<in> states M \<Longrightarrow> finite x"
  assumes "observable M"
  shows "observable (set_states_to_list_states M)"
  using rename_states_observable[OF linorder_set_list_bij[OF assms(1)] assms(2)]
  unfolding set_states_to_list_states_def by blast

lemma fset_states_to_list_states_minimal :
  assumes "minimal M"
  shows "minimal (fset_states_to_list_states M)"
  using rename_states_minimal[OF linorder_fset_list_bij assms]
  unfolding fset_states_to_list_states_def .

lemma set_states_to_list_states_minimal :
  assumes "\<And> x . x \<in> states M \<Longrightarrow> finite x"
  assumes "minimal M"
  shows "minimal (set_states_to_list_states M)"
  using rename_states_minimal[OF linorder_set_list_bij[OF assms(1)] assms(2)]
  unfolding set_states_to_list_states_def by blast

subsection \<open>The Transformation Algorithm\<close>

definition to_prime :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> (integer,'b,'c) fsm" where
  "to_prime M = restrict_to_reachable_states (
                  index_states_integer (
                    set_states_to_list_states (
                      minimise_refined (
                        index_states (
                          fset_states_to_list_states (
                            make_observable (
                              restrict_to_reachable_states M)))))))"

lemma to_prime_props :
  "L (to_prime M) = L M"
  "observable (to_prime M)"
  "minimal (to_prime M)"
  "reachable_states (to_prime M) = states (to_prime M)"
  "inputs (to_prime M) = inputs M"
  "outputs (to_prime M) = outputs M"
proof -

  define M1 where M1: "M1 = restrict_to_reachable_states M"
  define M2 where M2: "M2 = make_observable M1"
  define M3 where M3: "M3 = fset_states_to_list_states M2"
  define M4 where M4: "M4 = index_states M3"
  define M5 where M5: "M5 = minimise_refined M4"
  define M6 where M6: "M6 = set_states_to_list_states M5"
  define M7 where M7: "M7 = index_states_integer M6"
  define M8 where M8: "M8 = restrict_to_reachable_states M7"

  have "to_prime M = M8"
    unfolding M8 M7 M6 M5 M4 M3 M2 M1 to_prime_def by presburger

  have "observable M2"
    unfolding M2
    using make_observable_language_observable(2) by blast
  then have "observable M3"
    unfolding M3
    using fset_states_to_list_states_observable by blast
  then have "observable M4"
    unfolding M4
    using index_states_observable by blast
  then have "observable M5"
    unfolding M5
    unfolding minimise_refined_is_minimise[symmetric]
    using minimise_observable by blast
  then have "observable M6"
    unfolding M6 M5
    unfolding minimise_refined_is_minimise[symmetric]
    using minimise_states_finite[OF \<open>observable M4\<close>]
    using set_states_to_list_states_observable
    by metis
  then have "observable M7"
    unfolding M7
    using index_states_integer_observable by blast
  then show "observable (to_prime M)"
    unfolding \<open>to_prime M = M8\<close> M8
    using restrict_to_reachable_states_observable by blast

  have "L M = L M1"
    unfolding M1 restrict_to_reachable_states_language by simp
  also have "\<dots> = L M2"
    unfolding M2 make_observable_language_observable(1) by simp
  also have "\<dots> = L M3"
    unfolding M3 fset_states_to_list_states_language by simp
  also have "\<dots> = L M4"
    unfolding M4 index_states_language by simp
  also have "\<dots> = L M5"
    unfolding M5 unfolding minimise_refined_is_minimise[symmetric]
    using minimise_language[OF \<open>observable M4\<close>] by blast
  also have "\<dots> = L M6"
    unfolding M6 M5 unfolding minimise_refined_is_minimise[symmetric]
    using set_states_to_list_states_language[OF minimise_states_finite[OF \<open>observable M4\<close>]] by blast
  also have "\<dots> = L M7"
    unfolding M7 using index_states_integer_language by blast
  also have "\<dots> = L M8"
    unfolding M8 restrict_to_reachable_states_language by simp
  finally show "L (to_prime M) = L M"
    unfolding \<open>to_prime M = M8\<close> by blast

  have "minimal M5"
    unfolding M5 unfolding minimise_refined_is_minimise[symmetric]
    using minimise_minimal[OF \<open>observable M4\<close>] .
  then have "minimal M6"
    unfolding M6 M5 unfolding minimise_refined_is_minimise[symmetric]
    using set_states_to_list_states_minimal[OF minimise_states_finite[OF \<open>observable M4\<close>]] by blast
  then have "minimal M7"
    unfolding M7 using index_states_integer_minimal by blast
  then show "minimal (to_prime M)"
    unfolding \<open>to_prime M = M8\<close> M8
    using restrict_to_reachable_states_minimal by blast

  show "reachable_states (to_prime M) = states (to_prime M)"
    unfolding \<open>to_prime M = M8\<close> M8 restrict_to_reachable_states_reachable_states by presburger

  have "inputs M = inputs M1"
    unfolding M1 restrict_to_reachable_states_simps by simp
  also have "\<dots> = inputs M2"
    unfolding M2 make_observable_language_observable Let_def add_transitions_simps create_unconnected_fsm_simps by blast
  also have "\<dots> = inputs M3"
    unfolding M3 fset_states_to_list_states_def by simp
  also have "\<dots> = inputs M4"
    unfolding M4 index_states.simps by simp
  also have "\<dots> = inputs M5"
    unfolding M5 unfolding minimise_refined_is_minimise[symmetric]
    using minimise_props[OF \<open>observable M4\<close>] by blast
  also have "\<dots> = inputs M6"
    unfolding M6 M5 set_states_to_list_states_def by simp
  also have "\<dots> = inputs M7"
    unfolding M7 index_states.simps by simp
  also have "\<dots> = inputs M8"
    unfolding M8 restrict_to_reachable_states_simps by simp
  finally show "inputs (to_prime M) = inputs M"
    unfolding \<open>to_prime M = M8\<close> by blast

  have "outputs M = outputs M1"
    unfolding M1 restrict_to_reachable_states_simps by simp
  also have "\<dots> = outputs M2"
    unfolding M2 make_observable_language_observable Let_def add_transitions_simps create_unconnected_fsm_simps by blast
  also have "\<dots> = outputs M3"
    unfolding M3 fset_states_to_list_states_def by simp
  also have "\<dots> = outputs M4"
    unfolding M4 index_states.simps by simp
  also have "\<dots> = outputs M5"
    unfolding M5 unfolding minimise_refined_is_minimise[symmetric]
    using minimise_props[OF \<open>observable M4\<close>] by blast
  also have "\<dots> = outputs M6"
    unfolding M6 M5 set_states_to_list_states_def by simp
  also have "\<dots> = outputs M7"
    unfolding M7 index_states.simps by simp
  also have "\<dots> = outputs M8"
    unfolding M8 restrict_to_reachable_states_simps by simp
  finally show "outputs (to_prime M) = outputs M"
    unfolding \<open>to_prime M = M8\<close> by blast
qed

subsection \<open>Renaming states to Words\<close>

lemma uint64_nat_bij : "(x :: nat) < 2^64 \<Longrightarrow> nat_of_uint64 (uint64_of_nat x) = x"
  by transfer (simp add: unsigned_of_nat take_bit_nat_eq_self)

fun index_states_uint64 :: "('a::linorder,'b,'c) fsm \<Rightarrow> (uint64,'b,'c) fsm" where
  "index_states_uint64 M = rename_states M (uint64_of_nat \<circ> assign_indices (states M))"

lemma assign_indices_uint64_bij_betw :
  assumes "size M < 2^64"
  shows "bij_betw (uint64_of_nat \<circ> assign_indices (states M)) (FSM.states M) ((uint64_of_nat \<circ> assign_indices (states M)) ` FSM.states M)"
proof -
  have *: "inj_on (assign_indices (FSM.states M)) (FSM.states M)"
    using assign_indices_bij[OF fsm_states_finite[of M]]
    unfolding bij_betw_def
    by auto
  moreover have "\<And> q . q \<in> states M \<Longrightarrow> assign_indices (states M) q < 2^64"
    using assms assign_indices_bij[OF fsm_states_finite[of M]]
    unfolding size_def
    by (meson bij_betwE lessThan_iff less_imp_le less_le_trans)
  ultimately have "inj_on (uint64_of_nat \<circ> assign_indices (states M)) (FSM.states M)"
    unfolding inj_on_def
    by (metis comp_apply uint64_nat_bij)
  then show ?thesis
    unfolding bij_betw_def
    by auto
qed

lemma index_states_uint64_language :
  assumes "size M < 2^64"
 shows  "L (index_states_uint64 M) = L M"
  using rename_states_isomorphism_language[of "uint64_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_uint64_bij_betw[OF assms]]
  by auto

lemma index_states_uint64_observable :
  assumes "size M < 2^64" and "observable M"
  shows "observable (index_states_uint64 M)"
  using rename_states_observable[of "uint64_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_uint64_bij_betw[OF assms(1)] assms(2)]
  unfolding index_states_uint64.simps .

lemma index_states_uint64_minimal :
  assumes "size M < 2^64" and "minimal M"
  shows "minimal (index_states_uint64 M)"
  using rename_states_minimal[of "uint64_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_uint64_bij_betw[OF assms(1)] assms(2)]
  unfolding index_states_uint64.simps .

(* TODO: remove superfluous restriction to reachable states *)
definition to_prime_uint64 :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> (uint64,'b,'c) fsm" where
  "to_prime_uint64 M = restrict_to_reachable_states (index_states_uint64 (to_prime M))"

lemma to_prime_uint64_props :
  assumes "size (to_prime M) < 2^64"
shows
  "L (to_prime_uint64 M) = L M"
  "observable (to_prime_uint64 M)"
  "minimal (to_prime_uint64 M)"
  "reachable_states (to_prime_uint64 M) = states (to_prime_uint64 M)"
  "inputs (to_prime_uint64 M) = inputs M"
  "outputs (to_prime_uint64 M) = outputs M"
    using restrict_to_reachable_states_reachable_states[of "index_states_uint64 (to_prime M)"]
    unfolding to_prime_uint64_def
    using index_states_uint64_language[OF assms]
    unfolding restrict_to_reachable_states_language
    using restrict_to_reachable_states_observable[OF index_states_uint64_observable[OF assms to_prime_props(2)]]
    using restrict_to_reachable_states_minimal[OF index_states_uint64_minimal[OF assms to_prime_props(3)]]
    unfolding index_states_uint64.simps
    unfolding restrict_to_reachable_states_simps
    unfolding rename_states_simps(3,4)
    unfolding to_prime_props(1,5,6)
    by blast+

end