(*
  Partially inspired by Simon Foster's lens theory
*)
theory Lenses
  imports Option_Monad
  keywords "define_lenses" :: thy_decl
begin

  section \<open>Lenses\<close>

  datatype ('a,'s) lens (infixr "\<Longrightarrow>" 1) =
    LENS (get: "'s \<Rightarrow> 'a option") (put: "'a \<Rightarrow> 's \<Rightarrow> 's option")

  definition "pre_put L s \<equiv> \<forall>x. put L x s \<noteq> None"
  definition "pre_get L s \<equiv> get L s \<noteq> None"
  definition "get' L s = the (get L s)"
  definition "put' L x s = the (put L x s)"

  locale lens =
    fixes L :: "'a \<Longrightarrow> 's"
    (*assumes pre_get_imp: "pre_put L x s \<Longrightarrow> pre_get L s"*)
    assumes pre_get_imp_put: "get L s \<noteq> None \<Longrightarrow> put L x s \<noteq> None"

    assumes pre_put_indep_val: "put L y s\<noteq>None \<Longrightarrow> put L x s \<noteq> None"

    assumes get_put_pre: "pre_put L s \<Longrightarrow> pre_get L (put' L x s)"
    assumes get_put: "pre_put L s \<Longrightarrow> get' L (put' L x s) = x"
    assumes put_get: "pre_get L s \<Longrightarrow> put' L (get' L s) s = s"
    assumes put_put: "pre_put L s \<Longrightarrow> put' L x (put' L y s) = put' L x s"
  begin
    lemmas laws = get_put put_get put_put
    lemmas pre_laws = get_put_pre

    lemma pre_put_indep_val1: "put L y s = Some s' \<Longrightarrow> \<exists>s'. put L x s = Some s'"
      using pre_put_indep_val by fastforce

    lemma pre_put_indep_val2: "put L y s=None \<Longrightarrow> put L x s=None"
      using pre_put_indep_val by blast

    lemma get':
      "get L s = Some v \<longleftrightarrow> pre_get L s \<and> v=get' L s"
      "get L s = None \<longleftrightarrow> \<not>pre_get L s"
      unfolding pre_get_def get'_def
      apply (auto)
      done

    lemma put':
      "put L x s = Some s' \<longleftrightarrow> pre_put L s \<and> s'=put' L x s"
      "put L x s = None \<longleftrightarrow> \<not>pre_put L s"
      unfolding pre_put_def put'_def
      by (auto 0 1 simp: pre_put_indep_val2 intro: pre_put_indep_val1)

    lemma pre_get_imp_putI: "pre_get L s \<Longrightarrow> pre_put L s"
      unfolding pre_get_def
      apply (drule pre_get_imp_put)
      by (simp add: put')

    lemmas simp_rls[simp] = laws pre_laws get' put' pre_get_imp_putI
    (*lemmas intro_rls[intro] = TrueI*)
  end

  locale hlens = lens L for L :: "'a \<Longrightarrow> 's" +
    assumes pre_get_imp_put: "pre_put L s \<Longrightarrow> pre_get L s"
  begin
    lemma pre_put_eq: "pre_put L s \<longleftrightarrow> pre_get L s"
      using pre_get_imp_put by auto

    lemmas hsimp_rls[simp] = pre_put_eq
    lemmas is_lens = lens_axioms
  end

  declare lens.simp_rls[simp]
  declare hlens.hsimp_rls[simp]
  declare hlens.is_lens[simp]

  (*declare lens.intro_rls[intro]*)

  lemma LENS_downstage[simp]:
    "pre_get (LENS g p) s \<longleftrightarrow> g s \<noteq> None"
    "pre_put (LENS g p) s \<longleftrightarrow> (\<forall>x. p x s \<noteq> None)"
    "get' (LENS g p) = (\<lambda>s. the (g s))"
    "put' (LENS g p) = (\<lambda>x s. the (p x s))"
    "get (LENS g p) = g"
    "put (LENS g p) = p"
    unfolding pre_get_def pre_put_def get'_def put'_def by auto

  lemma put_get'_combine[simp]:
    "(get L s \<noteq> None) = pre_get L s"
    (*"lens L \<Longrightarrow> (put L x s = None) \<longleftrightarrow> \<not>pre_put L s"*)
    "the (get L s) = get' L s"
    "the (put L x s) = put' L x s"
    unfolding get'_def put'_def pre_get_def pre_put_def by (auto simp: prod_eqI)

  lemma lens_ext[intro?]:
    assumes "lens l1" "lens l2"
    assumes "\<And>s. pre_get l1 s = pre_get l2 s"
    assumes "\<And>s x. pre_put l1 s = pre_put l2 s"
    assumes "\<And>s. pre_get l2 s \<Longrightarrow> get' l1 s = get' l2 s"
    assumes "\<And>s x. pre_put l2 s \<Longrightarrow> put' l1 x s = put' l2 x s"
    shows "l1 = l2"
    using assms
    apply (cases l1; cases l2; simp)
    apply (auto intro!: ext)
    apply (metis option.collapse option.simps(5) option.the_def)
    by (metis LENS_downstage(4) assms(4) assms(6) lens.put'(2) lens.sel(2) option.expand)

  subsection \<open>Lens Algebra\<close>

  subsubsection \<open>Identity Lens\<close>

  definition id\<^sub>L :: "'a \<Longrightarrow> 'a" where "id\<^sub>L \<equiv> LENS (\<lambda>x. Some x) (\<lambda>x s. Some x)"

  lemma [simp, intro!]: "hlens id\<^sub>L"
    by (unfold_locales) (auto simp: id\<^sub>L_def)

  lemma [simp, intro!]:
    "pre_get id\<^sub>L s"
    "pre_put id\<^sub>L s"
    by (auto simp: id\<^sub>L_def)

  subsubsection \<open>Lens Composition\<close>

  definition comp\<^sub>L :: "('a,'b) lens \<Rightarrow> ('b,'c) lens \<Rightarrow> ('a,'c) lens" (infixr ";\<^sub>L" 80)
  where
    "comp\<^sub>L L1 L2 \<equiv> LENS
      (\<lambda>s. do { s \<leftarrow> get L2 s; get L1 s})
      (\<lambda>x s. do {
        s' \<leftarrow> get L2 s;
        s' \<leftarrow> put L1 x s';
        put L2 s' s
      })"

  lemma comp_lens[simp, intro!]:
    assumes [simp, intro!]: "lens l1" "lens l2"
    shows "lens (l1;\<^sub>Ll2)"
    apply (unfold_locales)
    apply (auto simp: comp\<^sub>L_def split: Option.bind_splits prod.splits)
    done

  lemma comp_hlens[simp, intro!]:
    assumes [simp, intro!]: "hlens l1" "hlens l2"
    shows "hlens (l1;\<^sub>Ll2)"
    apply (unfold_locales)
    apply (auto simp: comp\<^sub>L_def split: Option.bind_splits prod.splits)
    done

  lemma compL_pre_get[simp]: "\<lbrakk>lens l1; lens l2\<rbrakk> \<Longrightarrow> pre_get (l1;\<^sub>Ll2) s \<longleftrightarrow> pre_get l2 s \<and> pre_get l1 (get' l2 s)"
    unfolding comp\<^sub>L_def
    by (auto split: option.splits Option.bind_splits)

  lemma compL_pre_put[simp]: "\<lbrakk>lens l1; lens l2\<rbrakk> \<Longrightarrow> pre_put (l1;\<^sub>Ll2) s
    \<longleftrightarrow> pre_get l2 s \<and> pre_put l1 (get' l2 s)"
    unfolding comp\<^sub>L_def
    by (auto split: option.splits Option.bind_splits)

  lemma compL_decomp[simp]:
    assumes [simp]: "lens l1" "lens l2"
    shows
    "pre_get (l1;\<^sub>Ll2) s \<Longrightarrow> get' (l1;\<^sub>Ll2) s = (get' l1 (get' l2 s))"
    "pre_put (l1;\<^sub>Ll2) s \<Longrightarrow> put' (l1;\<^sub>Ll2) x s = put' l2 (put' l1 x (get' l2 s)) s"
    by (auto simp: comp\<^sub>L_def split: prod.splits option.splits Option.bind_splits)

  subsubsection \<open>Monoid Laws\<close>

  thm prod.splits

  lemma id_left_neutral[simp]:
    "hlens a \<Longrightarrow> id\<^sub>L;\<^sub>La = a"
    apply (rule)
    apply (auto simp: )
    done

  lemma id_right_neutral[simp]:
    "lens a \<Longrightarrow> a;\<^sub>Lid\<^sub>L = a"
    by (rule) auto

  lemma assoc_comp_weak: "lens a \<Longrightarrow> lens b \<Longrightarrow> lens c \<Longrightarrow> (a;\<^sub>Lb);\<^sub>Lc = a;\<^sub>Lb;\<^sub>Lc"
    by (rule) auto

  lemma assoc_comp[simp]: "(a;\<^sub>Lb);\<^sub>Lc = a;\<^sub>Lb;\<^sub>Lc"
    unfolding comp\<^sub>L_def by (auto intro!: ext split: Option.bind_splits)

  subsubsection \<open>Independence\<close>

  (* TODO: Move
  lemma option_eq_casesI:
    assumes "a=None \<Longrightarrow> b=None"
    assumes "\<And>x. a=Some x \<Longrightarrow> b=Some x"
    shows "a = b"
    by (cases a; cases b; simp add: assms)
  *)

  locale lens_indep =
    fixes X :: "'a \<Longrightarrow> 'c" and Y :: "'b \<Longrightarrow> 'c"
    assumes get_put_irr1Some: "pre_put Y s \<Longrightarrow> get X (put' Y y s) = Some x \<Longrightarrow> get X s = Some x"
    assumes get_put_irr1None: "pre_put Y s \<Longrightarrow> get X (put' Y y s) = None \<Longrightarrow> get X s = None"
    assumes get_put_irr2Some: "pre_put X s \<Longrightarrow> get Y (put' X x s) = Some y \<Longrightarrow> get Y s = Some y"
    assumes get_put_irr2None: "pre_put X s \<Longrightarrow> get Y (put' X x s) = None \<Longrightarrow> get Y s = None"
    assumes pre_put_irr1:  "pre_put X s \<Longrightarrow> pre_put Y (put' X x s) \<longleftrightarrow> pre_put Y s"
    assumes pre_put_irr2: "pre_put Y s \<Longrightarrow> pre_put X (put' Y y s) \<longleftrightarrow> pre_put X s"
    assumes comm: "\<lbrakk> pre_put X s; pre_put Y s \<rbrakk> \<Longrightarrow> put' X x (put' Y y s) = put' Y y (put' X x s)"
  begin

    lemma get_put_irr1: "pre_put Y s \<Longrightarrow> get X (put' Y y s) = get X s"
      using get_put_irr1None get_put_irr1Some by fastforce

    lemma get_put_irr2: "pre_put X s \<Longrightarrow> get Y (put' X x s) = get Y s"
      using get_put_irr2None get_put_irr2Some by fastforce

    lemma lens_indep_get':
      "pre_put X s \<Longrightarrow> get' Y (put' X x s) = get' Y s"
      "pre_put Y s \<Longrightarrow> get' X (put' Y y s) = get' X s"
      apply (metis get'_def get_put_irr2)
      apply (metis get'_def get_put_irr1)
      done

    lemma lens_indep_pre_get':
      "pre_put Y s \<Longrightarrow> pre_get X (put' Y y s) \<longleftrightarrow> pre_get X s"
      "pre_put X s \<Longrightarrow> pre_get Y (put' X x s) \<longleftrightarrow> pre_get Y s"
      by (auto simp add: get_put_irr1 get_put_irr2 pre_get_def)

    lemmas simps[simp] = lens_indep_get' lens_indep_pre_get' pre_put_irr1 pre_put_irr2

  end

  declare lens_indep.simps[simp]

  notation lens_indep (infix "\<bowtie>" 50)

  lemma lens_indep_sym:  "x \<bowtie> y \<Longrightarrow> y \<bowtie> x"
    unfolding lens_indep_def by simp

  lemmas lens_indep_comm = lens_indep.comm

  lemma lens_indep_left_comp:
    assumes [simp]: "x \<bowtie> y" "lens x" "lens y" "lens z"
    shows "(x ;\<^sub>L z) \<bowtie> (y ;\<^sub>L z)"
    apply (unfold_locales)
    apply (auto simp: comp\<^sub>L_def lens_indep_comm split!: Option.bind_splits)
    done

  lemma lens_indep_right_comp:
    assumes [simp]: "y \<bowtie> z" "lens x" "lens y" "lens z"
    shows "(x ;\<^sub>L y) \<bowtie> (x ;\<^sub>L z)"
    apply (unfold_locales)
    apply (auto simp: comp\<^sub>L_def lens_indep_comm split!: Option.bind_splits)
    done

  lemma lens_indep_left_ext:
    assumes [simp]: "y \<bowtie> z" "lens x" "lens y" "lens z"
    shows "(x ;\<^sub>L y) \<bowtie> z"
    apply (unfold_locales)
    apply (auto simp: comp\<^sub>L_def lens_indep_comm split!: Option.bind_splits)
    done

  lemma lens_indep_right_ext:
    assumes [simp]: "x \<bowtie> z" "lens x" "lens y" "lens z"
    shows "x \<bowtie> (y ;\<^sub>L z)"
    by (simp add: lens_indep_left_ext lens_indep_sym)

  lemma lens_indep_extend2:
    assumes [simp]: "x \<bowtie> y" "lens x" "lens y" "lens a" "lens b"
    shows "a ;\<^sub>L x \<bowtie> b ;\<^sub>L y"
    apply (unfold_locales)
    apply (auto simp: comp\<^sub>L_def lens_indep_comm split!: Option.bind_splits)
    done

  subsubsection \<open>Transfer of Values\<close>
  text \<open>Relation that indicates that \<open>s'\<close> originated from \<open>s\<close> by changing \<open>L\<close>\<close>
  definition ltrans where "ltrans L s s' \<equiv> lens L \<and> (\<exists>x. put L x s = Some s')"

  lemma ltransI[simp]: "lens L \<Longrightarrow> pre_put L s \<Longrightarrow> ltrans L s (put' L x s)"
    unfolding ltrans_def by auto

  lemma ltrans_trans[simp]: "ltrans L OO ltrans L = ltrans L"
    unfolding ltrans_def by fastforce

  lemma ltrans_push_indep:
    assumes "L \<bowtie> L'"
    assumes "ltrans L' s s'"
    shows "get L s = get L s'"
    using assms
    by (auto simp: ltrans_def lens_indep.get_put_irr1)

  text \<open>Predicate to indicate that all states in relation \<open>R\<close> are equal on \<open>L\<close>\<close>
  definition eq_on\<^sub>L where "eq_on\<^sub>L R L \<equiv> \<forall>s s'. R s s' \<longrightarrow> get L s = get L s'"

  lemma eq_on_compI: "eq_on\<^sub>L R\<^sub>1 L \<Longrightarrow> eq_on\<^sub>L R\<^sub>2 L \<Longrightarrow> eq_on\<^sub>L (R\<^sub>1 OO R\<^sub>2) L"
    by (auto simp: eq_on\<^sub>L_def)

  lemma eq_on_ltrans_indepI: "L \<bowtie> L' \<Longrightarrow> eq_on\<^sub>L (ltrans L') L"
    by (auto simp: eq_on\<^sub>L_def ltrans_push_indep)

  subsection \<open>Lens Instances\<close>

  subsubsection \<open>Function\<close>

  definition fun\<^sub>L :: "'a \<Rightarrow> 'b \<Longrightarrow> ('a\<Rightarrow>'b)" where
    "fun\<^sub>L x \<equiv> LENS (\<lambda>f. Some (f x)) (\<lambda>y f. Some (f(x:=y)))"

  lemma fun_lens[simp, intro!]: "hlens (fun\<^sub>L x)"
    by (unfold_locales) (auto simp: fun\<^sub>L_def)

  lemma funL_pre[simp]:
    "pre_get (fun\<^sub>L x) s"
    "pre_put (fun\<^sub>L x) s"
    by (auto simp: fun\<^sub>L_def)

  lemma funL_getput'[simp]:
    "get' (fun\<^sub>L x) f = f x"
    "put' (fun\<^sub>L x) a f = f(x:=a)"
    by (auto simp: fun\<^sub>L_def)

  lemma fun\<^sub>L_indepI[simp]: "x\<noteq>y \<Longrightarrow> fun\<^sub>L x \<bowtie> fun\<^sub>L y"
    by standard (auto simp: fun\<^sub>L_def)

  subsubsection \<open>Products\<close>
  definition fst\<^sub>L :: "'a \<Longrightarrow> 'a \<times> 'b" where "fst\<^sub>L \<equiv> LENS (\<lambda>(a,_). Some a) (\<lambda>a (_,b). Some (a,b))"
  definition snd\<^sub>L :: "'b \<Longrightarrow> 'a \<times> 'b" where "snd\<^sub>L \<equiv> LENS (\<lambda>(_,b). Some b) (\<lambda>b (a,_). Some (a,b))"

  lemma fst_lens[simp,intro!]: "hlens fst\<^sub>L"
    by (unfold_locales) (auto simp: fst\<^sub>L_def)

  lemma snd_lens[simp,intro!]: "hlens snd\<^sub>L"
    by (unfold_locales) (auto simp: snd\<^sub>L_def)

  lemma fstL_getput'[simp]:
    "get' fst\<^sub>L x = fst x"
    "put' fst\<^sub>L a x = (a,snd x)"
    by (auto simp: fst\<^sub>L_def split: prod.splits)

  lemma sndL_getput'[simp]:
    "get' snd\<^sub>L x = snd x"
    "put' snd\<^sub>L b x = (fst x,b)"
    by (auto simp: snd\<^sub>L_def split: prod.splits)

  lemma fstL_pre[simp, intro!]: "pre_get fst\<^sub>L s" "pre_put fst\<^sub>L s" by (auto simp: fst\<^sub>L_def split: prod.splits)
  lemma sndL_pre[simp, intro!]: "pre_get snd\<^sub>L s" "pre_put snd\<^sub>L s" by (auto simp: snd\<^sub>L_def split: prod.splits)

  lemma prod_indep[simp]: "fst\<^sub>L \<bowtie> snd\<^sub>L"
    by unfold_locales auto

  subsubsection \<open>Lists\<close>

  definition idx\<^sub>L :: "nat \<Rightarrow> ('a \<Longrightarrow> 'a list)" where
    "idx\<^sub>L i \<equiv> LENS
      (\<lambda>s. do {assert (i < length s); Some (s!i)})
      (\<lambda>x s. do {assert (i < length s); Some (s[i:=x])})"

  definition hd\<^sub>L :: "'a \<Longrightarrow> 'a list" where
    "hd\<^sub>L \<equiv> LENS (\<lambda>x#_\<Rightarrow> Some x | _ \<Rightarrow> None) (\<lambda>x. \<lambda>_#xs \<Rightarrow> Some (x#xs) | _ \<Rightarrow> None )"

  definition tl\<^sub>L :: "'a list \<Longrightarrow> 'a list" where
    "tl\<^sub>L \<equiv> LENS (\<lambda>_#xs\<Rightarrow> Some xs | _ \<Rightarrow> None) (\<lambda>xs. \<lambda>x#_ \<Rightarrow> Some (x#xs) | _ \<Rightarrow> None )"

  definition last\<^sub>L :: "'a \<Longrightarrow> 'a list" where
    "last\<^sub>L \<equiv> LENS
      (\<lambda>xs. do {assert (xs\<noteq>[]); Some (last xs)})
      (\<lambda>x xs. do {assert (xs\<noteq>[]); Some (butlast xs @ [x])} )"

  lemma idx_lens[simp, intro!]: "hlens (idx\<^sub>L i)"
    by (unfold_locales) (auto simp: idx\<^sub>L_def split: if_splits prod.splits Option.bind_splits)

  lemma idxL_pre[simp]:
    "pre_get (idx\<^sub>L i) s \<longleftrightarrow> i < length s"
    "pre_put (idx\<^sub>L i) s \<longleftrightarrow> i < length s"
    by (auto simp: idx\<^sub>L_def split: if_splits Option.bind_splits)

  lemma idxL_getput'[simp]:
    "pre_get (idx\<^sub>L i) l \<Longrightarrow> get' (idx\<^sub>L i) l = l!i"
    "pre_put (idx\<^sub>L i) l \<Longrightarrow> put' (idx\<^sub>L i) a l = l[i:=a]"
    by (auto simp: idx\<^sub>L_def split: prod.splits Option.bind_splits)

  lemma hd_lens[simp, intro!]: "hlens (hd\<^sub>L)"
    by (unfold_locales) (auto simp: hd\<^sub>L_def split: list.splits)

  lemma hd_lens_pre[simp]:
    "pre_get hd\<^sub>L l \<longleftrightarrow> l\<noteq>[]"
    "pre_put hd\<^sub>L l \<longleftrightarrow> l\<noteq>[]"
    by (auto simp: hd\<^sub>L_def split: list.splits)

  lemma hd_lens_getput'[simp]:
    "pre_get hd\<^sub>L l \<Longrightarrow> get' hd\<^sub>L l = hd l"
    "pre_put hd\<^sub>L l \<Longrightarrow> put' hd\<^sub>L x l = x # tl l"
    by (auto simp: hd\<^sub>L_def split: list.splits)

  lemma tl_lens[simp, intro!]: "hlens (tl\<^sub>L)"
    by (unfold_locales) (auto simp: tl\<^sub>L_def split: list.splits)

  lemma tlL_pre[simp]:
    "pre_get tl\<^sub>L l \<longleftrightarrow> l\<noteq>[]"
    "pre_put tl\<^sub>L l \<longleftrightarrow> l\<noteq>[]"
    by (auto simp: tl\<^sub>L_def split: list.splits)

  lemma tlL_getput'[simp]:
    "pre_get tl\<^sub>L l \<Longrightarrow> get' tl\<^sub>L l = tl l"
    "pre_put tl\<^sub>L l \<Longrightarrow> put' tl\<^sub>L xs l = hd l # xs"
    by (auto simp: tl\<^sub>L_def split: list.splits)

  lemma last_lens[simp, intro!]: "hlens (last\<^sub>L)"
    by (unfold_locales) (auto simp: last\<^sub>L_def split: prod.splits Option.bind_splits)

  lemma lastL_pre[simp]:
    "pre_get last\<^sub>L l \<longleftrightarrow> l\<noteq>[]"
    "pre_put last\<^sub>L l \<longleftrightarrow> l\<noteq>[]"
    by (auto simp: last\<^sub>L_def)

  lemma lastL_getput'[simp]:
    "pre_get last\<^sub>L l \<Longrightarrow> get' last\<^sub>L l = last l"
    "pre_put last\<^sub>L l \<Longrightarrow> put' last\<^sub>L x l = butlast l@[x]"
    by (auto simp: last\<^sub>L_def split: prod.splits Option.bind_splits)

  lemma hdL_is_idx0: "hd\<^sub>L = idx\<^sub>L 0"
    unfolding hd\<^sub>L_def idx\<^sub>L_def
    by (auto split: list.splits if_splits intro!: ext)

  lemma hd_tl_indep[simp]: "hd\<^sub>L \<bowtie> tl\<^sub>L"
    by unfold_locales auto

  lemma idx\<^sub>L_indep[simp]: "i\<noteq>j \<Longrightarrow> idx\<^sub>L i \<bowtie> idx\<^sub>L j"
    apply unfold_locales
    by (auto simp: list_update_swap)

  subsubsection \<open>Option\<close>
  definition "the\<^sub>L \<equiv>
    LENS (\<lambda>x. x) (\<lambda>x. \<lambda>Some _ \<Rightarrow> Some (Some x) | _ \<Rightarrow> None)"

  lemma the_lens[simp, intro!]: "hlens (the\<^sub>L)"
    by (unfold_locales) (auto simp: the\<^sub>L_def split: option.splits)

  lemma theL_pre[simp]:
    "pre_get the\<^sub>L l \<longleftrightarrow> l\<noteq>None"
    "pre_put the\<^sub>L l \<longleftrightarrow> l\<noteq>None"
    by (auto simp: the\<^sub>L_def split: option.split)

  lemma theL_getput'[simp]:
    "pre_get the\<^sub>L l \<Longrightarrow> get' the\<^sub>L l = the l"
    "pre_put the\<^sub>L l \<Longrightarrow> put' the\<^sub>L x l = Some x"
    by (auto simp: the\<^sub>L_def split: option.split)

  definition "crov\<^sub>L \<equiv>
    LENS (\<lambda>x. x) (\<lambda>x _. Some (Some x))"

  lemma crov_lens[simp, intro!]: "lens (crov\<^sub>L)"
    by (unfold_locales) (auto simp: crov\<^sub>L_def split: option.splits)

  lemma crovL_pre[simp]:
    "pre_get crov\<^sub>L l \<longleftrightarrow> l\<noteq>None"
    "pre_put crov\<^sub>L l"
    by (auto simp: crov\<^sub>L_def split: option.split)

  lemma crovL_getput'[simp]:
    "pre_get crov\<^sub>L l \<Longrightarrow> get' crov\<^sub>L l = the l"
    "pre_put crov\<^sub>L l \<Longrightarrow> put' crov\<^sub>L x l = Some x"
    by (auto simp: crov\<^sub>L_def split: option.split)

  subsection \<open>Datatype Lens Generation\<close>

  context begin
    private lemma theMO_return: "the (Some x) = x" by simp
    private lemma domMO_return: "Some x \<noteq> None" by simp
    private lemma domMO_None: "\<not>(None \<noteq> None)" by simp

    ML \<open>
      structure Datatype_Lens = struct

        fun define_lens (cs : Ctr_Sugar.ctr_sugar) qualified i j lthy = let
          val ctors = #ctrs cs
          val namess = #selss cs |> map (map (dest_Const #> fst))

          fun mk_optionMT T = Type (@{type_name option}, [T])

          fun mk_return t = let
            val T = fastype_of t
            val rT = T --> mk_optionMT T
          in
            Const (@{const_name Some},rT) $ t
          end

          fun mk_abort T = let
            val rT = mk_optionMT T
          in
            Const (@{const_name None},rT)
          end

          fun mk_get ctxt ctor i = let
            val (Ts,_) = strip_type (fastype_of ctor)
            val (vs,_) = Variable.variant_fixes (map (K "x") Ts) ctxt
            val vs = map Free (vs ~~ Ts)
            val t = mk_return (nth vs i) |> fold lambda (rev vs)
          in
            t
          end

          fun mk_invcase ctxt T ctor = let
            val (Ts,_) = strip_type (fastype_of ctor)
            val (vs,_) = Variable.variant_fixes (map (K "x") Ts) ctxt
            val vs = map Free (vs ~~ Ts)
            val t = mk_abort T |> fold lambda (rev vs)
          in
            t
          end

          fun mk_put ctxt ctor pvn i = let
            val (Ts,_) = strip_type (fastype_of ctor)
            val (vs,_) = Variable.variant_fixes (map (K "x") Ts) ctxt
            val vsa = nth_map i (K pvn) vs
            val vs = map Free (vs ~~ Ts)
            val vsa = map Free (vsa ~~ Ts)
            val t = mk_return (list_comb (ctor,vsa)) |> fold lambda (rev vs)
          in
            t
          end

          fun mk_case ts = let
            val rT = body_type (fastype_of (hd ts))
            val cT = (map fastype_of ts) ---> #T cs --> rT

            val (cn,_) = dest_Const (#casex cs)
            val cc = Const (cn,cT)
            val r = list_comb (cc,ts)
          in
            r
          end

          fun mk_lens ctxt i j = let
            val ctor = nth ctors i
            val lname = nth (nth namess i) j
            val T = nth (binder_types (fastype_of ctor)) j

            (* Get *)
            val get =
                 map (mk_invcase ctxt T) ctors
              |> nth_map i (K (mk_get ctxt ctor j))
              |> mk_case

            (* Put *)
            val (pvn,ctxt) = yield_singleton Variable.variant_fixes "v" ctxt
            val pvT = nth (binder_types (fastype_of ctor)) j
            val pv = Free (pvn,pvT)

            val put =
                 map (mk_invcase ctxt (#T cs)) ctors
              |> nth_map i (K (mk_put ctxt ctor pvn j))
              |> mk_case
              |> lambda pv

            val lensT = Type (@{type_name lens},[T,#T cs])
            val lens = Const (@{const_name LENS}, fastype_of get --> fastype_of put --> lensT)
            val rhs_term = lens $ get $ put

            val lname = String.tokens (fn x => x = #".") lname |> rev
            val (qname,lname) = (hd (tl lname),hd lname)
            val lname = lname ^ "\<^sub>L"
            val lhs_term = Free (lname, fastype_of rhs_term)
            val def_term = Logic.mk_equals (lhs_term,rhs_term)
          in
            ((qname,lname),def_term)
          end

          val ((qname,lname),def_term) = mk_lens lthy i j

          val lname = Binding.name lname
          val lname = Binding.qualify qualified qname lname

          val (def_term,_) = yield_singleton (Variable.importT_terms) def_term lthy

          val ((lens_t,(_,def_thm)),lthy) = Specification.definition
            (SOME (lname,NONE,Mixfix.NoSyn)) [] [] ((Binding.empty,[]),def_term) lthy;

          val lens_prop =
              Const (@{const_name hlens}, fastype_of lens_t --> HOLogic.boolT) $ lens_t
            |> HOLogic.mk_Trueprop

          fun prove ctxt = let
            val ctxt = put_simpset HOL_ss ctxt
            val ctxt = ctxt
              addsimps @{thms hlens.is_lens LENS_downstage theMO_return domMO_return domMO_None}
              addsimps #injects cs
              addsimps #distincts cs
            val ctxt = Splitter.add_split (#split cs) ctxt
            val ctxt = Splitter.add_split (#split_asm cs) ctxt
          in
            Locale.intro_locales_tac true ctxt []
            THEN unfold_tac ctxt [def_thm]
            THEN ALLGOALS (asm_full_simp_tac ctxt)
          end

          val lens_thm = Goal.prove lthy [] [] lens_prop (fn {context, ...} => prove context)
          val lt_name = Binding.suffix_name "_lens" lname
          val (_,lthy) = Local_Theory.note ((lt_name,@{attributes [simp, intro!]}),[lens_thm]) lthy

        in
          lthy
        end

        fun define_all_lenses cs qual lthy = let
          fun def_lens i lthy = let
            val ub = nth (#ctrs cs) i |> fastype_of |> binder_types |> length
          in
            fold (fn j => define_lens cs qual i j) (0 upto ub - 1) lthy
          end
        in
          fold (fn i => def_lens i) (0 upto length (#ctrs cs) - 1) lthy
        end

      end
    \<close>

    ML \<open>
      let
        val parse_qualified =
          Scan.optional (@{keyword "("} |-- (@{keyword open} >> K true) --| @{keyword ")"}) false
      in
        Outer_Syntax.local_theory
          @{command_keyword define_lenses}
          "Define lenses for datatype"
          (parse_qualified -- Parse.type_const
            >> (fn (qual, tyname) => fn lthy => let
              val tyname =
                  Proof_Context.read_type_name {proper=true, strict=false} lthy tyname
               |> dest_Type |> fst
              val cs = Ctr_Sugar.ctr_sugar_of lthy tyname
              val _ = is_none cs andalso error ("Not a datatype " ^ tyname)
              val cs = the cs
            in
              Datatype_Lens.define_all_lenses cs qual lthy
            end)
          )
      end
    \<close>

  end

  abbreviation comp\<^sub>L_aux where "comp\<^sub>L_aux a b \<equiv> comp\<^sub>L b a"
  bundle forward_composition_syntax begin
    no_notation comp\<^sub>L (infixr ";\<^sub>L" 80)
    notation comp\<^sub>L_aux (infixl "\<bullet>\<^sub>L" 80)
  end

  (* Can be used to generate simp-lemma to unfold generated lenses. TODO: Generate clean simp-theorems! *)
  lemma lens_eq_unfolds:
    assumes "L \<equiv> LENS g p"
    shows "get L s = g s" "put L x s = p x s"
    using assms by auto

  section \<open>Tests and Examples\<close>

  context begin

    private datatype 'a test =
      A (xcord: nat) (ycord: 'a)
    | B (name: string)
    | C bool bool int

    private define_lenses test
    print_theorems

    value [code] "put ycord\<^sub>L ''bar'' (A 3 ''foo'')"
    value [code] "put' ycord\<^sub>L ''bar'' (A 3 ''foo'')"
    value [code] "put ycord\<^sub>L ''bar'' (B ''foo'')"
  end

end


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

section \<open>Defining algebraic domains by ideal completion\<close>

theory Completion
imports Cfun
begin

subsection \<open>Ideals over a preorder\<close>

locale preorder =
  fixes r :: "'a::type \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
  assumes r_refl: "x \<preceq> x"
  assumes r_trans: "\<lbrakk>x \<preceq> y; y \<preceq> z\<rbrakk> \<Longrightarrow> x \<preceq> z"
begin

definition
  ideal :: "'a set \<Rightarrow> bool" where
  "ideal A = ((\<exists>x. x \<in> A) \<and> (\<forall>x\<in>A. \<forall>y\<in>A. \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z) \<and>
    (\<forall>x y. x \<preceq> y \<longrightarrow> y \<in> A \<longrightarrow> x \<in> A))"

lemma idealI:
  assumes "\<exists>x. x \<in> A"
  assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
  assumes "\<And>x y. \<lbrakk>x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
  shows "ideal A"
unfolding ideal_def using assms by fast

lemma idealD1:
  "ideal A \<Longrightarrow> \<exists>x. x \<in> A"
unfolding ideal_def by fast

lemma idealD2:
  "\<lbrakk>ideal A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
unfolding ideal_def by fast

lemma idealD3:
  "\<lbrakk>ideal A; x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
unfolding ideal_def by fast

lemma ideal_principal: "ideal {x. x \<preceq> z}"
  apply (rule idealI)
    apply (rule exI [where x = z])
    apply (fast intro: r_refl)
   apply (rule bexI [where x = z], fast)
   apply (fast intro: r_refl)
  apply (fast intro: r_trans)
  done

lemma ex_ideal: "\<exists>A. A \<in> {A. ideal A}"
by (fast intro: ideal_principal)

text \<open>The set of ideals is a cpo\<close>

lemma ideal_UN:
  fixes A :: "nat \<Rightarrow> 'a set"
  assumes ideal_A: "\<And>i. ideal (A i)"
  assumes chain_A: "\<And>i j. i \<le> j \<Longrightarrow> A i \<subseteq> A j"
  shows "ideal (\<Union>i. A i)"
  apply (rule idealI)
  using idealD1 [OF ideal_A] apply fast
   apply (clarify)
  subgoal for i j
    apply (drule subsetD [OF chain_A [OF max.cobounded1]])
    apply (drule subsetD [OF chain_A [OF max.cobounded2]])
    apply (drule (1) idealD2 [OF ideal_A])
    apply blast
    done
  apply clarify
  apply (drule (1) idealD3 [OF ideal_A])
  apply fast
  done

lemma typedef_ideal_po:
  fixes Abs :: "'a set \<Rightarrow> 'b::below"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  shows "OFCLASS('b, po_class)"
 apply (intro_classes, unfold below)
   apply (rule subset_refl)
  apply (erule (1) subset_trans)
 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
 apply (erule (1) subset_antisym)
done

lemma
  fixes Abs :: "'a set \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  assumes S: "chain S"
  shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
    and typedef_ideal_rep_lub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
proof -
  have 1: "ideal (\<Union>i. Rep (S i))"
    apply (rule ideal_UN)
     apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
    apply (subst below [symmetric])
    apply (erule chain_mono [OF S])
    done
  hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
    by (simp add: type_definition.Abs_inverse [OF type])
  show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
    apply (rule is_lubI)
     apply (rule is_ubI)
     apply (simp add: below 2, fast)
    apply (simp add: below 2 is_ub_def, fast)
    done
  hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
    by (rule lub_eqI)
  show 5: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
    by (simp add: 4 2)
qed

lemma typedef_ideal_cpo:
  fixes Abs :: "'a set \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  shows "OFCLASS('b, cpo_class)"
  by standard (rule exI, erule typedef_ideal_lub [OF type below])

end

interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
apply unfold_locales
apply (rule below_refl)
apply (erule (1) below_trans)
done

subsection \<open>Lemmas about least upper bounds\<close>

lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
apply (erule exE, drule is_lub_lub)
apply (drule is_lubD1)
apply (erule (1) is_ubD)
done

lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
by (erule exE, drule is_lub_lub, erule is_lubD2)

subsection \<open>Locale for ideal completion\<close>

hide_const (open) Filter.principal

locale ideal_completion = preorder +
  fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
  fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
  assumes ideal_rep: "\<And>x. ideal (rep x)"
  assumes rep_lub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
  assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
  assumes belowI: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
begin

lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
apply (frule bin_chain)
apply (drule rep_lub)
apply (simp only: lub_eqI [OF is_lub_bin_chain])
apply (rule subsetI, rule UN_I [where a=0], simp_all)
done

lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
by (rule iffI [OF rep_mono belowI])

lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
unfolding below_def rep_principal
by (auto intro: r_refl elim: idealD3 [OF ideal_rep])

lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
by (simp add: principal_below_iff_mem_rep rep_principal)

lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
unfolding po_eq_conv [where 'a='b] principal_below_iff ..

lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
unfolding po_eq_conv below_def by auto

lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
by (simp only: principal_below_iff)

lemma ch2ch_principal [simp]:
  "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
by (simp add: chainI principal_mono)

subsubsection \<open>Principal ideals approximate all elements\<close>

lemma compact_principal [simp]: "compact (principal a)"
by (rule compactI2, simp add: principal_below_iff_mem_rep rep_lub)

text \<open>Construct a chain whose lub is the same as a given ideal\<close>

lemma obtain_principal_chain:
  obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
proof -
  obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
    using countable ..
  define enum where "enum i = (THE a. count a = i)" for i
  have enum_count [simp]: "\<And>x. enum (count x) = x"
    unfolding enum_def by (simp add: inj_eq [OF inj])
  define a where "a = (LEAST i. enum i \<in> rep x)"
  define b where "b i = (LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i)" for i
  define c where "c i j = (LEAST k. enum k \<in> rep x \<and> enum i \<preceq> enum k \<and> enum j \<preceq> enum k)" for i j
  define P where "P i \<longleftrightarrow> (\<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i)" for i
  define X where "X = rec_nat a (\<lambda>n i. if P i then c i (b i) else i)"
  have X_0: "X 0 = a" unfolding X_def by simp
  have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
    unfolding X_def by simp
  have a_mem: "enum a \<in> rep x"
    unfolding a_def
    apply (rule LeastI_ex)
    apply (insert ideal_rep [of x])
    apply (drule idealD1)
    apply (clarify)
    subgoal for a by (rule exI [where x="count a"]) simp
    done
  have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
    \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
    unfolding P_def b_def by (erule LeastI2_ex, simp)
  have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
    \<Longrightarrow> enum (c i j) \<in> rep x \<and> enum i \<preceq> enum (c i j) \<and> enum j \<preceq> enum (c i j)"
    unfolding c_def
    apply (drule (1) idealD2 [OF ideal_rep], clarify)
    subgoal for \<dots> z by (rule LeastI2 [where a="count z"], simp, simp)
    done
  have X_mem: "enum (X n) \<in> rep x" for n
  proof (induct n)
    case 0
    then show ?case by (simp add: X_0 a_mem)
  next
    case (Suc n)
    with b c show ?case by (auto simp: X_Suc)
  qed
  have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
    apply (clarsimp simp add: X_Suc r_refl)
    apply (simp add: b c X_mem)
    done
  have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
    unfolding b_def by (drule not_less_Least, simp)
  have X_covers: "\<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)" for n
  proof (induct n)
    case 0
    then show ?case
      apply (clarsimp simp add: X_0 a_def)
      apply (drule Least_le [where k=0], simp add: r_refl)
      done
  next
    case (Suc n)
    then show ?case
      apply clarsimp
      apply (erule le_SucE)
       apply (rule r_trans [OF _ X_chain], simp)
      apply (cases "P (X n)", simp add: X_Suc)
       apply (rule linorder_cases [where x="b (X n)" and y="Suc n"])
         apply (simp only: less_Suc_eq_le)
         apply (drule spec, drule (1) mp, simp add: b X_mem)
        apply (simp add: c X_mem)
       apply (drule (1) less_b)
       apply (erule r_trans)
       apply (simp add: b c X_mem)
      apply (simp add: X_Suc)
      apply (simp add: P_def)
      done
  qed
  have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
    by (simp add: X_chain)
  have "x = (\<Squnion>n. principal (enum (X n)))"
    apply (simp add: eq_iff rep_lub 1 rep_principal)
    apply auto
    subgoal for a
      apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
       apply (rule_tac x=i in exI, simp add: X_covers)
      apply (rule_tac x="count a" in exI, simp)
      done
    subgoal
      apply (erule idealD3 [OF ideal_rep])
      apply (rule X_mem)
      done
    done
  with 1 show ?thesis ..
qed

lemma principal_induct:
  assumes adm: "adm P"
  assumes P: "\<And>a. P (principal a)"
  shows "P x"
apply (rule obtain_principal_chain [of x])
apply (simp add: admD [OF adm] P)
done

lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
apply (rule obtain_principal_chain [of x])
apply (drule adm_compact_neq [OF _ cont_id])
apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
apply (drule (2) admD2, fast, simp)
done

subsection \<open>Defining functions in terms of basis elements\<close>

definition
  extension :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
  "extension = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"

lemma extension_lemma:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "\<exists>u. f ` rep x <<| u"
proof -
  obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
  and x: "x = (\<Squnion>i. principal (Y i))"
    by (rule obtain_principal_chain [of x])
  have chain: "chain (\<lambda>i. f (Y i))"
    by (rule chainI, simp add: f_mono Y)
  have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
    by (simp add: x rep_lub Y rep_principal)
  have "f ` rep x <<| (\<Squnion>n. f (Y n))"
    apply (rule is_lubI)
     apply (rule ub_imageI)
    subgoal for a
      apply (clarsimp simp add: rep_x)
      apply (drule f_mono)
      apply (erule below_lub [OF chain])
      done
    apply (rule lub_below [OF chain])
    subgoal for \<dots> n
      apply (drule ub_imageD [where x="Y n"])
       apply (simp add: rep_x, fast intro: r_refl)
      apply assumption
      done
    done
  then show ?thesis ..
qed

lemma extension_beta:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "extension f\<cdot>x = lub (f ` rep x)"
unfolding extension_def
proof (rule beta_cfun)
  have lub: "\<And>x. \<exists>u. f ` rep x <<| u"
    using f_mono by (rule extension_lemma)
  show cont: "cont (\<lambda>x. lub (f ` rep x))"
    apply (rule contI2)
     apply (rule monofunI)
     apply (rule is_lub_thelub_ex [OF lub ub_imageI])
     apply (rule is_ub_thelub_ex [OF lub imageI])
     apply (erule (1) subsetD [OF rep_mono])
    apply (rule is_lub_thelub_ex [OF lub ub_imageI])
    apply (simp add: rep_lub, clarify)
    apply (erule rev_below_trans [OF is_ub_thelub])
    apply (erule is_ub_thelub_ex [OF lub imageI])
    done
qed

lemma extension_principal:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "extension f\<cdot>(principal a) = f a"
apply (subst extension_beta, erule f_mono)
apply (subst rep_principal)
apply (rule lub_eqI)
apply (rule is_lub_maximal)
apply (rule ub_imageI)
apply (simp add: f_mono)
apply (rule imageI)
apply (simp add: r_refl)
done

lemma extension_mono:
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
  assumes below: "\<And>a. f a \<sqsubseteq> g a"
  shows "extension f \<sqsubseteq> extension g"
  apply (rule cfun_belowI)
  apply (simp only: extension_beta f_mono g_mono)
  apply (rule is_lub_thelub_ex)
   apply (rule extension_lemma, erule f_mono)
  apply (rule ub_imageI)
  subgoal for x a
    apply (rule below_trans [OF below])
    apply (rule is_ub_thelub_ex)
     apply (rule extension_lemma, erule g_mono)
    apply (erule imageI)
    done
  done

lemma cont_extension:
  assumes f_mono: "\<And>a b x. a \<preceq> b \<Longrightarrow> f x a \<sqsubseteq> f x b"
  assumes f_cont: "\<And>a. cont (\<lambda>x. f x a)"
  shows "cont (\<lambda>x. extension (\<lambda>a. f x a))"
 apply (rule contI2)
  apply (rule monofunI)
  apply (rule extension_mono, erule f_mono, erule f_mono)
  apply (erule cont2monofunE [OF f_cont])
 apply (rule cfun_belowI)
 apply (rule principal_induct, simp)
 apply (simp only: contlub_cfun_fun)
 apply (simp only: extension_principal f_mono)
 apply (simp add: cont2contlubE [OF f_cont])
done

end

lemma (in preorder) typedef_ideal_completion:
  fixes Abs :: "'a set \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  assumes principal: "\<And>a. principal a = Abs {b. b \<preceq> a}"
  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
  shows "ideal_completion r principal Rep"
proof
  interpret type_definition Rep Abs "{S. ideal S}" by fact
  fix a b :: 'a and x y :: 'b and Y :: "nat \<Rightarrow> 'b"
  show "ideal (Rep x)"
    using Rep [of x] by simp
  show "chain Y \<Longrightarrow> Rep (\<Squnion>i. Y i) = (\<Union>i. Rep (Y i))"
    using type below by (rule typedef_ideal_rep_lub)
  show "Rep (principal a) = {b. b \<preceq> a}"
    by (simp add: principal Abs_inverse ideal_principal)
  show "Rep x \<subseteq> Rep y \<Longrightarrow> x \<sqsubseteq> y"
    by (simp only: below)
  show "\<exists>f::'a \<Rightarrow> nat. inj f"
    by (rule countable)
qed

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Fragments on permuations\<close>

theory Perm_Fragments
imports "HOL-Library.Perm" "HOL-Library.Dlist"
begin

text \<open>On cycles\<close>

context
  includes permutation_syntax
begin

lemma cycle_prod_list:
  "\<langle>a # as\<rangle> = prod_list (map (\<lambda>b. \<langle>a \<leftrightarrow> b\<rangle>) (rev as))"
  by (induct as) simp_all

lemma cycle_append [simp]:
  "\<langle>a # as @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # as\<rangle>"
proof (induct as rule: cycle.induct)
  case (3 b c as)
  then have "\<langle>a # (b # as) @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # b # as\<rangle>"
    by simp
  then have "\<langle>a # as @ bs\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>"
    by (simp add: ac_simps)
  then have "\<langle>a # as @ bs\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>"
    by simp
  then have "\<langle>a # as @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # as\<rangle>"
    by (simp add: ac_simps)
  then show "\<langle>a # (b # c # as) @ bs\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # b # c # as\<rangle>"
    by (simp add: ac_simps)
qed simp_all

lemma affected_cycle:
  "affected \<langle>as\<rangle> \<subseteq> set as"
proof (induct as rule: cycle.induct)
  case (3 a b as)
  from affected_times
  have "affected (\<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>)
    \<subseteq> affected \<langle>a # as\<rangle> \<union> affected \<langle>a \<leftrightarrow> b\<rangle>" .
  moreover from 3
  have "affected (\<langle>a # as\<rangle>) \<subseteq> insert a (set as)"
    by simp
  moreover
  have "affected \<langle>a \<leftrightarrow> b\<rangle> \<subseteq> {a, b}"
    by (cases "a = b") (simp_all add: affected_swap)
  ultimately have "affected (\<langle>a # as\<rangle> * \<langle>a \<leftrightarrow> b\<rangle>)
    \<subseteq> insert a (insert b (set as))"
    by blast
  then show ?case by auto
qed simp_all

lemma orbit_cycle_non_elem:
  assumes "a \<notin> set as"
  shows "orbit \<langle>as\<rangle> a = {a}"
  unfolding not_in_affected_iff_orbit_eq_singleton [symmetric]
  using assms affected_cycle [of as] by blast

lemma inverse_cycle:
  assumes "distinct as"
  shows "inverse \<langle>as\<rangle> = \<langle>rev as\<rangle>"
using assms proof (induct as rule: cycle.induct)
  case (3 a b as)
  then have *: "inverse \<langle>a # as\<rangle> = \<langle>rev (a # as)\<rangle>"
    and distinct: "distinct (a # b # as)"
    by simp_all
  show " inverse \<langle>a # b # as\<rangle> = \<langle>rev (a # b # as)\<rangle>"
  proof (cases as rule: rev_cases)
    case Nil with * show ?thesis
      by (simp add: swap_sym)
  next
    case (snoc cs c)
    with distinct have "distinct (a # b # cs @ [c])"
      by simp
    then have **: "\<langle>a \<leftrightarrow> b\<rangle> * \<langle>c \<leftrightarrow> a\<rangle> = \<langle>c \<leftrightarrow> a\<rangle> * \<langle>c \<leftrightarrow> b\<rangle>"
      by transfer (auto simp add: comp_def Fun.swap_def)
    with snoc * show ?thesis
      by (simp add: mult.assoc [symmetric])
  qed
qed simp_all

lemma order_cycle_non_elem:
  assumes "a \<notin> set as"
  shows "order \<langle>as\<rangle> a = 1"
proof -
  from assms have "orbit \<langle>as\<rangle> a = {a}"
    by (rule orbit_cycle_non_elem)
  then have "card (orbit \<langle>as\<rangle> a) = card {a}"
    by simp
  then show ?thesis
    by simp
qed

lemma orbit_cycle_elem:
  assumes "distinct as" and "a \<in> set as"
  shows "orbit \<langle>as\<rangle> a = set as"
  oops \<comment> \<open>(we need rotation here\<close>

lemma order_cycle_elem:
  assumes "distinct as" and "a \<in> set as"
  shows "order \<langle>as\<rangle> a = length as"
  oops

text \<open>Adding fixpoints\<close>

definition fixate :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a perm"
where
  "fixate a f = (if a \<in> affected f then f * \<langle>inverse f \<langle>$\<rangle> a \<leftrightarrow> a\<rangle> else f)"

lemma affected_fixate_trivial:
  assumes "a \<notin> affected f"
  shows "affected (fixate a f) = affected f"
  using assms by (simp add: fixate_def)

lemma affected_fixate_binary_circle:
  assumes "order f a = 2"
  shows "affected (fixate a f) = affected f - {a, apply f a}" (is "?A = ?B")
proof (rule set_eqI)
  interpret bijection "apply f"
    by standard simp
  fix b
  from assms order_greater_eq_two_iff [of f a] have "a \<in> affected f"
    by simp
  moreover have "apply (f ^ 2) a = a"
    by (simp add: assms [symmetric])
  ultimately show "b \<in> ?A \<longleftrightarrow> b \<in> ?B"
    by (cases "b \<in> {a, apply (inverse f) a}")
      (auto simp add: in_affected power2_eq_square apply_inverse apply_times fixate_def)
qed

lemma affected_fixate_no_binary_circle:
  assumes "order f a > 2"
  shows "affected (fixate a f) = affected f - {a}" (is "?A = ?B")
proof (rule set_eqI)
  interpret bijection "apply f"
    by standard simp
  fix b
  from assms order_greater_eq_two_iff [of f a]
  have "a \<in> affected f"
    by simp
  moreover from assms
  have "apply f (apply f a) \<noteq> a"
    using apply_power_eq_iff [of f 2 a 0]
    by (simp add: power2_eq_square apply_times)
  ultimately show "b \<in> ?A \<longleftrightarrow> b \<in> ?B"
    by (cases "b \<in> {a, apply (inverse f) a}")
      (auto simp add: in_affected apply_inverse apply_times fixate_def)
qed

lemma affected_fixate:
  "affected (fixate a f) \<subseteq> affected f - {a}"
proof -
  have "a \<notin> affected f \<or> order f a = 2 \<or> order f a > 2"
    by (auto simp add: not_less dest: affected_order_greater_eq_two)
  then consider "a \<notin> affected f" | "order f a = 2" | "order f a > 2"
    by blast
  then show ?thesis apply cases
  using affected_fixate_trivial [of a f]
    affected_fixate_binary_circle [of f a]
    affected_fixate_no_binary_circle [of f a]
    by auto
qed

lemma orbit_fixate_self [simp]:
  "orbit (fixate a f) a = {a}"
proof -
  have "apply (f * inverse f) a = a"
    by simp
  then have "apply f (apply (inverse f) a) = a"
    by (simp only: apply_times comp_apply)
  then show ?thesis
    by (simp add: fixate_def not_in_affected_iff_orbit_eq_singleton [symmetric] in_affected apply_times)
qed

lemma order_fixate_self [simp]:
  "order (fixate a f) a = 1"
proof -
  have "card (orbit (fixate a f) a) = card {a}"
    by simp
  then show ?thesis
    by (simp only: card_orbit_eq) simp
qed

lemma
  assumes "b \<notin> orbit f a"
  shows "orbit (fixate b f) a = orbit f a"
  oops

lemma
  assumes "b \<in> orbit f a" and "b \<noteq> a"
  shows "orbit (fixate b f) a = orbit f a - {b}"
  oops

text \<open>Distilling cycles from permutations\<close>

inductive_set orbits :: "'a perm \<Rightarrow> 'a set set" for f
where
  in_orbitsI: "a \<in> affected f \<Longrightarrow> orbit f a \<in> orbits f"

lemma orbits_unfold:
  "orbits f = orbit f ` affected f"
  by (auto intro: in_orbitsI elim: orbits.cases)

lemma in_orbit_affected:
  assumes "b \<in> orbit f a"
  assumes "a \<in> affected f"
  shows "b \<in> affected f"
proof (cases "a = b")
  case True with assms show ?thesis by simp
next
  case False with assms have "{a, b} \<subseteq> orbit f a"
    by auto
  also from assms have "orbit f a \<subseteq> affected f"
    by (blast intro!: orbit_subset_eq_affected)
  finally show ?thesis by simp
qed

lemma Union_orbits [simp]:
  "\<Union>(orbits f) = affected f"
  by (auto simp add: orbits.simps intro: in_orbitsI in_orbit_affected)

lemma finite_orbits [simp]:
  "finite (orbits f)"
  by (simp add: orbits_unfold)

lemma card_in_orbits:
  assumes "A \<in> orbits f"
  shows "card A \<ge> 2"
  using assms by cases
    (auto dest: affected_order_greater_eq_two)

lemma disjoint_orbits:
  assumes "A \<in> orbits f" and "B \<in> orbits f" and "A \<noteq> B"
  shows "A \<inter> B = {}"
  using \<open>A \<in> orbits f\<close> apply cases
  using \<open>B \<in> orbits f\<close> apply cases
  using \<open>A \<noteq> B\<close> apply (simp_all add: orbit_disjoint)
  done

definition trace :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a list"
where
  "trace a f = map (\<lambda>n. apply (f ^ n) a) [0..<order f a]"

lemma set_trace_eq [simp]:
  "set (trace a f) = orbit f a"
  by (auto simp add: trace_def orbit_unfold_image)

definition seeds :: "'a perm \<Rightarrow> 'a::linorder list"
where
  "seeds f = sorted_list_of_set (Min ` orbits f)"

definition cycles :: "'a perm \<Rightarrow> 'a::linorder list list"
where
  "cycles f = map (\<lambda>a. trace a f) (seeds f)"

end

text \<open>Misc\<close>

lemma (in comm_monoid_list_set) sorted_list_of_set:
  assumes "finite A"
  shows "list.F (map h (sorted_list_of_set A)) = set.F h A"
proof -
  from distinct_sorted_list_of_set
  have "set.F h (set (sorted_list_of_set A)) = list.F (map h (sorted_list_of_set A))"
    by (rule distinct_set_conv_list)
  with \<open>finite A\<close> show ?thesis
    by (simp)
qed

primrec subtract :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "subtract [] ys = ys"
| "subtract (x # xs) ys = subtract xs (removeAll x ys)"

lemma length_subtract_less_eq [simp]:
  "length (subtract xs ys) \<le> length ys"
proof (induct xs arbitrary: ys)
  case Nil then show ?case by simp
next
  case (Cons x xs)
  then have "length (subtract xs (removeAll x ys)) \<le> length (removeAll x ys)" .
  also have "length (removeAll x ys) \<le> length ys"
    by simp
  finally show ?case
    by simp
qed

end