Session Optics

Theory Interp

(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Interp.thy                                                           *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk frank.zeyda@york.ac.uk                     *)
(******************************************************************************)
(* LAST REVIEWED: 7/12/2016 *)

section ‹Interpretation Tools›

theory Interp
imports Main
begin

subsection ‹Interpretation Locale›

locale interp =
fixes f :: "'a  'b"
assumes f_inj : "inj f"
begin
lemma meta_interp_law:
"(P. PROP Q P)  (P. PROP Q (P o f))"
  apply (rule equal_intr_rule)
    ― ‹Subgoal 1›
   apply (drule_tac x = "P o f" in meta_spec)
   apply (assumption)
    ― ‹Subgoal 2›
  apply (drule_tac x = "P o inv f" in meta_spec)
  apply (simp add: f_inj)
done

lemma all_interp_law:
"(P. Q P) = (P. Q (P o f))"
  apply (safe)
    ― ‹Subgoal 1›
   apply (drule_tac x = "P o f" in spec)
   apply (assumption)
    ― ‹Subgoal 2›
  apply (drule_tac x = "P o inv f" in spec)
  apply (simp add: f_inj)
done

lemma exists_interp_law:
"(P. Q P) = (P. Q (P o f))"
  apply (safe)
    ― ‹Subgoal 1›
   apply (rule_tac x = "P o inv f" in exI)
   apply (simp add: f_inj)
    ― ‹Subgoal 2›
  apply (rule_tac x = "P o f" in exI)
  apply (assumption)
done
end
end

Theory Two

section ‹ Types of Cardinality 2 or Greater ›

theory Two
imports HOL.Real
begin

text ‹ The two class states that a type's carrier is either infinite, or else it has a finite 
  cardinality of at least 2. It is needed when we depend on having at least two distinguishable
  elements. ›
  
class two =
  assumes card_two: "infinite (UNIV :: 'a set)  card (UNIV :: 'a set)  2"
begin
lemma two_diff: " x y :: 'a. x  y"
proof -
  obtain A where "finite A" "card A = 2" "A  (UNIV :: 'a set)"
  proof (cases "infinite (UNIV :: 'a set)")
    case True
    with infinite_arbitrarily_large[of "UNIV :: 'a set" 2] that
    show ?thesis by auto
  next
    case False
    with card_two that
    show ?thesis
      by (metis UNIV_bool card_UNIV_bool card_image card_le_inj finite.intros(1) finite_insert finite_subset)
  qed
  thus ?thesis
    by (metis (full_types) One_nat_def Suc_1 UNIV_eq_I card.empty card.insert finite.intros(1) insertCI nat.inject nat.simps(3))
qed
end

instance bool :: two
  by (intro_classes, auto)

instance nat :: two
  by (intro_classes, auto)

instance int :: two
  by (intro_classes, auto simp add: infinite_UNIV_int)

instance rat :: two
  by (intro_classes, auto simp add: infinite_UNIV_char_0)

instance real :: two
  by (intro_classes, auto simp add: infinite_UNIV_char_0)

instance list :: (type) two
  by (intro_classes, auto simp add: infinite_UNIV_listI)

end

Theory Lens_Laws

section ‹Core Lens Laws›

theory Lens_Laws
imports
  Two Interp
begin

subsection ‹Lens Signature›
  
text ‹This theory introduces the signature of lenses and indentifies the core algebraic hierarchy of lens 
  classes, including laws for well-behaved, very well-behaved, and bijective lenses~\cite{Foster07,Fischer2015,Gibbons17}.›
  
record ('a, 'b) lens =
  lens_get :: "'b  'a" ("getı")
  lens_put :: "'b  'a  'b" ("putı")

type_notation
  lens (infixr "" 0)

text ‹ Alternative parameters ordering, inspired by Back and von Wright's refinement 
  calculus~\cite{Back1998}, which similarly uses two functions to characterise updates to variables. ›

abbreviation (input) lens_set :: "('a  'b)  'a  'b  'b" ("lsetı") where
"lens_set  (λ X v s. putX s v)"

text ‹
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Lens}
  \end{center}
  \vspace{-5ex}
  \caption{Visualisation of a simple lens}
  \label{fig:Lens}
  \end{figure}

  A lens $X : \view \lto \src$, for source type $\src$ and view type $\view$, identifies
  $\view$ with a subregion of $\src$~\cite{Foster07,Foster09}, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes
  $X$ and the hatched area denotes the subregion $\view$ it characterises. Transformations on
  $\view$ can be performed without affecting the parts of $\src$ outside the hatched area. The lens
  signature consists of a pair of functions $\lget_X : \src \Rightarrow \view$ that extracts a view
  from a source, and $\lput_X : \src \Rightarrow \view \Rightarrow \src$ that updates a view within
  a given source. ›

named_theorems lens_defs

text @{text lens_source} gives the set of constructible sources; that is those that can be built
  by putting a value into an arbitrary source. ›

definition lens_source :: "('a  'b)  'b set" ("𝒮ı") where
"lens_source X = {s.  v s'. s = putX s' v}"

abbreviation some_source :: "('a  'b)  'b" ("srcı") where
"some_source X  (SOME s. s  𝒮X)"

definition lens_create :: "('a  'b)  'a  'b" ("createı") where
[lens_defs]: "createX v = putX (srcX) v"

text ‹ Function $\lcreate_X~v$ creates an instance of the source type of $X$ by injecting $v$
  as the view, and leaving the remaining context arbitrary. ›
    
definition lens_update :: "('a  'b)  ('a  'a)  ('b  'b)" ("updateı") where
[lens_defs]: "lens_update X f σ = putX σ (f (getX σ))"

text ‹ The update function is analogous to the record update function which lifts a function
  on a view type to one on the source type. ›

definition lens_obs_eq :: "('b  'a)  'a  'a  bool" (infix "ı" 50) where
[lens_defs]: "s1 X s2 = (s1 = putX s2 (getX s1))"

text ‹ This relation states that two sources are equivalent outside of the region characterised
  by lens $X$. ›

definition lens_override :: "('b  'a)  'a  'a  'a" (infixl "ı" 95) where
[lens_defs]: "S1 X S2 = putX S1 (getX S2)"

abbreviation (input) lens_override' :: "'a  'a  ('b  'a)  'a" ("_ L _ on _" [95,0,96] 95) where
"S1 L S2 on X  S1 X S2"

text ‹Lens override uses a lens to replace part of a source type with a given value for the
  corresponding view.›

subsection ‹Weak Lenses›

text ‹ Weak lenses are the least constrained class of lenses in our algebraic hierarchy. They
  simply require that the PutGet law~\cite{Foster09,Fischer2015} is satisfied, meaning that
  $\lget$ is the inverse of $\lput$. ›

locale weak_lens =
  fixes x :: "'a  'b" (structure)
  assumes put_get: "get (put σ v) = v"
begin
  lemma source_nonempty: " s. s  𝒮"
    by (auto simp add: lens_source_def)

  lemma put_closure: "put σ v  𝒮"
    by (auto simp add: lens_source_def)

  lemma create_closure: "create v  𝒮"
    by (simp add: lens_create_def put_closure)

  lemma src_source [simp]: "src  𝒮"
    using some_in_eq source_nonempty by auto

  lemma create_get: "get (create v) = v"
    by (simp add: lens_create_def put_get)

  lemma create_inj: "inj create"
    by (metis create_get injI)

  lemma get_update: "get (update f σ) = f (get σ)"
    by (simp add: put_get lens_update_def)

  lemma view_determination: 
    assumes "put σ u = put ρ v"
    shows "u = v"
    by (metis assms put_get)
    
  lemma put_inj: "inj (put σ)"
    by (simp add: injI view_determination)

end

declare weak_lens.put_get [simp]
declare weak_lens.create_get [simp]

subsection ‹Well-behaved Lenses›

text ‹ Well-behaved lenses add to weak lenses that requirement that the GetPut law~\cite{Foster09,Fischer2015}
  is satisfied, meaning that $\lput$ is the inverse of $\lget$. ›

locale wb_lens = weak_lens +
  assumes get_put: "put σ (get σ) = σ"
begin

  lemma put_twice: "put (put σ v) v = put σ v"
    by (metis get_put put_get)

  lemma put_surjectivity: " ρ v. put ρ v = σ"
    using get_put by blast

  lemma source_stability: " v. put σ v = σ"
    using get_put by auto

  lemma source_UNIV [simp]: "𝒮 = UNIV"
    by (metis UNIV_eq_I put_closure wb_lens.source_stability wb_lens_axioms)

end

declare wb_lens.get_put [simp]

lemma wb_lens_weak [simp]: "wb_lens x  weak_lens x"
  by (simp add: wb_lens_def)

subsection ‹ Mainly Well-behaved Lenses ›

text ‹ Mainly well-behaved lenses extend weak lenses with the PutPut law that shows how one put
  override a previous one. ›

locale mwb_lens = weak_lens +
  assumes put_put: "put (put σ v) u = put σ u"
begin

  lemma update_comp: "update f (update g σ) = update (f  g) σ"
    by (simp add: put_get put_put lens_update_def)

  text ‹ Mainly well-behaved lenses give rise to a weakened version of the $get-put$ law, 
    where the source must be within the set of constructible sources. ›

  lemma weak_get_put: "σ  𝒮  put σ (get σ) = σ"
    by (auto simp add: lens_source_def put_get put_put)

  lemma weak_source_determination:
    assumes "σ  𝒮" "ρ  𝒮" "get σ = get ρ" "put σ v = put ρ v"
    shows "σ = ρ"
    by (metis assms put_put weak_get_put)

   lemma weak_put_eq:
     assumes "σ  𝒮" "get σ = k" "put σ u = put ρ v"
     shows "put ρ k = σ"
     by (metis assms put_put weak_get_put)

  text ‹ Provides $s$ is constructible, then @{term get} can be uniquely determined from @{term put}

  lemma weak_get_via_put: "s  𝒮  get s = (THE v. put s v = s)"
    by (rule sym, auto intro!: the_equality weak_get_put, metis put_get)

end

abbreviation (input) "partial_lens  mwb_lens"

declare mwb_lens.put_put [simp]
declare mwb_lens.weak_get_put [simp]

lemma mwb_lens_weak [simp]:
  "mwb_lens x  weak_lens x"
  by (simp add: mwb_lens.axioms(1))

subsection ‹Very Well-behaved Lenses›

text ‹Very well-behaved lenses combine all three laws, as in the literature~\cite{Foster09,Fischer2015}.
  The same set of axioms can be found in Back and von Wright's refinement calculus~\cite{Back1998}, 
  though with different names for the functions. ›

locale vwb_lens = wb_lens + mwb_lens
begin

  lemma source_determination:
    assumes "get σ = get ρ" "put σ v = put ρ v"
    shows "σ = ρ"
    by (metis assms get_put put_put)
    
 lemma put_eq:
   assumes "get σ = k" "put σ u = put ρ v"
   shows "put ρ k = σ"
   using assms weak_put_eq[of σ k u ρ v] by (simp)

  text @{term get} can be uniquely determined from @{term put}

  lemma get_via_put: "get s = (THE v. put s v = s)"
    by (simp add: weak_get_via_put)

  lemma get_surj: "surj get"
    by (metis put_get surjI)

  text ‹ Observation equivalence is an equivalence relation. ›

  lemma lens_obs_equiv: "equivp (≃)"
  proof (rule equivpI)
    show "reflp (≃)"
      by (rule reflpI, simp add: lens_obs_eq_def get_put)
    show "symp (≃)"
      by (rule sympI, simp add: lens_obs_eq_def, metis get_put put_put)
    show "transp (≃)"
      by (rule transpI, simp add: lens_obs_eq_def, metis put_put)
  qed

end

abbreviation (input) "total_lens  vwb_lens"

lemma vwb_lens_wb [simp]: "vwb_lens x  wb_lens x"
  by (simp add: vwb_lens_def)

lemma vwb_lens_mwb [simp]: "vwb_lens x  mwb_lens x"
  using vwb_lens_def by auto

lemma mwb_UNIV_src_is_vwb_lens: 
  " mwb_lens X; 𝒮X = UNIV   vwb_lens X"
  using vwb_lens_def wb_lens_axioms_def wb_lens_def by fastforce

text ‹ Alternative characterisation: a very well-behaved (i.e. total) lens is a mainly well-behaved
  (i.e. partial) lens whose source is the universe set. ›

lemma vwb_lens_iff_mwb_UNIV_src: 
  "vwb_lens X  (mwb_lens X  𝒮X = UNIV)"
  by (meson mwb_UNIV_src_is_vwb_lens vwb_lens_def wb_lens.source_UNIV)

subsection ‹ Ineffectual Lenses ›

text ‹Ineffectual lenses can have no effect on the view type -- application of the $\lput$ function
  always yields the same source. They are thus, trivially, very well-behaved lenses.›

locale ief_lens = weak_lens +
  assumes put_inef: "put σ v = σ"
begin

sublocale vwb_lens
proof
  fix σ v u
  show "put σ (get σ) = σ"
    by (simp add: put_inef)
  show "put (put σ v) u = put σ u"
    by (simp add: put_inef)
qed

lemma ineffectual_const_get:
  " v.   σ𝒮. get σ = v"
  using put_get put_inef by auto

end

abbreviation "eff_lens X  (weak_lens X  (¬ ief_lens X))"

subsection ‹ Partially Bijective Lenses ›

locale pbij_lens = weak_lens +
  assumes put_det: "put σ v = put ρ v"
begin

  sublocale mwb_lens
  proof
    fix σ v u
    show "put (put σ v) u = put σ u"
      using put_det by blast
  qed
  
  lemma put_is_create: "put σ v = create v"
    by (simp add: lens_create_def put_det)

  lemma partial_get_put: "ρ  𝒮  put σ (get ρ) = ρ"
    by (metis put_det weak_get_put)

end

lemma pbij_lens_weak [simp]:
  "pbij_lens x  weak_lens x"
  by (simp_all add: pbij_lens_def)

lemma pbij_lens_mwb [simp]: "pbij_lens x  mwb_lens x"
  by (simp add: mwb_lens_axioms.intro mwb_lens_def pbij_lens.put_is_create)

lemma pbij_alt_intro:
  " weak_lens X;  s. s  𝒮X  createX (getX s) = s   pbij_lens X"
  by (metis pbij_lens_axioms_def pbij_lens_def weak_lens.put_closure weak_lens.put_get)

subsection ‹ Bijective Lenses ›

text ‹Bijective lenses characterise the situation where the source and view type are equivalent:
  in other words the view type full characterises the whole source type. It is often useful
  when the view type and source type are syntactically different, but nevertheless correspond
  precisely in terms of what they observe. Bijective lenses are formulates using
  the strong GetPut law~\cite{Foster09,Fischer2015}.›

locale bij_lens = weak_lens +
  assumes strong_get_put: "put σ (get ρ) = ρ"
begin

sublocale pbij_lens
proof
  fix σ v ρ
  show "put σ v = put ρ v"
    by (metis put_get strong_get_put)
qed

sublocale vwb_lens
proof
  fix σ v u
  show "put σ (get σ) = σ"
    by (simp add: strong_get_put)
qed

  lemma put_bij: "bij_betw (put σ) UNIV UNIV"
    by (metis bijI put_inj strong_get_put surj_def)

  lemma get_create: "create (get σ) = σ"
    by (simp add: lens_create_def strong_get_put)
    
end

declare bij_lens.strong_get_put [simp]
declare bij_lens.get_create [simp]

lemma bij_lens_weak [simp]:
  "bij_lens x  weak_lens x"
  by (simp_all add: bij_lens_def)

lemma bij_lens_pbij [simp]:
  "bij_lens x  pbij_lens x"
  by (metis bij_lens.get_create bij_lens_def pbij_lens_axioms.intro pbij_lens_def weak_lens.put_get)

lemma bij_lens_vwb [simp]: "bij_lens x  vwb_lens x"
  by (metis bij_lens.strong_get_put bij_lens_weak mwb_lens.intro mwb_lens_axioms.intro vwb_lens_def wb_lens.intro wb_lens_axioms.intro weak_lens.put_get)

text ‹ Alternative characterisation: a bijective lens is a partial bijective lens that is also
  very well-behaved (i.e. total). ›

lemma pbij_vwb_is_bij_lens:
  " pbij_lens X; vwb_lens X   bij_lens X"
  by (unfold_locales, simp_all, meson pbij_lens.put_det vwb_lens.put_eq)

lemma bij_lens_iff_pbij_vwb:
  "bij_lens X  (pbij_lens X  vwb_lens X)"
  using pbij_vwb_is_bij_lens by auto

subsection ‹Lens Independence›

text ‹ 
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Independence}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Independence}
  \label{fig:Indep}
  \end{figure}

  Lens independence shows when two lenses $X$ and $Y$ characterise disjoint regions of the
  source type, as illustrated in Figure~\ref{fig:Indep}. We specify this by requiring that the $\lput$ 
  functions of the two lenses commute, and that the $\lget$ function of each lens is unaffected by 
  application of $\lput$ from the corresponding lens. ›

locale lens_indep =
  fixes X :: "'a  'c" and Y :: "'b  'c"
  assumes lens_put_comm: "putX (putY σ v) u = putY (putX σ u) v"
  and lens_put_irr1: "getX (putY σ v) = getX σ"
  and lens_put_irr2: "getY (putX σ u) = getY σ"

notation lens_indep (infix "" 50)

lemma lens_indepI:
  "  u v σ. putx (puty σ v) u = puty (putx σ u) v;
      v σ. getx (puty σ v) = getx σ;
      u σ. gety (putx σ u) = gety σ   x  y"
  by (simp add: lens_indep_def)

text ‹Lens independence is symmetric.›

lemma lens_indep_sym:  "x  y  y  x"
  by (simp add: lens_indep_def)

lemma lens_indep_comm:
  "x  y  putx (puty σ v) u = puty (putx σ u) v"
  by (simp add: lens_indep_def)

lemma lens_indep_get [simp]:
  assumes "x  y"
  shows "getx (puty σ v) = getx σ"
  using assms lens_indep_def by fastforce

text ‹ Characterisation of independence for two very well-behaved lenses ›

lemma lens_indep_vwb_iff:
  assumes "vwb_lens x" "vwb_lens y"
  shows "x  y  ( u v σ. putx (puty σ v) u = puty (putx σ u) v)"
proof
  assume "x  y"
  thus " u v σ. putx (puty σ v) u = puty (putx σ u) v"
    by (simp add: lens_indep_comm)
next
  assume a: " u v σ. putx (puty σ v) u = puty (putx σ u) v"
  show "x  y"
  proof (unfold_locales)
    fix σ v u
    from a show "putx (puty σ v) u = puty (putx σ u) v" 
      by auto
    show "getx (puty σ v) = getx σ"
      by (metis a assms(1) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
    show "gety (putx σ u) = gety σ"
      by (metis a assms(2) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
  qed
qed

subsection ‹ Lens Compatibility ›

text ‹ Lens compatibility is a weaker notion than independence. It allows that two lenses can overlap
  so long as they manipulate the source in the same way in that region. It is most easily defined
  in terms of a function for copying a region from one source to another using a lens. ›

definition lens_compat (infix "##L" 50) where
[lens_defs]: "lens_compat X Y = (s1 s2. s1 X s2 Y s2 = s1 Y s2 X s2)"

lemma lens_compat_idem [simp]: "x ##L x"
  by (simp add: lens_defs)

lemma lens_compat_sym: "x ##L y  y ##L x"
  by (simp add: lens_defs)

lemma lens_indep_compat [simp]: "x  y  x ##L y"
  by (simp add: lens_override_def lens_compat_def lens_indep_comm)

end

Theory Lens_Algebra

section ‹Lens Algebraic Operators›

theory Lens_Algebra
imports Lens_Laws
begin

subsection ‹Lens Composition, Plus, Unit, and Identity›

text ‹
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Composition}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Composition}
  \label{fig:Comp}
  \end{figure}
  We introduce the algebraic lens operators; for more information please see our paper~\cite{Foster16a}.
  Lens composition, illustrated in Figure~\ref{fig:Comp}, constructs a lens by composing the source 
  of one lens with the view of another.›

definition lens_comp :: "('a  'b)  ('b  'c)  ('a  'c)" (infixl ";L" 80) where
[lens_defs]: "lens_comp Y X =  lens_get = getY  lens_get X
                              , lens_put = (λ σ v. lens_put X σ (lens_put Y (lens_get X σ) v)) "

text ‹
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Sum}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Sum}
  \label{fig:Sum}
  \end{figure}
  Lens plus, as illustrated in Figure~\ref{fig:Sum} parallel composes two independent lenses, 
  resulting in a lens whose view is the product of the two underlying lens views.›

definition lens_plus :: "('a  'c)  ('b  'c)  'a × 'b  'c" (infixr "+L" 75) where
[lens_defs]: "X +L Y =  lens_get = (λ σ. (lens_get X σ, lens_get Y σ))
                       , lens_put = (λ σ (u, v). lens_put X (lens_put Y σ v) u) "

text ‹The product functor lens similarly parallel composes two lenses, but in this case the lenses
  have different sources and so the resulting source is also a product.›

definition lens_prod :: "('a  'c)  ('b  'd)  ('a × 'b  'c × 'd)" (infixr "×L" 85) where
[lens_defs]: "lens_prod X Y =  lens_get = map_prod getX getY
                              , lens_put = λ (u, v) (x, y). (putX u x, putY v y) "

text ‹The $\lfst$ and $\lsnd$ lenses project the first and second elements, respectively, of a
  product source type.›

definition fst_lens :: "'a  'a × 'b" ("fstL") where
[lens_defs]: "fstL =  lens_get = fst, lens_put = (λ (σ, ρ) u. (u, ρ)) "

definition snd_lens :: "'b  'a × 'b" ("sndL") where
[lens_defs]: "sndL =  lens_get = snd, lens_put = (λ (σ, ρ) u. (σ, u)) "

lemma get_fst_lens [simp]: "getfstL (x, y) = x"
  by (simp add: fst_lens_def)

lemma get_snd_lens [simp]: "getsndL (x, y) = y"
  by (simp add: snd_lens_def)

text ‹The swap lens is a bijective lens which swaps over the elements of the product source type.›

abbreviation swap_lens :: "'a × 'b  'b × 'a" ("swapL") where
"swapL  sndL +L fstL"

text ‹The zero lens is an ineffectual lens whose view is a unit type. This means the zero lens
  cannot distinguish or change the source type.›

definition zero_lens :: "unit  'a" ("0L") where
[lens_defs]: "0L =  lens_get = (λ _. ()), lens_put = (λ σ x. σ) "

text ‹The identity lens is a bijective lens where the source and view type are the same.›

definition id_lens :: "'a  'a" ("1L") where
[lens_defs]: "1L =  lens_get = id, lens_put = (λ _. id) "

text ‹The quotient operator $X \lquot Y$ shortens lens $X$ by cutting off $Y$ from the end. It is
  thus the dual of the composition operator.›

definition lens_quotient :: "('a  'c)  ('b  'c)  'a  'b" (infixr "'/L" 90) where
[lens_defs]: "X /L Y =  lens_get = λ σ. getX (createY σ)
                       , lens_put = λ σ v. getY (putX (createY σ) v) "

text ‹Lens inverse take a bijective lens and swaps the source and view types.›

definition lens_inv :: "('a  'b)  ('b  'a)" ("invL") where
[lens_defs]: "lens_inv x =  lens_get = createx, lens_put = λ σ. getx "

subsection ‹Closure Poperties›

text ‹We show that the core lenses combinators defined above are closed under the key lens classes.›
  
lemma id_wb_lens: "wb_lens 1L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma source_id_lens: "𝒮1L = UNIV"
  by (simp add: id_lens_def lens_source_def)

lemma unit_wb_lens: "wb_lens 0L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma source_zero_lens: "𝒮0L = UNIV"
  by (simp_all add: zero_lens_def lens_source_def)

lemma comp_weak_lens: " weak_lens x; weak_lens y   weak_lens (x ;L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma comp_wb_lens: " wb_lens x; wb_lens y   wb_lens (x ;L y)"
  by (unfold_locales, auto simp add: lens_comp_def wb_lens_def weak_lens.put_closure)
   
lemma comp_mwb_lens: " mwb_lens x; mwb_lens y   mwb_lens (x ;L y)"
  by (unfold_locales, auto simp add: lens_comp_def mwb_lens_def weak_lens.put_closure)

lemma source_lens_comp: " mwb_lens x; mwb_lens y   𝒮x ;L y = {s  𝒮y. gety s  𝒮x}"
  by (auto simp add: lens_comp_def lens_source_def, blast, metis mwb_lens.put_put mwb_lens_def weak_lens.put_get)

lemma id_vwb_lens [simp]: "vwb_lens 1L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_vwb_lens [simp]: "vwb_lens 0L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_vwb_lens: " vwb_lens x; vwb_lens y   vwb_lens (x ;L y)"
  by (unfold_locales, simp_all add: lens_comp_def weak_lens.put_closure)

lemma unit_ief_lens: "ief_lens 0L"
  by (unfold_locales, simp_all add: zero_lens_def)

text ‹Lens plus requires that the lenses be independent to show closure.›
    
lemma plus_mwb_lens:
  assumes "mwb_lens x" "mwb_lens y" "x  y"
  shows "mwb_lens (x +L y)"
  using assms
  apply (unfold_locales)
   apply (simp_all add: lens_plus_def prod.case_eq_if lens_indep_sym)
  apply (simp add: lens_indep_comm)
done

lemma plus_wb_lens:
  assumes "wb_lens x" "wb_lens y" "x  y"
  shows "wb_lens (x +L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
  apply (simp add: lens_indep_sym prod.case_eq_if)
done

lemma plus_vwb_lens [simp]:
  assumes "vwb_lens x" "vwb_lens y" "x  y"
  shows "vwb_lens (x +L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
   apply (simp add: lens_indep_sym prod.case_eq_if)
  apply (simp add: lens_indep_comm prod.case_eq_if)
done

lemma source_plus_lens:
  assumes "mwb_lens x" "mwb_lens y" "x  y"
  shows "𝒮x +L y = 𝒮x  𝒮y"
  apply (auto simp add: lens_source_def lens_plus_def)
  apply (meson assms(3) lens_indep_comm)
  apply (metis assms(1) mwb_lens.weak_get_put mwb_lens_weak weak_lens.put_closure)
done

lemma prod_mwb_lens:
  " mwb_lens X; mwb_lens Y   mwb_lens (X ×L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_wb_lens:
  " wb_lens X; wb_lens Y   wb_lens (X ×L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_vwb_lens:
  " vwb_lens X; vwb_lens Y   vwb_lens (X ×L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_bij_lens:
  " bij_lens X; bij_lens Y   bij_lens (X ×L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma fst_vwb_lens: "vwb_lens fstL"
  by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if)

lemma snd_vwb_lens: "vwb_lens sndL"
  by (unfold_locales, simp_all add: snd_lens_def prod.case_eq_if)

lemma id_bij_lens: "bij_lens 1L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma inv_id_lens: "invL 1L = 1L"
  by (auto simp add: lens_inv_def id_lens_def lens_create_def)

lemma inv_inv_lens: "bij_lens X  invL (invL X) = X"
  apply (cases X)
  apply (auto simp add: lens_defs fun_eq_iff)
  apply (metis (no_types) bij_lens.strong_get_put bij_lens_def select_convs(2) weak_lens.put_get)
  done

lemma lens_inv_bij: "bij_lens X  bij_lens (invL X)"
  by (unfold_locales, simp_all add: lens_inv_def lens_create_def)

lemma swap_bij_lens: "bij_lens swapL"
  by (unfold_locales, simp_all add: lens_plus_def prod.case_eq_if fst_lens_def snd_lens_def)

subsection ‹Composition Laws›

text ‹Lens composition is monoidal, with unit @{term "1L"}, as the following theorems demonstrate. 
  It also has @{term "0L"} as a right annihilator. ›
  
lemma lens_comp_assoc: "X ;L (Y ;L Z) = (X ;L Y) ;L Z"
  by (auto simp add: lens_comp_def)

lemma lens_comp_left_id [simp]: "1L ;L X = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_right_id [simp]: "X ;L 1L = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_anhil [simp]: "wb_lens X  0L ;L X = 0L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

lemma lens_comp_anhil_right [simp]: "wb_lens X  X ;L 0L = 0L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

subsection ‹Independence Laws›

text ‹The zero lens @{term "0L"} is independent of any lens. This is because nothing can be observed
  or changed using @{term "0L"}. ›
  
lemma zero_lens_indep [simp]: "0L  X"
  by (auto simp add: zero_lens_def lens_indep_def)

lemma zero_lens_indep' [simp]: "X  0L"
  by (auto simp add: zero_lens_def lens_indep_def)

text ‹Lens independence is irreflexive, but only for effectual lenses as otherwise nothing can
  be observed.›
    
lemma lens_indep_quasi_irrefl: " wb_lens x; eff_lens x   ¬ (x  x)"
  by (auto simp add: lens_indep_def ief_lens_def ief_lens_axioms_def, metis (full_types) wb_lens.get_put)

text ‹Lens independence is a congruence with respect to composition, as the following properties demonstrate.›
    
lemma lens_indep_left_comp [simp]:
  " mwb_lens z; x  y   (x ;L z)  (y ;L z)"
  apply (rule lens_indepI)
    apply (auto simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_comp:
  "y  z  (x ;L y)  (x ;L z)"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
    using lens_indep_comm lens_indep_sym apply fastforce
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_left_ext [intro]:
  "y  z  (x ;L y)  z"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_ext [intro]:
  "x  z  x  (y ;L z)"
  by (simp add: lens_indep_left_ext lens_indep_sym)

lemma lens_comp_indep_cong_left:
  " mwb_lens Z; X ;L Z  Y ;L Z   X  Y"
  apply (rule lens_indepI)
    apply (rename_tac u v σ)
    apply (drule_tac u=u and v=v and σ="createZ σ" in lens_indep_comm)
    apply (simp add: lens_comp_def)
    apply (meson mwb_lens_weak weak_lens.view_determination)
   apply (rename_tac v σ)
   apply (drule_tac v=v and σ="createZ σ" in lens_indep_get)
   apply (simp add: lens_comp_def)
  apply (drule lens_indep_sym)
  apply (rename_tac u σ)
  apply (drule_tac v=u and σ="createZ σ" in lens_indep_get)
  apply (simp add: lens_comp_def)
done

lemma lens_comp_indep_cong:
  "mwb_lens Z  (X ;L Z)  (Y ;L Z)  X  Y"
  using lens_comp_indep_cong_left lens_indep_left_comp by blast

text ‹The first and second lenses are independent since the view different parts of a product source.›
    
lemma fst_snd_lens_indep [simp]:
  "fstL  sndL"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma snd_fst_lens_indep [simp]:
  "sndL  fstL"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma split_prod_lens_indep:
  assumes "mwb_lens X"
  shows "(fstL ;L X)  (sndL ;L X)"
  using assms fst_snd_lens_indep lens_indep_left_comp vwb_lens_mwb by blast
    
text ‹Lens independence is preserved by summation.›
    
lemma plus_pres_lens_indep [simp]: " X  Z; Y  Z   (X +L Y)  Z"
  apply (rule lens_indepI)
    apply (simp_all add: lens_plus_def prod.case_eq_if)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma plus_pres_lens_indep' [simp]:
  " X  Y; X  Z   X  Y +L Z"
  by (auto intro: lens_indep_sym plus_pres_lens_indep)

text ‹Lens independence is preserved by product.›
    
lemma lens_indep_prod:
  " X1  X2; Y1  Y2   X1 ×L Y1  X2 ×L Y2"
  apply (rule lens_indepI)
    apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def)
   apply (simp_all add: lens_indep_sym)
  done

subsection ‹ Compatibility Laws ›

lemma zero_lens_compat [simp]: "0L ##L X"
  by (auto simp add: zero_lens_def lens_override_def lens_compat_def)

lemma id_lens_compat [simp]: "vwb_lens X  1L ##L X"
  by (auto simp add: id_lens_def lens_override_def lens_compat_def)

subsection ‹Algebraic Laws›

text ‹Lens plus distributes to the right through composition.›
  
lemma plus_lens_distr: "mwb_lens Z  (X +L Y) ;L Z = (X ;L Z) +L (Y ;L Z)"
  by (auto simp add: lens_comp_def lens_plus_def comp_def)

text ‹The first lens projects the first part of a summation.›
  
lemma fst_lens_plus:
  "wb_lens y  fstL ;L (x +L y) = x"
  by (simp add: fst_lens_def lens_plus_def lens_comp_def comp_def)

text ‹The second law requires independence as we have to apply x first, before y›

lemma snd_lens_plus:
  " wb_lens x; x  y   sndL ;L (x +L y) = y"
  apply (simp add: snd_lens_def lens_plus_def lens_comp_def comp_def)
  apply (subst lens_indep_comm)
   apply (simp_all)
done

text ‹The swap lens switches over a summation.›
  
lemma lens_plus_swap:
  "X  Y  swapL ;L (X +L Y) = (Y +L X)"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def lens_comp_def lens_indep_comm)

text ‹The first, second, and swap lenses are all closely related.›
    
lemma fst_snd_id_lens: "fstL +L sndL = 1L"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def)

lemma swap_lens_idem: "swapL ;L swapL = 1L"
  by (simp add: fst_snd_id_lens lens_indep_sym lens_plus_swap)

lemma swap_lens_fst: "fstL ;L swapL = sndL"
  by (simp add: fst_lens_plus fst_vwb_lens)

lemma swap_lens_snd: "sndL ;L swapL = fstL"
  by (simp add: lens_indep_sym snd_lens_plus snd_vwb_lens)

text ‹The product lens can be rewritten as a sum lens.›
    
lemma prod_as_plus: "X ×L Y = X ;L fstL +L Y ;L sndL"
  by (auto simp add: lens_prod_def fst_lens_def snd_lens_def lens_comp_def lens_plus_def)

lemma prod_lens_id_equiv:
  "1L ×L 1L = 1L"
  by (auto simp add: lens_prod_def id_lens_def)

lemma prod_lens_comp_plus:
  "X2  Y2  ((X1 ×L Y1) ;L (X2 +L Y2)) = (X1 ;L X2) +L (Y1 ;L Y2)"
  by (auto simp add: lens_comp_def lens_plus_def lens_prod_def prod.case_eq_if fun_eq_iff)

text ‹The following laws about quotient are similar to their arithmetic analogues. Lens quotient 
  reverse the effect of a composition.›

lemma lens_comp_quotient:
  "weak_lens Y  (X ;L Y) /L Y = X"
  by (simp add: lens_quotient_def lens_comp_def)
    
lemma lens_quotient_id [simp]: "weak_lens X  (X /L X) = 1L"
  by (force simp add: lens_quotient_def id_lens_def)

lemma lens_quotient_id_denom: "X /L 1L = X"
  by (simp add: lens_quotient_def id_lens_def lens_create_def)

lemma lens_quotient_unit: "weak_lens X  (0L /L X) = 0L"
  by (simp add: lens_quotient_def zero_lens_def)

lemma lens_obs_eq_zero: "s1 0L s2 = (s1 = s2)"
  by (simp add: lens_defs)

lemma lens_obs_eq_one: "s1 1L s2"
  by (simp add: lens_defs)

lemma lens_obs_eq_as_override: "vwb_lens X  s1 X s2  (s2 = s1 L s2 on X)"
  by (auto simp add: lens_defs; metis vwb_lens.put_eq)

end

Theory Lens_Order

section ‹Order and Equivalence on Lenses›

theory Lens_Order
imports Lens_Algebra
begin

subsection ‹Sub-lens Relation›
  
text ‹A lens $X$ is a sub-lens of $Y$ if there is a well-behaved lens $Z$ such that $X = Z \lcomp Y$,
  or in other words if $X$ can be expressed purely in terms of $Y$.›

definition sublens :: "('a  'c)  ('b  'c)  bool" (infix "L" 55) where
[lens_defs]: "sublens X Y = ( Z :: ('a, 'b) lens. vwb_lens Z  X = Z ;L Y)"

text ‹Various lens classes are downward closed under the sublens relation.›

lemma sublens_pres_mwb:
  " mwb_lens Y; X L Y   mwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_wb:
  " wb_lens Y; X L Y   wb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_vwb:
  " vwb_lens Y; X L Y   vwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

text ‹Sublens is a preorder as the following two theorems show.›
    
lemma sublens_refl [simp]:
  "X L X"
  using id_vwb_lens sublens_def by fastforce

lemma sublens_trans [trans]:
  " X L Y; Y L Z   X L Z"
  apply (auto simp add: sublens_def lens_comp_assoc)
  apply (rename_tac Z1 Z2)
  apply (rule_tac x="Z1 ;L Z2" in exI)
  apply (simp add: lens_comp_assoc)
  using comp_vwb_lens apply blast
done

text ‹Sublens has a least element -- @{text "0L"} -- and a greatest element -- @{text "1L"}. 
  Intuitively, this shows that sublens orders how large a portion of the source type a particular
  lens views, with @{text "0L"} observing the least, and @{text "1L"} observing the most.›
  
lemma sublens_least: "wb_lens X  0L L X"
  using sublens_def unit_vwb_lens by fastforce

lemma sublens_greatest: "vwb_lens X  X L 1L"
  by (simp add: sublens_def)

text ‹If $Y$ is a sublens of $X$ then any put using $X$ will necessarily erase any put using $Y$.
  Similarly, any two source types are observationally equivalent by $Y$ when performed
  following a put using $X$.›
    
lemma sublens_put_put:
  " mwb_lens X; Y L X   putX (putY σ v) u = putX σ u"
  by (auto simp add: sublens_def lens_comp_def)

lemma sublens_obs_get:
  " mwb_lens X; Y L X    getY (putX σ v) = getY (putX ρ v)"
  by (auto simp add: sublens_def lens_comp_def)

text ‹Sublens preserves independence; in other words if $Y$ is independent of $Z$, then also
  any $X$ smaller than $Y$ is independent of $Z$.›
    
lemma sublens_pres_indep:
  " X L Y; Y  Z   X  Z"
  apply (auto intro!:lens_indepI simp add: sublens_def lens_comp_def lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma sublens_pres_indep':
  " X L Y; Z  Y   Z  X"
  by (meson lens_indep_sym sublens_pres_indep)

lemma sublens_compat: " vwb_lens X; vwb_lens Y; X L Y   X ##L Y"
  unfolding lens_compat_def lens_override_def
  by (metis (no_types, hide_lams) sublens_obs_get sublens_put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)

text ‹Well-behavedness of lens quotient has sublens as a proviso. This is because we can only
  remove $X$ from $Y$ if $X$ is smaller than $Y$. ›
  
lemma lens_quotient_mwb:
  " mwb_lens Y; X L Y   mwb_lens (X /L Y)"
  by (unfold_locales, auto simp add: lens_quotient_def lens_create_def sublens_def lens_comp_def comp_def)

subsection ‹Lens Equivalence›
    
text ‹Using our preorder, we can also derive an equivalence on lenses as follows. It should be
  noted that this equality, like sublens, is heterogeneously typed -- it can compare lenses whose
  view types are different, so long as the source types are the same. We show that it is reflexive, 
  symmetric, and transitive. ›
    
definition lens_equiv :: "('a  'c)  ('b  'c)  bool" (infix "L" 51) where
[lens_defs]: "lens_equiv X Y = (X L Y  Y L X)"

lemma lens_equivI [intro]:
  " X L Y; Y L X   X L Y"
  by (simp add: lens_equiv_def)

lemma lens_equiv_refl:
  "X L X"
  by (simp add: lens_equiv_def)

lemma lens_equiv_sym:
  "X L Y  Y L X"
  by (simp add: lens_equiv_def)

lemma lens_equiv_trans [trans]:
  " X L Y; Y L Z   X L Z"
  by (auto intro: sublens_trans simp add: lens_equiv_def)

lemma lens_equiv_pres_indep:
  " X L Y; Y  Z   X  Z"
  using lens_equiv_def sublens_pres_indep by blast

lemma lens_equiv_pres_indep':
  " X L Y; Z  Y   Z  X"
  using lens_equiv_def sublens_pres_indep' by blast

lemma lens_comp_cong_1: "X L Y  X ;L Z L Y ;L Z"
  unfolding lens_equiv_def
  by (metis (no_types, lifting) lens_comp_assoc sublens_def)

subsection ‹Further Algebraic Laws›

text ‹This law explains the behaviour of lens quotient.›

lemma lens_quotient_comp:
  " weak_lens Y; X L Y   (X /L Y) ;L Y = X"
  by (auto simp add: lens_quotient_def lens_comp_def comp_def sublens_def)

text ‹Plus distributes through quotient.›
    
lemma lens_quotient_plus:
  " mwb_lens Z; X L Z; Y L Z   (X +L Y) /L Z = (X /L Z) +L (Y /L Z)"
  apply (auto simp add: lens_quotient_def lens_plus_def sublens_def lens_comp_def comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (simp add: prod.case_eq_if)
done

text ‹Laws for for lens plus on the denominator. These laws allow us to extract compositions
  of @{term "fstL"} and @{term "sndL"} terms. ›

lemma lens_quotient_plus_den1: 
  " weak_lens x; weak_lens y; x  y   x /L (x +L y) = fstL"
  by (auto simp add: lens_defs prod.case_eq_if fun_eq_iff, metis (lifting) lens_indep_def weak_lens.put_get)

lemma lens_quotient_plus_den2: " weak_lens x; weak_lens z; x  z; y L z   y /L (x +L z) = (y /L z) ;L sndL "
  by (auto simp add: lens_defs prod.case_eq_if fun_eq_iff lens_indep.lens_put_irr2)

text ‹There follows a number of laws relating sublens and summation. Firstly, sublens is preserved
  by summation. ›
  
lemma plus_pred_sublens: " mwb_lens Z; X L Z; Y L Z; X  Y   (X +L Y) L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z1 Z2)
  apply (rule_tac x="Z1 +L Z2" in exI)
  apply (auto intro!: plus_wb_lens)
   apply (simp add: lens_comp_indep_cong_left plus_vwb_lens)
  apply (simp add: plus_lens_distr)
done

text ‹Intuitively, lens plus is associative. However we cannot prove this using HOL equality due
  to monomorphic typing of this operator. But since sublens and lens equivalence are both heterogeneous
  we can now prove this in the following three lemmas.›
  
lemma lens_plus_sub_assoc_1:
  "X +L Y +L Z L (X +L Y) +L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fstL ;L fstL) +L (sndL ;L fstL) +L sndL" in exI)
  apply (auto)
   apply (rule plus_vwb_lens)
     apply (simp add: comp_vwb_lens fst_vwb_lens)
    apply (rule plus_vwb_lens)
      apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
     apply (simp add: snd_vwb_lens)
    apply (simp add: lens_indep_left_ext)
   apply (rule lens_indep_sym)
   apply (rule plus_pres_lens_indep)
    using fst_snd_lens_indep fst_vwb_lens lens_indep_left_comp lens_indep_sym vwb_lens_mwb apply blast
   using fst_snd_lens_indep lens_indep_left_ext lens_indep_sym apply blast
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_sub_assoc_2:
  "(X +L Y) +L Z L X +L Y +L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fstL +L (fstL ;L sndL)) +L (sndL ;L sndL)" in exI)
  apply (auto)
   apply (rule plus_vwb_lens)
     apply (rule plus_vwb_lens)
       apply (simp add: fst_vwb_lens)
      apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
     apply (rule lens_indep_sym)
     apply (rule lens_indep_left_ext)
     using fst_snd_lens_indep lens_indep_sym apply blast
    apply (auto intro: comp_vwb_lens simp add: snd_vwb_lens)
   apply (rule plus_pres_lens_indep)
    apply (simp add: lens_indep_left_ext lens_indep_sym)
   apply (simp add: snd_vwb_lens)
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_assoc:
  "(X +L Y) +L Z L X +L Y +L Z"
  by (simp add: lens_equivI lens_plus_sub_assoc_1 lens_plus_sub_assoc_2)

text ‹We can similarly show that it is commutative.›
    
lemma lens_plus_sub_comm: "X  Y  X +L Y L Y +L X"
  apply (simp add: sublens_def)
  apply (rule_tac x="sndL +L fstL" in exI)
  apply (auto)
   apply (simp add: fst_vwb_lens lens_indep_sym snd_vwb_lens)
  apply (simp add: lens_indep_sym lens_plus_swap)
done

lemma lens_plus_comm: "X  Y  X +L Y L Y +L X"
  by (simp add: lens_equivI lens_indep_sym lens_plus_sub_comm)



text ‹Any composite lens is larger than an element of the lens, as demonstrated by the following
  four laws.›
    
lemma lens_plus_ub [simp]: "wb_lens Y  X L X +L Y"
  by (metis fst_lens_plus fst_vwb_lens sublens_def)

lemma lens_plus_right_sublens:
  " vwb_lens Y; Y  Z; X L Z   X L Y +L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' ;L sndL" in exI)
  apply (auto)
  using comp_vwb_lens snd_vwb_lens apply blast
  apply (metis lens_comp_assoc snd_lens_plus vwb_lens_def)
  done
    
lemma lens_plus_mono_left:
  " Y  Z; X L Y   X +L Z L Y +L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' ×L 1L" in exI)
  apply (subst prod_lens_comp_plus)
   apply (simp_all)
  using id_vwb_lens prod_vwb_lens apply blast
  done
    
lemma lens_plus_mono_right:
  " X  Z; Y L Z   X +L Y L X +L Z"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def sublens_refl)
    
text ‹If we compose a lens $X$ with lens $Y$ then naturally the resulting lens must be smaller
  than $Y$, as $X$ views a part of $Y$. ›
  
lemma lens_comp_lb [simp]: "vwb_lens X  X ;L Y L Y"
  by (auto simp add: sublens_def)

lemma sublens_comp [simp]:
  assumes "vwb_lens b" "c L a"
  shows "(b ;L c) L a"
  by (metis assms sublens_def sublens_trans)

text ‹We can now also show that @{text "0L"} is the unit of lens plus›
    
lemma lens_unit_plus_sublens_1: "X L 0L +L X"
  by (metis lens_comp_lb snd_lens_plus snd_vwb_lens zero_lens_indep unit_wb_lens)

lemma lens_unit_prod_sublens_2: "0L +L X L X"
  apply (auto simp add: sublens_def)
  apply (rule_tac x="0L +L 1L" in exI)
  apply (auto)
  apply (auto simp add: lens_plus_def zero_lens_def lens_comp_def id_lens_def prod.case_eq_if comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (auto)
done

lemma lens_plus_left_unit: "0L +L X L X"
  by (simp add: lens_equivI lens_unit_plus_sublens_1 lens_unit_prod_sublens_2)

lemma lens_plus_right_unit: "X +L 0L L X"
  using lens_equiv_trans lens_indep_sym lens_plus_comm lens_plus_left_unit zero_lens_indep by blast

text ‹We can also show that both sublens and equivalence are congruences with respect to lens plus
  and lens product.›
    
lemma lens_plus_subcong: " Y1  Y2; X1 L Y1; X2 L Y2   X1 +L X2 L Y1 +L Y2"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def)

lemma lens_plus_eq_left: " X  Z; X L Y   X +L Z L Y +L Z"
  by (meson lens_equiv_def lens_plus_mono_left sublens_pres_indep)

lemma lens_plus_eq_right: " X  Y; Y L Z   X +L Y L X +L Z"
  by (meson lens_equiv_def lens_indep_sym lens_plus_mono_right sublens_pres_indep)

lemma lens_plus_cong:
  assumes "X1  X2" "X1 L Y1" "X2 L Y2"
  shows "X1 +L X2 L Y1 +L Y2"
proof -
  have "X1 +L X2 L Y1 +L X2"
    by (simp add: assms(1) assms(2) lens_plus_eq_left)
  moreover have "... L Y1 +L Y2"
    using assms(1) assms(2) assms(3) lens_equiv_def lens_plus_eq_right sublens_pres_indep by blast
  ultimately show ?thesis
    using lens_equiv_trans by blast
qed

lemma prod_lens_sublens_cong:
  " X1 L X2; Y1 L Y2   (X1 ×L Y1) L (X2 ×L Y2)"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z1 Z2)
  apply (rule_tac x="Z1 ×L Z2" in exI)
  apply (auto)
   using prod_vwb_lens apply blast
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
  apply (rule ext, rule ext)
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
done

lemma prod_lens_equiv_cong:
  " X1 L X2; Y1 L Y2   (X1 ×L Y1) L (X2 ×L Y2)"
  by (simp add: lens_equiv_def prod_lens_sublens_cong)

text ‹We also have the following "exchange" law that allows us to switch over a lens product and plus.› 
    
lemma lens_plus_prod_exchange:
  "(X1 +L X2) ×L (Y1 +L Y2) L (X1 ×L Y1) +L (X2 ×L Y2)"
proof (rule lens_equivI)
  show "(X1 +L X2) ×L (Y1 +L Y2) L (X1 ×L Y1) +L (X2 ×L Y2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fstL ;L fstL) +L (fstL ;L sndL)) +L ((sndL ;L fstL) +L (sndL ;L sndL))" in exI)
    apply (auto)
     apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
       apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
    apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: prod.case_eq_if)
  done
  show "(X1 ×L Y1) +L (X2 ×L Y2) L (X1 +L X2) ×L (Y1 +L Y2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fstL ;L fstL) +L (fstL ;L sndL)) +L ((sndL ;L fstL) +L (sndL ;L sndL))" in exI)
    apply (auto)
     apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
       apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
     apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: lens_prod_def prod.case_eq_if)
  done
qed

lemma lens_get_put_quasi_commute:
  " vwb_lens Y; X L Y   getY (putX s v) = putX /L Y (getY s) v"
proof -
  assume a1: "vwb_lens Y"
  assume a2: "X L Y"
  have "l la. putl ;L la = (λb c. putla (b::'b) (putl (getla b::'a) (c::'c)))"
    by (simp add: lens_comp_def)
  then have "l la b c. getl (putla ;L l (b::'b) (c::'c)) = putla (getl b::'a) c  ¬ weak_lens l"
    by force
  then show ?thesis
    using a2 a1 by (metis lens_quotient_comp vwb_lens_wb wb_lens_def)
qed
  
lemma lens_put_of_quotient:
  " vwb_lens Y; X L Y   putY s (putX /L Y v2 v1) = putX (putY s v2) v1"
proof -
  assume a1: "vwb_lens Y"
  assume a2: "X L Y"
  have f3: "l b. putl (b::'b) (getl b::'a) = b  ¬ vwb_lens l"
    by force
  have f4: "b c. putX /L Y (getY b) c = getY (putX b c)"
    using a2 a1 by (simp add: lens_get_put_quasi_commute)
  have "b c a. putY (putX b c) a = putY b a"
    using a2 a1 by (simp add: sublens_put_put)
  then show ?thesis
    using f4 f3 a1 by (metis mwb_lens.put_put mwb_lens_def vwb_lens_mwb weak_lens.put_get)
qed

subsection ‹Bijective Lens Equivalences›
  
text ‹A bijective lens, like a bijective function, is its own inverse. Thus, if we compose its inverse
  with itself we get @{term "1L"}.›
  
lemma bij_lens_inv_left:
  "bij_lens X  invL X ;L X = 1L"
  by (auto simp add: lens_inv_def lens_comp_def lens_create_def comp_def id_lens_def, rule ext, auto)

lemma bij_lens_inv_right:
  "bij_lens X  X ;L invL X = 1L"
  by (auto simp add: lens_inv_def lens_comp_def comp_def id_lens_def, rule ext, auto)

text ‹The following important results shows that bijective lenses are precisely those that are 
  equivalent to identity. In other words, a bijective lens views all of the source type.›

lemma bij_lens_equiv_id:
  "bij_lens X  X L 1L"
  apply (auto)
   apply (rule lens_equivI)
    apply (simp_all add: sublens_def)
   apply (rule_tac x="lens_inv X" in exI)
   apply (simp add: bij_lens_inv_left lens_inv_bij)
  apply (auto simp add: lens_equiv_def sublens_def id_lens_def lens_comp_def comp_def)
  apply (unfold_locales)
   apply (simp)
  apply (simp)
  apply (metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)
done

text ‹For this reason, by transitivity, any two bijective lenses with the same source type must be equivalent.›
  
lemma bij_lens_equiv:
  " bij_lens X; X L Y   bij_lens Y"
  by (meson bij_lens_equiv_id lens_equiv_def sublens_trans)

lemma bij_lens_cong:
  "X L Y  bij_lens X = bij_lens Y"
  by (meson bij_lens_equiv lens_equiv_sym)

text ‹We can also show that the identity lens @{term "1L"} is unique. That is to say it is the only
  lens which when compose with $Y$ will yield $Y$.›
    
lemma lens_id_unique:
  "weak_lens Y  Y = X ;L Y  X = 1L"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
   apply (metis select_convs(1) weak_lens.create_get)
  apply (metis select_convs(1) select_convs(2) weak_lens.put_get)
done

text ‹Consequently, if composition of two lenses $X$ and $Y$ yields @{text "1L"}, then both
  of the composed lenses must be bijective.›
  
lemma bij_lens_via_comp_id_left:
  " wb_lens X; wb_lens Y; X ;L Y = 1L   bij_lens X"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
   apply (simp_all)
   using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

lemma bij_lens_via_comp_id_right:
  " wb_lens X; wb_lens Y; X ;L Y = 1L   bij_lens Y"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
   apply (simp_all)
   using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

text ‹Importantly, an equivalence between two lenses can be demonstrated by showing that one lens
  can be converted to the other by application of a suitable bijective lens $Z$. This $Z$ lens
  converts the view type of one to the view type of the other.›

lemma lens_equiv_via_bij:
  assumes "bij_lens Z" "X = Z ;L Y"
  shows "X L Y"
  using assms
  apply (auto simp add: lens_equiv_def sublens_def)
   using bij_lens_vwb apply blast
  apply (rule_tac x="lens_inv Z" in exI)
  apply (auto simp add: lens_comp_assoc bij_lens_inv_left)
   using bij_lens_vwb lens_inv_bij apply blast
done

text ‹Indeed, we actually have a stronger result than this -- the equivalent lenses are precisely
  those than can be converted to one another through a suitable bijective lens. Bijective lenses
  can thus be seen as a special class of "adapter" lens.›
  
lemma lens_equiv_iff_bij:
  assumes "weak_lens Y"
  shows "X L Y  ( Z. bij_lens Z  X = Z ;L Y)"
  apply (rule iffI)
   apply (auto simp add: lens_equiv_def sublens_def lens_id_unique)[1]
   apply (rename_tac Z1 Z2)
   apply (rule_tac x="Z1" in exI)
   apply (simp)
   apply (subgoal_tac "Z2 ;L Z1 = 1L")
    apply (meson bij_lens_via_comp_id_right vwb_lens_wb)
   apply (metis assms lens_comp_assoc lens_id_unique)
  using lens_equiv_via_bij apply blast
done

lemma pbij_plus_commute:
  " a  b; mwb_lens a; mwb_lens b; pbij_lens (b +L a)   pbij_lens (a +L b)"
  apply (unfold_locales, simp_all add:lens_defs lens_indep_sym prod.case_eq_if)
  using lens_indep.lens_put_comm pbij_lens.put_det apply fastforce
  done

subsection ‹Lens Override Laws›
  
text ‹The following laws are analogus to the equivalent laws for functions.›
  
lemma lens_override_id [simp]:
  "S1 L S2 on 1L = S2"
  by (simp add: lens_override_def id_lens_def)

lemma lens_override_unit [simp]:
  "S1 L S2 on 0L = S1"
  by (simp add: lens_override_def zero_lens_def)

lemma lens_override_overshadow:
  assumes "mwb_lens Y"  "X L Y"
  shows "(S1 L S2 on X) L S3 on Y = S1 L S3 on Y"
  using assms by (simp add: lens_override_def sublens_put_put)

lemma lens_override_irr:
  assumes "X  Y"
  shows "S1 L (S2 L S3 on Y) on X = S1 L S2 on X"
  using assms by (simp add: lens_override_def)

lemma lens_override_overshadow_left:
  assumes "mwb_lens X"
  shows "(S1 L S2 on X) L S3 on X = S1 L S3 on X"
  by (simp add: assms lens_override_def)

lemma lens_override_overshadow_right:
  assumes "mwb_lens X"
  shows "S1 L (S2  L S3 on X) on X = S1 L S3 on X"
  by (simp add: assms lens_override_def)

lemma lens_override_plus:
  "X  Y  S1 L S2 on (X +L Y) = (S1 L S2 on X) L S2 on Y"
  by (simp add: lens_indep_comm lens_override_def lens_plus_def)

lemma lens_override_idem [simp]:
  "vwb_lens X  S L S on X = S"
  by (simp add: lens_override_def)

lemma lens_override_mwb_idem [simp]:
  " mwb_lens X; S  𝒮X   S L S on X = S"
  by (simp add: lens_override_def)

lemma lens_override_put_right_in:
  " vwb_lens A; X L A   S1 L (putX S2 v) on A = putX (S1 L S2 on A) v"
  by (simp add: lens_override_def lens_get_put_quasi_commute lens_put_of_quotient)

lemma lens_override_put_right_out:
  " vwb_lens A; X  A   S1 L (putX S2 v) on A = (S1 L S2 on A)"
  by (simp add: lens_override_def  lens_indep.lens_put_irr2)

lemma lens_indep_overrideI:
  assumes "vwb_lens X" "vwb_lens Y" "( s1 s2 s3. s1 L s2 on X L s3 on Y = s1 L s3 on Y L s2 on X)"
  shows "X  Y"
  using assms
  apply (unfold_locales)
  apply (simp_all add: lens_override_def)
  apply (metis mwb_lens_def vwb_lens_mwb weak_lens.put_get)
  apply (metis lens_override_def lens_override_idem mwb_lens_def vwb_lens_mwb weak_lens.put_get)
  apply (metis mwb_lens_weak vwb_lens_mwb vwb_lens_wb wb_lens.get_put weak_lens.put_get)
  done  

lemma lens_indep_override_def:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X  Y  ( s1 s2 s3. s1 L s2 on X L s3 on Y = s1 L s3 on Y L s2 on X)"
  by (metis assms(1) assms(2) lens_indep_comm lens_indep_overrideI lens_override_def)

text ‹ Alternative characterisation of very-well behaved lenses: override is idempotent. ›

lemma override_idem_implies_vwb:
  " mwb_lens X;  s. s L s on X = s   vwb_lens X"
  by (unfold_locales, simp_all add: lens_defs)

subsection ‹ Alternative Sublens Characterisation ›

text ‹ The following definition is equivalent to the above when the two lenses are very well behaved. ›

definition sublens' :: "('a  'c)  ('b  'c)  bool" (infix "L''" 55) where
[lens_defs]: "sublens' X Y = ( s1 s2 s3. s1 L s2 on Y L s3 on X = s1 L s2 L s3 on X on Y)"

text ‹ We next prove some characteristic properties of our alternative definition of sublens. ›

lemma sublens'_prop1:
  assumes "vwb_lens X" "X L' Y"
  shows "putX (putY s1 (getY s2)) s3 = putY s1 (getY (putX s2 s3))"
  using assms
  by (simp add: sublens'_def, metis lens_override_def mwb_lens_def vwb_lens_mwb weak_lens.put_get)

lemma sublens'_prop2:
  assumes "vwb_lens X" "X L' Y"
  shows "getX (putY s1 (getY s2)) = getX s2"
  using assms unfolding sublens'_def
  by (metis lens_override_def vwb_lens_wb wb_lens_axioms_def wb_lens_def weak_lens.put_get)

lemma sublens'_prop3:
  assumes "vwb_lens X" "vwb_lens Y" "X L' Y"
  shows "putY σ (getY (putX (putY ρ (getY σ)) v)) = putX σ v"
  by (metis assms(1) assms(2) assms(3) mwb_lens_def sublens'_prop1 vwb_lens.put_eq vwb_lens_mwb weak_lens.put_get)

text ‹ Finally we show our two definitions of sublens are equivalent, assuming very well behaved lenses. ›

lemma sublens'_implies_sublens:
  assumes "vwb_lens X" "vwb_lens Y" "X L' Y"
  shows "X L Y"
proof -
  have "vwb_lens (X /L Y)"
    by (unfold_locales
       ,auto simp add: assms lens_quotient_def lens_comp_def lens_create_def sublens'_prop1 sublens'_prop2)
  moreover have "X = X /L Y ;L Y"
  proof -
    have "getX = (λσ. getX (createY σ))  getY"
      by (rule ext, simp add: assms(1) assms(3) lens_create_def sublens'_prop2)
    moreover have "putX = (λσ v. putY σ (getY (putX (createY (getY σ)) v)))"
      by (rule ext, rule ext, simp add: assms(1) assms(2) assms(3) lens_create_def sublens'_prop3)
    ultimately show ?thesis
      by (simp add: lens_quotient_def lens_comp_def)
  qed
  ultimately show ?thesis
    using sublens_def by blast
qed

lemma sublens_implies_sublens':
  assumes "vwb_lens Y" "X L Y"
  shows "X L' Y"
  by (metis assms lens_override_def lens_override_put_right_in sublens'_def)

lemma sublens_iff_sublens':
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X L Y  X L' Y"
  using assms sublens'_implies_sublens sublens_implies_sublens' by blast

subsection ‹ Alternative Equivalence Characterisation ›

definition lens_equiv' :: "('a  'c)  ('b  'c)  bool" (infix "L''" 51) where
[lens_defs]: "lens_equiv' X Y = ( s1 s2. (s1 L s2 on X = s1 L s2 on Y))"

lemma lens_equiv_iff_lens_equiv':
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X L Y  X L' Y"
  apply (simp add: lens_equiv_def sublens_iff_sublens' assms)
  apply (auto simp add: lens_defs assms)
  apply (metis assms(2) mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)
  done

end

Theory Lens_Symmetric

section ‹ Symmetric Lenses ›

theory Lens_Symmetric
  imports Lens_Order
begin

text ‹ A characterisation of Hofmann's ``Symmetric Lenses''~\cite{Hofmann2011}, where
  a lens is accompanied by its complement. ›

record ('a, 'b, 's) slens = 
  view   :: "'a  's" ("𝒱ı") ― ‹ The region characterised ›
  coview :: "'b  's" ("𝒞ı") ― ‹ The complement of the region ›

type_notation
  slens ("<_, _>  _" [0, 0, 0] 0)

declare slens.defs [lens_defs]

definition slens_compl :: "(<'a, 'c>  'b)  <'c, 'a>  'b" ("-L _" [81] 80) where
[lens_defs]: "slens_compl a =  view = coview a, coview = view a "

lemma view_slens_compl [simp]: "𝒱-L a =  𝒞a"
  by (simp add: slens_compl_def)

lemma coview_slens_compl [simp]: "𝒞-L a =  𝒱a"
  by (simp add: slens_compl_def)

subsection ‹ Partial Symmetric Lenses ›

locale psym_lens =
  fixes S :: "<'a, 'b>  's" (structure)
  assumes 
    mwb_region [simp]: "mwb_lens 𝒱" and
    mwb_coregion [simp]: "mwb_lens 𝒞" and
    indep_region_coregion [simp]: "𝒱  𝒞" and
    pbij_region_coregion [simp]: "pbij_lens (𝒱 +L 𝒞)"

declare psym_lens.mwb_region [simp]
declare psym_lens.mwb_coregion [simp]
declare psym_lens.indep_region_coregion [simp]

lemma psym_lens_compl [simp]: "psym_lens a  psym_lens (-L a)"
  apply (simp add: slens_compl_def)
  apply (rule psym_lens.intro)
  apply (simp_all)
  using lens_indep_sym psym_lens.indep_region_coregion apply blast
  using lens_indep_sym pbij_plus_commute psym_lens_def apply blast
  done

subsection ‹ Symmetric Lenses ›

locale sym_lens =
  fixes S :: "<'a, 'b>  's" (structure)
  assumes 
    vwb_region: "vwb_lens 𝒱" and
    vwb_coregion: "vwb_lens 𝒞" and
    indep_region_coregion: "𝒱  𝒞" and
    bij_region_coregion: "bij_lens (𝒱 +L 𝒞)"
begin

sublocale psym_lens
proof (rule psym_lens.intro)
  show "mwb_lens 𝒱"
    by (simp add: vwb_region)
  show "mwb_lens 𝒞"
    by (simp add: vwb_coregion)
  show "𝒱  𝒞"
    using indep_region_coregion by blast
  show "pbij_lens (𝒱 +L 𝒞)"
    by (simp add: bij_region_coregion)
qed

lemma put_region_coregion_cover:
  "put𝒱 (put𝒞 s1 (get𝒞 s2)) (get𝒱 s2) = s2"
proof -
  have "put𝒱 (put𝒞 s1 (get𝒞 s2)) (get𝒱 s2) = put𝒱 +L 𝒞 s1 (get𝒱 +L 𝒞 s2)"
    by (simp add: lens_defs)
  also have "... = s2"
    by (simp add: bij_region_coregion)
  finally show ?thesis .
qed

end

declare sym_lens.vwb_region [simp]
declare sym_lens.vwb_coregion [simp]
declare sym_lens.indep_region_coregion [simp]

lemma sym_lens_psym [simp]: "sym_lens x  psym_lens x"
  by (simp add: psym_lens_def sym_lens.bij_region_coregion)

lemma sym_lens_compl [simp]: "sym_lens a  sym_lens (-L a)"
  apply (simp add: slens_compl_def)
  apply (rule sym_lens.intro, simp_all)
  using lens_indep_sym sym_lens.indep_region_coregion apply blast
  using bij_lens_equiv lens_plus_comm sym_lens_def apply blast
  done

end

Theory Lens_Instances

section ‹Lens Instances›

theory Lens_Instances
  imports Lens_Order Lens_Symmetric "HOL-Eisbach.Eisbach"
  keywords "alphabet" "statespace" :: "thy_defn"
begin

text ‹In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.›

subsection ‹Function Lens›

text ‹A function lens views the valuation associated with a particular domain element @{typ "'a"}.
      We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.›

definition fun_lens :: "'a  ('b::two  ('a  'b))" where
[lens_defs]: "fun_lens x =  lens_get = (λ f. f x), lens_put = (λ f u. f(x := u)) "

lemma fun_vwb_lens: "vwb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

text ‹Two function lenses are independent if and only if the domain elements are different.›
    
lemma fun_lens_indep:
  "fun_lens x  fun_lens y  x  y"
proof -
  obtain u v :: "'a::two" where "u  v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

subsection ‹Function Range Lens›
  
text ‹The function range lens allows us to focus on a particular region of a function's range.›

definition fun_ran_lens :: "('c  'b)  (('a  'b)  )  (('a  'c)  )" where
[lens_defs]: "fun_ran_lens X Y =  lens_get = λ s. getX  getY s
                                 , lens_put = λ s v. putY s (λ x::'a. putX (getY s x) (v x)) "

lemma fun_ran_mwb_lens: " mwb_lens X; mwb_lens Y   mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: " wb_lens X; wb_lens Y   wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: " vwb_lens X; vwb_lens Y   vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection ‹Map Lens›

text ‹The map lens allows us to focus on a particular region of a partial function's range. It
  is only a mainly well-behaved lens because it does not satisfy the PutGet law when the view
  is not in the domain.› 
  
definition map_lens :: "'a  ('b  ('a  'b))" where
[lens_defs]: "map_lens x =  lens_get = (λ f. the (f x)), lens_put = (λ f u. f(x  u)) "

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

lemma source_map_lens: "𝒮map_lens x = {f. x  dom(f)}"
  by (force simp add: map_lens_def lens_source_def)

subsection ‹List Lens›

text ‹The list lens allows us to view a particular element of a list. In order to show it is mainly
  well-behaved we need to define to additional list functions. The following function adds 
  a number undefined elements to the end of a list.›
  
definition list_pad_out :: "'a list  nat  'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

text ‹The following function is like @{term "list_update"} but it adds additional elements to the
  list if the list isn't long enough first.›

definition list_augment :: "'a list  nat  'a  'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

text ‹The following function is like @{term nth} but it expressly returns @{term undefined} when
  the list isn't long enough.›

definition nth' :: "'a list  nat  'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

text ‹We can prove some additional laws about list update and append.›

lemma list_update_append_lemma1: "i < length xs  xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys  xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

text ‹We can also prove some laws about our new operators.›
    
lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = (list_pad_out xs (max i j))[i:=u, j:=v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

lemma list_augment_last [simp]:
  "list_augment (xs @ [y]) (length xs) z = xs @ [z]"
  by (induct xs, simp_all)

lemma list_augment_idem [simp]:
  "i < length xs  list_augment xs i (xs ! i) = xs"
  by (simp add: list_augment_def list_pad_out_def)

text ‹We can now prove that @{term list_augment} is commutative for different (arbitrary) indices.›
  
lemma list_augment_commute:
  "i  j  list_augment (list_augment σ j v) i u = list_augment (list_augment σ i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

text ‹We can also prove that we can always retrieve an element we have added to the list, since
  @{term list_augment} extends the list when necessary. This isn't true of @{term list_update}. ›
    
lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)
    
lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

text ‹ The length is expanded if not already long enough, or otherwise left as it is. ›

lemma length_list_augment_1: "k  length xs  length (list_augment xs k v) = Suc k"
  by (simp add: list_augment_def list_pad_out_def)

lemma length_list_augment_2: "k < length xs  length (list_augment xs k v) = length xs"
  by (simp add: list_augment_def list_pad_out_def)

text ‹We also have it that @{term list_augment} cancels itself.›
    
lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i  j  nth' (list_augment σ i v) j = nth' σ j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

text ‹Finally we can create the list lenses, of which there are three varieties. One that allows
  us to view an index, one that allows us to view the head, and one that allows us to view the tail.
  They are all mainly well-behaved lenses.›
    
definition list_lens :: "nat  ('a::two  'a list)" where
[lens_defs]: "list_lens i =  lens_get = (λ xs. nth' xs i)
                            , lens_put = (λ xs x. list_augment xs i x) "

abbreviation hd_lens ("hdL") where "hd_lens  list_lens 0"

definition tl_lens :: "'a list  'a list" ("tlL") where
[lens_defs]: "tl_lens =  lens_get = (λ xs. tl xs)
                        , lens_put = (λ xs xs'. hd xs # xs') "

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

text ‹ The set of constructible sources is precisely those where the length is greater than the
  given index. ›

lemma source_list_lens: "𝒮list_lens i = {xs. length xs > i}"
  apply (auto simp add: lens_source_def list_lens_def)
   apply (metis length_list_augment_1 length_list_augment_2 lessI not_less)
  apply (metis list_augment_idem)
  done

lemma tail_lens_mwb:
  "mwb_lens tlL"
  by (unfold_locales, simp_all add: tl_lens_def)

lemma source_tail_lens: "𝒮tlL = {xs. xs  []}"
  using list.exhaust_sel by (auto simp add: tl_lens_def lens_source_def)
  
text ‹Independence of list lenses follows when the two indices are different.›
    
lemma list_lens_indep:
  "i  j  list_lens i  list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hdL  tlL"
  apply (rule lens_indepI)
    apply (simp_all add: list_lens_def tl_lens_def)
    apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
   apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis One_nat_def diff_Suc_Suc diff_zero length_0_conv length_list_augment_1 length_tl linorder_not_less list.exhaust list.sel(2) list.sel(3) list_augment_0 not_less_zero)
done

lemma hd_tl_lens_pbij: "pbij_lens (hdL +L tlL)"
  by (unfold_locales, auto simp add: lens_defs)

subsection ‹Record Field Lenses›

text ‹We also add support for record lenses. Every record created can yield a lens for each field.
  These cannot be created generically and thus must be defined case by case as new records are
  created. We thus create a new Isabelle outer syntax command \textbf{alphabet} which enables this. 
  We first create syntax that allows us to obtain a lens from a given field using the internal
  record syntax translations.›
  
abbreviation (input) "fld_put f  (λ σ u. f (λ_. u) σ)"

syntax 
  "_FLDLENS" :: "id  logic"  ("FLDLENS _")
translations 
  "FLDLENS x" => " lens_get = x, lens_put = CONST fld_put (_update_name x) "

text ‹ We also allow the extraction of the "base lens", which characterises all the fields added
  by a record without the extension. ›

syntax
  "_BASELENS" :: "id  logic"  ("BASELENS _")

abbreviation (input) "base_lens t e m   lens_get = t, lens_put = λ s v. e v (m s) "

ML fun baselens_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
    in
      Const (@{const_syntax "base_lens"}, dummyT) $ truncate $ extend $ more
    end
  | baselens_tr _ = raise Match;

parse_translation [(@{syntax_const "_BASELENS"}, K baselens_tr)]  

text ‹We also introduce the \textbf{alphabet} command that creates a record with lenses for each field.
  For each field a lens is created together with a proof that it is very well-behaved, and for each 
  pair of lenses an independence theorem is generated. Alphabets can also be extended which yields 
  sublens proofs between the extension field lens and record extension lenses. ›

ML_file ‹Lens_Lib.ML›
ML_file ‹Lens_Record.ML›

text ‹The following theorem attribute stores splitting theorems for alphabet types which which is useful
  for proof automation.›

named_theorems alpha_splits

subsection ‹Locale State Spaces ›

text ‹ Alternative to the alphabet command, we also introduce the statespace command, which
  implements Schirmer and Wenzel's locale-based approach to state space modelling~\cite{Schirmer2009}. 

  It has the advantage of allowing multiple inheritance of state spaces, and also variable names are 
  fully internalised with the locales. The approach is also far simpler than record-based state
  spaces. 

  It has the disadvantage that variables may not be fully polymorphic, unlike for the
  alphabet command. This makes it in general unsuitable for UTP theory alphabets. ›

ML_file ‹Lens_Statespace.ML›

subsection ‹Type Definition Lens›

text ‹ Every type defined by a ‹typedef› command induces a partial bijective lens constructed
  using the abstraction and representation functions. ›

context type_definition
begin

definition typedef_lens :: "'b  'a" ("typedefL") where
[lens_defs]: "typedefL =  lens_get = Abs, lens_put = (λ s. Rep) "

lemma pbij_typedef_lens [simp]: "pbij_lens typedefL"
  by (unfold_locales, simp_all add: lens_defs Rep_inverse)

lemma source_typedef_lens: "𝒮typedefL = A"
  using Rep_cases by (auto simp add: lens_source_def lens_defs Rep)

lemma bij_typedef_lens_UNIV: "A = UNIV  bij_lens typedefL"
  by (auto intro: pbij_vwb_is_bij_lens simp add: mwb_UNIV_src_is_vwb_lens source_typedef_lens)

end

subsection ‹Mapper Lenses›

definition lmap_lens :: 
  "((  )  (  ))  
   ((  )    )  
   (  )  
   (  )  
   (  )" where
  [lens_defs]:
  "lmap_lens f g h l = 
  lens_get = f (getl),
  lens_put = g o (putl) o h "
  
text ‹
  The parse translation below yields a heterogeneous mapping lens for any
  record type. This achieved through the utility function above that
  constructs a functorial lens. This takes as input a heterogeneous mapping
  function that lifts a function on a record's extension type to an update
  on the entire record, and also the record's ``more'' function. The first input
  is given twice as it has different polymorphic types, being effectively
  a type functor construction which are not explicitly supported by HOL. We note 
  that the more_update› function does something similar to the extension lifting, 
  but is not precisely suitable here since it only considers homogeneous functions, 
  namely of type 'a ⇒ 'a› rather than 'a ⇒ 'b›.
›
  
syntax 
  "_lmap" :: "id  logic" ("lmap[_]")

ML fun lmap_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
      val map_ext = Abs ("f", dummyT,
                    Abs ("r", dummyT,
                      extend $ (truncate $ Bound 0) $ (Bound 1 $ (more $ (Bound 0)))))

    in
      Const (@{const_syntax "lmap_lens"}, dummyT) $ map_ext $ map_ext $ more
    end
  | lmap_tr _ = raise Match;

parse_translation [(@{syntax_const "_lmap"}, K lmap_tr)]  

subsection ‹Lens Interpretation›

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]

end

subsection ‹ Tactic ›

text ‹ A simple tactic for simplifying lens expressions ›

declare split_paired_all [alpha_splits]

method lens_simp = (simp add: alpha_splits lens_defs prod.case_eq_if)

end

File ‹Lens_Lib.ML›

signature LENS_LIB =
sig
  (* Lens Constant Names *)
  val bij_lensN: string
  val vwb_lensN: string
  val sym_lensN: string
  val lens_indepN: string
  val lens_plusN: string
  val lens_quotientN: string
  val lens_compN: string
  val id_lensN: string
  val sublensN: string
  val lens_equivN: string

  val lens_defsN: string
  val indepsN: string
  val sublensesN: string
  val quotientsN: string
  val compositionsN: string

  (* Lens terms *)

  val lensT: typ -> typ -> typ            (* Lens type *)
  val isLensT: typ -> bool                
  val astateT: typ                        (* Abstract state type *)
  val pairsWith: 'a list -> 'a list -> ('a * 'a) list
  val pairings: 'a list -> ('a * 'a) list (* Calculate all pairings *)
  val mk_vwb_lens: term -> term           (* Make a very well-behaved lens term *)
  val mk_indep: term -> term -> term      (* Make an independence term *)

end

structure Lens_Lib : LENS_LIB =
struct

open Syntax
open HOLogic

val bij_lensN = @{const_name bij_lens}
val vwb_lensN = @{const_name vwb_lens}
val sym_lensN = @{const_name sym_lens}
val lens_indepN = @{const_name lens_indep}
val lens_plusN = @{const_name lens_plus}
val lens_quotientN = @{const_name lens_quotient}
val lens_compN = @{const_name lens_comp}
val id_lensN = @{const_name id_lens}
val sublensN = @{const_name sublens}
val lens_equivN = @{const_name lens_equiv}

val lens_defsN = "lens_defs"
val indepsN = "indeps"
val sublensesN = "sublenses"
val quotientsN = "quotients"
val compositionsN = "compositions"

fun lensT a b = Type (@{type_name lens_ext}, [a, b, unitT])

fun isLensT (Type (n, _)) = (n = @{type_name lens_ext}) |
    isLensT _ = false

val astateT = (TFree ("'st", ["HOL.type"]))

fun pairWith _ [] = []
  | pairWith x (y :: ys) = [(x, y), (y, x)] @ pairWith x ys;

fun pairsWith [] _ = []
  | pairsWith (x :: xs) ys = pairWith x ys @ pairsWith xs ys;

fun pairings [] = []
  | pairings (x :: xs) = pairWith x xs @ pairings xs;  

fun mk_vwb_lens t = mk_Trueprop (const vwb_lensN $ t)

fun mk_indep x y = mk_Trueprop (const lens_indepN $ x $ y)

end

File ‹Lens_Record.ML›

signature LENS_UTILS =
sig
  val add_alphabet_cmd : {overloaded: bool} ->
     (string * string option) list * binding ->
       string option -> (binding * string * mixfix) list -> theory -> theory
end;

structure Lens_Utils : LENS_UTILS =
struct

open Syntax;
open Lens_Lib;

(* We set up the following syntactic entities that correspond to various parts of Isabelle syntax
  and names that we depend on. These code would need to be updated if the names of the Isabelle
  and lens theories and/or theorems change. *)

val FLDLENS = "FLDLENS"
val BASELENS = "BASELENS"
val base_lensN = "baseL"
val child_lensN = "moreL"
val all_lensN = "allL"
val base_moreN = "base_more"
val bij_lens_suffix = "_bij_lens"
val vwb_lens_suffix = "_vwb_lens"
val sym_lens_suffix = "_sym_lens"
val Trueprop = @{const_name Trueprop}
val HOLeq = @{const_name HOL.eq}

val lens_suffix = "v"
val lens_defsN = "lens_defs"
val lens_defs = (Binding.empty, [Token.make_src (lens_defsN, Position.none) []])
val alpha_splitsN = "alpha_splits"
val alpha_splits = [Token.make_src (alpha_splitsN, Position.none) []]
val equivN = "equivs"
val splits_suffix = ".splits"
val defs_suffix = ".defs"
val prod_case_eq_ifN = "prod.case_eq_if"
val slens_view = "view"
val slens_coview = "coview"

(* The following code is adapted from the record package. We generate a record, but also create
   lenses for each field and prove properties about them. *)

fun read_parent NONE ctxt = (NONE, ctxt)
  | read_parent (SOME raw_T) ctxt =
      (case Proof_Context.read_typ_abbrev ctxt raw_T of
        Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt)
      | T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T));

fun read_fields raw_fields ctxt =
  let
    val Ts = Syntax.read_typs ctxt (map (fn (_, raw_T, _) => raw_T) raw_fields);
    val fields = map2 (fn (x, _, mx) => fn T => (x, T, mx)) raw_fields Ts;
    val ctxt' = fold Variable.declare_typ Ts ctxt;
  in (fields, ctxt') end;

fun add_record_cmd overloaded (raw_params, binding) raw_parent raw_fields thy =
  let
    val ctxt = Proof_Context.init_global thy;
    val params = map (apsnd (Typedecl.read_constraint ctxt)) raw_params;
    val ctxt1 = fold (Variable.declare_typ o TFree) params ctxt;
    val (parent, ctxt2) = read_parent raw_parent ctxt1;
    val (fields, ctxt3) = read_fields raw_fields ctxt2;
    val params' = map (Proof_Context.check_tfree ctxt3) params;
  in thy |> Record.add_record overloaded (params', binding) parent fields end;

(* Construct a theorem and proof that a given field lens is very well-behaved *)

fun lens_proof tname x thy =
  let open Simplifier; open Global_Theory in
      Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [mk_vwb_lens (const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x))]))
      (fn {context = context, prems = _}
                           => EVERY [ Locale.intro_locales_tac {strict = true, eager = true} context []
                                    , PARALLEL_ALLGOALS (asm_simp_tac 
                                                          (fold add_simp (get_thm thy (x ^ "_def") :: get_thms thy (tname ^ ".defs"))
                                                                         context))])
  end

fun lens_sym_proof tname thy =
  let open Simplifier; open Global_Theory in
      Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ (const sym_lensN $ const (Context.theory_name thy ^ "." ^ tname ^ "." ^ all_lensN))]))
      (fn {context = context, prems = _}
                           => EVERY [ Classical.rule_tac context [@{thm sym_lens.intro}] [] 1
                                    , PARALLEL_ALLGOALS (asm_simp_tac 
                                                          (fold add_simp (@{thms slens.defs} @ get_thms thy (tname ^ ".defs"))
                                                                         context))])
  end


fun prove_lens_goal tname thy ctx =
  let open Simplifier; open Global_Theory in
  auto_tac (fold add_simp (get_thms thy lens_defsN @ 
                           get_thms thy (tname ^ splits_suffix) @ 
                           [get_thm thy prod_case_eq_ifN]) ctx)
end

fun prove_indep tname thy = 
  let open Simplifier; open Global_Theory in
  (fn {context, prems = _} =>
          EVERY [auto_tac (add_simp @{thm lens_indep_vwb_iff} context)
                ,prove_lens_goal tname thy context])
end

fun prove_sublens tname thy = 
  let open Simplifier; open Global_Theory in
  (fn {context, prems = _} =>
          EVERY [auto_tac (add_simp @{thm sublens_iff_sublens'} context)
                ,prove_lens_goal tname thy context])
end

fun prove_quotient tname thy = 
  let open Simplifier; open Global_Theory in
  (fn {context, prems = _} =>
          EVERY [prove_lens_goal tname thy context])
end


fun prove_equiv tname thy = 
  let open Simplifier; open Global_Theory in
  (fn {context, prems = _} =>
          EVERY [auto_tac (add_simp @{thm lens_equiv_iff_lens_equiv'} context)
                ,prove_lens_goal tname thy context])
end
 
(* Constrct a proof that base + more is a bijective lens *)

fun lens_bij_proof tname thy =
  let open Simplifier; open Global_Theory in
      Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ (const (bij_lensN) $ 
                (const (lens_plusN) $ const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN)
                                    $ const (Context.theory_name thy ^ "." ^ tname ^ "." ^ child_lensN)))]))
      (fn {context = context, prems = _}
                           => EVERY [ Locale.intro_locales_tac {strict = true, eager = true} context []
                                    , auto_tac (fold add_simp (get_thms thy lens_defsN @ [get_thm thy prod_case_eq_ifN])
                                                                         context)])
  end

(* Construct a theorem and proof that two lenses, x and y, are independent. Since some lenses exist
   both with the source type as the record extension, and in the context of the extended record
   we need two versions of this function. The first shows it for the lenses on the extension, and
   thus uses an "intro_locales" as a means to discharge the individual lens laws of the vwb_lens
   locale. *)

fun indep_proof tname thy (x, y) =
  let open Simplifier; open Global_Theory in
  Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ mk_indep 
                (const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x))
                (const (Context.theory_name thy ^ "." ^ tname ^ "." ^ y))
              ]))
      (prove_indep tname thy)
  end

fun equiv_more_proof tname pname thy fs =
  let open Simplifier; open Global_Theory; open Context; open Term in
  Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ ( Const (lens_equivN, dummyT)
                $ Const (pname ^ "." ^ child_lensN, dummyT)
                $ foldr1 (fn (x, y) => Const (lens_plusN, dummyT) $ x $ y) 
                         (map (fn n => Const (theory_name thy ^ "." ^ tname ^ "." ^ n, dummyT)) (fs @ [child_lensN]))
                )]))
      (prove_equiv tname thy)
  end

fun equiv_base_proof tname parent thy fs =
  let open Simplifier; open Global_Theory; open Context; open Term in
  Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ ( Const (lens_equivN, dummyT)
                $ Const (theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
                $ foldr1 (fn (x, y) => Const (lens_plusN, dummyT) $ x $ y) 
                         ((case parent of NONE => [] | SOME (_, pname) => [Const (pname ^ "." ^ base_lensN, dummyT)]) @ 
                          map (fn n => Const (theory_name thy ^ "." ^ tname ^ "." ^ n, dummyT)) fs)
                )]))
      (prove_equiv tname thy)
  end

fun equiv_partition_proof tname thy =
  let open Simplifier; open Global_Theory; open Context; open Term in
  Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ ( Const (lens_equivN, dummyT)
                $ ( Const (lens_plusN, dummyT) 
                  $ Const (theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
                  $ Const (theory_name thy ^ "." ^ tname ^ "." ^ child_lensN, dummyT))
                $ Const (id_lensN, dummyT)
                )]))
      (prove_equiv tname thy)
  end

(* Prove a theorem that every child lens is a sublens of the parent. *)

fun sublens_proof tname pname thy y x =
  let open Simplifier; open Global_Theory in
      Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ ( Const (sublensN, dummyT)
                $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
                $ Const (pname ^ "." ^ y, dummyT)
                )]))
      (prove_sublens tname thy)
end

fun quotient_proof tname thy x =
  let open Simplifier; open Global_Theory in
      Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ ( Const (HOLeq, dummyT)
                $ (Const (lens_quotientN, dummyT) 
                   $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
                   $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
                  )
                $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
                )]))
      (prove_quotient tname thy)
end

fun composition_proof tname thy x =
  let open Simplifier; open Global_Theory in
      Goal.prove_global thy [] []
      (hd (Type_Infer_Context.infer_types
              (Proof_Context.init_global thy)
              [ Const (Trueprop, dummyT)
              $ ( Const (HOLeq, dummyT)
                $ (Const (lens_compN, dummyT) 
                   $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
                   $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT)
                  )
                $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT)
                )]))
      (prove_quotient tname thy)
end

(* Finally we have the function that actually constructs the record, lenses for each field,
   independence proofs, and also sublens proofs. *)

fun add_alphabet_cmd _ (raw_params, binding) raw_parent raw_fields thy =
  let
    open Simplifier; open Global_Theory
    val tname = Binding.name_of binding
    val fields = map (fn (x, y, z) => (Binding.suffix_name lens_suffix x, y, z)) raw_fields
    val lnames = map (fn (x, _, _) => Binding.name_of x) raw_fields
    val (parent, _) = read_parent raw_parent (Proof_Context.init_global thy);
    fun ldef x = (x, x ^ " = " ^ FLDLENS ^ " " ^ x ^ lens_suffix)
    val pname = case parent of SOME (_,r) => r | NONE => "";
    val plchild =
      case parent of
        SOME (_, _) => child_lensN |
        NONE => ""
    val bldef = (base_lensN, base_lensN ^ " = " ^ BASELENS ^ " " ^ tname);
    val mldef = (child_lensN, child_lensN ^ " = " ^ FLDLENS ^ " more"); 
    val sldef = (all_lensN, all_lensN ^ " ≡ ⦇ " ^ slens_view ^ " = " ^ base_lensN ^ ", " ^ slens_coview ^ " = " ^ child_lensN ^ " ⦈");
    val plnames = if (raw_parent = NONE) then [] else lnames  @ [child_lensN];
    fun pindeps thy = map (fn thm => @{thm sublens_pres_indep} OF [thm]) (get_thms thy sublensesN)
                    @ map (fn thm => @{thm sublens_pres_indep'} OF [thm]) (get_thms thy sublensesN)
 in thy     (* Add a new record for the new alphabet lenses *)
         |> add_record_cmd {overloaded = false} (raw_params, binding) raw_parent fields
            (* Add the record definition theorems to lens_defs *)
         |> Named_Target.theory_map (snd o Specification.theorems_cmd "" [((Binding.empty, []), [(Facts.named (tname ^ defs_suffix), snd lens_defs)])] [] false)
            (* Add the record splitting theorems to the alpha_splits set for proof automation *)
         |> Named_Target.theory_map (snd o Specification.theorems_cmd "" [((Binding.empty, []), [(Facts.named (tname ^ splits_suffix), alpha_splits)])] [] false)
            (* Add definitions for each of the lenses corresponding to each record field in-situ *)
         |> Sign.qualified_path false binding
         |> Named_Target.theory_map
              (fold (fn (n, d) => snd o Specification.definition_cmd (SOME (Binding.make (n, Position.none), NONE, NoSyn)) [] [] (lens_defs, d) true) (map ldef lnames @ [bldef, mldef]))
            (* Add definition of the underlying symmetric lens *)
         |> Named_Target.theory_map
              (fold (fn (n, d) => Specification.abbreviation_cmd Syntax.mode_default (SOME (Binding.make (n, Position.none), NONE, NoSyn)) [] d true) [sldef])
            (* Add a vwb lens proof for each field lens *)
         |> fold (fn x => fn thy => snd (add_thm ((Binding.make (x ^ vwb_lens_suffix, Position.none), lens_proof tname x thy), [Simplifier.simp_add]) thy)) (lnames @ [base_lensN, child_lensN])
            (* Add a bij lens proof for the base and more lenses *)
         |> (fn thy => snd (add_thm ((Binding.make (base_moreN ^ bij_lens_suffix, Position.none), lens_bij_proof tname thy), [Simplifier.simp_add]) thy))
            (* Add sublens proofs *)
         |> (fn thy => snd (add_thmss [((Binding.make (sublensesN, Position.none), map (sublens_proof tname pname thy plchild) plnames @ map (sublens_proof tname (Context.theory_name thy ^ "." ^ tname) thy base_lensN) lnames), [Simplifier.simp_add])] thy))
            (* Add quotient proofs *)
         |> (fn thy => snd (add_thmss [((Binding.make (quotientsN, Position.none), map (quotient_proof tname thy) lnames), [Simplifier.simp_add])] thy))
            (* Add composition proofs *)
         |> (fn thy => snd (add_thmss [((Binding.make (compositionsN, Position.none), map (composition_proof tname thy) lnames), [Simplifier.simp_add])] thy))
            (* Add independence proofs for each pairing of lenses *)
         |> (fn thy => snd (add_thmss
              [((Binding.make (indepsN, Position.none), map (indep_proof tname thy) (pairings (lnames @ [child_lensN]) @ pairings [base_lensN, child_lensN]) (*@ map (parent_indep_proof_1 tname pname thy plchild) plnames @ map (parent_indep_proof_2 tname pname thy plchild) plnames *) @ pindeps thy), [Simplifier.simp_add])] thy))
            (* Add equivalence properties *)
         |> (fn thy => snd (add_thmss
              [((Binding.make (equivN, Position.none), (if (raw_parent = NONE) then [] else [equiv_more_proof tname pname thy lnames]) @ [equiv_base_proof tname parent thy lnames, equiv_partition_proof tname thy]), [Simplifier.simp_add])] thy))
            (* Add a symmetric lens proof for the base and more lenses *)
         |> (fn thy => snd (add_thm ((Binding.make (all_lensN ^ sym_lens_suffix, Position.none), lens_sym_proof tname thy), [Simplifier.simp_add]) thy)) 
         |> Sign.parent_path
  end;

val _ =
  Outer_Syntax.command @{command_keyword alphabet} "define record with lenses"
    (Parse_Spec.overloaded -- (Parse.type_args_constrained -- Parse.binding) --
      (@{keyword "="} |-- Scan.option (Parse.typ --| @{keyword "+"}) --
        Scan.repeat1 Parse.const_binding)
    >> (fn ((overloaded, x), (y, z)) =>
        Toplevel.theory (add_alphabet_cmd {overloaded = overloaded} x y z)));
end

File ‹Lens_Statespace.ML›

signature LENS_STATESPACE =
sig
  val mk_statespace_elements: bstring -> (bstring * typ) list -> xstring list -> theory -> Element.context_i list
  val compile_statespace: bstring -> (bstring * typ) list -> xstring list -> theory -> theory
  val statespace_cmd: bstring -> xstring list -> (bstring * string) list -> theory -> theory
end

structure Lens_Statespace =
struct
  (* Produce a list of new elements for a locale to characterise a state space *)
  fun mk_statespace_elements vds exts thy = 
  let
    open Lens_Lib;
    open Syntax;
    val ctx = Named_Target.theory_init thy
    val vns = map fst vds 
    val vfixes = map (fn (n, t) => (Binding.name n, SOME (lensT t astateT), NoSyn)) vds
    val vwbs   = map (mk_vwb_lens o free) vns;
    val simp   = Attrib.check_src ctx (Token.make_src ("simp", Position.none) [])
    val imps   = map (fn e => Locale.check thy (e, Position.none)) exts
    (* List of lenses imported *)
    val ilnsls = map (filter (isLensT o snd) o map fst o Locale.params_of thy) imps
    (* Independence axioms from imports *)
    val impind = List.concat (map (pairsWith vns) (map (map fst) ilnsls))
    val indeps = map (fn (x, y) => mk_indep (free x) (free y)) 
                     (pairings (vns) @ impind)
  in 
  (* Fix each of the variables as lenses *)
  [ Element.Fixes vfixes 
  (* Assume that all lenses are very well-behaved and independent (as in a product space) *)
  , Element.Assumes [((Binding.name "vwbs", [simp])
                     , map (fn vwb => (vwb, [])) vwbs),
                     ((Binding.name "indeps", [simp])
                     , map (fn vwb => (vwb, [])) indeps)]
  ]
  end


  (* Compile a state space from a given state space name and list of variable declarations *)
  fun compile_statespace ssn vds exts thy =
  let
    open Lens_Lib;
    open Syntax;
    val imps   = map (fn e => Locale.check thy (e, Position.none)) exts
    val locexs = map (fn i => (i, (("", false), (Expression.Positional [], [])))) imps
  in
  (Local_Theory.exit_global o snd o 
  Expression.add_locale (Binding.name ssn) Binding.empty [] (locexs,[]) 
  (mk_statespace_elements vds exts thy)) thy
  end

  fun statespace_cmd n exts vds thy = 
  let 
    open Syntax
    val ctx = Named_Target.theory_init thy in
    compile_statespace n (map (fn (n, t) => (n, read_typ ctx t)) vds) exts thy
  end
end;

let open Parse in
  Outer_Syntax.command @{command_keyword statespace} "define locale-based statespace with lenses"
    ((Parse.name --
      (@{keyword "="} |-- Scan.repeat (Parse.name --| @{keyword "+"}) --
        Scan.repeat (Parse.name -- ($$$ "::" |-- !!! typ))))
    >> (fn (n, (exts, vds)) => Toplevel.theory (Lens_Statespace.statespace_cmd n exts vds)))
end

Theory Lenses

section ‹Lenses›

theory Lenses
  imports
    Lens_Laws
    Lens_Algebra
    Lens_Order
    Lens_Symmetric
    Lens_Instances
begin end

Theory Prisms

section ‹Prisms›

theory Prisms
  imports Lenses
begin

subsection ‹ Signature and Axioms ›

text ‹Prisms are like lenses, but they act on sum types rather than product types~\cite{Gibbons17}. 
  See \url{https://hackage.haskell.org/package/lens-4.15.2/docs/Control-Lens-Prism.html}
  for more information.›

record ('v, 's) prism =
  prism_match :: "'s  'v option" ("matchı")
  prism_build :: "'v  's" ("buildı")

type_notation
  prism (infixr "" 0)

locale wb_prism =
  fixes x :: "'v  's" (structure)
  assumes match_build: "match (build v) = Some v"
  and build_match: "match s = Some v  s = build v"
begin

  lemma build_match_iff: "match s = Some v  s = build v"
    using build_match match_build by blast

  lemma range_build: "range build = dom match"
    using build_match match_build by fastforce
end

declare wb_prism.match_build [simp]
declare wb_prism.build_match [simp]

subsection ‹ Co-dependence ›

text ‹ The relation states that two prisms construct disjoint elements of the source. This
  can occur, for example, when the two prisms characterise different constructors of an
  algebraic datatype. ›

definition prism_diff :: "('a  's)  ('b  's)  bool" (infix "" 50) where
"prism_diff X Y = (range buildX  range buildY = {})"

lemma prism_diff_intro:
  "( s1 s2. buildX s1 = buildY s2  False)  X  Y"
  by (auto simp add: prism_diff_def)

lemma prism_diff_irrefl: "¬ X  X"
  by (simp add: prism_diff_def)

lemma prism_diff_sym: "X  Y  Y  X"
  by (auto simp add: prism_diff_def)

lemma prism_diff_build: "X  Y  buildX u  buildY v"
  by (simp add: disjoint_iff_not_equal prism_diff_def)

subsection ‹ Summation ›

definition prism_plus :: "('a  's)  ('b  's)  'a + 'b  's" (infixl "+" 85) 
  where
"X + Y =  prism_match = (λ s. case (matchX s, matchY s) of
                                 (Some u, _)  Some (Inl u) |
                                 (None, Some v)  Some (Inr v) |
                                 (None, None)  None),
           prism_build = (λ v. case v of Inl x  buildX x | Inr y  buildY y) "

subsection ‹ Instances ›

definition prism_suml :: "('a, 'a + 'b) prism" ("Inl") where
[lens_defs]: "prism_suml =  prism_match = (λ v. case v of Inl x  Some x | _  None), prism_build = Inl "

definition prism_sumr :: "('b, 'a + 'b) prism" ("Inr") where
[lens_defs]: "prism_sumr =  prism_match = (λ v. case v of Inr x  Some x | _  None), prism_build = Inr "

lemma wb_prim_suml: "wb_prism Inl"
  apply (unfold_locales)
   apply (simp_all add: prism_suml_def sum.case_eq_if)
  apply (metis option.inject option.simps(3) sum.collapse(1))
  done

lemma wb_prim_sumr: "wb_prism Inr"
  apply (unfold_locales)
   apply (simp_all add: prism_sumr_def sum.case_eq_if)
  apply (metis option.distinct(1) option.inject sum.collapse(2))
  done

lemma prism_suml_indep_sumr [simp]: "Inl  Inr"
  by (auto simp add: prism_diff_def lens_defs)

subsection ‹ Lens correspondence ›

text ‹ Every well-behaved prism can be represented by a partial bijective lens. We prove 
  this by exhibiting conversion functions and showing they are (almost) inverses. ›

definition prism_lens :: "('a, 's) prism  ('a  's)" where
"prism_lens X =  lens_get = (λ s. the (matchX s)), lens_put = (λ s v. buildX v) "

definition lens_prism :: "('a  's)  ('a, 's) prism" where
"lens_prism X =  prism_match = (λ s. if (s  𝒮X) then Some (getX s) else None)
                , prism_build = createX "

lemma get_prism_lens: "getprism_lens X = the  matchX"
  by (simp add: prism_lens_def fun_eq_iff)

lemma src_prism_lens: "𝒮prism_lens X = range (buildX)"
  by (auto simp add: prism_lens_def lens_source_def)

lemma create_prism_lens: "createprism_lens X = buildX"
  by (simp add: prism_lens_def lens_create_def fun_eq_iff)

lemma prism_lens_inverse:
  "wb_prism X  lens_prism (prism_lens X) = X"
  unfolding lens_prism_def src_prism_lens create_prism_lens get_prism_lens
  by (auto intro: prism.equality simp add: fun_eq_iff domIff wb_prism.range_build)

text ‹ Function @{const lens_prism} is almost inverted by @{const prism_lens}. The $put$
  functions are identical, but the $get$ functions differ when applied to a source where
  the prism @{term X} is undefined. ›

lemma lens_prism_put_inverse:
  "pbij_lens X  putprism_lens (lens_prism X) = putX"
  unfolding prism_lens_def lens_prism_def
  by (auto simp add: fun_eq_iff pbij_lens.put_is_create)

lemma wb_prism_implies_pbij_lens:
  "wb_prism X  pbij_lens (prism_lens X)"
  by (unfold_locales, simp_all add: prism_lens_def)

lemma pbij_lens_implies_wb_prism:
  assumes "pbij_lens X" 
  shows "wb_prism (lens_prism X)"
proof (unfold_locales)
  fix s v
  show "matchlens_prism X (buildlens_prism X v) = Some v"
    by (simp add: lens_prism_def weak_lens.create_closure assms)
  assume a: "matchlens_prism X s = Some v"
  show "s = buildlens_prism X v"
  proof (cases "s  𝒮X")
    case True
    with a assms show ?thesis 
      by (simp add: lens_prism_def lens_create_def, 
          metis mwb_lens.weak_get_put pbij_lens.put_det pbij_lens_mwb)
  next
    case False
    with a assms show ?thesis by (simp add: lens_prism_def)
  qed
qed

ML_file ‹Prism_Lib.ML›

end

File ‹Prism_Lib.ML›

signature PRISM_LIB =
sig
  val wb_prismN: string
  val prism_diffN: string
  val codepsN: string

  (* Prism terms *)

  val prismT: typ -> typ -> typ
  val isPrismT: typ -> bool
  val mk_wb_prism: term -> term           (* Make a well-behaved prism term *)
  val mk_codep: term -> term -> term      (* Make a codependence term *)

end

structure Prism_Lib : PRISM_LIB = 
struct

open Syntax
open HOLogic

val wb_prismN = @{const_name wb_prism}
val prism_diffN = @{const_name prism_diff}

val codepsN = "codeps"

fun prismT a b = Type (@{type_name prism_ext}, [a, b, unitT])

fun isPrismT (Type (n, _)) = (n = @{type_name prism_ext}) |
    isPrismT _ = false

fun mk_wb_prism t = mk_Trueprop (const wb_prismN $ t)

fun mk_codep x y = mk_Trueprop (const prism_diffN $ x $ y)

end

Theory Channel_Type

section ‹ Channel Types ›

theory Channel_Type
  imports Prisms
  keywords "chantype" :: "thy_defn"
begin

text ‹ A channel type is a simplified algebraic datatype where each constructor has exactly 
  one parameter, and it is wrapped up as a prism. It a dual of an alphabet type. ›

definition ctor_prism :: "('a  'd)  ('d  bool)  ('d  'a)  ('a  'd)" where
[lens_defs]: 
"ctor_prism ctor disc sel =  prism_match = (λ d. if (disc d) then Some (sel d) else None)
                            , prism_build = ctor "

lemma wb_ctor_prism_intro:
  assumes 
    " v. disc (ctor v)" 
    " v. sel (ctor v) = v"
    " s. disc s  ctor (sel s) = s"
  shows "wb_prism (ctor_prism ctor disc sel)"
  by (unfold_locales, simp_all add: lens_defs assms)
     (metis assms(3) option.distinct(1) option.sel)

lemma ctor_codep_intro:
  assumes " x y. ctor1 x  ctor2 y"
  shows "ctor_prism ctor1 disc1 sel1  ctor_prism ctor2 disc2 sel2"
  by (rule prism_diff_intro, simp add: lens_defs assms)

ML_file "Channel_Type.ML"

end

File ‹Channel_Type.ML›

structure Channel_Type =
struct
fun prove_prism_goal thy =
  let 
    open Simplifier; open Global_Theory; open Lens_Lib
    val ctx = Named_Target.theory_init thy
 in
  auto_tac (fold add_simp (get_thms thy lens_defsN) ctx)
end

val wb_prism_suffix = "_wb_prism"
val codep_suffix = "_codeps"

val ctor_suffix = "_C"

fun wb_prism_proof x thms ctx =
  let open Simplifier; open Prism_Lib; open Syntax 
  in
      Goal.prove ctx [] []
      (Syntax.check_term ctx (mk_wb_prism (free x)))
      (fn {context = context, prems = _}
                           => EVERY [ PARALLEL_ALLGOALS (full_simp_tac (fold add_simp thms context))
                                    , Classical.rule_tac context [@{thm wb_ctor_prism_intro}] [] 1
                                    , auto_tac (context delsimprocs [@{simproc unit_eq}])
                                    ])
  end

fun codep_proof thms ctx (x, y) =
  let open Simplifier; open Prism_Lib; open Syntax in
  Goal.prove ctx [] []
      (Syntax.check_term ctx (mk_codep (free x) (free y)))
      (fn {context = context, prems = _}
                           => EVERY [ PARALLEL_ALLGOALS (full_simp_tac (fold add_simp thms context))
                                    , Classical.rule_tac context [@{thm ctor_codep_intro}] [] 1
                                    , auto_tac ctx
                                    ])

  end



fun mk_def ty x v = Const ("Pure.eq", ty --> ty --> Term.propT) $ Free (x, ty) $ v;

val is_prefix = "is_";
val un_prefix = "un_";

fun def qual (x, tm) ctx = 
  let open Specification; open Syntax
      val ((_, (_, thm)), d) = definition (SOME (Binding.qualify false qual (Binding.name x), NONE, NoSyn)) [] [] ((Binding.empty, [Attrib.check_src @{context} (Token.make_src ("lens_defs", Position.none) [])]), mk_def dummyT x tm) ctx
  in (thm, d)  
  end


fun defs qual inds f ctx =
  fold (fn i => fn (thms, ctx) =>
        let val (thm, ctx') = def qual (i, f i) ctx 
        in (thms @ [thm], ctx') end) inds ([], ctx)

fun compile_chantype (name, chans) ctx =
  let 
    open BNF_FP_Def_Sugar; open BNF_FP_Rec_Sugar_Util; open BNF_LFP; open Ctr_Sugar
    open Prism_Lib; open Lens_Lib; open Local_Theory; open Specification; open Syntax
    val ctrs = map (fn (n, t) => (((Binding.empty, Binding.name (n ^ ctor_suffix)), [(Binding.empty, t)]), Mixfix.NoSyn)) chans 
    val pnames = map fst chans
    val thypfx = 
      case (Named_Target.locale_of ctx) of
        SOME loc => loc ^ "." |
        NONE => Context.theory_name (Local_Theory.exit_global ctx) ^ "."
    val prefix = thypfx ^ name ^ "."
    val simp = Attrib.check_src @{context} (Token.make_src ("simp", Position.none) [])
    val dummy_disc = absdummy dummyT @{term True}
  in
  (co_datatype_cmd Least_FP construct_lfp 
       ((K Plugin_Name.default_filter, true), 
        [((((([],Binding.name name), Mixfix.NoSyn), ctrs), (Binding.empty, Binding.empty, Binding.empty)),[])])
  (* The datatype package does not produce a discriminator for the second constructor when
     there are two constructors. We here generate one for uniformity. *)
  #> (if (length pnames = 2)
      then abbreviation 
             Syntax.mode_default (SOME (Binding.qualify false name (Binding.name (is_prefix ^ nth pnames 1 ^ ctor_suffix)), NONE, NoSyn)) [] 
             (mk_def dummyT 
                (is_prefix ^ nth pnames 1 ^ ctor_suffix) 
                (const @{const_name comp} $ @{term Not} $ const (prefix ^ is_prefix ^ nth pnames 0 ^ ctor_suffix))) false
      else I)
  #> defs name pnames (fn x => (const @{const_name ctor_prism}
                         $ const (prefix ^ x ^ ctor_suffix)
                         $ (if (length pnames = 1) then dummy_disc else const (prefix ^ is_prefix ^ x ^ ctor_suffix))
                         $ const (prefix ^ un_prefix ^ x ^ ctor_suffix)))
  #> (fn (thms, ctx) =>
       (fold (fn x => fn thy => snd (note ((Binding.qualify false name (Binding.name (x ^ wb_prism_suffix)), [simp]), [wb_prism_proof x thms thy]) thy)) pnames
       #> (snd o note ((Binding.qualify false name (Binding.name codepsN), [simp]), map (codep_proof thms ctx) (pairings pnames)))
       ) ctx))
  ctx
  end;

end;

let open Parse; open Parse_Spec; open Scan in
  Outer_Syntax.command @{command_keyword chantype} "define a channel datatype"
    ((name --
      (@{keyword "="} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))))
    >> (fn x => Toplevel.local_theory NONE NONE (Channel_Type.compile_chantype x)))
  end;

Theory Dataspace

section ‹ Data spaces ›

theory Dataspace
  imports Lenses Prisms
  keywords "dataspace" :: "thy_defn" and "constants" "variables" "channels"
begin

text ‹ A data space is like a more sophisticated version of a locale-based state space. It 
  allows us to introduce both variables, modelled by lenses, and channels, modelled by
  prisms. It also allows local constants, and assumptions over them. ›

ML_file "Dataspace.ML"

end

File ‹Dataspace.ML›

structure Dataspace =
struct

  val achanT = TFree ("'ch", ["HOL.type"])

  fun mk_constant_elements cds =
    let
    open Syntax;
    val cfixes = map (fn (n, t) => (Binding.name n, SOME t, NoSyn)) cds
    in [ Element.Fixes cfixes ] end;

  (* Produce a list of new elements for a locale to characterise the channels *)
  fun mk_channel_elements exts chds thy = 
  let
    open Lens_Lib;
    open Prism_Lib;
    open Syntax;
    val ctx = Named_Target.theory_init thy
    val chns = map fst chds 
    val chfixes = map (fn (n, t) => (Binding.name n, SOME (prismT t achanT), NoSyn)) chds
    val wbs    = map (mk_wb_prism o free) chns;
    val simp   = Attrib.check_src ctx (Token.make_src ("simp", Position.none) [])
    val imps   = map (fn e => Locale.check thy (e, Position.none)) exts
    (* List of prisms imported *)
    val ilnsls = map (filter (isPrismT o snd) o map fst o Locale.params_of thy) imps
    (* Codependence axioms from imports *)
    val impind = List.concat (map (pairsWith chns) (map (map fst) ilnsls))
    val codeps = map (fn (x, y) => mk_codep (free x) (free y)) 
                     (pairings (chns) @ impind)
  in 
  (* Fix each of the channels as prisms *)
  [ Element.Fixes chfixes 
  (* Assume that all prisms are well-behaved and codependent (as in an algebraic datatype) *)
  , Element.Assumes [((Binding.name "prisms", [simp])
                     , map (fn wb => (wb, [])) wbs),
                     ((Binding.name "codeps", [simp])
                     , map (fn dp => (dp, [])) codeps)]
  ]
  end

  val STATE = "STATE_TYPE"
  val CHAN = "CHAN_TYPE"

  fun compile_dataspace nm exts cds assms vds chds thy =
  let
    open Lens_Lib;
    open Syntax;
    val imps   = map (fn e => Locale.check thy (e, Position.none)) exts
    (* When extending existing dataspaces, we instantiate their respective state and channel
       types to avoid ambiguity (via a locale "where" clause) *)
    val pinsts = Expression.Named 
                    [(STATE, Logic.mk_type astateT)
                    ,(CHAN, Logic.mk_type achanT)]
    val locexs = map (fn i => (i, (("", false), (pinsts, [])))) imps
    (* We also create fixed parameters for the types so they can be instantiated later *)
    val st_par = (Binding.name STATE, SOME (Term.itselfT astateT), NoSyn)
    val ch_par = (Binding.name CHAN, SOME (Term.itselfT achanT), NoSyn)
  in
  (Local_Theory.exit_global o snd o 
  Expression.add_locale (Binding.name nm) Binding.empty [] (locexs, []) 
  (mk_constant_elements cds 
   @ [Element.Assumes assms]
   @ Lens_Statespace.mk_statespace_elements vds exts thy
   @ mk_channel_elements exts chds thy
   @ [Element.Fixes [st_par, ch_par]])) thy
  end
  
  fun dataspace_cmd nm exts cds rassms vds chds thy = 
  let 
    open Syntax; open HOLogic;
    val ctx = Named_Target.theory_init thy 
    val assms = map (fn (b, td) => (b, map (fn (t, ts) => (mk_Trueprop (parse_term ctx t), map (mk_Trueprop o parse_term ctx) ts)) td)) rassms in
    compile_dataspace nm exts (map (fn (n, t) => (n, read_typ ctx t)) cds) assms (map (fn (n, t) => (n, read_typ ctx t)) vds) (map (fn (n, t) => (n, read_typ ctx t)) chds)  thy
  end

end;

let open Parse; open Parse_Spec; open Scan in
  Outer_Syntax.command @{command_keyword dataspace} "define reactive contexts"
    ((name --
      ((@{keyword "="} |-- repeat (Parse.name --| @{keyword "+"}))
       -- optional (@{keyword "constants"} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))) []
       -- optional (@{keyword "assumes"} |-- !!! (and_list1 (opt_thm_name ":" -- repeat1 propp))) []
       -- optional (@{keyword "variables"} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))) []
       -- optional (@{keyword "channels"} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))) [])
    >> (fn (nm, ((((exts, cds), assms), vds), chds)) => Toplevel.theory (Dataspace.dataspace_cmd nm exts cds assms vds chds))))
end;

Theory Scenes

section ‹ Scenes ›

theory Scenes
  imports Lens_Instances
begin

text ‹ Like lenses, scenes characterise a region of a source type. However, unlike lenses, scenes
  do not explicitly assign a view type to this region, and consequently they have just one type
  parameter. This means they can be more flexibly composed, and in particular it is possible to
  show they form nice algebraic structures in Isabelle/HOL. They are mainly of use in characterising
  sets of variables, where, of course, we do not care about the types of those variables and
  therefore representing them as lenses is inconvenient. ›

subsection ‹ Overriding Functions ›

text ‹ Overriding functions provide an abstract way of replacing a region of an existing source
  with the corresponding region of another source. ›

locale overrider =
  fixes F  :: "'s  's  's" (infixl "" 65)
  assumes 
    ovr_overshadow_left: "x  y  z = x  z" and
    ovr_overshadow_right: "x  (y  z) = x  z"
begin
  lemma ovr_assoc: "x  (y  z) = x  y  z"
    by (simp add: ovr_overshadow_left ovr_overshadow_right)
end

locale idem_overrider = overrider +
  assumes ovr_idem: "x  x = x"

declare overrider.ovr_overshadow_left [simp]
declare overrider.ovr_overshadow_right [simp]
declare idem_overrider.ovr_idem [simp]

subsection ‹ Scene Type ›

typedef 's scene = "{F :: 's  's  's. overrider F}"
  by (rule_tac x="λ x y. x" in exI, simp, unfold_locales, simp_all)

setup_lifting type_definition_scene

lift_definition idem_scene :: "'s scene  bool" is idem_overrider .

lift_definition region :: "'s scene  's rel" 
is "λ F. {(s1, s2). ( s. F s s1 = F s s2)}" .

lift_definition coregion :: "'s scene  's rel" 
is "λ F. {(s1, s2). ( s. F s1 s = F s2 s)}" .

lemma equiv_region: "equiv UNIV (region X)"
  apply (transfer)
  apply (rule equivI)
    apply (rule refl_onI)
     apply (auto)
   apply (rule symI)
   apply (auto)
  apply (rule transI)
  apply (auto)
  done

lemma equiv_coregion: "equiv UNIV (coregion X)"
  apply (transfer)
  apply (rule equivI)
    apply (rule refl_onI)
     apply (auto)
   apply (rule symI)
   apply (auto)
  apply (rule transI)
  apply (auto)
  done

lemma region_coregion_Id:
  "idem_scene X  region X  coregion X = Id"
  by (transfer, auto, metis idem_overrider.ovr_idem)

lemma state_eq_iff: "idem_scene S  x = y  (x, y)  region S  (x, y)  coregion S"
  by (metis IntE IntI pair_in_Id_conv region_coregion_Id)

lift_definition scene_override :: "'a  'a  ('a scene)  'a" ("_ S _ on _" [95,0,96] 95)
is "λ s1 s2 F. F s1 s2" .

abbreviation (input) scene_copy :: "'a scene  'a  ('a  'a)" ("cp⇘_") where
"cpA s  (λ s'. s' S s on A)"

lemma scene_override_idem [simp]: "idem_scene X  s S s on X = s"
  by (transfer, simp)

lemma scene_override_overshadow_left [simp]:
  "S1 S S2 on X S S3 on X = S1 S S3 on X"
  by (transfer, simp)

lemma scene_override_overshadow_right [simp]:
  "S1 S (S2 S S3 on X) on X = S1 S S3 on X"
  by (transfer, simp)

definition scene_equiv :: "'a  'a  ('a scene)  bool" ("_ S _ on _" [65,0,66] 65) where
[lens_defs]: "S1 S S2 on X = (S1 S S2 on X = S1)"

lemma scene_equiv_region: "idem_scene X  region X = {(S1, S2). S1 S S2 on X}"
  by (simp add: lens_defs, transfer, auto)
     (metis idem_overrider.ovr_idem, metis overrider.ovr_overshadow_right)

lift_definition scene_indep :: "'a scene  'a scene  bool" (infix "S" 50)
is "λ F G. ( s1 s2 s3. G (F s1 s2) s3 = F (G s1 s3) s2)" .

lemma scene_indep_override:
  "X S Y = ( s1 s2 s3. s1 S s2 on X S s3 on Y = s1 S s3 on Y S s2 on X)"
  by (transfer, auto)

lemma scene_indep_copy:
  "X S Y = ( s1  s2. cpX s1  cpY s2 = cpY s2  cpX s1)"
  by (auto simp add: scene_indep_override comp_def fun_eq_iff)

lemma scene_indep_sym:
  "X S Y  Y S X"
  by (transfer, auto)

text ‹ Compatibility is a weaker notion than independence; the scenes can overlap but they must
  agree when they do. ›

lift_definition scene_compat :: "'a scene  'a scene  bool" (infix "##S" 50)
is "λ F G. ( s1 s2. G (F s1 s2) s2 = F (G s1 s2) s2)" .

lemma scene_compat_copy:
  "X ##S Y = ( s. cpX s  cpY s = cpY s  cpX s)"
  by (transfer, auto simp add: fun_eq_iff)

lemma scene_indep_compat [simp]: "X S Y  X ##S Y"
  by (transfer, auto)

lemma scene_compat_refl: "X ##S X"
  by (transfer, simp)

lemma scene_compat_sym: "X ##S Y  Y ##S X"
  by (transfer, simp)

lemma scene_override_commute_indep:
  assumes "X S Y"
  shows "S1 S S2 on X S S3 on Y = S1 S S3 on Y S S2 on X"
  using assms
  by (transfer, auto)

instantiation scene :: (type) "{bot, top, uminus, sup, inf}"
begin
  lift_definition bot_scene    :: "'s scene" is "λ x y. x" by (unfold_locales, simp_all)
  lift_definition top_scene    :: "'s scene" is "λ x y. y" by (unfold_locales, simp_all)
  lift_definition uminus_scene :: "'s scene  's scene" is "λ F x y. F y x"
    by (unfold_locales, simp_all)
  text ‹ Scene union requires that the two scenes are at least compatible. If they are not, the
        result is the bottom scene. ›
  lift_definition sup_scene :: "'s scene  's scene  's scene" 
    is "λ F G. if ( s1 s2. G (F s1 s2) s2 = F (G s1 s2) s2) then (λ s1 s2. G (F s1 s2) s2) else (λ s1 s2. s1)"
    by (unfold_locales, auto, metis overrider.ovr_overshadow_right)
  definition inf_scene :: "'s scene  's scene  's scene" where
    [lens_defs]: "inf_scene X Y = - (sup (- X) (- Y))"
  instance ..
end

abbreviation union_scene :: "'s scene  's scene  's scene" (infixl "S" 65)
where "union_scene  sup"

abbreviation inter_scene :: "'s scene  's scene  's scene" (infixl "S" 70)
where "inter_scene  inf"

abbreviation top_scene :: "'s scene" ("S")
where "top_scene  top"

abbreviation bot_scene :: "'s scene" ("S")
where "bot_scene  bot"

lemma uminus_scene_twice: "- (- (X :: 's scene)) = X"
  by (transfer, simp)

lemma scene_override_id [simp]: "S1 S S2 on S = S2"
  by (transfer, simp)

lemma scene_override_unit [simp]: "S1 S S2 on S = S1"
  by (transfer, simp)

lemma scene_override_commute: "S2 S S1 on (- X) = S1 S S2 on X"
  by (transfer, simp)

lemma scene_union_incompat: "¬ X ##S Y  X S Y = S"
  by (transfer, auto)

lemma scene_override_union: "X ##S Y  S1 S S2 on (X S Y) = (S1 S S2 on X) S S2 on Y"
  by (transfer, auto)

lemma scene_union_unit: "X S S = X"
  by (transfer, simp)

lemma idem_scene_union [simp]: " idem_scene A; idem_scene B   idem_scene (A S B)"
  apply (transfer, auto)
  apply (unfold_locales, auto)
  apply (metis overrider.ovr_overshadow_left)
  apply (metis overrider.ovr_overshadow_right)
  done

lemma scene_union_annhil: "idem_scene X  X S S = S"
  by (transfer, simp)

lemma scene_union_pres_compat: " A ##S B; A ##S C   A ##S (B S C)"
  by (transfer, auto)

lemma scene_indep_self_compl: "A S -A"
  by (transfer, simp)

lemma scene_compat_self_compl: "A ##S -A"
  by (transfer, simp)

lemma scene_union_assoc: 
  assumes "X ##S Y" "X ##S Z" "Y ##S Z"
  shows "X S (Y S Z) = (X S Y) S Z"
  using assms by (transfer, auto)

lemma scene_inter_indep:
  assumes "idem_scene X" "idem_scene Y" "X S Y"
  shows "X S Y = S"
  using assms
  unfolding lens_defs
  apply (transfer, auto)
  apply (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_assoc overrider.ovr_overshadow_right)
  apply (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_overshadow_right)
  done

lemma scene_union_idem: "X S X = X"
  by (transfer, simp)

lemma scene_union_compl: "idem_scene X  X S - X = S"
  by (transfer, auto)

lemma scene_inter_idem: "X S X = X"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_union_commute: "X S Y = Y S X"
  by (transfer, auto)
  
lemma scene_inter_compl: "idem_scene X  X S - X = S"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_demorgan1: "-(X S Y) = -X S -Y"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_demorgan2: "-(X S Y) = -X S -Y"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_compat_top: "idem_scene X  X ##S S"
  by (transfer, simp)

instantiation scene :: (type) ord
begin
  text ‹ $X$ is a subscene of $Y$ provided that overriding with first $Y$ and then $X$ can
         be rewritten using the complement of $X$. ›
  definition less_eq_scene :: "'a scene  'a scene  bool" where
  [lens_defs]: "less_eq_scene X Y = ( s1 s2 s3. s1 S s2 on Y S s3 on X = s1 S (s2 S s3 on X) on Y)"
  definition less_scene :: "'a scene  'a scene  bool" where
  [lens_defs]: "less_scene x y = (x  y  ¬ y  x)"
instance ..
end

abbreviation subscene :: "'a scene  'a scene  bool" (infix "S" 55)
where "subscene X Y  X  Y"

lemma subscene_refl: "X S X"
  by (simp add: less_eq_scene_def)

lemma subscene_trans: " idem_scene Y; X S Y; Y S Z   X S Z"
  by (simp add: less_eq_scene_def, transfer, auto, metis (no_types, hide_lams) idem_overrider.ovr_idem)

lemma subscene_antisym: " idem_scene Y; X S Y; Y S X   X = Y"
  apply (simp add: less_eq_scene_def, transfer, auto)
  apply (rule ext)
  apply (rule ext)
  apply (metis (full_types) idem_overrider.ovr_idem overrider.ovr_overshadow_left)
  done

lemma subscene_copy_def:
  assumes "idem_scene X" "idem_scene Y"
  shows "X S Y = ( s1 s2. cpX s1  cpY s2 = cpY (cpX s1 s2))"
  using assms
  by (simp add: less_eq_scene_def fun_eq_iff, transfer, auto)

lemma subscene_eliminate:
  " idem_scene Y; X  Y   s1 S s2 on X S s3 on Y = s1 S s3 on Y"
  by (metis less_eq_scene_def scene_override_overshadow_left scene_override_idem)
    
lemma scene_bot_least: "S  X"
  unfolding less_eq_scene_def by (transfer, auto)

lemma scene_top_greatest: "X  S"
  unfolding less_eq_scene_def by (transfer, auto)

lemma scene_union_ub: " idem_scene Y; X S Y   X  (X S Y)"
  by (simp add: less_eq_scene_def, transfer, auto)
     (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_overshadow_right)

lemma scene_le_then_compat: " idem_scene X; idem_scene Y; X  Y   X ##S Y"
  unfolding less_eq_scene_def
  by (transfer, auto, metis (no_types, lifting) idem_overrider.ovr_idem overrider_def)

lemma indep_then_compl_in: "A S B  A  -B"
  unfolding less_eq_scene_def by (transfer, simp)

lift_definition scene_comp :: "'a scene  ('a  'b)  'b scene" (infixl ";S" 80)
is "λ S X a b. if (vwb_lens X) then putX a (S (getX a) (getX b)) else a"
  by (unfold_locales, auto)

lemma scene_comp_idem [simp]: "idem_scene S  idem_scene (S ;S X)"
  by (transfer, unfold_locales, simp_all)

lemma scene_comp_lens_indep [simp]: "X  Y  (A ;S X) S (A ;S Y)"
  by (transfer, auto simp add: lens_indep.lens_put_comm lens_indep.lens_put_irr2)

lemma scene_comp_indep [simp]: "A S B  (A ;S X) S (B ;S X)"
  by (transfer, auto)

subsection ‹ Linking Scenes and Lenses ›

text ‹ The following function extracts a scene from a very well behaved lens ›

lift_definition lens_scene :: "('v  's)  's scene" ("_") is
"λ X s1 s2. if (mwb_lens X) then s1 L s2 on X else s1"
  by (unfold_locales, auto simp add: lens_override_def)

lemma vwb_impl_idem_scene [simp]:
  "vwb_lens X  idem_scene X"
  by (transfer, unfold_locales, auto simp add: lens_override_overshadow_left lens_override_overshadow_right)

lemma idem_scene_impl_vwb:
  " mwb_lens X; idem_scene X   vwb_lens X"
  apply (cases "mwb_lens X")
   apply (transfer, unfold idem_overrider_def overrider_def, auto)
  apply (simp add: idem_overrider_axioms_def override_idem_implies_vwb)
  done

lemma lens_compat_scene: " mwb_lens X; mwb_lens Y   X ##L Y  X ##S Y"
  by (auto simp add: lens_scene.rep_eq scene_compat.rep_eq lens_defs)

text ‹ Next we show some important congruence properties ›

lemma zero_lens_scene: "0L = S"
  by (transfer, simp)

lemma one_lens_scene: "1L = S"
  by (transfer, simp)

lemma lens_scene_override: 
  "mwb_lens X  s1 S s2 on X = s1 L s2 on X"
  by (transfer, simp)

lemma lens_indep_scene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "(X  Y)  X S Y"
  using assms
  by (auto, (simp add: scene_indep_override, transfer, simp add: lens_indep_override_def)+)

lemma lens_indep_impl_scene_indep [simp]:
  "(X  Y)  X S Y"
  by (transfer, auto simp add: lens_indep_comm lens_override_def)

lemma lens_plus_scene:
  " vwb_lens X; vwb_lens Y; X  Y   X +L Y = X S Y"
  by (transfer, auto simp add: lens_override_plus lens_indep_override_def lens_indep_overrideI plus_vwb_lens)

lemma subscene_implies_sublens': " vwb_lens X; vwb_lens Y   X  Y  X L' Y"
  by (simp add: lens_defs less_eq_scene_def, transfer, simp add: lens_override_def)

lemma sublens'_implies_subscene: " vwb_lens X; vwb_lens Y; X L' Y   X  Y"
  by (simp add: lens_defs less_eq_scene_def, auto simp add: lens_override_def lens_scene_override)

lemma sublens_iff_subscene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X L Y  X  Y"
  by (simp add: assms sublens_iff_sublens' subscene_implies_sublens')

text ‹ Equality on scenes is sound and complete with respect to lens equivalence. ›

lemma lens_equiv_scene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X L Y  X = Y"
proof
  assume a: "X L Y"
  show "X = Y"
    by (meson a assms lens_equiv_def sublens_iff_subscene subscene_antisym vwb_impl_idem_scene)
next
  assume b: "X = Y"
  show "X L Y"
    by (simp add: assms b lens_equiv_def sublens_iff_subscene subscene_refl)
qed

definition lens_insert :: "('a  'b)  'b scene  'b scene" ("insertS") where
"lens_insert x A = (if (x  A) then x S A else A)"

lemma lens_insert_idem: "insertS x (insertS x A) = insertS x A"
  apply (auto simp add: lens_insert_def less_eq_scene_def)
  apply (transfer)
  apply (auto simp add: lens_override_overshadow_left)
  apply (metis lens_override_overshadow_left)
  done

text ‹ Membership operations. These have slightly hacky definitions at the moment in order to
  cater for @{term mwb_lens}. See if they can be generalised? ›

definition lens_member :: "('a  'b)  'b scene  bool" (infix "S" 50) where
[lens_defs]:
"lens_member x A = (( s1 s2 s3. s1 S s2 on A L s3 on x = s1 S (s2 L s3 on x) on A) 
                      ( b b'. getx (b S b' on A) = getx b'))"

lemma lens_member_override: "x S A  s1 S s2 on A L s3 on x = s1 S (s2 L s3 on x) on A"
  using lens_member_def by force

lemma lens_member_put:
  assumes "vwb_lens x" "idem_scene a" "x S a"
  shows "putx s v S s on a = s"
  by (metis (full_types) assms lens_member_override lens_override_def scene_override_idem vwb_lens.put_eq)

lemma lens_member_top: "x S S"
  by (auto simp add: lens_member_def)

abbreviation lens_not_member :: "('a  'b)  'b scene  bool" (infix "S" 50) where
"x S A  (x S - A)" 

lemma lens_member_get_override [simp]: "x S a  getx (b S b' on a) = getx b'"
  by (simp add: lens_member_def)

lemma lens_not_member_get_override [simp]: "x S a  getx (b S b' on a) = getx b"
  by (simp add: lens_member_def scene_override_commute)

subsection ‹ Function Domain Scene ›

lift_definition fun_dom_scene :: "'a set  ('a  'b::two) scene" ("fds") is
"λ A f g. override_on f g A" by (unfold_locales, simp_all add: override_on_def fun_eq_iff)

lemma fun_dom_scene_empty: "fds({}) = S"
  by (transfer, simp)

lemma fun_dom_scene_union: "fds(A  B) = fds(A) S fds(B)"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_compl: "fds(- A) = - fds(A)"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_inter: "fds(A  B) = fds(A) S fds(B)"
  by (simp add: inf_scene_def fun_dom_scene_union[THEN sym] fun_dom_scene_compl[THEN sym])

lemma fun_dom_scene_UNIV: "fds(UNIV) = S"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_indep [simp]:   
  "fds(A) S fds(B)  A  B = {}"
  by (transfer, auto simp add: override_on_def fun_eq_iff, meson two_diff)

lemma fun_dom_scene_always_compat [simp]: "fds(A) ##S fds(B)"
  by (transfer, simp add: override_on_def fun_eq_iff)

lemma fun_dom_scene_le [simp]: "fds(A) S fds(B)  A  B"
  unfolding less_eq_scene_def
  by (transfer, auto simp add: override_on_def fun_eq_iff, meson two_diff)

text ‹ Hide implementation details for scenes ›  

lifting_update scene.lifting
lifting_forget scene.lifting

end

Theory Optics

section ‹Optics Meta-Theory›

theory Optics
  imports Lenses Prisms Scenes Dataspace Channel_Type
begin end

Theory Lens_Record_Example

theory Lens_Record_Example
  imports Optics
begin

text ‹The alphabet command supports syntax illustrated in the following comments.›

alphabet mylens =
  x :: nat
  y :: string

thm base_more_bij_lens
thm indeps
thm equivs
thm sublenses
thm quotients
thm compositions

lemma mylens_composition: 
  "x +L y +L moreL L 1L" (is "?P L ?Q")
proof -
  have "?Q L baseL +L moreL"
    by (simp add: lens_equiv_sym)
  also have "... L (x +L y) +L moreL"
    by (simp add: lens_plus_eq_left)
  also have "... L x +L y +L moreL"
    by (simp add: lens_plus_assoc)
  finally show ?thesis
    using lens_equiv_sym by auto
qed

lemma mylens_bij_lens:
  "bij_lens (x +L y +L moreL)"
  using bij_lens_equiv_id mylens_composition by auto

alphabet mylens_2 = mylens +
  z :: int
  k :: "string list"

thm lens_defs

thm base_more_bij_lens
thm indeps
thm equivs
thm sublenses

alphabet mylens_3 = mylens_2 +
  n :: real
  h :: nat

thm base_more_bij_lens
thm indeps
thm equivs
thm sublenses

end

Theory Lens_State

section ‹State and Lens integration›

theory Lens_State
imports
  "HOL-Library.State_Monad"
  Lens_Algebra
begin

text ‹Inspired by Haskell's lens package›

definition zoom :: "('a  'b)  ('a, 'c) state  ('b, 'c) state" where
"zoom l m = State (λb. case run_state m (lens_get l b) of (c, a)  (c, lens_put l b a))"

definition use :: "('a  'b)  ('b, 'a) state" where
"use l = zoom l State_Monad.get"

definition modify :: "('a  'b)  ('a  'a)  ('b, unit) state" where
"modify l f = zoom l (State_Monad.update f)"

definition assign :: "('a  'b)  'a  ('b, unit) state" where
"assign l b = zoom l (State_Monad.set b)"

context begin

qualified abbreviation "add l n  modify l (λx. x + n)"
qualified abbreviation "sub l n  modify l (λx. x - n)"
qualified abbreviation "mul l n  modify l (λx. x * n)"
qualified abbreviation "inc l  add l 1"
qualified abbreviation "dec l  sub l 1"

end

bundle lens_state_notation begin
  notation zoom (infixr "" 80)
  notation modify (infix "%=" 80)
  notation assign (infix ".=" 80)
  notation Lens_State.add (infix "+=" 80)
  notation Lens_State.sub (infix "-=" 80)
  notation Lens_State.mul (infix "*=" 80)
  notation Lens_State.inc ("_ ++")
  notation Lens_State.dec ("_ --")
end

context includes lens_state_notation begin

lemma zoom_comp1: "l1  l2  s = (l2 ;L l1)  s"
unfolding zoom_def lens_comp_def
by (auto split: prod.splits)

lemma zoom_zero[simp]: "zero_lens  s = s"
unfolding zoom_def zero_lens_def
by simp

lemma zoom_id[simp]: "id_lens  s = s"
unfolding zoom_def id_lens_def
by simp

end

lemma (in mwb_lens) zoom_comp2[simp]: "zoom x m  (λa. zoom x (n a)) = zoom x (m  n)"
unfolding zoom_def State_Monad.bind_def
by (auto split: prod.splits simp: put_get put_put)

lemma (in wb_lens) use_alt_def: "use x = map_state (lens_get x) State_Monad.get"
unfolding State_Monad.get_def use_def zoom_def
by (simp add: comp_def get_put)

lemma (in wb_lens) modify_alt_def: "modify x f = State_Monad.update (update f)"
  unfolding modify_def zoom_def lens_update_def State_Monad.update_def State_Monad.get_def State_Monad.set_def State_Monad.bind_def
  by (auto)
 
lemma (in wb_lens) modify_id[simp]: "modify x (λx. x) = State_Monad.return ()"
unfolding lens_update_def modify_alt_def
by (simp add: get_put)

lemma (in mwb_lens) modify_comp[simp]: "bind (modify x f) (λ_. modify x g) = modify x (g  f)"
unfolding modify_def
by simp

end