(*  Title:      HOL/HOLCF/Map_Functions.thy
    Author:     Brian Huffman
*)

section \<open>Map functions for various types\<close>

theory Map_Functions
imports Deflation
begin

subsection \<open>Map operator for continuous function space\<close>

default_sort cpo

definition
  cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
where
  "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"

lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
unfolding cfun_map_def by simp

lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
unfolding cfun_eq_iff by simp

lemma cfun_map_map:
  "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
    cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
by (rule cfun_eqI) simp

lemma ep_pair_cfun_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
proof
  interpret e1p1: ep_pair e1 p1 by fact
  interpret e2p2: ep_pair e2 p2 by fact
  fix f show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
    by (simp add: cfun_eq_iff)
  fix g show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
    apply (rule cfun_belowI, simp)
    apply (rule below_trans [OF e2p2.e_p_below])
    apply (rule monofun_cfun_arg)
    apply (rule e1p1.e_p_below)
    done
qed

lemma deflation_cfun_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix f
  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
    by (simp add: cfun_eq_iff d1.idem d2.idem)
  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
    apply (rule cfun_belowI, simp)
    apply (rule below_trans [OF d2.below])
    apply (rule monofun_cfun_arg)
    apply (rule d1.below)
    done
qed

lemma finite_range_cfun_map:
  assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
  assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
  shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))"  (is "finite (range ?h)")
proof (rule finite_imageD)
  let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
  show "finite (?f ` range ?h)"
  proof (rule finite_subset)
    let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
    show "?f ` range ?h \<subseteq> ?B"
      by clarsimp
    show "finite ?B"
      by (simp add: a b)
  qed
  show "inj_on ?f (range ?h)"
  proof (rule inj_onI, rule cfun_eqI, clarsimp)
    fix x f g
    assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
    hence "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
      by (rule equalityD1)
    hence "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
      by (simp add: subset_eq)
    then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
      by (rule rangeE)
    thus "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
      by clarsimp
  qed
qed

lemma finite_deflation_cfun_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (cfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_cfun_map)
  have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
    using d1.finite_range d2.finite_range
    by (rule finite_range_cfun_map)
  thus "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (rule finite_range_imp_finite_fixes)
qed

text \<open>Finite deflations are compact elements of the function space\<close>

lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
apply (frule finite_deflation_imp_deflation)
apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
apply (simp add: cfun_map_def deflation.idem eta_cfun)
apply (rule finite_deflation.compact)
apply (simp only: finite_deflation_cfun_map)
done

subsection \<open>Map operator for product type\<close>

definition
  prod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
where
  "prod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"

lemma prod_map_Pair [simp]: "prod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
unfolding prod_map_def by simp

lemma prod_map_ID: "prod_map\<cdot>ID\<cdot>ID = ID"
unfolding cfun_eq_iff by auto

lemma prod_map_map:
  "prod_map\<cdot>f1\<cdot>g1\<cdot>(prod_map\<cdot>f2\<cdot>g2\<cdot>p) =
    prod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
by (induct p) simp

lemma ep_pair_prod_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (prod_map\<cdot>e1\<cdot>e2) (prod_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: ep_pair e1 p1 by fact
  interpret e2p2: ep_pair e2 p2 by fact
  fix x show "prod_map\<cdot>p1\<cdot>p2\<cdot>(prod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
    by (induct x) simp
  fix y show "prod_map\<cdot>e1\<cdot>e2\<cdot>(prod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
    by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
qed

lemma deflation_prod_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (prod_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "prod_map\<cdot>d1\<cdot>d2\<cdot>(prod_map\<cdot>d1\<cdot>d2\<cdot>x) = prod_map\<cdot>d1\<cdot>d2\<cdot>x"
    by (induct x) (simp add: d1.idem d2.idem)
  show "prod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    by (induct x) (simp add: d1.below d2.below)
qed

lemma finite_deflation_prod_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (prod_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (prod_map\<cdot>d1\<cdot>d2)" by (rule deflation_prod_map)
  have "{p. prod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
    by clarsimp
  thus "finite {p. prod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection \<open>Map function for lifted cpo\<close>

definition
  u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
where
  "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"

lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
unfolding u_map_def by simp

lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
unfolding u_map_def by simp

lemma u_map_ID: "u_map\<cdot>ID = ID"
unfolding u_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
by (induct p) simp_all

lemma u_map_oo: "u_map\<cdot>(f oo g) = u_map\<cdot>f oo u_map\<cdot>g"
by (simp add: cfcomp1 u_map_map eta_cfun)

lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
apply standard
apply (case_tac x, simp, simp add: ep_pair.e_inverse)
apply (case_tac y, simp, simp add: ep_pair.e_p_below)
done

lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
apply standard
apply (case_tac x, simp, simp add: deflation.idem)
apply (case_tac x, simp, simp add: deflation.below)
done

lemma finite_deflation_u_map:
  assumes "finite_deflation d" shows "finite_deflation (u_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  have "deflation d" by fact
  thus "deflation (u_map\<cdot>d)" by (rule deflation_u_map)
  have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
    by (rule subsetI, case_tac x, simp_all)
  thus "finite {x. u_map\<cdot>d\<cdot>x = x}"
    by (rule finite_subset, simp add: d.finite_fixes)
qed

subsection \<open>Map function for strict products\<close>

default_sort pcpo

definition
  sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
where
  "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"

lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
unfolding sprod_map_def by simp

lemma sprod_map_spair [simp]:
  "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
by (simp add: sprod_map_def)

lemma sprod_map_spair':
  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
by (cases "x = \<bottom> \<or> y = \<bottom>") auto

lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
unfolding sprod_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma sprod_map_map:
  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
    sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
     sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
apply (induct p, simp)
apply (case_tac "f2\<cdot>x = \<bottom>", simp)
apply (case_tac "g2\<cdot>y = \<bottom>", simp)
apply simp
done

lemma ep_pair_sprod_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
  fix x show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
    by (induct x) simp_all
  fix y show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
    apply (induct y, simp)
    apply (case_tac "p1\<cdot>x = \<bottom>", simp, case_tac "p2\<cdot>y = \<bottom>", simp)
    apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
    done
qed

lemma deflation_sprod_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
    apply (induct x, simp)
    apply (case_tac "d1\<cdot>x = \<bottom>", simp, case_tac "d2\<cdot>y = \<bottom>", simp)
    apply (simp add: d1.idem d2.idem)
    done
  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    apply (induct x, simp)
    apply (simp add: monofun_cfun d1.below d2.below)
    done
qed

lemma finite_deflation_sprod_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (sprod_map\<cdot>d1\<cdot>d2)" by (rule deflation_sprod_map)
  have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq> insert \<bottom>
        ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
    by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
  thus "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection \<open>Map function for strict sums\<close>

definition
  ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
where
  "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"

lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
unfolding ssum_map_def by simp

lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
unfolding ssum_map_def by simp

lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
unfolding ssum_map_def by simp

lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
by (cases "x = \<bottom>") simp_all

lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
by (cases "x = \<bottom>") simp_all

lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
unfolding ssum_map_def by (simp add: cfun_eq_iff eta_cfun)

lemma ssum_map_map:
  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
    ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
     ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
apply (induct p, simp)
apply (case_tac "f2\<cdot>x = \<bottom>", simp, simp)
apply (case_tac "g2\<cdot>y = \<bottom>", simp, simp)
done

lemma ep_pair_ssum_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
  fix x show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x"
    by (induct x) simp_all
  fix y show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y"
    apply (induct y, simp)
    apply (case_tac "p1\<cdot>x = \<bottom>", simp, simp add: e1p1.e_p_below)
    apply (case_tac "p2\<cdot>y = \<bottom>", simp, simp add: e2p2.e_p_below)
    done
qed

lemma deflation_ssum_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
    apply (induct x, simp)
    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.idem)
    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.idem)
    done
  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    apply (induct x, simp)
    apply (case_tac "d1\<cdot>x = \<bottom>", simp, simp add: d1.below)
    apply (case_tac "d2\<cdot>y = \<bottom>", simp, simp add: d2.below)
    done
qed

lemma finite_deflation_ssum_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (ssum_map\<cdot>d1\<cdot>d2)" by (rule deflation_ssum_map)
  have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
        (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
        (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
    by (rule subsetI, case_tac x, simp_all)
  thus "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection \<open>Map operator for strict function space\<close>

definition
  sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
where
  "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"

lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
  unfolding sfun_map_def
  by (simp add: cfun_map_ID cfun_eq_iff)

lemma sfun_map_map:
  assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
  "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
    sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
unfolding sfun_map_def
by (simp add: cfun_eq_iff strictify_cancel assms cfun_map_map)

lemma ep_pair_sfun_map:
  assumes 1: "ep_pair e1 p1"
  assumes 2: "ep_pair e2 p2"
  shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1
    unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2
    unfolding pcpo_ep_pair_def by fact
  fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
    unfolding sfun_map_def
    apply (simp add: sfun_eq_iff strictify_cancel)
    apply (rule ep_pair.e_inverse)
    apply (rule ep_pair_cfun_map [OF 1 2])
    done
  fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
    unfolding sfun_map_def
    apply (simp add: sfun_below_iff strictify_cancel)
    apply (rule ep_pair.e_p_below)
    apply (rule ep_pair_cfun_map [OF 1 2])
    done
qed

lemma deflation_sfun_map:
  assumes 1: "deflation d1"
  assumes 2: "deflation d2"
  shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
apply (simp add: sfun_map_def)
apply (rule deflation.intro)
apply simp
apply (subst strictify_cancel)
apply (simp add: cfun_map_def deflation_strict 1 2)
apply (simp add: cfun_map_def deflation.idem 1 2)
apply (simp add: sfun_below_iff)
apply (subst strictify_cancel)
apply (simp add: cfun_map_def deflation_strict 1 2)
apply (rule deflation.below)
apply (rule deflation_cfun_map [OF 1 2])
done

lemma finite_deflation_sfun_map:
  assumes 1: "finite_deflation d1"
  assumes 2: "finite_deflation d2"
  shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
proof (intro finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  have "deflation d1" and "deflation d2" by fact+
  thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
  from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
    by (rule finite_deflation_cfun_map)
  then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (rule finite_deflation.finite_fixes)
  moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
    by (rule inj_onI, simp add: sfun_eq_iff)
  ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
    by (rule finite_vimageI)
  then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    unfolding sfun_map_def sfun_eq_iff
    by (simp add: strictify_cancel
         deflation_strict \<open>deflation d1\<close> \<open>deflation d2\<close>)
qed

end


theory LazyPrelude_ListNoNumbers_E4
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"Comp1\", \"IdDef\", \"FlipDef\", \"FstDef\", \"SndDef\",
     \"CurryDef\", \"UncurryDef\", \"NotFalse\", \"NotTrue\",
     \"AndFalse\", \"AndTrue\", \"AndSym\", \"OrDef\", \"OtherwiseDef\",
     \"NotFalse1\", \"NotTrue1\", \"notNot1\", \"notNot2\",
     \"EqualTDef\", \"EqualSymDef\", \"EqualReflex\", \"EqualTransT\",
     \"DiffDef\", \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\", \"TE1\",
     \"TE2\", \"TE3\", \"TE4\", \"IUE1\", \"IUE2\", \"IBE1\", \"IBE2\",
     \"IBE3\", \"IBE4\", \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\",
     \"IOE01\", \"IOE02\", \"IOE03\", \"IOE04\", \"IOE05\", \"IOE06\",
     \"IOE07\", \"IOE08\", \"IOE09\", \"LeIrreflexivity\",
     \"LeTAsymmetry\", \"LeTTransitive\", \"LeTTotal\", \"GeDef\",
     \"GeIrreflexivity\", \"GeTAsymmetry\", \"GeTTransitive\",
     \"GeTTotal\", \"LeqDef\", \"LeqReflexivity\", \"LeqTTransitive\",
     \"LeqTTotal\", \"GeqDef\", \"GeqReflexivity\", \"GeqTTransitive\",
     \"GeqTTotal\", \"EqTSOrdRel\", \"EqFSOrdRel\", \"EqTOrdRel\",
     \"EqFOrdRel\", \"EqTOrdTSubstE\", \"EqTOrdFSubstE\",
     \"EqTOrdTSubstD\", \"EqTOrdFSubstD\", \"LeTGeFEqFRel\",
     \"LeFGeTEqTRel\", \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\",
     \"LeqFGetFRel\", \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\",
     \"GeqFLeqFRel\", \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\",
     \"GeFLeTEqTRel\", \"GeqTLeFRel\", \"GeqFLeTRel\",
     \"LeqTLeTEqTRel\", \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\",
     \"GeqFGeFEqFRel\", \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\",
     \"CmpLTDef\", \"CmpEQDef\", \"CmpGTDef\", \"MaxYDef\", \"MaxXDef\",
     \"MinXDef\", \"MinYDef\", \"MaxSym\", \"MinSym\", \"TO1\", \"TO2\",
     \"TO3\", \"TO4\", \"TO5\", \"TO6\", \"TO7\", \"IUO01\", \"IUO02\",
     \"IUO03\", \"IUO04\", \"IUO05\", \"IUO06\", \"IUO07\", \"IOO13\",
     \"IOO14\", \"IOO15\", \"IOO16\", \"IOO17\", \"IOO18\", \"IOO19\",
     \"IOO20\", \"IOO21\", \"IOO22\", \"IOO23\", \"IOO24\", \"IOO25\",
     \"IOO26\", \"IOO27\", \"IOO28\", \"IOO29\", \"IOO30\", \"IOO31\",
     \"IOO32\", \"IOO33\", \"IBO5\", \"IBO6\", \"IBO7\", \"IBO8\",
     \"IBO9\", \"IBO10\", \"IBO11\", \"IBO12\", \"NotDefHead\",
     \"HeadDef\", \"NotDefTail\", \"TailDef\", \"FoldrNil\",
     \"FoldrCons\", \"FoldlNil\", \"FoldlCons\", \"MapNil\",
     \"MapCons\", \"XPlusXPlusNil\", \"XPlusXPlusCons\", \"FilterNil\",
     \"FilterConsT\", \"FilterConsF\", \"ZipNil\", \"ZipConsNil\",
     \"ZipConsCons\", \"UnzipNil\", \"UnzipCons\", \"ILE02\", \"ILO05\",
     \"ILO06\", \"ILO07\", \"ILE01\", \"ILO01\", \"ILO02\", \"ILO03\",
     \"ILO04\", \"ILO08\", \"ILO09\", \"ILO10\", \"ILO11\", \"ILO12\",
     \"ILO13\", \"ILO14\", \"ILO15\", \"ILO16\", \"ILO17\", \"ILO18\",
     \"ILO19\", \"ILO20\", \"ILO21\", \"ILO22\", \"FoldlDecomp\",
     \"MapDecomp\", \"MapFunctor\", \"FilterProm\"]"

typedecl Bool
typedecl ('a1) DList
typedecl Unit
typedecl X_Nat

datatype Ordering = EQ | GT | LT
datatype 'a List = X_Cons "'a partial" "'a List partial" | X_Nil ("Nil''")

consts
Not__X :: "bool => bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a partial => 'a partial => bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a partial => 'a partial => bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a partial => 'a partial => bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a partial => 'a partial => bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a partial => 'a partial => bool" ("(_/ <''/ _)" [54,54] 52)
X__XPlusXPlus__X :: "'a List partial => 'a List partial => 'a List partial" ("(_/ ++''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a partial => 'a partial => bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
X__o__X :: "('b partial => 'c partial) * ('a partial => 'b partial) => 'a partial => 'c partial"
X_curry :: "('a partial * 'b partial => 'c partial) => 'a partial => 'b partial => 'c partial"
X_filter :: "('a partial => bool) => 'a List partial => 'a List partial"
X_flip :: "('a partial => 'b partial => 'c partial) => 'b partial => 'a partial => 'c partial"
X_foldl :: "('a partial => 'b partial => 'a partial) => 'a partial => 'b List partial => 'a partial"
X_foldr :: "('a partial => 'b partial => 'b partial) => 'b partial => 'a List partial => 'b partial"
X_fst :: "'a partial => 'b partial => 'a partial" ("fst''/'(_,/ _')" [3,3] 999)
X_head :: "'a List partial => 'a partial" ("head/'(_')" [3] 999)
X_id :: "'a partial => 'a partial" ("id''/'(_')" [3] 999)
X_map :: "('a partial => 'b partial) => 'a List partial => 'b List partial"
X_max :: "'a partial => 'a partial => 'a partial"
X_min :: "'a partial => 'a partial => 'a partial"
X_snd :: "'a partial => 'b partial => 'b partial" ("snd''/'(_,/ _')" [3,3] 999)
X_tail :: "'a List partial => 'a List partial" ("tail/'(_')" [3] 999)
X_unzip :: "('a * 'b) List partial => 'a List partial * 'b List partial" ("unzip/'(_')" [3] 999)
X_zip :: "'a List partial => 'b List partial => ('a * 'b) List partial"
compare :: "'a partial => 'a partial => Ordering partial"
otherwiseH :: "bool"
uncurry :: "('a partial => 'b partial => 'c partial) => 'a partial * 'b partial => 'c partial"

axioms
Comp1 [rule_format] :
"ALL f. ALL g. ALL y. X__o__X (f, g) y = f (g y)"

IdDef [rule_format] : "ALL x. id'(x) = x"

FlipDef [rule_format] : "ALL f. ALL x. ALL y. X_flip f y x = f x y"

FstDef [rule_format] : "ALL x. ALL y. fst'(x, y) = x"

SndDef [rule_format] : "ALL x. ALL y. snd'(x, y) = y"

CurryDef [rule_format] :
"ALL g. ALL x. ALL y. X_curry g x y = g (x, y)"

UncurryDef [rule_format] :
"ALL f. ALL x. ALL y. uncurry f (x, y) = f x y"

NotFalse [rule_format] : "Not' False"

NotTrue [rule_format] : "~ Not' True"

AndFalse [rule_format] : "ALL x. ~ False && x"

AndTrue [rule_format] : "ALL x. True && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH"

NotFalse1 [rule_format] : "ALL x. Not' x = (~ x)"

NotTrue1 [rule_format] : "ALL x. ~ Not' x = x"

notNot1 [rule_format] : "ALL x. (~ x) = Not' x"

notNot2 [rule_format] : "ALL x. (~ ~ x) = (~ Not' x)"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x"

EqualTransT [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y ==' z --> x ==' z"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

DiffTDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffFDef [rule_format] : "ALL x. ALL y. (~ x /= y) = x ==' y"

TE1 [rule_format] : "ALL x. ALL y. ~ x ==' y --> ~ x = y"

TE2 [rule_format] : "ALL x. ALL y. Not' (x ==' y) = (~ x ==' y)"

TE3 [rule_format] : "ALL x. ALL y. (~ Not' (x ==' y)) = x ==' y"

TE4 [rule_format] : "ALL x. ALL y. (~ x ==' y) = (~ x ==' y)"

IUE1 [rule_format] : "makePartial () ==' makePartial ()"

IUE2 [rule_format] : "~ makePartial () /= makePartial ()"

IBE1 [rule_format] : "makePartial () ==' makePartial ()"

IBE2 [rule_format] : "undefinedOp ==' undefinedOp"

IBE3 [rule_format] : "~ undefinedOp ==' makePartial ()"

IBE4 [rule_format] : "~ makePartial () ==' undefinedOp"

IBE5 [rule_format] : "makePartial () /= undefinedOp"

IBE6 [rule_format] : "undefinedOp /= makePartial ()"

IBE7 [rule_format] : "Not' (makePartial () ==' undefinedOp)"

IBE8 [rule_format] : "~ Not' Not' (makePartial () ==' undefinedOp)"

IOE01 [rule_format] : "makePartial LT ==' makePartial LT"

IOE02 [rule_format] : "makePartial EQ ==' makePartial EQ"

IOE03 [rule_format] : "makePartial GT ==' makePartial GT"

IOE04 [rule_format] : "~ makePartial LT ==' makePartial EQ"

IOE05 [rule_format] : "~ makePartial LT ==' makePartial GT"

IOE06 [rule_format] : "~ makePartial EQ ==' makePartial GT"

IOE07 [rule_format] : "makePartial LT /= makePartial EQ"

IOE08 [rule_format] : "makePartial LT /= makePartial GT"

IOE09 [rule_format] : "makePartial EQ /= makePartial GT"

LeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y --> ~ x <' y"

LeTAsymmetry [rule_format] : "ALL x. ALL y. x <' y --> ~ y <' x"

LeTTransitive [rule_format] :
"ALL x. ALL y. ALL z. x <' y & y <' z --> x <' z"

LeTTotal [rule_format] :
"ALL x. ALL y. (x <' y | y <' x) | x ==' y"

GeDef [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y --> ~ x >' y"

GeTAsymmetry [rule_format] : "ALL x. ALL y. x >' y --> ~ y >' x"

GeTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x >' y) && (y >' z) --> x >' z"

GeTTotal [rule_format] :
"ALL x. ALL y. ((x >' y) || (y >' x)) || (x ==' y)"

LeqDef [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y) || (x ==' y)"

LeqReflexivity [rule_format] : "ALL x. x <=' x"

LeqTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x <=' y) && (y <=' z) --> x <=' z"

LeqTTotal [rule_format] :
"ALL x. ALL y. (x <=' y) && (y <=' x) = x ==' y"

GeqDef [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y) || (x ==' y)"

GeqReflexivity [rule_format] : "ALL x. x >=' x"

GeqTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x >=' y) && (y >=' z) --> x >=' z"

GeqTTotal [rule_format] :
"ALL x. ALL y. (x >=' y) && (y >=' x) = x ==' y"

EqTSOrdRel [rule_format] :
"ALL x. ALL y. x ==' y = (~ x <' y & ~ x >' y)"

EqFSOrdRel [rule_format] :
"ALL x. ALL y. (~ x ==' y) = (x <' y | x >' y)"

EqTOrdRel [rule_format] :
"ALL x. ALL y. x ==' y = (x <=' y & x >=' y)"

EqFOrdRel [rule_format] :
"ALL x. ALL y. (~ x ==' y) = (x <=' y | x >=' y)"

EqTOrdTSubstE [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y <' z --> x <' z"

EqTOrdFSubstE [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & ~ y <' z --> ~ x <' z"

EqTOrdTSubstD [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & z <' y --> z <' x"

EqTOrdFSubstD [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & ~ z <' y --> ~ z <' x"

LeTGeFEqFRel [rule_format] :
"ALL x. ALL y. x <' y = (~ x >' y & ~ x ==' y)"

LeFGeTEqTRel [rule_format] :
"ALL x. ALL y. (~ x <' y) = (x >' y | x ==' y)"

LeTGeTRel [rule_format] : "ALL x. ALL y. x <' y = y >' x"

LeFGeFRel [rule_format] : "ALL x. ALL y. (~ x <' y) = (~ y >' x)"

LeqTGetTRel [rule_format] : "ALL x. ALL y. x <=' y = y >=' x"

LeqFGetFRel [rule_format] :
"ALL x. ALL y. (~ x <=' y) = (~ y >=' x)"

GeTLeTRel [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeFLeFRel [rule_format] : "ALL x. ALL y. (~ x >' y) = (~ y <' x)"

GeqTLeqTRel [rule_format] : "ALL x. ALL y. x >=' y = y <=' x"

GeqFLeqFRel [rule_format] :
"ALL x. ALL y. (~ x >=' y) = (~ y <=' x)"

LeqTGeFRel [rule_format] : "ALL x. ALL y. x <=' y = (~ x >' y)"

LeqFGeTRel [rule_format] : "ALL x. ALL y. (~ x <=' y) = x >' y"

GeTLeFEqFRel [rule_format] :
"ALL x. ALL y. x >' y = (~ x <' y & ~ x ==' y)"

GeFLeTEqTRel [rule_format] :
"ALL x. ALL y. (~ x >' y) = (x <' y | x ==' y)"

GeqTLeFRel [rule_format] : "ALL x. ALL y. x >=' y = (~ x <' y)"

GeqFLeTRel [rule_format] : "ALL x. ALL y. (~ x >=' y) = x <' y"

LeqTLeTEqTRel [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y | x ==' y)"

LeqFLeFEqFRel [rule_format] :
"ALL x. ALL y. (~ x <=' y) = (~ x <' y & ~ x ==' y)"

GeqTGeTEqTRel [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y | x ==' y)"

GeqFGeFEqFRel [rule_format] :
"ALL x. ALL y. (~ x >=' y) = (~ x >' y & ~ x ==' y)"

LeTGeqFRel [rule_format] : "ALL x. ALL y. x <' y = (~ x >=' y)"

GeTLeqFRel [rule_format] : "ALL x. ALL y. x >' y = (~ x <=' y)"

LeLeqDiff [rule_format] :
"ALL x. ALL y. x <' y = (x <=' y) && (x /= y)"

CmpLTDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial LT = x <' y"

CmpEQDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial EQ = x ==' y"

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial GT = x >' y"

MaxYDef [rule_format] : "ALL x. ALL y. X_max x y ==' y = x <=' y"

MaxXDef [rule_format] : "ALL x. ALL y. X_max x y ==' x = y <=' x"

MinXDef [rule_format] : "ALL x. ALL y. X_min x y ==' x = x <=' y"

MinYDef [rule_format] : "ALL x. ALL y. X_min x y ==' y = y <=' x"

MaxSym [rule_format] :
"ALL x. ALL y. X_max x y ==' y = X_max y x ==' y"

MinSym [rule_format] :
"ALL x. ALL y. X_min x y ==' y = X_min y x ==' y"

TO1 [rule_format] : "ALL x. ALL y. (x ==' y | x <' y) = x <=' y"

TO2 [rule_format] : "ALL x. ALL y. x ==' y --> ~ x <' y"

TO3 [rule_format] :
"ALL x. ALL y. Not' Not' (x <' y) | Not' (x <' y)"

TO4 [rule_format] : "ALL x. ALL y. x <' y --> Not' (x ==' y)"

TO5 [rule_format] :
"ALL w. ALL x. ALL y. ALL z. (x <' y & y <' z) & z <' w --> x <' w"

TO6 [rule_format] : "ALL x. ALL z. z <' x --> Not' (x <' z)"

TO7 [rule_format] : "ALL x. ALL y. x <' y = y >' x"

IUO01 [rule_format] : "makePartial () <=' makePartial ()"

IUO02 [rule_format] : "~ makePartial () <' makePartial ()"

IUO03 [rule_format] : "makePartial () >=' makePartial ()"

IUO04 [rule_format] : "~ makePartial () >' makePartial ()"

IUO05 [rule_format] :
"X_max (makePartial ()) (makePartial ()) ==' makePartial ()"

IUO06 [rule_format] :
"X_min (makePartial ()) (makePartial ()) ==' makePartial ()"

IUO07 [rule_format] :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"

IOO13 [rule_format] : "makePartial LT <' makePartial EQ"

IOO14 [rule_format] : "makePartial EQ <' makePartial GT"

IOO15 [rule_format] : "makePartial LT <' makePartial GT"

IOO16 [rule_format] : "makePartial LT <=' makePartial EQ"

IOO17 [rule_format] : "makePartial EQ <=' makePartial GT"

IOO18 [rule_format] : "makePartial LT <=' makePartial GT"

IOO19 [rule_format] : "makePartial EQ >=' makePartial LT"

IOO20 [rule_format] : "makePartial GT >=' makePartial EQ"

IOO21 [rule_format] : "makePartial GT >=' makePartial LT"

IOO22 [rule_format] : "makePartial EQ >' makePartial LT"

IOO23 [rule_format] : "makePartial GT >' makePartial EQ"

IOO24 [rule_format] : "makePartial GT >' makePartial LT"

IOO25 [rule_format] :
"X_max (makePartial LT) (makePartial EQ) ==' makePartial EQ"

IOO26 [rule_format] :
"X_max (makePartial EQ) (makePartial GT) ==' makePartial GT"

IOO27 [rule_format] :
"X_max (makePartial LT) (makePartial GT) ==' makePartial GT"

IOO28 [rule_format] :
"X_min (makePartial LT) (makePartial EQ) ==' makePartial LT"

IOO29 [rule_format] :
"X_min (makePartial EQ) (makePartial GT) ==' makePartial EQ"

IOO30 [rule_format] :
"X_min (makePartial LT) (makePartial GT) ==' makePartial LT"

IOO31 [rule_format] :
"compare (makePartial LT) (makePartial LT) ==' makePartial EQ"

IOO32 [rule_format] :
"compare (makePartial EQ) (makePartial EQ) ==' makePartial EQ"

IOO33 [rule_format] :
"compare (makePartial GT) (makePartial GT) ==' makePartial EQ"

IBO5 [rule_format] : "undefinedOp <' makePartial ()"

IBO6 [rule_format] : "~ undefinedOp >=' makePartial ()"

IBO7 [rule_format] : "makePartial () >=' undefinedOp"

IBO8 [rule_format] : "~ makePartial () <' undefinedOp"

IBO9 [rule_format] :
"X_max undefinedOp (makePartial ()) ==' makePartial ()"

IBO10 [rule_format] :
"X_min undefinedOp (makePartial ()) ==' undefinedOp"

IBO11 [rule_format] :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"

IBO12 [rule_format] :
"compare undefinedOp undefinedOp ==' makePartial EQ"

NotDefHead [rule_format] : "~ defOp (head(makePartial Nil'))"

HeadDef [rule_format] :
"ALL x. ALL xs. head(makePartial (X_Cons x xs)) = x"

NotDefTail [rule_format] : "~ defOp (tail(makePartial Nil'))"

TailDef [rule_format] :
"ALL x. ALL xs. tail(makePartial (X_Cons x xs)) = xs"

FoldrNil [rule_format] :
"ALL f. ALL s. X_foldr f s (makePartial Nil') = s"

FoldrCons [rule_format] :
"ALL f.
 ALL s.
 ALL x.
 ALL xs.
 X_foldr f s (makePartial (X_Cons x xs)) = f x (X_foldr f s xs)"

FoldlNil [rule_format] :
"ALL g. ALL t. X_foldl g t (makePartial Nil') = t"

FoldlCons [rule_format] :
"ALL g.
 ALL t.
 ALL z.
 ALL zs.
 X_foldl g t (makePartial (X_Cons z zs)) = X_foldl g (g t z) zs"

MapNil [rule_format] :
"ALL h. X_map h (makePartial Nil') = makePartial Nil'"

MapCons [rule_format] :
"ALL h.
 ALL x.
 ALL xs.
 X_map h (makePartial (X_Cons x xs)) =
 makePartial (X_Cons (h x) (X_map h xs))"

XPlusXPlusNil [rule_format] : "ALL l. makePartial Nil' ++' l = l"

XPlusXPlusCons [rule_format] :
"ALL l.
 ALL x.
 ALL xs.
 makePartial (X_Cons x xs) ++' l =
 makePartial (X_Cons x (xs ++' l))"

FilterNil [rule_format] :
"ALL p. X_filter p (makePartial Nil') = makePartial Nil'"

FilterConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x -->
 X_filter p (makePartial (X_Cons x xs)) =
 makePartial (X_Cons x (X_filter p xs))"

FilterConsF [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 ~ p x --> X_filter p (makePartial (X_Cons x xs)) = X_filter p xs"

ZipNil [rule_format] :
"ALL l. X_zip (makePartial Nil') l = makePartial Nil'"

ZipConsNil [rule_format] :
"ALL l.
 ALL x.
 ALL xs.
 l = makePartial Nil' -->
 X_zip (makePartial (X_Cons x xs)) l = makePartial Nil'"

ZipConsCons [rule_format] :
"ALL l.
 ALL x.
 ALL xs.
 ALL y.
 ALL ys.
 l = makePartial (X_Cons y ys) -->
 X_zip (makePartial (X_Cons x xs)) l =
 makePartial
 (X_Cons
  (restrictOp (makePartial (makeTotal x, makeTotal y))
   (defOp x & defOp y))
  (X_zip xs ys))"

UnzipNil [rule_format] :
"mapSnd makeTotal (mapFst makeTotal (unzip(makePartial Nil'))) =
 (Nil', Nil')"

UnzipCons [rule_format] :
"ALL ps.
 ALL x.
 ALL z.
 mapSnd makeTotal
 (mapFst makeTotal
  (unzip(makePartial
         (X_Cons
          (restrictOp (makePartial (makeTotal x, makeTotal z))
           (defOp x & defOp z))
          ps)))) =
 (let (ys, zs) = unzip(ps) in (X_Cons x ys, X_Cons z zs))"

ILE02 [rule_format] :
"ALL x.
 ALL xs.
 ALL y.
 ALL ys.
 makePartial (X_Cons x xs) ==' makePartial (X_Cons y ys) =
 (x ==' y) && (xs ==' ys)"

ILO05 [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 z <' w --> makePartial (X_Cons z zs) <' makePartial (X_Cons w ws)"

ILO06 [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 z ==' w -->
 makePartial (X_Cons z zs) <' makePartial (X_Cons w ws) = zs <' ws"

ILO07 [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 ~ z <' w & ~ z ==' w -->
 ~ makePartial (X_Cons z zs) <' makePartial (X_Cons w ws)"

declare Comp1 [simp]
declare IdDef [simp]
declare FlipDef [simp]
declare FstDef [simp]
declare SndDef [simp]
declare CurryDef [simp]
declare UncurryDef [simp]
declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]
declare NotTrue1 [simp]
declare EqualReflex [simp]
declare IUE1 [simp]
declare IUE2 [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare IOE01 [simp]
declare IOE02 [simp]
declare IOE03 [simp]
declare IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare IOE07 [simp]
declare IOE08 [simp]
declare IOE09 [simp]
declare LeIrreflexivity [simp]
declare LeTAsymmetry [simp]
declare GeIrreflexivity [simp]
declare GeTAsymmetry [simp]
declare GeTTransitive [simp]
declare GeTTotal [simp]
declare LeqReflexivity [simp]
declare LeqTTransitive [simp]
declare LeqTTotal [simp]
declare GeqReflexivity [simp]
declare GeqTTransitive [simp]
declare GeqTTotal [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare TO2 [simp]
declare TO4 [simp]
declare TO6 [simp]
declare IUO01 [simp]
declare IUO02 [simp]
declare IUO03 [simp]
declare IUO04 [simp]
declare IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IOO16 [simp]
declare IOO17 [simp]
declare IOO18 [simp]
declare IOO19 [simp]
declare IOO20 [simp]
declare IOO21 [simp]
declare IOO22 [simp]
declare IOO23 [simp]
declare IOO24 [simp]
declare IOO25 [simp]
declare IOO26 [simp]
declare IOO27 [simp]
declare IOO28 [simp]
declare IOO29 [simp]
declare IOO30 [simp]
declare IOO31 [simp]
declare IOO32 [simp]
declare IOO33 [simp]
declare IBO5 [simp]
declare IBO6 [simp]
declare IBO7 [simp]
declare IBO8 [simp]
declare IBO9 [simp]
declare IBO10 [simp]
declare IBO11 [simp]
declare IBO12 [simp]
declare NotDefHead [simp]
declare HeadDef [simp]
declare NotDefTail [simp]
declare TailDef [simp]
declare FoldrNil [simp]
declare FoldrCons [simp]
declare FoldlNil [simp]
declare FoldlCons [simp]
declare MapNil [simp]
declare XPlusXPlusNil [simp]
declare FilterNil [simp]
declare FilterConsF [simp]
declare ZipNil [simp]
declare UnzipNil [simp]
declare ILE02 [simp]
declare ILO05 [simp]
declare ILO06 [simp]

theorem ILE01 : "makePartial Nil' ==' makePartial Nil'"
by (auto)

ML "Header.record \"ILE01\""

theorem ILO01 : "~ makePartial Nil' <' makePartial Nil'"
by (auto)

ML "Header.record \"ILO01\""

theorem ILO02 : "makePartial Nil' <=' makePartial Nil'"
by (auto)

ML "Header.record \"ILO02\""

theorem ILO03 : "~ makePartial Nil' >' makePartial Nil'"
by (auto)

ML "Header.record \"ILO03\""

theorem ILO04 : "makePartial Nil' >=' makePartial Nil'"
by (auto)

ML "Header.record \"ILO04\""

theorem ILO08 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons z zs) <=' makePartial (X_Cons w ws) =
 (makePartial (X_Cons z zs) <' makePartial (X_Cons w ws)) ||
 (makePartial (X_Cons z zs) ==' makePartial (X_Cons w ws))"
apply(rule allI)+
apply(simp only: LeqDef)
done

ML "Header.record \"ILO08\""

theorem ILO09 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons z zs) >' makePartial (X_Cons w ws) =
 makePartial (X_Cons w ws) <' makePartial (X_Cons z zs)"
apply(rule allI)+
apply(simp only: GeTLeTRel)
done

ML "Header.record \"ILO09\""

theorem ILO10 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons z zs) >=' makePartial (X_Cons w ws) =
 (makePartial (X_Cons z zs) >' makePartial (X_Cons w ws)) ||
 (makePartial (X_Cons z zs) ==' makePartial (X_Cons w ws))"
apply(rule allI)+
apply(simp only: GeqDef)
done

ML "Header.record \"ILO10\""

theorem ILO11 :
"compare (makePartial Nil') (makePartial Nil') ==' makePartial EQ =
 makePartial Nil' ==' makePartial Nil'"
by (auto)

ML "Header.record \"ILO11\""

theorem ILO12 :
"compare (makePartial Nil') (makePartial Nil') ==' makePartial LT =
 makePartial Nil' <' makePartial Nil'"
by (auto)

ML "Header.record \"ILO12\""

theorem ILO13 :
"compare (makePartial Nil') (makePartial Nil') ==' makePartial GT =
 makePartial Nil' >' makePartial Nil'"
by (auto)

ML "Header.record \"ILO13\""

theorem ILO14 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 compare (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial EQ =
 makePartial (X_Cons z zs) ==' makePartial (X_Cons w ws)"
by (auto)

ML "Header.record \"ILO14\""

theorem ILO15 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 compare (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial LT =
 makePartial (X_Cons z zs) <' makePartial (X_Cons w ws)"
apply(rule allI)+
apply(simp only: CmpLTDef)
done

ML "Header.record \"ILO15\""

theorem ILO16 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 compare (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial GT =
 makePartial (X_Cons z zs) >' makePartial (X_Cons w ws)"
apply(rule allI)+
apply(simp only: CmpGTDef)
done

ML "Header.record \"ILO16\""

theorem ILO17 :
"X_max (makePartial Nil') (makePartial Nil') ==' makePartial Nil' =
 makePartial Nil' <=' makePartial Nil'"
by (auto)

ML "Header.record \"ILO17\""

theorem ILO18 :
"X_min (makePartial Nil') (makePartial Nil') ==' makePartial Nil' =
 makePartial Nil' <=' makePartial Nil'"
by (auto)

ML "Header.record \"ILO18\""

theorem ILO19 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons z zs) <=' makePartial (X_Cons w ws) =
 X_max (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial (X_Cons w ws)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO19\""

theorem ILO20 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons w ws) <=' makePartial (X_Cons z zs) =
 X_max (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial (X_Cons z zs)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO20\""

theorem ILO21 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons z zs) <=' makePartial (X_Cons w ws) =
 X_min (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial (X_Cons z zs)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO21\""

theorem ILO22 :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs.
 makePartial (X_Cons w ws) <=' makePartial (X_Cons z zs) =
 X_min (makePartial (X_Cons z zs)) (makePartial (X_Cons w ws)) =='
 makePartial (X_Cons w ws)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"ILO22\""

theorem FoldlDecomp :
"ALL e.
 ALL i.
 ALL ts.
 ALL ys. X_foldl i e (ys ++' ts) = X_foldl i (X_foldl i e ys) ts"
apply(auto)
apply(case_tac "(ab, bb) ++' (aa, ba)")
apply(auto)
oops

ML "Header.record \"FoldlDecomp\""

theorem MapDecomp :
"ALL f.
 ALL xs. ALL zs. X_map f (xs ++' zs) = X_map f xs ++' X_map f zs"
apply(auto)
apply(induct_tac a)
apply(auto)
apply(case_tac b)
apply(auto)
oops

ML "Header.record \"MapDecomp\""

theorem MapFunctor :
"ALL f.
 ALL g. ALL xs. X_map (X__o__X (g, f)) xs = X_map g (X_map f xs)"
apply(auto)
apply(induct_tac a)
apply(case_tac b)
apply(auto)
oops

ML "Header.record \"MapFunctor\""

theorem FilterProm :
"ALL f.
 ALL p.
 ALL xs.
 X_filter p (X_map f xs) =
 X_map f (X_filter (id o defOp o X__o__X (bool2partial o p, f)) xs)"
apply(auto)
apply(induct_tac a)
apply(auto)
apply(case_tac "p(f a)")
oops

ML "Header.record \"FilterProm\""

end


(*  Title:      HOL/Library/Quotient_Product.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section {* Quotient infrastructure for the product type *}

theory Quotient_Product
imports Main Quotient_Syntax
begin

subsection {* Rules for the Quotient package *}

lemma map_prod_id [id_simps]:
  shows "map_prod id id = id"
  by (simp add: fun_eq_iff)

lemma rel_prod_eq [id_simps]:
  shows "rel_prod (op =) (op =) = (op =)"
  by (simp add: fun_eq_iff)

lemma prod_equivp [quot_equiv]:
  assumes "equivp R1"
  assumes "equivp R2"
  shows "equivp (rel_prod R1 R2)"
  using assms by (auto intro!: equivpI reflpI sympI transpI elim!: equivpE elim: reflpE sympE transpE)

lemma prod_quotient [quot_thm]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "Quotient3 (rel_prod R1 R2) (map_prod Abs1 Abs2) (map_prod Rep1 Rep2)"
  apply (rule Quotient3I)
  apply (simp add: map_prod.compositionality comp_def map_prod.identity
     Quotient3_abs_rep [OF assms(1)] Quotient3_abs_rep [OF assms(2)])
  apply (simp add: split_paired_all Quotient3_rel_rep [OF assms(1)] Quotient3_rel_rep [OF assms(2)])
  using Quotient3_rel [OF assms(1)] Quotient3_rel [OF assms(2)]
  apply (auto simp add: split_paired_all)
  done

declare [[mapQ3 prod = (rel_prod, prod_quotient)]]

lemma Pair_rsp [quot_respect]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(R1 ===> R2 ===> rel_prod R1 R2) Pair Pair"
  by (rule Pair_transfer)

lemma Pair_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Rep2 ---> (map_prod Abs1 Abs2)) Pair = Pair"
  apply(simp add: fun_eq_iff)
  apply(simp add: Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
  done

lemma fst_rsp [quot_respect]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "(rel_prod R1 R2 ===> R1) fst fst"
  by auto

lemma fst_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(map_prod Rep1 Rep2 ---> Abs1) fst = fst"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1])

lemma snd_rsp [quot_respect]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "(rel_prod R1 R2 ===> R2) snd snd"
  by auto

lemma snd_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(map_prod Rep1 Rep2 ---> Abs2) snd = snd"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q2])

lemma split_rsp [quot_respect]:
  shows "((R1 ===> R2 ===> (op =)) ===> (rel_prod R1 R2) ===> (op =)) split split"
  by (rule case_prod_transfer)

lemma split_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(((Abs1 ---> Abs2 ---> id) ---> map_prod Rep1 Rep2 ---> id) split) = split"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [quot_respect]:
  shows "((R2 ===> R2 ===> op =) ===> (R1 ===> R1 ===> op =) ===>
  rel_prod R2 R1 ===> rel_prod R2 R1 ===> op =) rel_prod rel_prod"
  by (rule prod.rel_transfer)

lemma [quot_preserve]:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> abs1 ---> id) ---> (abs2 ---> abs2 ---> id) --->
  map_prod rep1 rep2 ---> map_prod rep1 rep2 ---> id) rel_prod = rel_prod"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [quot_preserve]:
  shows"(rel_prod ((rep1 ---> rep1 ---> id) R1) ((rep2 ---> rep2 ---> id) R2)
  (l1, l2) (r1, r2)) = (R1 (rep1 l1) (rep1 r1) \<and> R2 (rep2 l2) (rep2 r2))"
  by simp

declare Pair_eq[quot_preserve]

end


(*  Title:      While_Combinator_Exts.thy
    Author:     Denis Lohner
*)

section {* Code Generation *}
subsection {* While Combinator Extensions *}

theory While_Combinator_Exts imports
  "~~/src/HOL/Library/While_Combinator"
begin
lemma while_option_None_invD:
  assumes "while_option b c s = None" and "wf r"
  and "I s" and "\<And>s. \<lbrakk> I s; b s \<rbrakk> \<Longrightarrow> I (c s)"
  and "\<And>s. \<lbrakk> I s; b s \<rbrakk> \<Longrightarrow> (c s, s ) \<in> r"
  shows "False"
  using assms
  by -(drule wf_rel_while_option_Some [of r I b c], auto)

lemma while_option_NoneD:
  assumes "while_option b c s = None"
  and "wf r" and "\<And>s. b s \<Longrightarrow> (c s, s) \<in> r"
  shows "False"
  using assms
  by (blast intro: while_option_None_invD)

lemma while_option_sim:
  assumes start: "R (Some s1) (Some s2)"
  and cond: "\<And>s1 s2. \<lbrakk> R (Some s1) (Some s2); I s1 \<rbrakk> \<Longrightarrow> b1 s1 = b2 s2"
  and step : "\<And>s1 s2. \<lbrakk> R (Some s1) (Some s2); I s1; b1 s1 \<rbrakk> \<Longrightarrow> R (Some (c1 s1)) (Some (c2 s2))"
  and diverge: "R None None"
  and inv_start: "I s1"
  and inv_step: "\<And>s1. \<lbrakk> I s1; b1 s1 \<rbrakk> \<Longrightarrow> I (c1 s1)"
  shows "R (while_option b1 c1 s1) (while_option b2 c2 s2)"
proof -
  { fix k
    assume "\<forall>k' < k. b1 ((c1 ^^ k') s1)"
    with start cond step inv_start inv_step
    have "b1 ((c1 ^^ k) s1) = b2 ((c2 ^^ k) s2)" and "I ((c1 ^^ k) s1)"
      and "R (Some ((c1 ^^ k) s1)) (Some ((c2 ^^ k) s2))"
      by (induction k) auto
  }
  moreover
  { fix k
    assume "\<not> b1 ((c1 ^^ k) s1)"
    hence "\<forall>k' < LEAST k. \<not> b1 ((c1 ^^ k) s1). b1 ((c1 ^^ k') s1)"
      by (metis (lifting) not_less_Least)
  }
  moreover
  { fix k
    assume "\<not> b2 ((c2 ^^ k) s2)"
    hence "\<forall>k' < LEAST k. \<not> b2 ((c2 ^^ k) s2). b2 ((c2 ^^ k') s2)"
      by (metis (lifting) not_less_Least)
  }
  moreover
  {
    assume "\<exists>k. \<not> b1 ((c1 ^^ k) s1)"
      and "\<exists>k. \<not> b2 ((c2 ^^ k) s2)"
    hence not_cond_Least: "\<not> b1 ((c1 ^^ (LEAST k. \<not> b1 ((c1 ^^ k) s1))) s1)"
      "\<not> b2 ((c2 ^^ (LEAST k. \<not> b2 ((c2 ^^ k) s2))) s2)"
      by -(drule LeastI_ex, assumption)+
    { fix k
      assume "\<forall>k' < k. b1 ((c1 ^^ k') s1)"
      with calculation(1) dual_order.strict_trans
      have "\<forall>k' < k. b2 ((c2 ^^ k') s2)"
        by blast
    }
    hence "(LEAST k'. \<not> b1 ((c1 ^^ k') s1)) = (LEAST k'. \<not> b2 ((c2 ^^ k') s2))"
      by (metis (no_types, lifting) not_cond_Least calculation(1,4,5) less_linear)
    with calculation(3,4)
    have "R (Some ((c1 ^^ (LEAST k. \<not> b1 ((c1 ^^ k) s1))) s1))
      (Some ((c2 ^^ (LEAST k. \<not> b2 ((c2 ^^ k) s2))) s2))"
      by auto
  }
  ultimately show ?thesis using diverge
    unfolding while_option_def
    apply (split split_if)
    apply (rule conjI)
     apply (split split_if)
     apply metis
    apply (split split_if)
    by (metis (lifting) LeastI_ex)
qed

end


(*  File:       Plurality_Module_Ref.thy
    Copyright   2022  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin Springsklee, Karlsruhe Institute of Technology (KIT)"\<close>

theory Plurality_Module_Ref
  imports
          "Verified_Voting_Rule_Construction.Plurality_Rule"
           "Component_Types/Elimination_Module_Ref"
begin

section \<open>Refined Plurality Module\<close>

subsection \<open>Definition\<close>

definition plur_score_ref :: "'a Evaluation_Function_Ref" where
  "plur_score_ref x A p = (wc_fold p x)"

definition plurality_ref :: "'a::{default, heap, hashable} Electoral_Module_Ref" where
  "plurality_ref A pl \<equiv> do {
   scores \<leftarrow> (pre_compute_scores plur_score_ref A pl);
   max_eliminator_ref scores A pl
}"

lemma plur_score_correct:
  fixes A:: "'a::{default, heap, hashable} set"
  fixes pl:: "'a Profile_List" and pr:: "'a Profile"
  assumes
    fina: "finite A"
    and prel: "(pl, pr) \<in> profile_rel"
    and profp: "profile A pr"
  shows "\<forall> a \<in> A. plur_score_ref a A pl \<le> SPEC (\<lambda> sc. sc = (plur_score a A pr))"
  unfolding plur_score_ref_def plur_score.simps
proof safe
  fix a :: 'a
  from prel profp have profl: "profile_l A pl" using profile_ref by auto
  show "wc_fold pl a \<le> SPEC (\<lambda>sc. sc = win_count pr a) "
    by (refine_vcg fina prel profl wc_fold_correct)
qed

text \<open>Optimized Map Compuation\<close>

definition pre_compute_plur_scores :: "'a set
   \<Rightarrow> 'a Profile_List \<Rightarrow> 'a Scores_Map nres"
  where "pre_compute_plur_scores A pl \<equiv>
  if (A = {}) then RETURN Map.empty else
  do {
   zeromap:: 'a Scores_Map  \<leftarrow> init_map A;
  nfoldli pl (\<lambda>_. True)
    (\<lambda>ballot map.
     do{
      ASSERT (length ballot > 0);
      let top = ballot!0;
      ASSERT (op_map_contains_key top map);
      let scx = the (op_map_lookup top map);
        RETURN (op_map_update top (scx + 1) map)})
     (zeromap)}"

sepref_definition plurmap_sep is "uncurry pre_compute_plur_scores" ::
  "(alts_set_impl_assn nat_assn)\<^sup>k *\<^sub>a (profile_impl_assn nat_assn)\<^sup>k \<rightarrow>\<^sub>a (hm.assn nat_assn nat_assn)"
  unfolding pre_compute_plur_scores_def init_map_def op_set_is_empty_def[symmetric]
     hm.fold_custom_empty
  apply sepref_dbg_keep
  done

declare plurmap_sep.refine [sepref_fr_rules]

definition plurality_ref_opt :: "'a::{default, heap, hashable} Electoral_Module_Ref" where
  "plurality_ref_opt A pl \<equiv> do {
   scores \<leftarrow> (pre_compute_plur_scores A pl);
   max_eliminator_ref scores A pl
}"

subsection \<open>Refinement Lemmas\<close>

lemma plurality_map_correct:
  fixes A :: "'a set" and
        pr :: "'a Profile" and
        pl :: "'a Profile_List"
  assumes fina: "finite A" and
        prel : "(pl, pr) \<in> profile_rel" and
        profl: "profile_l A pl"
  shows "(pre_compute_plur_scores A pl) \<le> SPEC (\<lambda> map. map =(scores_map plur_score A pr))"
  unfolding pre_compute_plur_scores_def scores_map_def plur_score.simps
  apply (refine_vcg empty_map fina prel profl
          nfoldli_rule[where I = "\<lambda> p1 p2 si. ( \<forall> a \<in> A. ((si a) = Some (win_count_l p1 a)))
          \<and>  (\<forall> a . (a \<notin> A \<longrightarrow> si a = None))"] )
     apply (auto)
proof -
  fix xa :: "'a Preference_List"
  fix xb :: 'a
  fix l1 l2 :: "'a Profile_List"
  assume "xb \<in> A"
  from this have nempa: "A \<noteq> {}" by auto
  assume "pl = l1 @ [] # l2"
  from this profl show "False"
    unfolding profile_l_def well_formed_pl_def losimp using nempa
    by (metis in_set_conv_decomp in_set_conv_nth list.set(1))
next
  fix xa :: "'a Preference_List"
  fix l1 l2 :: "'a Profile_List"
  fix sigma :: "'a Scores_Map"
  assume nempxa: "xa \<noteq> []"
  assume "pl = l1 @ xa # l2"
  from this have "set xa = A"
    using profl  unfolding profile_l_def well_formed_pl_def losimp
    by (metis in_set_conv_decomp in_set_conv_nth)
  from this nempxa have innit: "xa ! 0 \<in> A" by auto
  assume somev: "\<forall>a\<in>A. sigma a = Some (fold (\<lambda>x ac. if x \<noteq> [] \<and> x ! 0 = a then ac + 1 else ac) l1 0)"
  assume "sigma (xa ! 0) = None"
  from this somev innit show False
    by simp
next
  fix xa :: 'a
  assume "xa \<in> A"
  from this have nempa: "A \<noteq> {}" by auto
  fix sigma ::  "('a \<Rightarrow> nat option)"
  assume valuemap: "\<forall>a\<in>A. sigma a = Some (fold (\<lambda>x ac. if x \<noteq> [] \<and> x ! 0 = a then ac + 1 else ac) pl 0)"
  assume outnone: " \<forall>a. a \<notin> A \<longrightarrow> sigma a = None"
  from valuemap this have wclmap: "(sigma) = (\<lambda>a . Some (win_count_l pl a))|`A"
    unfolding restrict_map_def win_count_l.simps by auto
  from prel profl have "(pl, pr) \<in> profile_on_A_rel A"
    by (simp add: in_br_conv list_rel_eq_listrel listrel_iff_nth profile_l_def relAPP_def relcomp.intros)
  from this wclmap have wcmap: "(sigma) = (\<lambda>a . Some (win_count pr a))|`A"
    using  win_count_l_correct[THEN fun_relD,THEN fun_relD, where x1 = pl and x'1 = pr and A2 = A]
    by fastforce
  assume neg: "sigma \<noteq> (\<lambda>a. Some (card {i. i < length pr \<and> above (pr ! i) a = {a}})) |` A"
  from wcmap this show False by auto
qed

lemma plurality_ref_correct:
  shows "(uncurry plurality_ref, uncurry (RETURN oo plurality_mod)) \<in>
  ([\<lambda> (A, pl). finite_profile A
            pl]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
   \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel)"
proof (intro frefI nres_relI,  clarsimp simp del:  plurality_mod.simps plur_score.simps,
     unfold plurality_ref_def plurality_mod.simps
     RETURN_SPEC_conv, rename_tac A pl pr)
  note max_eliminator_ref_correct_default[where A = A and efn_ref = plur_score_ref and
       efn = plur_score]
  fix A :: "'a::{default, heap, hashable} set"
  fix pr :: "'a Profile"
  fix pl :: "'a Profile_List"
  assume fina: "finite A"
  assume prel: "(pl, pr) \<in> profile_rel"
  assume profp: "profile A pr"
  show " pre_compute_scores plur_score_ref A pl \<bind> (\<lambda>scores. max_eliminator_ref scores A pl)
       \<le> SPEC (\<lambda>x. x = max_eliminator plur_score A pr)"
    using max_eliminator_ref_correct_default plur_score_correct fina prel profp
    by metis
qed

lemma plurality_ref_opt_correct:
  shows "(uncurry plurality_ref_opt, uncurry (RETURN oo plurality_mod)) \<in>
  ([\<lambda> (A, pl). finite_profile A
            pl]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
   \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel)"
proof (intro frefI nres_relI,  clarsimp simp del:  plurality_mod.simps plur_score.simps,
     unfold plurality_ref_opt_def plurality_mod.simps
     RETURN_SPEC_conv, rename_tac A pl pr)
  fix A :: "'a::{default, heap, hashable} set"
  fix pr :: "'a Profile"
  fix pl :: "'a Profile_List"
  assume fina: "finite A"
  assume prel: "(pl, pr) \<in> profile_rel"
  assume profp: "profile A pr"
  from this have profl: "profile_l A pl" using prel profile_ref by blast
  show "pre_compute_plur_scores A pl \<bind> (\<lambda>scores. max_eliminator_ref scores A pl)
       \<le> SPEC (\<lambda>x. x = max_eliminator plur_score A pr)"
    by (refine_vcg max_eliminator_ref_correct_pc plurality_map_correct fina prel profl)
qed

subsection \<open>Imperative HOL Synthesis Using Sepref\<close>

sepref_definition plurality_elim_sep is
  "uncurry plurality_ref"::
    "(hs.assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k
   \<rightarrow>\<^sub>a (result_impl_assn id_assn)"
  unfolding plurality_ref_def  max_eliminator_ref_def plur_score_ref_def
    less_eliminator_ref_def  elimination_module_ref_def[abs_def] eliminate_def[abs_def]
    pre_compute_scores_def[abs_def] scoremax_def[abs_def] wc_fold_def[abs_def]
    short_circuit_conv hm.fold_custom_empty
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)
  apply (rewrite in "RETURN (_, _, rewrite_HOLE)" hs.fold_custom_empty)
  apply (rewrite in "RETURN (_, rewrite_HOLE, _)" hs.fold_custom_empty)
  apply (rewrite in "RETURN (rewrite_HOLE, _, _)" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (rewrite_HOLE, _, rej) else RETURN ({}, rej, def))" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (_, rewrite_HOLE, rej) else RETURN ({}, rej, def))" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (_, _, rej) else RETURN (rewrite_HOLE, rej, def))" hs.fold_custom_empty)
  apply sepref_dbg_keep
  done

sepref_definition plurality_elim_sep_opt is
  "uncurry plurality_ref_opt"::
    "(alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k
   \<rightarrow>\<^sub>a (result_impl_assn id_assn)"
  unfolding plurality_ref_opt_def  max_eliminator_ref_def plur_score_ref_def
    less_eliminator_ref_def  elimination_module_ref_def[abs_def] eliminate_def[abs_def]
    scoremax_def[abs_def] op_set_is_empty_def[symmetric]
   pre_compute_plur_scores_def init_map_def op_set_is_empty_def[symmetric]
     hm.fold_custom_empty
  apply (rewrite in "RETURN (_, _, rewrite_HOLE)" hs.fold_custom_empty)
  apply (rewrite in "RETURN (_, rewrite_HOLE, _)" hs.fold_custom_empty)+
  apply (rewrite in "RETURN (rewrite_HOLE, _, _)" hs.fold_custom_empty)+
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)+
  by sepref

subsection \<open>Overall Correctness Lemma for Imperative HOL function\<close>

lemma plurality_elim_sep_correct:
  shows "(uncurry plurality_elim_sep_opt, uncurry (RETURN \<circ>\<circ> plurality_mod))
        \<in> elec_mod_seprel id_assn"
  unfolding ballot_assn_def
  using plurality_elim_sep_opt.refine[FCOMP plurality_ref_opt_correct]
  set_rel_id hr_comp_Id2 by simp

declare plurality_elim_sep_correct [sepref_fr_rules]

end


theory Proof_1_7
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_1_7:
"VC7 inv1 s0 hands_value"
  apply(simp only: VC7_def inv1_def R1_def dryer_def)
  apply(rule impI; rule conjI)
proof -
  print_state
  assume VC: " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON \<and>
    \<not> 10 \<le> ltimeEnv (setVarAny s0 hands_value)
             Ctrl"
  show " toEnvP (toEnv (setVarAny s0 hands_value)) \<and>
    (\<forall>s1 s2.
        substate s1 s2 \<and>
        substate s2
         (toEnv (setVarAny s0 hands_value)) \<and>
        toEnvP s1 \<and>
        toEnvP s2 \<and>
        toEnvNum s1 s2 = hands \<and>
        getVarBool s1 hands = OFF \<and>
        getVarBool s1 (Suc (Suc 0)) = OFF \<and>
        getVarBool s2 hands = ON \<longrightarrow>
        (\<exists>s4. toEnvP s4 \<and>
              substate s2 s4 \<and>
              substate s4
               (toEnv (setVarAny s0 hands_value)) \<and>
              toEnvNum s2 s4 \<le> hands \<and>
              getVarBool s4 (Suc (Suc 0)) = ON \<and>
              (\<forall>s3. toEnvP s3 \<and>
                    substate s2 s3 \<and>
                    substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 hands = ON)))"
    apply(rule conjI)
     apply(simp)
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: " substate s1 s2 \<and>
       substate s2
         (toEnv (setVarAny s0 hands_value)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       getVarBool s1 hands = OFF \<and>
       getVarBool s1 (Suc (Suc 0)) = OFF \<and>
       getVarBool s2 hands = ON "
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4
             (toEnv (setVarAny s0 hands_value)) \<and>
            toEnvNum s2 s4 \<le> hands \<and>
            getVarBool s4 (Suc (Suc 0)) = ON \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and>
                  s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 hands = ON)"
    proof cases
      assume 1: "s2 =   (toEnv (setVarAny s0 hands_value))"
      have " (toEnvP s2 \<and>
         substate s2 s2 \<and>
         substate s2
          (toEnv (setVarAny s0 hands_value)) \<and>
         toEnvNum s2 s2 \<le> hands \<and>
         getVarBool s2 (Suc (Suc 0)) = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and>
               s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 hands = ON)"
      proof
        from 1  VC req_prems show "toEnvP s2 \<and>
    substate s2 s2 \<and>
    substate s2
     (toEnv (setVarAny s0 hands_value)) \<and>
    toEnvNum s2 s2 \<le> hands \<and>
    getVarBool s2 (Suc (Suc 0)) = ON" by auto
      next
        from substate_asym show " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
         getVarBool s3 hands = ON"
          by auto
      qed
      thus ?thesis by blast
    next
       assume 1: "s2 \<noteq>   (toEnv (setVarAny s0 hands_value))"
       with req_prems have 2: "substate s2 s0"
         by (simp split: if_splits)
       from VC req_prems 2 obtain "\<exists>s4. toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)"by auto
       then obtain s4 where 3: "toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)" ..
       have "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4
        (toEnv (setVarAny s0 hands_value)) \<and>
      toEnvNum s2 s4 \<le> hands \<and>
      getVarBool s4 (Suc (Suc 0)) = ON \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 hands = ON)"
         using 3 by auto
       thus ?thesis ..
     qed
   qed
 next
   assume VC: "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON \<and>
    \<not> 10 \<le> ltimeEnv (setVarAny s0 hands_value)
             Ctrl"
   with extra7
   show "extraInv (toEnv (setVarAny s0 hands_value))"
     by (auto simp add: VC7_def)
 qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_44
  imports "../../Test_Base"
begin

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

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

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

fun zipConcat :: "'a => 'a list => 'b list =>
                  (('a, 'b) pair) list" where
  "zipConcat x y (nil2) = nil2"
| "zipConcat x y (cons2 y2 ys) = cons2 (pair2 x y2) (zip y ys)"

theorem property0 :
  "((zip (cons2 x xs) ys) = (zipConcat x xs ys))"
  oops

end