(*  Title:      HOL/Library/Option_ord.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Canonical order on option type\<close>

theory Option_ord
imports MainRLT
begin

unbundle lattice_syntax

instantiation option :: (preorder) preorder
begin

definition less_eq_option where
  "x \<le> y \<longleftrightarrow> (case x of None \<Rightarrow> True | Some x \<Rightarrow> (case y of None \<Rightarrow> False | Some y \<Rightarrow> x \<le> y))"

definition less_option where
  "x < y \<longleftrightarrow> (case y of None \<Rightarrow> False | Some y \<Rightarrow> (case x of None \<Rightarrow> True | Some x \<Rightarrow> x < y))"

lemma less_eq_option_None [simp]: "None \<le> x"
  by (simp add: less_eq_option_def)

lemma less_eq_option_None_code [code]: "None \<le> x \<longleftrightarrow> True"
  by simp

lemma less_eq_option_None_is_None: "x \<le> None \<Longrightarrow> x = None"
  by (cases x) (simp_all add: less_eq_option_def)

lemma less_eq_option_Some_None [simp, code]: "Some x \<le> None \<longleftrightarrow> False"
  by (simp add: less_eq_option_def)

lemma less_eq_option_Some [simp, code]: "Some x \<le> Some y \<longleftrightarrow> x \<le> y"
  by (simp add: less_eq_option_def)

lemma less_option_None [simp, code]: "x < None \<longleftrightarrow> False"
  by (simp add: less_option_def)

lemma less_option_None_is_Some: "None < x \<Longrightarrow> \<exists>z. x = Some z"
  by (cases x) (simp_all add: less_option_def)

lemma less_option_None_Some [simp]: "None < Some x"
  by (simp add: less_option_def)

lemma less_option_None_Some_code [code]: "None < Some x \<longleftrightarrow> True"
  by simp

lemma less_option_Some [simp, code]: "Some x < Some y \<longleftrightarrow> x < y"
  by (simp add: less_option_def)

instance
  by standard
    (auto simp add: less_eq_option_def less_option_def less_le_not_le
      elim: order_trans split: option.splits)

end

instance option :: (order) order
  by standard (auto simp add: less_eq_option_def less_option_def split: option.splits)

instance option :: (linorder) linorder
  by standard (auto simp add: less_eq_option_def less_option_def split: option.splits)

instantiation option :: (order) order_bot
begin

definition bot_option where "\<bottom> = None"

instance
  by standard (simp add: bot_option_def)

end

instantiation option :: (order_top) order_top
begin

definition top_option where "\<top> = Some \<top>"

instance
  by standard (simp add: top_option_def less_eq_option_def split: option.split)

end

instance option :: (wellorder) wellorder
proof
  fix P :: "'a option \<Rightarrow> bool"
  fix z :: "'a option"
  assume H: "\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x"
  have "P None" by (rule H) simp
  then have P_Some [case_names Some]: "P z" if "\<And>x. z = Some x \<Longrightarrow> (P \<circ> Some) x" for z
    using \<open>P None\<close> that by (cases z) simp_all
  show "P z"
  proof (cases z rule: P_Some)
    case (Some w)
    show "(P \<circ> Some) w"
    proof (induct rule: less_induct)
      case (less x)
      have "P (Some x)"
      proof (rule H)
        fix y :: "'a option"
        assume "y < Some x"
        show "P y"
        proof (cases y rule: P_Some)
          case (Some v)
          with \<open>y < Some x\<close> have "v < x" by simp
          with less show "(P \<circ> Some) v" .
        qed
      qed
      then show ?case by simp
    qed
  qed
qed

instantiation option :: (inf) inf
begin

definition inf_option where
  "x \<sqinter> y = (case x of None \<Rightarrow> None | Some x \<Rightarrow> (case y of None \<Rightarrow> None | Some y \<Rightarrow> Some (x \<sqinter> y)))"

lemma inf_None_1 [simp, code]: "None \<sqinter> y = None"
  by (simp add: inf_option_def)

lemma inf_None_2 [simp, code]: "x \<sqinter> None = None"
  by (cases x) (simp_all add: inf_option_def)

lemma inf_Some [simp, code]: "Some x \<sqinter> Some y = Some (x \<sqinter> y)"
  by (simp add: inf_option_def)

instance ..

end

instantiation option :: (sup) sup
begin

definition sup_option where
  "x \<squnion> y = (case x of None \<Rightarrow> y | Some x' \<Rightarrow> (case y of None \<Rightarrow> x | Some y \<Rightarrow> Some (x' \<squnion> y)))"

lemma sup_None_1 [simp, code]: "None \<squnion> y = y"
  by (simp add: sup_option_def)

lemma sup_None_2 [simp, code]: "x \<squnion> None = x"
  by (cases x) (simp_all add: sup_option_def)

lemma sup_Some [simp, code]: "Some x \<squnion> Some y = Some (x \<squnion> y)"
  by (simp add: sup_option_def)

instance ..

end

instance option :: (semilattice_inf) semilattice_inf
proof
  fix x y z :: "'a option"
  show "x \<sqinter> y \<le> x"
    by (cases x, simp_all, cases y, simp_all)
  show "x \<sqinter> y \<le> y"
    by (cases x, simp_all, cases y, simp_all)
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x, simp_all, cases y, simp_all, cases z, simp_all)
qed

instance option :: (semilattice_sup) semilattice_sup
proof
  fix x y z :: "'a option"
  show "x \<le> x \<squnion> y"
    by (cases x, simp_all, cases y, simp_all)
  show "y \<le> x \<squnion> y"
    by (cases x, simp_all, cases y, simp_all)
  fix x y z :: "'a option"
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases y, simp_all, cases z, simp_all, cases x, simp_all)
qed

instance option :: (lattice) lattice ..

instance option :: (lattice) bounded_lattice_bot ..

instance option :: (bounded_lattice_top) bounded_lattice_top ..

instance option :: (bounded_lattice_top) bounded_lattice ..

instance option :: (distrib_lattice) distrib_lattice
proof
  fix x y z :: "'a option"
  show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
    by (cases x, simp_all, cases y, simp_all, cases z, simp_all add: sup_inf_distrib1 inf_commute)
qed

instantiation option :: (complete_lattice) complete_lattice
begin

definition Inf_option :: "'a option set \<Rightarrow> 'a option" where
  "\<Sqinter>A = (if None \<in> A then None else Some (\<Sqinter>Option.these A))"

lemma None_in_Inf [simp]: "None \<in> A \<Longrightarrow> \<Sqinter>A = None"
  by (simp add: Inf_option_def)

definition Sup_option :: "'a option set \<Rightarrow> 'a option" where
  "\<Squnion>A = (if A = {} \<or> A = {None} then None else Some (\<Squnion>Option.these A))"

lemma empty_Sup [simp]: "\<Squnion>{} = None"
  by (simp add: Sup_option_def)

lemma singleton_None_Sup [simp]: "\<Squnion>{None} = None"
  by (simp add: Sup_option_def)

instance
proof
  fix x :: "'a option" and A
  assume "x \<in> A"
  then show "\<Sqinter>A \<le> x"
    by (cases x) (auto simp add: Inf_option_def in_these_eq intro: Inf_lower)
next
  fix z :: "'a option" and A
  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  show "z \<le> \<Sqinter>A"
  proof (cases z)
    case None then show ?thesis by simp
  next
    case (Some y)
    show ?thesis
      by (auto simp add: Inf_option_def in_these_eq Some intro!: Inf_greatest dest!: *)
  qed
next
  fix x :: "'a option" and A
  assume "x \<in> A"
  then show "x \<le> \<Squnion>A"
    by (cases x) (auto simp add: Sup_option_def in_these_eq intro: Sup_upper)
next
  fix z :: "'a option" and A
  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  show "\<Squnion>A \<le> z "
  proof (cases z)
    case None
    with * have "\<And>x. x \<in> A \<Longrightarrow> x = None" by (auto dest: less_eq_option_None_is_None)
    then have "A = {} \<or> A = {None}" by blast
    then show ?thesis by (simp add: Sup_option_def)
  next
    case (Some y)
    from * have "\<And>w. Some w \<in> A \<Longrightarrow> Some w \<le> z" .
    with Some have "\<And>w. w \<in> Option.these A \<Longrightarrow> w \<le> y"
      by (simp add: in_these_eq)
    then have "\<Squnion>Option.these A \<le> y" by (rule Sup_least)
    with Some show ?thesis by (simp add: Sup_option_def)
  qed
next
  show "\<Squnion>{} = (\<bottom>::'a option)"
    by (auto simp: bot_option_def)
  show "\<Sqinter>{} = (\<top>::'a option)"
    by (auto simp: top_option_def Inf_option_def)
qed

end

lemma Some_Inf:
  "Some (\<Sqinter>A) = \<Sqinter>(Some ` A)"
  by (auto simp add: Inf_option_def)

lemma Some_Sup:
  "A \<noteq> {} \<Longrightarrow> Some (\<Squnion>A) = \<Squnion>(Some ` A)"
  by (auto simp add: Sup_option_def)

lemma Some_INF:
  "Some (\<Sqinter>x\<in>A. f x) = (\<Sqinter>x\<in>A. Some (f x))"
  by (simp add: Some_Inf image_comp)

lemma Some_SUP:
  "A \<noteq> {} \<Longrightarrow> Some (\<Squnion>x\<in>A. f x) = (\<Squnion>x\<in>A. Some (f x))"
  by (simp add: Some_Sup image_comp)

lemma option_Inf_Sup: "\<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
  for A :: "('a::complete_distrib_lattice option) set set"
proof (cases "{} \<in> A")
  case True
  then show ?thesis
    by (rule INF_lower2, simp_all)
next
  case False
  from this have X: "{} \<notin> A"
    by simp
  then show ?thesis
  proof (cases "{None} \<in> A")
    case True
    then show ?thesis
      by (rule INF_lower2, simp_all)
  next
    case False

    {fix y
      assume A: "y \<in> A"
      have "Sup (y - {None}) = Sup y"
        by (metis (no_types, lifting) Sup_option_def insert_Diff_single these_insert_None these_not_empty_eq)
      from A and this have "(\<exists>z. y - {None} = z - {None} \<and> z \<in> A) \<and> \<Squnion>y = \<Squnion>(y - {None})"
        by auto
    }
    from this have A: "Sup ` A = (Sup ` {y - {None} | y. y\<in>A})"
      by (auto simp add: image_def)

    have [simp]: "\<And>y. y \<in> A \<Longrightarrow> \<exists>ya. {ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x}
          = {y. \<exists>x\<in>ya - {None}. y = the x} \<and> ya \<in> A"
      by (rule exI, auto)

    have [simp]: "\<And>y. y \<in> A \<Longrightarrow>
         (\<exists>ya. y - {None} = ya - {None} \<and> ya \<in> A) \<and> \<Squnion>{ya. \<exists>x\<in>y - {None}. ya = the x}
          = \<Squnion>{ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x}"
      apply (safe, blast)
      by (rule arg_cong [of _ _ Sup], auto)
    {fix y
      assume [simp]: "y \<in> A"
      have "\<exists>x. (\<exists>y. x = {ya. \<exists>x\<in>y - {None}. ya = the x} \<and> y \<in> A) \<and> \<Squnion>{ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x} = \<Squnion>x"
      and "\<exists>x. (\<exists>y. x = y - {None} \<and> y \<in> A) \<and> \<Squnion>{ya. \<exists>x\<in>y - {None}. ya = the x} = \<Squnion>{y. \<exists>xa. xa \<in> x \<and> (\<exists>y. xa = Some y) \<and> y = the xa}"
         apply (rule exI [of _ "{ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x}"], simp)
        by (rule exI [of _ "y - {None}"], simp)
    }
    from this have C: "(\<lambda>x.  (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A} =  (Sup ` {the ` (y - {None}) |y. y \<in> A})"
      by (simp add: image_def Option.these_def, safe, simp_all)

    have D: "\<forall> f . \<exists>Y\<in>A. f Y \<notin> Y \<Longrightarrow> False"
      by (drule spec [of _ "\<lambda> Y . SOME x . x \<in> Y"], simp add: X some_in_eq)

    define F where "F = (\<lambda> Y . SOME x::'a option . x \<in> (Y - {None}))"

    have G: "\<And> Y . Y \<in> A \<Longrightarrow> \<exists> x . x \<in> Y - {None}"
      by (metis False X all_not_in_conv insert_Diff_single these_insert_None these_not_empty_eq)

    have F: "\<And> Y . Y \<in> A \<Longrightarrow> F Y \<in> (Y - {None})"
      by (metis F_def G empty_iff some_in_eq)

    have "Some \<bottom> \<le> Inf (F ` A)"
      by (metis (no_types, lifting) Diff_iff F Inf_option_def bot.extremum image_iff
          less_eq_option_Some singletonI)

    from this have "Inf (F ` A) \<noteq> None"
      by (cases "\<Sqinter>x\<in>A. F x", simp_all)

    from this have "Inf (F ` A) \<noteq> None \<and> Inf (F ` A) \<in> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}"
      using F by auto

    from this have "\<exists> x . x \<noteq> None \<and> x \<in> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}"
      by blast

    from this have E:" Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {None} \<Longrightarrow> False"
      by blast

    have [simp]: "((\<Squnion>x\<in>{f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}. \<Sqinter>x) = None) = False"
      by (metis (no_types, lifting) E Sup_option_def \<open>\<exists>x. x \<noteq> None \<and> x \<in> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}\<close>
          ex_in_conv option.simps(3))

    have B: "Option.these ((\<lambda>x. Some (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A})
        = ((\<lambda>x. (\<Squnion> Option.these x)) ` {y - {None} |y. y \<in> A})"
      by (metis image_image these_image_Some_eq)
    {
      fix f
      assume A: "\<And> Y . (\<exists>y. Y = the ` (y - {None}) \<and> y \<in> A) \<Longrightarrow> f Y \<in> Y"

      have "\<And>xa. xa \<in> A \<Longrightarrow> f {y. \<exists>a\<in>xa - {None}. y = the a} = f (the ` (xa - {None}))"
        by  (simp add: image_def)
      from this have [simp]: "\<And>xa. xa \<in> A \<Longrightarrow> \<exists>x\<in>A. f {y. \<exists>a\<in>xa - {None}. y = the a} = f (the ` (x - {None}))"
        by blast
      have "\<And>xa. xa \<in> A \<Longrightarrow> f (the ` (xa - {None})) = f {y. \<exists>a \<in> xa - {None}. y = the a} \<and> xa \<in> A"
        by (simp add: image_def)
      from this have [simp]: "\<And>xa. xa \<in> A \<Longrightarrow> \<exists>x. f (the ` (xa - {None})) = f {y. \<exists>a\<in>x - {None}. y = the a} \<and> x \<in> A"
        by blast

      {
        fix Y
        have "Y \<in> A \<Longrightarrow> Some (f (the ` (Y - {None}))) \<in> Y"
          using A [of "the ` (Y - {None})"] apply (simp add: image_def)
          using option.collapse by fastforce
      }
      from this have [simp]: "\<And> Y . Y \<in> A \<Longrightarrow> Some (f (the ` (Y - {None}))) \<in> Y"
        by blast
      have [simp]: "(\<Sqinter>x\<in>A. Some (f {y. \<exists>x\<in>x - {None}. y = the x})) = \<Sqinter>{Some (f {y. \<exists>a\<in>x - {None}. y = the a}) |x. x \<in> A}"
        by (simp add: Setcompr_eq_image)

      have [simp]: "\<exists>x. (\<exists>f. x = {y. \<exists>x\<in>A. y = f x} \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> \<Sqinter>{Some (f {y. \<exists>a\<in>x - {None}. y = the a}) |x. x \<in> A} = \<Sqinter>x"
        apply (rule exI [of _ "{Some (f {y. \<exists>a\<in>x - {None}. y = the a}) | x . x\<in> A}"], safe)
        by (rule exI [of _ "(\<lambda> Y . Some (f (the ` (Y - {None})))) "], safe, simp_all)

      {
        fix xb
        have "xb \<in> A \<Longrightarrow> (\<Sqinter>x\<in>{{ya. \<exists>x\<in>y - {None}. ya = the x} |y. y \<in> A}. f x) \<le> f {y. \<exists>x\<in>xb - {None}. y = the x}"
          apply (rule INF_lower2 [of "{y. \<exists>x\<in>xb - {None}. y = the x}"])
          by blast+
      }
      from this have [simp]: "(\<Sqinter>x\<in>{the ` (y - {None}) |y. y \<in> A}. f x) \<le> the (\<Sqinter>Y\<in>A. Some (f (the ` (Y - {None}))))"
        apply (simp add: Inf_option_def image_def Option.these_def)
        by (rule Inf_greatest, clarsimp)
      have [simp]: "the (\<Sqinter>Y\<in>A. Some (f (the ` (Y - {None})))) \<in> Option.these (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
        apply (auto simp add: Option.these_def)
        apply (rule imageI)
        apply auto
        using \<open>\<And>Y. Y \<in> A \<Longrightarrow> Some (f (the ` (Y - {None}))) \<in> Y\<close> apply blast
        apply (auto simp add: Some_INF [symmetric])
        done
      have "(\<Sqinter>x\<in>{the ` (y - {None}) |y. y \<in> A}. f x) \<le> \<Squnion>Option.these (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
        by (rule Sup_upper2 [of "the (Inf ((\<lambda> Y . Some (f (the ` (Y - {None})) )) ` A))"], simp_all)
    }
    from this have X: "\<And> f . \<forall>Y. (\<exists>y. Y = the ` (y - {None}) \<and> y \<in> A) \<longrightarrow> f Y \<in> Y \<Longrightarrow>
      (\<Sqinter>x\<in>{the ` (y - {None}) |y. y \<in> A}. f x) \<le> \<Squnion>Option.these (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
      by blast

    have [simp]: "\<And> x . x\<in>{y - {None} |y. y \<in> A} \<Longrightarrow>  x \<noteq> {} \<and> x \<noteq> {None}"
      using F by fastforce

    have "(Inf (Sup `A)) = (Inf (Sup ` {y - {None} | y. y\<in>A}))"
      by (subst A, simp)

    also have "... = (\<Sqinter>x\<in>{y - {None} |y. y \<in> A}. if x = {} \<or> x = {None} then None else Some (\<Squnion>Option.these x))"
      by (simp add: Sup_option_def)

    also have "... = (\<Sqinter>x\<in>{y - {None} |y. y \<in> A}. Some (\<Squnion>Option.these x))"
      using G by fastforce

    also have "... = Some (\<Sqinter>Option.these ((\<lambda>x. Some (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A}))"
      by (simp add: Inf_option_def, safe)

    also have "... =  Some (\<Sqinter> ((\<lambda>x.  (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A}))"
      by (simp add: B)

    also have "... = Some (Inf (Sup ` {the ` (y - {None}) |y. y \<in> A}))"
      by (unfold C, simp)
    thm Inf_Sup
    also have "... = Some (\<Squnion>x\<in>{f ` {the ` (y - {None}) |y. y \<in> A} |f. \<forall>Y. (\<exists>y. Y = the ` (y - {None}) \<and> y \<in> A) \<longrightarrow> f Y \<in> Y}. \<Sqinter>x) "
      by (simp add: Inf_Sup)

    also have "... \<le> \<Squnion> (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
    proof (cases "\<Squnion> (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})")
      case None
      then show ?thesis by (simp add: less_eq_option_def)
    next
      case (Some a)
      then show ?thesis
        apply simp
        apply (rule Sup_least, safe)
        apply (simp add: Sup_option_def)
        apply (cases "(\<forall>f. \<exists>Y\<in>A. f Y \<notin> Y) \<or> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {None}", simp_all)
        by (drule X, simp)
    qed
    finally show ?thesis by simp
  qed
qed

instance option :: (complete_distrib_lattice) complete_distrib_lattice
  by (standard, simp add: option_Inf_Sup)

instance option :: (complete_linorder) complete_linorder ..

unbundle no_lattice_syntax

end


theory AF_Relator imports
  "$AFP/Applicative_Lifting/Abstract_AF"
  "~~/src/HOL/Library/Rewrite"
begin

interpretation applicative_syntax .

section \<open>Alternative set of applicative operations\<close>

definition unit :: "unit af"
where unit_conv [applicative_unfold]: "unit = pure ()"

definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a af \<Rightarrow> 'b af"
where map_conv [applicative_unfold]: "map f x = pure f \<diamondop> x"

definition zip :: "'a af \<Rightarrow> 'b af \<Rightarrow> ('a \<times> 'b) af"
where zip_conv [applicative_unfold]: "zip x y = pure Pair \<diamondop> x \<diamondop> y"

lemma pure_conv: "pure x = map (\<lambda>_. x) unit"
by applicative_nf simp

lemma ap_conv: "f \<diamondop> x = map (\<lambda>(f, x). f x) (zip f x)"
by applicative_nf simp

lemma map_id: "map (\<lambda>a. a) x = x"
by applicative_nf simp

lemma map_comp: "map f (map g x) = map (f \<circ> g) x"
by applicative_nf simp

lemma map_zip: "map (map_prod f g) (zip x y) = zip (map f x) (map g y)"
by applicative_nf simp

lemma map_snd: "map snd (zip unit x) = x"
by applicative_nf simp

lemma map_fst: "map fst (zip x unit) = x"
by applicative_nf simp

lemma map_assoc: "zip (zip a b) c = map (\<lambda>(a, (b, c)). ((a, b), c)) (zip a (zip b c))"
by applicative_nf simp

section \<open>The set function\<close>

consts set :: "'a af \<Rightarrow> 'a set"
axiomatization
  where map_cong: "\<And>f g x. (\<forall>a\<in>set x. f a = g a) \<Longrightarrow> map f x = map g x"
  and set_natural: "\<And>f x. set (map f x) \<subseteq> f ` set x"
  -- \<open>This is only half of the usual naturality. Does this direction follow already from @{thm map_cong}?\<close>

lemma set_pure_subset: "set (pure x) \<subseteq> {x}"
proof
  fix a
  assume "a \<in> set (pure x)"
  with set_natural have "a \<in> (\<lambda>_. x) ` set unit" unfolding pure_conv ..
  hence "a = x" by blast
  then show "a \<in> {x}" by simp
qed

abbreviation pred :: "('a \<Rightarrow> bool) \<Rightarrow> 'a af \<Rightarrow> bool"
where "pred P x \<equiv> \<forall>a\<in>set x. P a"

(*axiomatization where set_unit: "() \<in> set unit" This forbids applicative functors without elements (phantom type variables)*)

section \<open>Relator\<close>

definition rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a af \<Rightarrow> 'b af \<Rightarrow> bool"
where "rel P x y \<longleftrightarrow> (\<exists>z. (\<forall>(a, b)\<in>set z. P a b) \<and> map fst z = x \<and> map snd z = y)"

lemma rel_mono:
  assumes "P \<le> Q"
  shows "rel P \<le> rel Q"
proof(intro le_funI le_boolI)
  fix x y
  assume "rel P x y"
  then obtain z where "\<forall>(a, b)\<in>set z. P a b" and x: "map fst z = x" and y: "map snd z = y"
    unfolding rel_def by blast
  from assms this(1) have "\<forall>(a, b)\<in>set z. Q a b" unfolding le_fun_def le_bool_def by blast
  with x y show "rel Q x y" unfolding rel_def by blast
qed

corollary rel_mono':
  "\<lbrakk> rel P x y; \<And>a b. P a b \<Longrightarrow> Q a b \<rbrakk> \<Longrightarrow> rel Q x y"
using rel_mono unfolding le_fun_def le_bool_def by blast

lemma rel_reflI:
  assumes "\<forall>a\<in>set x. P a a"
  shows "rel P x x"
proof -
  let ?z = "map (\<lambda>a. (a, a)) x"
  have "\<forall>(a, b)\<in>set ?z. P a b" using assms set_natural[where f="\<lambda>a. (a, a)"] by blast
  moreover have "map fst ?z = x" unfolding map_comp o_def fst_conv map_id ..
  moreover have "map snd ?z = x" unfolding map_comp o_def snd_conv map_id ..
  ultimately show "rel P x x" unfolding rel_def by blast
qed

lemma rel_eq: "rel (op =) = op ="
proof(intro ext iffI)
  fix x y :: "'a af"
  assume *: "x = y"
  show "rel op = x y" unfolding * by(rule rel_reflI) blast
next
  fix x y :: "'a af"
  assume "rel op = x y"
  then obtain z where z: "\<forall>(a, b)\<in>set z. a = b" and x: "map fst z = x" and y: "map snd z = y"
    unfolding rel_def by blast
  show "x = y" using z unfolding x[symmetric] y[symmetric] split_def
    by(rule map_cong)
qed

lemma rel_pureI:
  assumes "P x y"
  shows "rel P (pure x) (pure y)"
proof -
  let ?z = "pure (x, y)"
  { fix a b
    assume "(a, b) \<in> set (pure (x, y))"
    with set_pure_subset have "(a, b) \<in> {(x, y)}" ..
    with assms have "P a b" by simp }
  moreover have "map fst ?z = pure x" unfolding pure_conv map_comp o_def fst_conv ..
  moreover have "map snd ?z = pure y" unfolding pure_conv map_comp o_def snd_conv ..
  ultimately show ?thesis unfolding rel_def by blast
qed

lemma rel_Grp:
  "rel (BNF_Def.Grp P f) = BNF_Def.Grp (Collect (pred (\<lambda>x. x \<in> P))) (map f)"
unfolding Grp_def
apply(rule ext iffI)+

 apply(subst (asm) rel_def)
 apply(erule exE conjE)+
 apply clarify
 apply(rule conjI)
  apply(subst map_comp)
  apply(rule map_cong)
  apply fastforce
 apply clarify
 apply(drule subsetD[OF set_natural])
 apply clarify
 apply(drule (1) bspec)
 apply(simp add: Grp_def)

apply(subst rel_def)
apply clarify
apply(rename_tac x y)
apply(rule_tac x="map (\<lambda>x. (x, f x)) x" in exI)
apply(intro conjI)
  apply clarify
  apply(drule subsetD[OF set_natural])
  apply blast
 apply(subst map_comp)
 apply(simp add: o_def map_id)
apply(subst map_comp)
apply(simp add: o_def map_id)
done

lemma rel_conversep: "rel P\<inverse>\<inverse> = (rel P)\<inverse>\<inverse>"
apply(rule ext iffI)+
 apply(clarsimp simp add: rel_def)
 apply(rule_tac x="map (\<lambda>(x, y). (y, x)) z" in exI)
 apply(intro conjI)
   apply(clarify)
   apply(drule subsetD[OF set_natural])
   apply fastforce
  apply(subst map_comp)
  apply(simp add: o_def split_def map_id)
 apply(subst map_comp)
 apply(simp add: o_def split_def map_id)
apply(clarsimp simp add: rel_def)
apply(rule_tac x="map (\<lambda>(x, y). (y, x)) z" in exI)
apply(intro conjI)
  apply(clarify)
  apply(drule subsetD[OF set_natural])
  apply fastforce
 apply(subst map_comp)
 apply(simp add: o_def split_def map_id)
apply(subst map_comp)
apply(simp add: o_def split_def map_id)
done

text \<open>We say that two effects are compatible iff they can be related ignoring their elements,
  i.e., they have the same structure or effects\<close>

abbreviation compat :: "'a af \<Rightarrow> 'b af \<Rightarrow> bool"
where "compat \<equiv> rel (\<lambda>_ _. True)"

text \<open>
  What is the difference between structure and effect? Is effect just more general than structure
  and structure means that we can swap effects?

  Examples:
  - set, pmf, option, llist are commutative, they have structure
  - state, reader, writer monads are not commutative, so this feels more like an effect.
\<close>

lemma compat_self: "compat x x"
by(rule rel_reflI) blast

axiomatization
  where set_zip_subset: "\<And>x y. set (zip x y) \<subseteq> set x \<times> set y"
  -- \<open>We should not require equality here.
    For example on coinductive lists with the canonical zip, only the subset relation holds.\<close>
  -- \<open>TODO: Does this somehow follow from the applicative axioms and the previous set axioms?\<close>

lemma rel_apI:
  assumes fg: "rel (rel_fun P Q) f g"
  and xy: "rel P x y"
  shows "rel Q (f \<diamondop> x) (g \<diamondop> y)"
proof -
  from fg obtain fg where fg: "\<forall>(a, b)\<in>set fg. rel_fun P Q a b"
    and f: "map fst fg = f"
    and g: "map snd fg = g"
    unfolding rel_def by blast
  from xy obtain xy where xy: "\<forall>(a, b)\<in>set xy. P a b"
    and x: "map fst xy = x"
    and y: "map snd xy = y"
    unfolding rel_def by blast
  let ?z = "map (\<lambda>((f, g), (x, y)). (f x, g y)) (zip fg xy)"
  { have "map fst ?z = map (\<lambda>(f, x). f x) (map (map_prod fst fst) (zip fg xy))"
      unfolding map_comp by(simp add: o_def split_def)
    also have "\<dots> = map (\<lambda>(f, x). f x) (zip (map fst fg) (map fst xy))"
      unfolding map_zip ..
    also have "\<dots> = map (\<lambda>(f, x). f x) (zip f x)" unfolding f x ..
    also have "\<dots> = f \<diamondop> x" unfolding ap_conv ..
    finally have "map fst ?z = f \<diamondop> x" . }
  moreover
  { have "map snd ?z = map (\<lambda>(g, y). g y) (map (map_prod snd snd) (zip fg xy))"
      unfolding map_comp by(simp add: o_def split_def)
    also have "\<dots> = map (\<lambda>(g, y). g y) (zip (map snd fg) (map snd xy))"
      unfolding map_zip ..
    also have "\<dots> = map (\<lambda>(g, y). g y) (zip g y)" unfolding g y ..
    also have "\<dots> = g \<diamondop> y" unfolding ap_conv ..
    finally have "map snd ?z = g \<diamondop> y" . }
  moreover
  { fix a b
    assume "(a, b) \<in> set ?z"
    with set_natural have "(a, b) \<in> (\<lambda>((f, g), (x, y)). (f x, g y)) ` set (zip fg xy)" ..
    then obtain f' g' x' y'
      where a: "a = f' x'" and b: "b = g' y'"
      and "((f', g'), (x', y')) \<in> set (zip fg xy)" by auto
    from set_zip_subset this(3) have "((f', g'), (x', y')) \<in> set fg \<times> set xy" ..
    hence f'g': "(f', g') \<in> set fg" and x'y': "(x', y') \<in> set xy" by blast+
    from f'g' fg have "rel_fun P Q f' g'" by blast
    moreover from x'y' xy have "P x' y'" by blast
    ultimately have "Q (f' x') (g' y')" by(rule rel_funD)
    hence "Q a b" unfolding a b . }
  ultimately show ?thesis unfolding rel_def by blast
qed

subsection \<open>Lifting of relations\<close>

text \<open>
  With @{const rel}, we can generalise lifting to arbitrary binary relations on the base level.
  1. First, normalise both idiomatic expressions according to the normalisation laws available.
  Both idiomatic expressions should be pure applied to the same list of impure terms.
  2. Use @{thm [source] rel_apI} to strip off the impure terms with reflexivity on the argument.
  3. Use @{thm [source] rel_pureI} to strip off pure.
  4. Use @{thm [source] rel_funI} to get back the universal quantifiers.

  Equality is just a special case due to @{thm [source] rel_eq}.
\<close>

lemma lifting_relations_example:
  assumes "\<forall>x y. R (f x y) (g x y)"
  shows "rel R (pure f \<diamondop> x \<diamondop> y) (pure g \<diamondop> x \<diamondop> y)"
apply(rule rel_apI[where P="op ="])+
  apply(rule rel_pureI)
  apply(rule rel_funI)+
  apply clarify
  apply(simp add: assms)
 apply(rule rel_reflI; blast)
apply(rule rel_reflI; blast)
done

text \<open>
  We can add compatible effects that the pure function ignores.
\<close>

lemma rel_addI: -- \<open>add at the end\<close>
  assumes "rel P f g"
  and "compat x y"
  shows "rel P (pure (\<lambda>x y. x) \<diamondop> f \<diamondop> x) (pure (\<lambda>x y. x) \<diamondop> g \<diamondop> y)"
using _ assms(2)
apply(rule rel_apI)
using _ assms(1)
apply(rule rel_apI)
apply(rule rel_pureI)
apply(rule rel_funI)+
apply assumption
done

lemma rel_addI': -- \<open>add at the front\<close>
  assumes "rel P x y"
  and "compat f g"
  shows "rel P (pure (\<lambda>x y. y) \<diamondop> f \<diamondop> x) (pure (\<lambda>x y. y) \<diamondop> g \<diamondop> y)"
using _ assms(1)
apply(rule rel_apI)
using _ assms(2)
apply(rule rel_apI)
apply(rule rel_pureI)
apply(rule rel_funI)+
apply assumption
done

subsection \<open>Lifting implication\<close>

text \<open>
  Implication lifting does not hold in general.
  Consider integer addition modulo 2 over the set functor.
  We have @{lemma "rel_set (\<lambda>x y :: int. x = (y + 1) mod 2) {0,1} {0,1}" by(auto simp add: rel_set_def)}
  and @{lemma "\<forall>x :: int. x = (x + 1) mod 2 \<longrightarrow> False" by arith},
  yet @{lemma "~ rel_set (\<lambda>x y. False) {0,1} {0,1}" by(auto simp add: rel_set_def)}.

  The problem is that @{thm rel_reflI} is only sufficient, not necessary. Among others,
  @{term "rel P x y"} says that each element of @{term x} is related to an element in @{term y}
  and vice versa. However, if @{term "y = x"}, there is no requirement that every element be
  related to itself.

  Therefore, we need more machinery. Initially, suppose that @{const rel} preserves weak pullbacks,
  i.e., it distributes over composition and commutes with @{const map}.
\<close>

axiomatization
  where rel_compp: "rel (P OO Q) = rel P OO rel Q"
  -- \<open>preservation of weak pullbacks required for @{const rel} distributing over @{const map} (naturality of @{const rel})}\<close>

lemma rel_map1 [unfolded vimage2p_def id_apply]: "rel P (map f x) y = rel (BNF_Def.vimage2p f id P) x y"
apply(tactic \<open>BNF_Def_Tactics.mk_rel_map0_tac @{context} 1 @{thm rel_compp} @{thm rel_conversep} @{thm rel_Grp} @{thm map_id}\<close>)
apply(simp add: Grp_def)
apply(rule iffI)
 apply(rule relcomppI)
  apply(rule refl)
 apply(erule relcomppI)
 apply(simp add: map_id id_def)
apply clarify
apply(simp add: map_id id_def)
done

lemma rel_map2 [unfolded vimage2p_def id_apply]: "rel P x (map f y) = rel (BNF_Def.vimage2p id f P) x y"
apply(tactic \<open>BNF_Def_Tactics.mk_rel_map0_tac @{context} 1 @{thm rel_compp} @{thm rel_conversep} @{thm rel_Grp} @{thm map_id}\<close>)
apply(simp add: Grp_def)
apply(rule iffI)
 apply(rule relcomppI)
  apply(rule refl)
 apply(rule relcomppI)
  apply(simp add: map_id id_def)
 apply simp
apply clarify
apply(simp add: map_id id_def)
done

lemma rel_map:
  "rel P (map f x) (map g y) \<longleftrightarrow> rel (\<lambda>x y. P (f x) (g y)) x y"
unfolding rel_map1 rel_map2 ..

text \<open>
  Now, we can also lift conditional equations and relations.
  However, as we cannot double effects yet, we must require that the idiomatic expressions
  (assumption and conclusion) of the left-hand side use the same variables in the same order,
  and similarly for the right-hand side, and both sides do not share variables.

  1. If necessary, expand the assumed relation with the additional variables.
  2. Zip all impure arguments into one for each side of assumed and stated relation.
  3. Apply @{thm "rel_mono"}.
\<close>

lemma lift_implication:
  assumes base: "\<forall>a b c d e f''. P (f a b) (g d e) \<longrightarrow> Q (f' a b c) (g' d e f'')"
  and assm: "rel P (pure f \<diamondop> x \<diamondop> y) (pure g \<diamondop> u \<diamondop> v)"
  and zw: "compat z w" -- \<open>We can always add compatible effects at the end\<close>
  -- \<open>we could relax compatibility such that z and w have compatible effects given the effects of x and y -- how to express this?\<close>
  shows "rel Q (pure f' \<diamondop> x \<diamondop> y \<diamondop> z) (pure g' \<diamondop> u \<diamondop> v \<diamondop> w)"
proof -
  from assm have "rel P (pure (\<lambda>x y. x) \<diamondop> (pure f \<diamondop> x \<diamondop> y) \<diamondop> z) (pure (\<lambda>x y. x) \<diamondop> (pure g \<diamondop> u \<diamondop> v) \<diamondop> w)"
    using zw by(rule rel_addI)
  also have "pure (\<lambda>x y. x) \<diamondop> (pure f \<diamondop> x \<diamondop> y) \<diamondop> z = pure (\<lambda>x y z. f x y) \<diamondop> x \<diamondop> y \<diamondop> z"
    unfolding af_composition[symmetric] af_homomorphism o_def ..
  also have "\<dots> = map (\<lambda>(x, y, z). f x y) (zip x (zip y z))"
    unfolding zip_conv map_conv af_composition[symmetric] af_homomorphism o_def prod.simps
    by(subst af_interchange)(simp add: af_composition[symmetric] af_homomorphism o_def)
  also have "pure (\<lambda>x y. x) \<diamondop> (pure g \<diamondop> u \<diamondop> v) \<diamondop> w = pure (\<lambda>x y z. g x y) \<diamondop> u \<diamondop> v \<diamondop> w"
    unfolding af_composition[symmetric] af_homomorphism o_def ..
  also have "\<dots> = map (\<lambda>(x, y, z). g x y) (zip u (zip v w))"
    unfolding zip_conv map_conv af_composition[symmetric] af_homomorphism o_def prod.simps
    by(subst af_interchange)(simp add: af_composition[symmetric] af_homomorphism o_def)
  finally have "rel (\<lambda>(x, y, z) (x', y', z'). P (f x y) (g x' y')) (zip x (zip y z)) (zip u (zip v w))"
    unfolding rel_map by(simp add: split_def)
  hence "rel (\<lambda>(x, y, z) (x', y', z'). Q (f' x y z) (g' x' y' z')) (zip x (zip y z)) (zip u (zip v w))"
    apply(rule rel_mono') -- \<open>This is the key step: exploit monotonicity\<close>
    using base by auto
  hence "rel Q (map (\<lambda>(x, y, z). f' x y z) (zip x (zip y z))) (map (\<lambda>(x, y, z). g' x y z) (zip u (zip v w)))"
    unfolding rel_map by(simp add: split_def)
  also have "map (\<lambda>(x, y, z). f' x y z) (zip x (zip y z)) = pure f' \<diamondop> x \<diamondop> y \<diamondop> z"
    unfolding zip_conv map_conv af_composition[symmetric] af_homomorphism
    by(subst af_interchange)(simp add: af_composition[symmetric] af_homomorphism o_def)
  also have "map (\<lambda>(x, y, z). g' x y z) (zip u (zip v w)) = pure g' \<diamondop> u \<diamondop> v \<diamondop> w"
    unfolding zip_conv map_conv af_composition[symmetric] af_homomorphism
    by(subst af_interchange)(simp add: af_composition[symmetric] af_homomorphism o_def)
  finally show ?thesis .
qed

text \<open>
  Intuition for the requirement for distinct variables on the left and on the right in the case of equality:
  The relator does not ensure that in the reflexive case, every element is related to itself.
  Hinze's lifting relies on @{thm rel_reflI} plus equality being reflexive,
  but @{thm rel_reflI} is only sufficient, not necessary. This means that equality between
  lifted terms does not imply point-wise equality between terms.
\<close>

text \<open>
  We can avoid some of the rewriting by directly pushing the ap's into the rel using the combinator
  @{term BNF_Def.vimage2p} and its monotonicity theorem @{thm [source] vimage2p_mono}.
\<close>
lemma
  assumes "BNF_Def.vimage2p (case_prod zip) (case_prod zip) (rel (\<lambda>(f, x) (g, y). P (f x) (g y))) (f, x) (g, y)"
  shows "rel P (f \<diamondop> x) (g \<diamondop> y)"
using assms
unfolding vimage2p_def prod.simps ap_conv rel_map split_def fst_conv snd_conv .

subsection \<open>Doubling effects\<close>

text \<open> If we can double effects, products are unique. \<close>

axiomatization W :: "(('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) af"
where ap_W: "W \<diamondop> f \<diamondop> x = f \<diamondop> x \<diamondop> x"
  and W_def: "W = pure (\<lambda>f x. f x x)"

lemma product_unique:
   assumes x: "map fst z = x"
   and y: "map snd z = y"
   shows "z = zip x y"
proof -
  have "zip x y = zip (map fst z) (map snd z)" by(simp add: assms)
  also have "\<dots> = map (map_prod fst snd) (zip z z)" unfolding map_zip ..
  also have "zip z z = W \<diamondop> pure Pair \<diamondop> z" unfolding zip_conv ap_W af_identity ..
  also have "\<dots> = pure (\<lambda>W. W Pair) \<diamondop> W \<diamondop> z"
    apply(subst af_interchange) ..
  also have "map (map_prod fst snd) \<dots> = pure (\<lambda>W z. map_prod fst snd (W Pair z)) \<diamondop> W \<diamondop> z"
    unfolding map_conv af_composition[symmetric] af_homomorphism o_def ..
  also have "\<dots> = z" unfolding W_def af_homomorphism by(simp add: af_identity[unfolded id_def])
  finally show ?thesis by simp
qed

text \<open>
  Unfortunately, doubling adjacent effects is not enough for lifting with shared variables.
  We also want to be able to duplicate effects with other stuff in between.
\<close>

axiomatization H :: "(('a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c) af"
where ap_H: "H \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> x \<diamondop> y \<diamondop> x"
  and H_def: "H = pure (\<lambda>f x y. f x y x)"
  -- \<open>Hummingbird combinator taken from "To Mock a Mockingbird"\<close>

text \<open>If there is H, then there is W\<close>

lemma "W \<diamondop> f \<diamondop> x = H \<diamondop> (pure (\<lambda>f x y. f x) \<diamondop> f) \<diamondop> x \<diamondop> pure id"
unfolding H_def W_def
apply(subst af_interchange)
apply(subst af_composition[symmetric])
apply(subst af_homomorphism)
apply(subst af_composition[symmetric])
apply(subst af_homomorphism)+
apply(subst af_composition[symmetric])
apply(subst af_homomorphism)+
apply(simp add: o_def)
done

text \<open>Lifting with shared variables\<close>

axiomatization where set_natural2: "\<And>f x. set (map f x) \<supseteq> f ` set x"
  -- \<open>This is is the other half to @{thm set_natural}\<close>

text \<open>
  General approach:
  1. obtain the product from the assumption
  2. eliminate the shared variables using @{const H}
  3. push pure term into the predicator
  4. use monotonicity of the predicator
  5. pull pure term out of the predicator
  6. show that the projections are as expected
\<close>

lemma
  assumes *: "rel P (pure f \<diamondop> x \<diamondop> y) (pure g \<diamondop> x \<diamondop> y)"
  and base: "\<forall>x y. P (f x y) (g x y) \<longrightarrow> Q (f' x y) (g' x y)"
  shows "rel Q (pure f' \<diamondop> x \<diamondop> y) (pure g' \<diamondop> x \<diamondop> y)"
proof -
  txt \<open>This unfolding of @{const rel} is ugly. Can we find a more abstract rule for reasoning?\<close>
  from * obtain z where z: "pred (\<lambda>(x, y). P x y) z"
    and proj: "map fst z = pure f \<diamondop> x \<diamondop> y" "map snd z = pure g \<diamondop> x \<diamondop> y"
    unfolding rel_def by blast
  from proj have "z = zip (pure f \<diamondop> x \<diamondop> y) (pure g \<diamondop> x \<diamondop> y)" by(rule product_unique)
  also have "\<dots> = pure (\<lambda>x y x' y'. (f x y, g x' y')) \<diamondop> x \<diamondop> y \<diamondop> x \<diamondop> y"
    unfolding zip_conv af_composition[symmetric] af_homomorphism o_def
    by(subst af_interchange)(simp add: af_composition[symmetric] af_homomorphism o_def)
  also have "\<dots> = H \<diamondop> pure (\<lambda>x y x' y'. (f x y, g x' y')) \<diamondop> x \<diamondop> y \<diamondop> y" unfolding ap_H ..
  also have "\<dots> = W \<diamondop> (H \<diamondop> pure (\<lambda>x y x' y'. (f x y, g x' y')) \<diamondop> x) \<diamondop> y" unfolding ap_W ..
  also have "\<dots> = pure (\<lambda>x y. (f x y, g x y)) \<diamondop> x \<diamondop> y"
    unfolding W_def H_def af_composition[symmetric] af_homomorphism o_def ..
  also have "\<dots> = map (\<lambda>(x, y). (f x y, g x y)) (zip x y)" unfolding map_conv zip_conv
    af_composition[symmetric] af_homomorphism o_def split_beta fst_conv snd_conv ..
  finally have "pred (\<lambda>(x, y). P (f x y) (g x y)) (zip x y)" using z
    -- \<open>uses distributivity of predicator over map\<close>
    apply clarsimp
    apply(drule bspec)
     apply(rule subsetD[OF set_natural2])
     apply(erule imageI)
    apply simp
    done
  with base have "pred (\<lambda>(x, y). Q (f' x y) (g' x y)) (zip x y)"
    -- \<open>uses monotonicity of the predicator\<close>
    by auto
  txt \<open>And now we are essentially there: push @{term f'} and @{term g'} back into the product and then project\<close>
  hence 1: "pred (\<lambda>(x, y). Q x y) (map (\<lambda>(x, y). (f' x y, g' x y)) (zip x y))" (is "pred _ ?z")
    apply clarsimp
    apply(drule subsetD[OF set_natural])
    apply auto
    done
  moreover have "map fst ?z = pure f' \<diamondop> x \<diamondop> y"
    unfolding zip_conv map_conv af_composition[symmetric] af_homomorphism o_def prod.simps fst_conv ..
  moreover have "map snd ?z = pure g' \<diamondop> x \<diamondop> y"
    unfolding zip_conv map_conv af_composition[symmetric] af_homomorphism o_def prod.simps snd_conv ..
  ultimately show ?thesis unfolding rel_def by blast
qed

text \<open>
  Doubling is really the crucial property here.
  The above example with set also works for pmfs, which have K and C.
\<close>

subsection \<open>Discarding effects\<close>

text \<open>
  If we can discard effects, products exist (@{const zip}!), but they need not be unique
  (example @{text pair_pmf}). Thus, all effects are compatible.
\<close>

axiomatization K :: "('a \<Rightarrow> 'b \<Rightarrow> 'a) af"
  where ap_K: "K \<diamondop> x \<diamondop> y = x"
  and K_def: "K = pure (\<lambda>x y. x)"

lemma map_fst_zip_K: "map fst (zip x y) = x" -- \<open>see Hinze, Eq. (1)\<close>
unfolding map_conv zip_conv af_composition[symmetric] af_homomorphism o_def fst_conv
by(fold K_def)(fact ap_K)

lemma map_snd_zip_K: "map snd (zip x y) = y" -- \<open>see Hinze, Eq. (2)\<close>
proof -
  have "map snd (zip x y) = K \<diamondop> pure id \<diamondop> x \<diamondop> y"
    unfolding map_conv zip_conv af_composition[symmetric] af_homomorphism o_def snd_conv K_def id_def ..
  also have "\<dots> = pure id \<diamondop> y" unfolding ap_K ..
  also have "\<dots> = y" unfolding af_identity ..
  finally show ?thesis .
qed

lemma compat_K: "compat x y"
unfolding rel_def
apply(rule_tac x="zip x y" in exI)
apply(unfold map_fst_zip_K map_snd_zip_K)
apply blast
done

text \<open>If we have K and W, we can reify equality.\<close>

text \<open>Intuition: We want to exploit equality here, so we need W. We also need K because K ensures
  that x and y are always compatible in their effects.
\<close>
lemma af_eq_reify: "x = y \<longleftrightarrow> pure (op =) \<diamondop> x \<diamondop> y = pure True" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  have "pure (op =) \<diamondop> x \<diamondop> y = W \<diamondop> pure (op =) \<diamondop> y" unfolding \<open>?lhs\<close> ap_W ..
  also have "\<dots> = pure (\<lambda>_. True) \<diamondop> y" unfolding W_def by applicative_nf simp
  also have "\<dots> = K \<diamondop> pure True \<diamondop> y" unfolding K_def by applicative_nf simp
  also have "\<dots> = pure True" unfolding ap_K ..
  finally show ?rhs .
next
  assume ?rhs
  have "x = K \<diamondop> x \<diamondop> y" unfolding ap_K ..
  also have "\<dots> = pure (\<lambda>x y. if x = y then y else x) \<diamondop> x \<diamondop> y" unfolding K_def by applicative_nf simp
  also have "\<dots> = W \<diamondop> (W \<diamondop> (pure (\<lambda>x x' y y'. if x' = y then y' else x)) \<diamondop> x) \<diamondop> y" unfolding W_def by applicative_nf simp
  also have "\<dots> = pure (\<lambda>x x' y y'. if x' = y then y' else x) \<diamondop> x \<diamondop> x \<diamondop> y \<diamondop> y" unfolding ap_W ..
  also have "\<dots> = pure (\<lambda>x b y'. if b then y' else x) \<diamondop> x \<diamondop> (pure op = \<diamondop> x \<diamondop> y) \<diamondop> y" by applicative_nf simp
  also have "\<dots> = pure (\<lambda>x y'. y') \<diamondop> x \<diamondop> y" unfolding \<open>?rhs\<close> by applicative_nf simp
  also have "\<dots> = K \<diamondop> pure (\<lambda>x. x) \<diamondop> x \<diamondop> y" unfolding K_def by applicative_nf simp
  also have "\<dots> = y" unfolding ap_K by applicative_nf simp
  finally show ?lhs .
qed

text \<open>
  If we have K and W, then we also have C.
\<close>

lemma ap_C_KW: "pure (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x" (is "?lhs = ?rhs")
proof -
  have "?lhs = (pure (\<lambda>f x y. f y x) \<diamondop> f) \<diamondop> (K \<diamondop> pure (\<lambda>x. x) \<diamondop> y \<diamondop> x) \<diamondop> y"
    unfolding ap_K by applicative_nf simp
  also have "\<dots> = K \<diamondop> \<dots> \<diamondop> x" unfolding ap_K ..
  also have "\<dots> = pure (\<lambda>f y' x y x'. f y x) \<diamondop> f \<diamondop> y \<diamondop> x \<diamondop> y \<diamondop> x" unfolding K_def
    by applicative_nf simp
  also have "\<dots> = W \<diamondop> (pure (\<lambda>f (y', x) (y, x'). f y x) \<diamondop> f) \<diamondop> zip y x"
    unfolding ap_W by applicative_nf simp
  also have "\<dots> = pure (\<lambda>f (y', x). f y' x) \<diamondop> f \<diamondop> zip y x"
    unfolding W_def by applicative_nf simp
  also have "\<dots> = ?rhs" by applicative_nf simp
  finally show ?thesis .
qed

subsection \<open>Swapping\<close>

text \<open>
  Is there an applicative functor that has a K but not a C?
\<close>

axiomatization C :: "(('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c) af"
  where ap_C: "C \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
  and C_def: "C = pure (\<lambda>f x y. f y x)"

text \<open>With swapping, we can add effects in the middle.\<close>

lemma rel_add_middle:
  assumes "rel P (f \<diamondop> y) (f' \<diamondop> y')"
  and "rel (\<lambda>_ _. True) x x'"
  shows "rel P (pure (\<lambda>f x y. f y) \<diamondop> f \<diamondop> x \<diamondop> y) (pure (\<lambda>f x y. f y) \<diamondop> f' \<diamondop> x' \<diamondop> y')"
apply(rule rel_apI)
apply(rule rel_apI)
prefer 2
apply(rule assms(2))
apply(rule rel_apI)
apply(rule rel_apI)+
prefer 3
apply(rule assms)
oops

end


theory Simplificacion4
imports Main
begin

subsection{* Distinción de casos *}

text {* Ejemplos de distinción automática de casos con if *}
lemma "P (if A then s else t)
       = ((A \<longrightarrow> P(s)) \<and> (\<not>A \<longrightarrow> P(t)))"
apply simp
done

lemma "(if A then B else False)
       = (A \<and> B)"
apply simp
done

lemma "(if A then B else C)
       = ((A \<longrightarrow> B) \<and> (\<not>A \<longrightarrow> C))"
apply simp
done

text {* Ejemplos de distinción no automática de casos con case *}

lemma "P (case e of 0 \<Rightarrow> a | Suc n \<Rightarrow> b)
       = ((e = 0 \<longrightarrow> P(a)) \<and> (\<forall> n. e = Suc n \<longrightarrow> P(b)))"
apply (simp split: nat.split)
done

lemma "P (case xs of [] \<Rightarrow> a | (y#ys) \<Rightarrow> b)
       = ((xs = [] \<longrightarrow> P a ) \<and> ((\<exists>y ys. xs = y # ys) \<longrightarrow> P b))"
apply (simp split: list.split)
done

lemma "1 \<le> (case ns of [] \<Rightarrow> 1 | n#_ \<Rightarrow> Suc n)"
apply (simp split: list.split)
done

lemma "P (case t of (x,y) \<Rightarrow> f x y)
       = (\<forall> x y. t = (x,y) \<longrightarrow> P (f x y))"
apply (simp split: prod.split)
done

text {* Ejemplos de distinción no automática de casos con let *}

lemma "P (let (x,y) = t in f x y)
       = (\<forall> x y. t = (x,y) \<longrightarrow> P (f x y))"
apply (simp split: prod.split)
done

section {* Simplificación en aritmética lineal *}

text {* Ejemplo de simplificación con las reglas de la aritmética
  lineal. *}
lemma "\<lbrakk> (x::nat) \<le> y+z
       ; z+x < y \<rbrakk>
       \<Longrightarrow> x < y"
apply simp
done

end


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

section \<open>Injections from A to B up to a permutation on A and B\<close>

theory Twelvefold_Way_Entry11
imports Twelvefold_Way_Entry10
begin

subsection \<open>Properties for Bijections\<close>

lemma all_one_implies_inj_on:
  assumes "finite A" "finite B"
  assumes "\<forall>n. n\<in># N \<longrightarrow> n = 1" "number_partition (card A) N" "size N \<le> card B"
  assumes "f \<in> functions_of A B N"
  shows   "inj_on f A"
proof -
  from \<open>f \<in> functions_of A B N\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
    and "N = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))"
    unfolding functions_of_def by auto
  from this \<open>\<forall>n. n\<in># N \<longrightarrow> n = 1\<close> have parts: "\<forall>b \<in> B. card {x \<in> A. f x = b} = 1 \<or> {x \<in> A. f x = b} = {}"
    using \<open>finite B\<close> by auto
  show "inj_on f A"
  proof
    fix x y
    assume a: "x \<in> A" "y \<in> A" "f x = f y"
    from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>x \<in> A\<close> have "f x \<in> B" by auto
    from a have 1: "x \<in> {x' \<in> A. f x' = f x}" "y \<in> {x' \<in> A. f x' = f x}" by auto
    from this have 2: "card {x' \<in> A. f x' = f x} = 1"
      using parts \<open>f x \<in> B\<close> by blast
    from this have "is_singleton {x' \<in> A. f x' = f x}"
      by (simp add: is_singleton_altdef)
    from 1 this show "x = y"
      by (metis is_singletonE singletonD)
  qed
qed

lemma inj_on_implies_all_one:
  assumes "finite A" "finite B"
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B"
  assumes "univ (\<lambda>f. inj_on f A) F"
  shows "\<forall>n. n\<in># number_partition_of A B F \<longrightarrow> n = 1"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = domain_and_range_permutation A B `` {f}" using quotientE by blast
  have "number_partition_of A B F = univ (\<lambda>f. image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))) F"
    unfolding number_partition_of_def ..
  also have "\<dots> =  univ (\<lambda>f. image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))) (domain_and_range_permutation A B `` {f})"
    unfolding F_eq ..
  also have "\<dots> = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))"
    using \<open>finite B\<close> equiv_domain_and_range_permutation multiset_of_partition_cards_respects_domain_and_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  finally have eq: "number_partition_of A B F = image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}))" .
  from iffD1[OF univ_commute', OF equiv_domain_and_range_permutation, OF inj_on_respects_domain_and_range_permutation, OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>]
    assms(4) have "inj_on f A" by (simp add: F_eq)
  have "\<forall>n. n \<in># image_mset card (mset_set ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})) \<longrightarrow> n = 1"
  proof -
    have "\<forall>b \<in> B. card {x \<in> A. f x = b} = 1 \<or> {x \<in> A. f x = b} = {}"
    proof
      fix b
      assume "b \<in> B"
      show "card {x \<in> A. f x = b} = 1 \<or> {x \<in> A. f x = b} = {}"
      proof (cases "b \<in> f ` A")
        assume "b \<in> f ` A"
        from \<open>inj_on f A\<close> this have "is_singleton {x \<in> A. f x = b}"
          by (auto simp add: inj_on_eq_iff intro: is_singletonI')
        from this have "card {x \<in> A. f x = b} = 1"
          by (subst is_singleton_altdef[symmetric])
        from this show ?thesis ..
      next
        assume "b \<notin> f ` A"
        from this have "{x \<in> A. f x = b} = {}" by auto
        from this show ?thesis ..
      qed
    qed
    from this show ?thesis
      using \<open>finite B\<close> by auto
  qed
  from this show "\<forall>n. n\<in># number_partition_of A B F \<longrightarrow> n = 1"
    unfolding eq by auto
qed

lemma functions_of_is_inj_on:
  assumes "finite A" "finite B"
  assumes "\<forall>n. n\<in># N \<longrightarrow> n = 1" "number_partition (card A) N" "size N \<le> card B"
  shows "univ (\<lambda>f. inj_on f A) (functions_of A B N)"
proof -
  have "functions_of A B N \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B"
    using assms functions_of by auto
  from this obtain f where eq_f: "functions_of A B N = domain_and_range_permutation A B `` {f}" and "f \<in> A \<rightarrow>\<^sub>E B"
    using quotientE by blast
  from eq_f have "f \<in> functions_of A B N"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> equiv_domain_and_range_permutation equiv_class_self by fastforce
  have "inj_on f A"
    using \<open>f \<in> functions_of A B N\<close> assms all_one_implies_inj_on by blast
  from this show ?thesis
    unfolding eq_f using equiv_domain_and_range_permutation inj_on_respects_domain_and_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') assumption+
qed

subsection \<open>Bijections\<close>

lemma bij_betw_number_partition_of:
  assumes "finite A" "finite B"
  shows "bij_betw (number_partition_of A B) ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B) {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}"
proof (rule bij_betw_byWitness[where f'="functions_of A B"])
  have quotient_eq: "{f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B). univ (\<lambda>f. inj_on f A) F}"
    using equiv_domain_and_range_permutation[of A B] inj_on_respects_domain_and_range_permutation[of A B] by (simp only: univ_preserves_predicate)
  show "\<forall>F\<in>{f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B.
       functions_of A B (number_partition_of A B F) = F"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp only: quotient_eq functions_of_number_partition_of)
  show "\<forall>N\<in> {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}. number_partition_of A B (functions_of A B N) = N"
    using \<open>finite A\<close> \<open>finite B\<close> number_partition_of_functions_of by auto
  show "number_partition_of A B ` ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B)
    \<subseteq> {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}"
    using \<open>finite A\<close> \<open>finite B\<close>
    by (auto simp add: quotient_eq number_partition_of inj_on_implies_all_one simp del: One_nat_def)
  show "functions_of A B ` {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}
    \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq intro: functions_of functions_of_is_inj_on)
qed

lemma bij_betw_functions_of:
  assumes "finite A" "finite B"
  shows "bij_betw (functions_of A B) {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B} ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B)"
proof (rule bij_betw_byWitness[where f'="number_partition_of A B"])
  have quotient_eq: "{f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B). univ (\<lambda>f. inj_on f A) F}"
    using equiv_domain_and_range_permutation[of A B] inj_on_respects_domain_and_range_permutation[of A B] by (simp only: univ_preserves_predicate)
  show "\<forall>F\<in>{f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B.
       functions_of A B (number_partition_of A B F) = F"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp only: quotient_eq functions_of_number_partition_of)
  show "\<forall>N\<in> {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}. number_partition_of A B (functions_of A B N) = N"
    using \<open>finite A\<close> \<open>finite B\<close> number_partition_of_functions_of by auto
  show "number_partition_of A B ` ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B)
    \<subseteq> {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}"
    using \<open>finite A\<close> \<open>finite B\<close>
    by (auto simp add: quotient_eq number_partition_of inj_on_implies_all_one simp del: One_nat_def)
  show "functions_of A B ` {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}
    \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: quotient_eq intro: functions_of functions_of_is_inj_on)
qed

subsection \<open>Cardinality\<close>

lemma card_injective_functions_domain_and_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B) = iverson (card A \<le> card B)"
proof -
  have "bij_betw (number_partition_of A B) ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B) {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}"
     using \<open>finite A\<close> \<open>finite B\<close> by (rule bij_betw_number_partition_of)
  from this have "card ({f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B) = card {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B}"
    by (rule bij_betw_same_card)
  also have "card {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition (card A) N \<and> size N \<le> card B} = iverson (card A \<le> card B)"
    by (rule card_number_partitions_with_only_parts_1)
  finally show ?thesis .
qed

end


(*  Title:      HOL/Nonstandard_Analysis/Star.thy
    Author:     Jacques D. Fleuriot
    Copyright:  1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2003/4
*)

section \<open>Star-Transforms in Non-Standard Analysis\<close>

theory Star
  imports NSA
begin

definition  \<comment> \<open>internal sets\<close>
  starset_n :: "(nat \<Rightarrow> 'a set) \<Rightarrow> 'a star set"  ("*sn* _" [80] 80)
  where "*sn* As = Iset (star_n As)"

definition InternalSets :: "'a star set set"
  where "InternalSets = {X. \<exists>As. X = *sn* As}"

definition  \<comment> \<open>nonstandard extension of function\<close>
  is_starext :: "('a star \<Rightarrow> 'a star) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "is_starext F f \<longleftrightarrow>
    (\<forall>x y. \<exists>X \<in> Rep_star x. \<exists>Y \<in> Rep_star y. y = F x \<longleftrightarrow> eventually (\<lambda>n. Y n = f(X n)) \<U>)"

definition  \<comment> \<open>internal functions\<close>
  starfun_n :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a star \<Rightarrow> 'b star"  ("*fn* _" [80] 80)
  where "*fn* F = Ifun (star_n F)"

definition InternalFuns :: "('a star => 'b star) set"
  where "InternalFuns = {X. \<exists>F. X = *fn* F}"

subsection \<open>Preamble - Pulling \<open>\<exists>\<close> over \<open>\<forall>\<close>\<close>

text \<open>This proof does not need AC and was suggested by the
   referee for the JCM Paper: let \<open>f x\<close> be least \<open>y\<close> such
   that \<open>Q x y\<close>.\<close>
lemma no_choice: "\<forall>x. \<exists>y. Q x y \<Longrightarrow> \<exists>f :: 'a \<Rightarrow> nat. \<forall>x. Q x (f x)"
  by (rule exI [where x = "\<lambda>x. LEAST y. Q x y"]) (blast intro: LeastI)

subsection \<open>Properties of the Star-transform Applied to Sets of Reals\<close>

lemma STAR_star_of_image_subset: "star_of ` A \<subseteq> *s* A"
  by auto

lemma STAR_hypreal_of_real_Int: "*s* X \<inter> \<real> = hypreal_of_real ` X"
  by (auto simp add: SReal_def)

lemma STAR_star_of_Int: "*s* X \<inter> Standard = star_of ` X"
  by (auto simp add: Standard_def)

lemma lemma_not_hyprealA: "x \<notin> hypreal_of_real ` A \<Longrightarrow> \<forall>y \<in> A. x \<noteq> hypreal_of_real y"
  by auto

lemma lemma_not_starA: "x \<notin> star_of ` A \<Longrightarrow> \<forall>y \<in> A. x \<noteq> star_of y"
  by auto

lemma STAR_real_seq_to_hypreal: "\<forall>n. (X n) \<notin> M \<Longrightarrow> star_n X \<notin> *s* M"
  by (simp add: starset_def star_of_def Iset_star_n FreeUltrafilterNat.proper)

lemma STAR_singleton: "*s* {x} = {star_of x}"
  by simp

lemma STAR_not_mem: "x \<notin> F \<Longrightarrow> star_of x \<notin> *s* F"
  by transfer

lemma STAR_subset_closed: "x \<in> *s* A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<in> *s* B"
  by (erule rev_subsetD) simp

text \<open>Nonstandard extension of a set (defined using a constant
   sequence) as a special case of an internal set.\<close>
lemma starset_n_starset: "\<forall>n. As n = A \<Longrightarrow> *sn* As = *s* A"
  by (drule fun_eq_iff [THEN iffD2]) (simp add: starset_n_def starset_def star_of_def)

subsection \<open>Theorems about nonstandard extensions of functions\<close>

text \<open>Nonstandard extension of a function (defined using a
  constant sequence) as a special case of an internal function.\<close>

lemma starfun_n_starfun: "F = (\<lambda>n. f) \<Longrightarrow> *fn* F = *f* f"
  by (simp add: starfun_n_def starfun_def star_of_def)

text \<open>Prove that \<open>abs\<close> for hypreal is a nonstandard extension of abs for real w/o
  use of congruence property (proved after this for general
  nonstandard extensions of real valued functions).

  Proof now Uses the ultrafilter tactic!\<close>

lemma hrabs_is_starext_rabs: "is_starext abs abs"
  proof -
  have "\<exists>f\<in>Rep_star (star_n h). \<exists>g\<in>Rep_star (star_n k). (star_n k = \<bar>star_n h\<bar>) = (\<forall>\<^sub>F n in \<U>. (g n::'a) = \<bar>f n\<bar>)"
    for x y :: "'a star" and h k
    by (metis (full_types) Rep_star_star_n star_n_abs star_n_eq_iff)
  then show ?thesis
    unfolding is_starext_def by (metis star_cases)
qed

text \<open>Nonstandard extension of functions.\<close>

lemma starfun: "( *f* f) (star_n X) = star_n (\<lambda>n. f (X n))"
  by (rule starfun_star_n)

lemma starfun_if_eq: "\<And>w. w \<noteq> star_of x \<Longrightarrow> ( *f* (\<lambda>z. if z = x then a else g z)) w = ( *f* g) w"
  by transfer simp

text \<open>Multiplication: \<open>( *f) x ( *g) = *(f x g)\<close>\<close>
lemma starfun_mult: "\<And>x. ( *f* f) x * ( *f* g) x = ( *f* (\<lambda>x. f x * g x)) x"
  by transfer (rule refl)
declare starfun_mult [symmetric, simp]

text \<open>Addition: \<open>( *f) + ( *g) = *(f + g)\<close>\<close>
lemma starfun_add: "\<And>x. ( *f* f) x + ( *f* g) x = ( *f* (\<lambda>x. f x + g x)) x"
  by transfer (rule refl)
declare starfun_add [symmetric, simp]

text \<open>Subtraction: \<open>( *f) + -( *g) = *(f + -g)\<close>\<close>
lemma starfun_minus: "\<And>x. - ( *f* f) x = ( *f* (\<lambda>x. - f x)) x"
  by transfer (rule refl)
declare starfun_minus [symmetric, simp]

(*FIXME: delete*)
lemma starfun_add_minus: "\<And>x. ( *f* f) x + -( *f* g) x = ( *f* (\<lambda>x. f x + -g x)) x"
  by transfer (rule refl)
declare starfun_add_minus [symmetric, simp]

lemma starfun_diff: "\<And>x. ( *f* f) x  - ( *f* g) x = ( *f* (\<lambda>x. f x - g x)) x"
  by transfer (rule refl)
declare starfun_diff [symmetric, simp]

text \<open>Composition: \<open>( *f) \<circ> ( *g) = *(f \<circ> g)\<close>\<close>
lemma starfun_o2: "(\<lambda>x. ( *f* f) (( *f* g) x)) = *f* (\<lambda>x. f (g x))"
  by transfer (rule refl)

lemma starfun_o: "( *f* f) \<circ> ( *f* g) = ( *f* (f \<circ> g))"
  by (transfer o_def) (rule refl)

text \<open>NS extension of constant function.\<close>
lemma starfun_const_fun [simp]: "\<And>x. ( *f* (\<lambda>x. k)) x = star_of k"
  by transfer (rule refl)

text \<open>The NS extension of the identity function.\<close>
lemma starfun_Id [simp]: "\<And>x. ( *f* (\<lambda>x. x)) x = x"
  by transfer (rule refl)

text \<open>The Star-function is a (nonstandard) extension of the function.\<close>
lemma is_starext_starfun: "is_starext ( *f* f) f"
proof -
  have "\<exists>X\<in>Rep_star x. \<exists>Y\<in>Rep_star y. (y = (*f* f) x) = (\<forall>\<^sub>F n in \<U>. Y n = f (X n))"
    for x y
    by (metis (mono_tags) Rep_star_star_n star_cases star_n_eq_iff starfun_star_n)
  then show ?thesis
    by (auto simp: is_starext_def)
qed

text \<open>Any nonstandard extension is in fact the Star-function.\<close>
lemma is_starfun_starext:
  assumes "is_starext F f"
  shows "F = *f* f"
  proof -
  have "F x = (*f* f) x"
    if "\<forall>x y. \<exists>X\<in>Rep_star x. \<exists>Y\<in>Rep_star y. (y = F x) = (\<forall>\<^sub>F n in \<U>. Y n = f (X n))" for x
    by (metis that mem_Rep_star_iff star_n_eq_iff starfun_star_n)
  with assms show ?thesis
    by (force simp add: is_starext_def)
qed

lemma is_starext_starfun_iff: "is_starext F f \<longleftrightarrow> F = *f* f"
  by (blast intro: is_starfun_starext is_starext_starfun)

text \<open>Extended function has same solution as its standard version
  for real arguments. i.e they are the same for all real arguments.\<close>
lemma starfun_eq: "( *f* f) (star_of a) = star_of (f a)"
  by (rule starfun_star_of)

lemma starfun_approx: "( *f* f) (star_of a) \<approx> star_of (f a)"
  by simp

text \<open>Useful for NS definition of derivatives.\<close>
lemma starfun_lambda_cancel: "\<And>x'. ( *f* (\<lambda>h. f (x + h))) x'  = ( *f* f) (star_of x + x')"
  by transfer (rule refl)

lemma starfun_lambda_cancel2: "( *f* (\<lambda>h. f (g (x + h)))) x' = ( *f* (f \<circ> g)) (star_of x + x')"
  unfolding o_def by (rule starfun_lambda_cancel)

lemma starfun_mult_HFinite_approx:
  "( *f* f) x \<approx> l \<Longrightarrow> ( *f* g) x \<approx> m \<Longrightarrow> l \<in> HFinite \<Longrightarrow> m \<in> HFinite \<Longrightarrow>
    ( *f* (\<lambda>x. f x * g x)) x \<approx> l * m"
  for l m :: "'a::real_normed_algebra star"
  using approx_mult_HFinite by auto

lemma starfun_add_approx: "( *f* f) x \<approx> l \<Longrightarrow> ( *f* g) x \<approx> m \<Longrightarrow> ( *f* (%x. f x + g x)) x \<approx> l + m"
  by (auto intro: approx_add)

text \<open>Examples: \<open>hrabs\<close> is nonstandard extension of \<open>rabs\<close>,
  \<open>inverse\<close> is nonstandard extension of \<open>inverse\<close>.\<close>

text \<open>Can be proved easily using theorem \<open>starfun\<close> and
  properties of ultrafilter as for inverse below we
  use the theorem we proved above instead.\<close>

lemma starfun_rabs_hrabs: "*f* abs = abs"
  by (simp only: star_abs_def)

lemma starfun_inverse_inverse [simp]: "( *f* inverse) x = inverse x"
  by (simp only: star_inverse_def)

lemma starfun_inverse: "\<And>x. inverse (( *f* f) x) = ( *f* (\<lambda>x. inverse (f x))) x"
  by transfer (rule refl)
declare starfun_inverse [symmetric, simp]

lemma starfun_divide: "\<And>x. ( *f* f) x / ( *f* g) x = ( *f* (\<lambda>x. f x / g x)) x"
  by transfer (rule refl)
declare starfun_divide [symmetric, simp]

lemma starfun_inverse2: "\<And>x. inverse (( *f* f) x) = ( *f* (\<lambda>x. inverse (f x))) x"
  by transfer (rule refl)

text \<open>General lemma/theorem needed for proofs in elementary topology of the reals.\<close>
lemma starfun_mem_starset: "\<And>x. ( *f* f) x \<in> *s* A \<Longrightarrow> x \<in> *s* {x. f x \<in> A}"
  by transfer simp

text \<open>Alternative definition for \<open>hrabs\<close> with \<open>rabs\<close> function applied
  entrywise to equivalence class representative.
  This is easily proved using @{thm [source] starfun} and ns extension thm.\<close>
lemma hypreal_hrabs: "\<bar>star_n X\<bar> = star_n (\<lambda>n. \<bar>X n\<bar>)"
  by (simp only: starfun_rabs_hrabs [symmetric] starfun)

text \<open>Nonstandard extension of set through nonstandard extension
   of \<open>rabs\<close> function i.e. \<open>hrabs\<close>. A more general result should be
   where we replace \<open>rabs\<close> by some arbitrary function \<open>f\<close> and \<open>hrabs\<close>
   by its NS extenson. See second NS set extension below.\<close>
lemma STAR_rabs_add_minus: "*s* {x. \<bar>x + - y\<bar> < r} = {x. \<bar>x + -star_of y\<bar> < star_of r}"
  by transfer (rule refl)

lemma STAR_starfun_rabs_add_minus:
  "*s* {x. \<bar>f x + - y\<bar> < r} = {x. \<bar>( *f* f) x + -star_of y\<bar> < star_of r}"
  by transfer (rule refl)

text \<open>Another characterization of Infinitesimal and one of \<open>\<approx>\<close> relation.
  In this theory since \<open>hypreal_hrabs\<close> proved here. Maybe move both theorems??\<close>
lemma Infinitesimal_FreeUltrafilterNat_iff2:
  "star_n X \<in> Infinitesimal \<longleftrightarrow> (\<forall>m. eventually (\<lambda>n. norm (X n) < inverse (real (Suc m))) \<U>)"
  by (simp add: Infinitesimal_hypreal_of_nat_iff star_of_def hnorm_def
      star_of_nat_def starfun_star_n star_n_inverse star_n_less)

lemma HNatInfinite_inverse_Infinitesimal [simp]:
  assumes "n \<in> HNatInfinite"
  shows "inverse (hypreal_of_hypnat n) \<in> Infinitesimal"
proof (cases n)
  case (star_n X)
  then have *: "\<And>k. \<forall>\<^sub>F n in \<U>. k < X n"
    using HNatInfinite_FreeUltrafilterNat assms by blast
  have "\<forall>\<^sub>F n in \<U>. inverse (real (X n)) < inverse (1 + real m)" for m
    using * [of "Suc m"] by (auto elim!: eventually_mono)
  then show ?thesis
    using star_n by (auto simp: of_hypnat_def starfun_star_n star_n_inverse Infinitesimal_FreeUltrafilterNat_iff2)
qed

lemma approx_FreeUltrafilterNat_iff:
  "star_n X \<approx> star_n Y \<longleftrightarrow> (\<forall>r>0. eventually (\<lambda>n. norm (X n - Y n) < r) \<U>)"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (star_n X - star_n Y \<approx> 0)"
    using approx_minus_iff by blast
  also have "... = ?rhs"
    by (metis (full_types) Infinitesimal_FreeUltrafilterNat_iff mem_infmal_iff star_n_diff)
  finally show ?thesis .
qed

lemma approx_FreeUltrafilterNat_iff2:
  "star_n X \<approx> star_n Y \<longleftrightarrow> (\<forall>m. eventually (\<lambda>n. norm (X n - Y n) < inverse (real (Suc m))) \<U>)"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (star_n X - star_n Y \<approx> 0)"
    using approx_minus_iff by blast
  also have "... = ?rhs"
    by (metis (full_types) Infinitesimal_FreeUltrafilterNat_iff2 mem_infmal_iff star_n_diff)
  finally show ?thesis .
qed

lemma inj_starfun: "inj starfun"
proof (rule inj_onI)
  show "\<phi> = \<psi>" if eq: "*f* \<phi> = *f* \<psi>" for \<phi> \<psi> :: "'a \<Rightarrow> 'b"
  proof (rule ext, rule ccontr)
    show False
      if "\<phi> x \<noteq> \<psi> x" for x
      by (metis eq that star_of_inject starfun_eq)
  qed
qed

end


(*  Title:      HOL/ZF/LProd.thy
    Author:     Steven Obua

    Introduces the lprod relation.
    See "Partizan Games in Isabelle/HOLZF", available from http://www4.in.tum.de/~obua/partizan
*)

theory LProd
imports "~~/src/HOL/Library/Multiset"
begin

inductive_set
  lprod :: "('a * 'a) set \<Rightarrow> ('a list * 'a list) set"
  for R :: "('a * 'a) set"
where
  lprod_single[intro!]: "(a, b) \<in> R \<Longrightarrow> ([a], [b]) \<in> lprod R"
| lprod_list[intro!]: "(ah@at, bh@bt) \<in> lprod R \<Longrightarrow> (a,b) \<in> R \<or> a = b \<Longrightarrow> (ah@a#at, bh@b#bt) \<in> lprod R"

lemma "(as,bs) \<in> lprod R \<Longrightarrow> length as = length bs"
  apply (induct as bs rule: lprod.induct)
  apply auto
  done

lemma "(as, bs) \<in> lprod R \<Longrightarrow> 1 \<le> length as \<and> 1 \<le> length bs"
  apply (induct as bs rule: lprod.induct)
  apply auto
  done

lemma lprod_subset_elem: "(as, bs) \<in> lprod S \<Longrightarrow> S \<subseteq> R \<Longrightarrow> (as, bs) \<in> lprod R"
  apply (induct as bs rule: lprod.induct)
  apply (auto)
  done

lemma lprod_subset: "S \<subseteq> R \<Longrightarrow> lprod S \<subseteq> lprod R"
  by (auto intro: lprod_subset_elem)

lemma lprod_implies_mult: "(as, bs) \<in> lprod R \<Longrightarrow> trans R \<Longrightarrow> (mset as, mset bs) \<in> mult R"
proof (induct as bs rule: lprod.induct)
  case (lprod_single a b)
  note step = one_step_implies_mult[
    where r=R and I="{#}" and K="{#a#}" and J="{#b#}", simplified]
  show ?case by (auto intro: lprod_single step)
next
  case (lprod_list ah at bh bt a b)
  then have transR: "trans R" by auto
  have as: "mset (ah @ a # at) = mset (ah @ at) + {#a#}" (is "_ = ?ma + _")
    by (simp add: algebra_simps)
  have bs: "mset (bh @ b # bt) = mset (bh @ bt) + {#b#}" (is "_ = ?mb + _")
    by (simp add: algebra_simps)
  from lprod_list have "(?ma, ?mb) \<in> mult R"
    by auto
  with mult_implies_one_step[OF transR] have
    "\<exists>I J K. ?mb = I + J \<and> ?ma = I + K \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> R)"
    by blast
  then obtain I J K where
    decomposed: "?mb = I + J \<and> ?ma = I + K \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> R)"
    by blast
  show ?case
  proof (cases "a = b")
    case True
    have "((I + {#b#}) + K, (I + {#b#}) + J) \<in> mult R"
      apply (rule one_step_implies_mult)
      apply (auto simp add: decomposed)
      done
    then show ?thesis
      apply (simp only: as bs)
      apply (simp only: decomposed True)
      apply (simp add: algebra_simps)
      done
  next
    case False
    from False lprod_list have False: "(a, b) \<in> R" by blast
    have "(I + (K + {#a#}), I + (J + {#b#})) \<in> mult R"
      apply (rule one_step_implies_mult)
      apply (auto simp add: False decomposed)
      done
    then show ?thesis
      apply (simp only: as bs)
      apply (simp only: decomposed)
      apply (simp add: algebra_simps)
      done
  qed
qed

lemma wf_lprod[simp,intro]:
  assumes wf_R: "wf R"
  shows "wf (lprod R)"
proof -
  have subset: "lprod (R^+) \<subseteq> inv_image (mult (R^+)) mset"
    by (auto simp add: lprod_implies_mult trans_trancl)
  note lprodtrancl = wf_subset[OF wf_inv_image[where r="mult (R^+)" and f="mset",
    OF wf_mult[OF wf_trancl[OF wf_R]]], OF subset]
  note lprod = wf_subset[OF lprodtrancl, where p="lprod R", OF lprod_subset, simplified]
  show ?thesis by (auto intro: lprod)
qed

definition gprod_2_2 :: "('a * 'a) set \<Rightarrow> (('a * 'a) * ('a * 'a)) set" where
  "gprod_2_2 R \<equiv> { ((a,b), (c,d)) . (a = c \<and> (b,d) \<in> R) \<or> (b = d \<and> (a,c) \<in> R) }"

definition gprod_2_1 :: "('a * 'a) set \<Rightarrow> (('a * 'a) * ('a * 'a)) set" where
  "gprod_2_1 R \<equiv>  { ((a,b), (c,d)) . (a = d \<and> (b,c) \<in> R) \<or> (b = c \<and> (a,d) \<in> R) }"

lemma lprod_2_3: "(a, b) \<in> R \<Longrightarrow> ([a, c], [b, c]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[a]" and at = "[]" and bh="[b]" and bt="[]", simplified])

lemma lprod_2_4: "(a, b) \<in> R \<Longrightarrow> ([c, a], [c, b]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[]" and at = "[a]" and bh="[]" and bt="[b]", simplified])

lemma lprod_2_1: "(a, b) \<in> R \<Longrightarrow> ([c, a], [b, c]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[]" and at = "[a]" and bh="[b]" and bt="[]", simplified])

lemma lprod_2_2: "(a, b) \<in> R \<Longrightarrow> ([a, c], [c, b]) \<in> lprod R"
  by (auto intro: lprod_list[where a=c and b=c and
    ah = "[a]" and at = "[]" and bh="[]" and bt="[b]", simplified])

lemma [simp, intro]:
  assumes wfR: "wf R" shows "wf (gprod_2_1 R)"
proof -
  have "gprod_2_1 R \<subseteq> inv_image (lprod R) (\<lambda> (a,b). [a,b])"
    by (auto simp add: gprod_2_1_def lprod_2_1 lprod_2_2)
  with wfR show ?thesis
    by (rule_tac wf_subset, auto)
qed

lemma [simp, intro]:
  assumes wfR: "wf R" shows "wf (gprod_2_2 R)"
proof -
  have "gprod_2_2 R \<subseteq> inv_image (lprod R) (\<lambda> (a,b). [a,b])"
    by (auto simp add: gprod_2_2_def lprod_2_3 lprod_2_4)
  with wfR show ?thesis
    by (rule_tac wf_subset, auto)
qed

lemma lprod_3_1: assumes "(x', x) \<in> R" shows "([y, z, x'], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[]" and at="[z,x']" and bh="[x]" and bt="[z]", simplified])
  apply (auto simp add: lprod_2_1 assms)
  done

lemma lprod_3_2: assumes "(z',z) \<in> R" shows "([z', x, y], [x,y,z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[z',x]" and at="[]" and bh="[x]" and bt="[z]", simplified])
  apply (auto simp add: lprod_2_2 assms)
  done

lemma lprod_3_3: assumes xr: "(xr, x) \<in> R" shows "([xr, y, z], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[xr]" and at="[z]" and bh="[x]" and bt="[z]", simplified])
  apply (simp add: xr lprod_2_3)
  done

lemma lprod_3_4: assumes yr: "(yr, y) \<in> R" shows "([x, yr, z], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="x" and b="x" and ah="[]" and at="[yr,z]" and bh="[]" and bt="[y,z]", simplified])
  apply (simp add: yr lprod_2_3)
  done

lemma lprod_3_5: assumes zr: "(zr, z) \<in> R" shows "([x, y, zr], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="x" and b="x" and ah="[]" and at="[y,zr]" and bh="[]" and bt="[y,z]", simplified])
  apply (simp add: zr lprod_2_4)
  done

lemma lprod_3_6: assumes y': "(y', y) \<in> R" shows "([x, z, y'], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="z" and b="z" and ah="[x]" and at="[y']" and bh="[x,y]" and bt="[]", simplified])
  apply (simp add: y' lprod_2_4)
  done

lemma lprod_3_7: assumes z': "(z',z) \<in> R" shows "([x, z', y], [x, y, z]) \<in> lprod R"
  apply (rule lprod_list[where a="y" and b="y" and ah="[x, z']" and at="[]" and bh="[x]" and bt="[z]", simplified])
  apply (simp add: z' lprod_2_4)
  done

definition perm :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> bool" where
   "perm f A \<equiv> inj_on f A \<and> f ` A = A"

lemma "((as,bs) \<in> lprod R) =
  (\<exists> f. perm f {0 ..< (length as)} \<and>
  (\<forall> j. j < length as \<longrightarrow> ((nth as j, nth bs (f j)) \<in> R \<or> (nth as j = nth bs (f j)))) \<and>
  (\<exists> i. i < length as \<and> (nth as i, nth bs (f i)) \<in> R))"
oops

lemma "trans R \<Longrightarrow> (ah@a#at, bh@b#bt) \<in> lprod R \<Longrightarrow> (b, a) \<in> R \<or> a = b \<Longrightarrow> (ah@at, bh@bt) \<in> lprod R"
oops

end