# 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)
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)
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)
― ‹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. put⇘X⇙ 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 = put⇘X⇙ 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]: "create⇘X⇙ v = put⇘X⇙ (src⇘X⇙) 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 σ = put⇘X⇙ σ (f (get⇘X⇙ σ))"

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]: "s⇩1 ≃⇘X⇙ s⇩2 = (s⇩1 = put⇘X⇙ s⇩2 (get⇘X⇙ s⇩1))"

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]: "S⇩1 ◃⇘X⇙ S⇩2 = put⇘X⇙ S⇩1 (get⇘X⇙ S⇩2)"

abbreviation (input) lens_override' :: "'a ⇒ 'a ⇒ ('b ⟹ 'a) ⇒ 'a" ("_ ⊕⇩L _ on _" [95,0,96] 95) where
"S⇩1 ⊕⇩L S⇩2 on X ≡ S⇩1 ◃⇘X⇙ S⇩2"

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 ∈ 𝒮"

lemma put_closure: "put σ v ∈ 𝒮"

lemma create_closure: "create v ∈ 𝒮"

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

lemma create_get: "get (create v) = v"

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

lemma get_update: "get (update f σ) = f (get σ)"

lemma view_determination:
assumes "put σ u = put ρ v"
shows "u = v"
by (metis assms put_get)

lemma put_inj: "inj (put σ)"

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"

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"

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)"

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"

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 σ) = σ"
show "put (put σ v) u = put σ u"
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"

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"

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⇙ ⟹ create⇘X⇙ (get⇘X⇙ 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 σ) = σ"
qed

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

lemma get_create: "create (get σ) = σ"

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"

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: "put⇘X⇙ (put⇘Y⇙ σ v) u = put⇘Y⇙ (put⇘X⇙ σ u) v"
and lens_put_irr1: "get⇘X⇙ (put⇘Y⇙ σ v) = get⇘X⇙ σ"
and lens_put_irr2: "get⇘Y⇙ (put⇘X⇙ σ u) = get⇘Y⇙ σ"

notation lens_indep (infix "⨝" 50)

lemma lens_indepI:
"⟦ ⋀ u v σ. put⇘x⇙ (put⇘y⇙ σ v) u = put⇘y⇙ (put⇘x⇙ σ u) v;
⋀ v σ. get⇘x⇙ (put⇘y⇙ σ v) = get⇘x⇙ σ;
⋀ u σ. get⇘y⇙ (put⇘x⇙ σ u) = get⇘y⇙ σ ⟧ ⟹ x ⨝ y"

text ‹Lens independence is symmetric.›

lemma lens_indep_sym:  "x ⨝ y ⟹ y ⨝ x"

lemma lens_indep_comm:
"x ⨝ y ⟹ put⇘x⇙ (put⇘y⇙ σ v) u = put⇘y⇙ (put⇘x⇙ σ u) v"

lemma lens_indep_get [simp]:
assumes "x ⨝ y"
shows "get⇘x⇙ (put⇘y⇙ σ v) = get⇘x⇙ σ"
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 σ. put⇘x⇙ (put⇘y⇙ σ v) u = put⇘y⇙ (put⇘x⇙ σ u) v)"
proof
assume "x ⨝ y"
thus "∀ u v σ. put⇘x⇙ (put⇘y⇙ σ v) u = put⇘y⇙ (put⇘x⇙ σ u) v"
next
assume a: "∀ u v σ. put⇘x⇙ (put⇘y⇙ σ v) u = put⇘y⇙ (put⇘x⇙ σ u) v"
show "x ⨝ y"
proof (unfold_locales)
fix σ v u
from a show "put⇘x⇙ (put⇘y⇙ σ v) u = put⇘y⇙ (put⇘x⇙ σ u) v"
by auto
show "get⇘x⇙ (put⇘y⇙ σ v) = get⇘x⇙ σ"
by (metis a assms(1) vwb_lens.put_eq vwb_lens_wb wb_lens_def weak_lens.put_get)
show "get⇘y⇙ (put⇘x⇙ σ u) = get⇘y⇙ σ"
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 = (∀s⇩1 s⇩2. s⇩1 ◃⇘X⇙ s⇩2 ◃⇘Y⇙ s⇩2 = s⇩1 ◃⇘Y⇙ s⇩2 ◃⇘X⇙ s⇩2)"

lemma lens_compat_idem [simp]: "x ##⇩L x"

lemma lens_compat_sym: "x ##⇩L y ⟹ y ##⇩L x"

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}
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 = get⇘Y⇙ ∘ 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 get⇘X⇙ get⇘Y⇙
, lens_put = λ (u, v) (x, y). (put⇘X⇙ u x, put⇘Y⇙ 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" ("fst⇩L") where
[lens_defs]: "fst⇩L = ⦇ lens_get = fst, lens_put = (λ (σ, ρ) u. (u, ρ)) ⦈"

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

lemma get_fst_lens [simp]: "get⇘fst⇩L⇙ (x, y) = x"

lemma get_snd_lens [simp]: "get⇘snd⇩L⇙ (x, y) = y"

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" ("swap⇩L") where
"swap⇩L ≡ snd⇩L +⇩L fst⇩L"

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" ("0⇩L") where
[lens_defs]: "0⇩L = ⦇ 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" ("1⇩L") where
[lens_defs]: "1⇩L = ⦇ 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 = λ σ. get⇘X⇙ (create⇘Y⇙ σ)
, lens_put = λ σ v. get⇘Y⇙ (put⇘X⇙ (create⇘Y⇙ σ) v) ⦈"

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

definition lens_inv :: "('a ⟹ 'b) ⇒ ('b ⟹ 'a)" ("inv⇩L") where
[lens_defs]: "lens_inv x = ⦇ lens_get = create⇘x⇙, lens_put = λ σ. get⇘x⇙ ⦈"

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 1⇩L"

lemma source_id_lens: "𝒮⇘1⇩L⇙ = UNIV"

lemma unit_wb_lens: "wb_lens 0⇩L"

lemma source_zero_lens: "𝒮⇘0⇩L⇙ = UNIV"

lemma comp_weak_lens: "⟦ weak_lens x; weak_lens y ⟧ ⟹ weak_lens (x ;⇩L y)"

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⇙. get⇘y⇙ 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 1⇩L"

lemma unit_vwb_lens [simp]: "vwb_lens 0⇩L"

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 0⇩L"

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)
done

lemma plus_wb_lens:
assumes "wb_lens x" "wb_lens y" "x ⨝ y"
shows "wb_lens (x +⇩L y)"
using assms
done

lemma plus_vwb_lens [simp]:
assumes "vwb_lens x" "vwb_lens y" "x ⨝ y"
shows "vwb_lens (x +⇩L y)"
using assms
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 fst⇩L"
by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if)

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

lemma id_bij_lens: "bij_lens 1⇩L"

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

lemma inv_inv_lens: "bij_lens X ⟹ inv⇩L (inv⇩L 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 (inv⇩L X)"
by (unfold_locales, simp_all add: lens_inv_def lens_create_def)

lemma swap_bij_lens: "bij_lens swap⇩L"
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 "1⇩L"}, as the following theorems demonstrate.
It also has @{term "0⇩L"} as a right annihilator. ›

lemma lens_comp_assoc: "X ;⇩L (Y ;⇩L Z) = (X ;⇩L Y) ;⇩L Z"

lemma lens_comp_left_id [simp]: "1⇩L ;⇩L X = X"

lemma lens_comp_right_id [simp]: "X ;⇩L 1⇩L = X"

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

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

subsection ‹Independence Laws›

text ‹The zero lens @{term "0⇩L"} is independent of any lens. This is because nothing can be observed
or changed using @{term "0⇩L"}. ›

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

lemma zero_lens_indep' [simp]: "X ⨝ 0⇩L"
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)
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
done

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

lemma lens_indep_right_ext [intro]:
"x ⨝ z ⟹ x ⨝ (y ;⇩L z)"

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 σ="create⇘Z⇙ σ" in lens_indep_comm)
apply (meson mwb_lens_weak weak_lens.view_determination)
apply (rename_tac v σ)
apply (drule_tac v=v and σ="create⇘Z⇙ σ" in lens_indep_get)
apply (drule lens_indep_sym)
apply (rename_tac u σ)
apply (drule_tac v=u and σ="create⇘Z⇙ σ" in lens_indep_get)
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]:
"fst⇩L ⨝ snd⇩L"
by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma snd_fst_lens_indep [simp]:
"snd⇩L ⨝ fst⇩L"
by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma split_prod_lens_indep:
assumes "mwb_lens X"
shows "(fst⇩L ;⇩L X) ⨝ (snd⇩L ;⇩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)
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:
"⟦ X⇩1 ⨝ X⇩2; Y⇩1 ⨝ Y⇩2 ⟧ ⟹ X⇩1 ×⇩L Y⇩1 ⨝ X⇩2 ×⇩L Y⇩2"
apply (rule lens_indepI)
apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def)
done

subsection ‹ Compatibility Laws ›

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

lemma id_lens_compat [simp]: "vwb_lens X ⟹ 1⇩L ##⇩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 ⟹ fst⇩L ;⇩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 ⟧ ⟹ snd⇩L ;⇩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 ⟹ swap⇩L ;⇩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: "fst⇩L +⇩L snd⇩L = 1⇩L"
by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def)

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

lemma swap_lens_fst: "fst⇩L ;⇩L swap⇩L = snd⇩L"

lemma swap_lens_snd: "snd⇩L ;⇩L swap⇩L = fst⇩L"
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 fst⇩L +⇩L Y ;⇩L snd⇩L"
by (auto simp add: lens_prod_def fst_lens_def snd_lens_def lens_comp_def lens_plus_def)

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

lemma prod_lens_comp_plus:
"X⇩2 ⨝ Y⇩2 ⟹ ((X⇩1 ×⇩L Y⇩1) ;⇩L (X⇩2 +⇩L Y⇩2)) = (X⇩1 ;⇩L X⇩2) +⇩L (Y⇩1 ;⇩L Y⇩2)"
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"

lemma lens_quotient_id [simp]: "weak_lens X ⟹ (X /⇩L X) = 1⇩L"
by (force simp add: lens_quotient_def id_lens_def)

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

lemma lens_quotient_unit: "weak_lens X ⟹ (0⇩L /⇩L X) = 0⇩L"

lemma lens_obs_eq_zero: "s⇩1 ≃⇘0⇩L⇙ s⇩2 = (s⇩1 = s⇩2)"

lemma lens_obs_eq_one: "s⇩1 ≃⇘1⇩L⇙ s⇩2"

lemma lens_obs_eq_as_override: "vwb_lens X ⟹ s⇩1 ≃⇘X⇙ s⇩2 ⟷ (s⇩2 = s⇩1 ⊕⇩L s⇩2 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 Z⇩1 Z⇩2)
apply (rule_tac x="Z⇩1 ;⇩L Z⇩2" in exI)
using comp_vwb_lens apply blast
done

text ‹Sublens has a least element -- @{text "0⇩L"} -- and a greatest element -- @{text "1⇩L"}.
Intuitively, this shows that sublens orders how large a portion of the source type a particular
lens views, with @{text "0⇩L"} observing the least, and @{text "1⇩L"} observing the most.›

lemma sublens_least: "wb_lens X ⟹ 0⇩L ⊆⇩L X"
using sublens_def unit_vwb_lens by fastforce

lemma sublens_greatest: "vwb_lens X ⟹ X ⊆⇩L 1⇩L"

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 ⟧ ⟹ put⇘X⇙ (put⇘Y⇙ σ v) u = put⇘X⇙ σ u"
by (auto simp add: sublens_def lens_comp_def)

lemma sublens_obs_get:
"⟦ mwb_lens X; Y ⊆⇩L X ⟧ ⟹  get⇘Y⇙ (put⇘X⇙ σ v) = get⇘Y⇙ (put⇘X⇙ ρ 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)
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"

lemma lens_equiv_refl:
"X ≈⇩L X"

lemma lens_equiv_sym:
"X ≈⇩L Y ⟹ Y ≈⇩L X"

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)
done

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

lemma lens_quotient_plus_den1:
"⟦ weak_lens x; weak_lens y; x ⨝ y ⟧ ⟹ x /⇩L (x +⇩L y) = fst⇩L"
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 snd⇩L "
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 (rename_tac Z⇩1 Z⇩2)
apply (rule_tac x="Z⇩1 +⇩L Z⇩2" in exI)
apply (auto intro!: plus_wb_lens)
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 (rule_tac x="(fst⇩L ;⇩L fst⇩L) +⇩L (snd⇩L ;⇩L fst⇩L) +⇩L snd⇩L" in exI)
apply (auto)
apply (rule plus_vwb_lens)
apply (rule plus_vwb_lens)
apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
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 (rule_tac x="(fst⇩L +⇩L (fst⇩L ;⇩L snd⇩L)) +⇩L (snd⇩L ;⇩L snd⇩L)" in exI)
apply (auto)
apply (rule plus_vwb_lens)
apply (rule plus_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 (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 (rule_tac x="snd⇩L +⇩L fst⇩L" in exI)
apply (auto)
apply (simp add: fst_vwb_lens lens_indep_sym snd_vwb_lens)
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 (rename_tac Z')
apply (rule_tac x="Z' ;⇩L snd⇩L" 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 (rename_tac Z')
apply (rule_tac x="Z' ×⇩L 1⇩L" 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"

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 "0⇩L"} is the unit of lens plus›

lemma lens_unit_plus_sublens_1: "X ⊆⇩L 0⇩L +⇩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: "0⇩L +⇩L X ⊆⇩L X"
apply (rule_tac x="0⇩L +⇩L 1⇩L" 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: "0⇩L +⇩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 0⇩L ≈⇩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: "⟦ Y⇩1 ⨝ Y⇩2; X⇩1 ⊆⇩L Y⇩1; X⇩2 ⊆⇩L Y⇩2 ⟧ ⟹ X⇩1 +⇩L X⇩2 ⊆⇩L Y⇩1 +⇩L Y⇩2"
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 "X⇩1 ⨝ X⇩2" "X⇩1 ≈⇩L Y⇩1" "X⇩2 ≈⇩L Y⇩2"
shows "X⇩1 +⇩L X⇩2 ≈⇩L Y⇩1 +⇩L Y⇩2"
proof -
have "X⇩1 +⇩L X⇩2 ≈⇩L Y⇩1 +⇩L X⇩2"
by (simp add: assms(1) assms(2) lens_plus_eq_left)
moreover have "... ≈⇩L Y⇩1 +⇩L Y⇩2"
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:
"⟦ X⇩1 ⊆⇩L X⇩2; Y⇩1 ⊆⇩L Y⇩2 ⟧ ⟹ (X⇩1 ×⇩L Y⇩1) ⊆⇩L (X⇩2 ×⇩L Y⇩2)"
apply (rename_tac Z⇩1 Z⇩2)
apply (rule_tac x="Z⇩1 ×⇩L Z⇩2" 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:
"⟦ X⇩1 ≈⇩L X⇩2; Y⇩1 ≈⇩L Y⇩2 ⟧ ⟹ (X⇩1 ×⇩L Y⇩1) ≈⇩L (X⇩2 ×⇩L Y⇩2)"

text ‹We also have the following "exchange" law that allows us to switch over a lens product and plus.›

lemma lens_plus_prod_exchange:
"(X⇩1 +⇩L X⇩2) ×⇩L (Y⇩1 +⇩L Y⇩2) ≈⇩L (X⇩1 ×⇩L Y⇩1) +⇩L (X⇩2 ×⇩L Y⇩2)"
proof (rule lens_equivI)
show "(X⇩1 +⇩L X⇩2) ×⇩L (Y⇩1 +⇩L Y⇩2) ⊆⇩L (X⇩1 ×⇩L Y⇩1) +⇩L (X⇩2 ×⇩L Y⇩2)"
apply (rule_tac x="((fst⇩L ;⇩L fst⇩L) +⇩L (fst⇩L ;⇩L snd⇩L)) +⇩L ((snd⇩L ;⇩L fst⇩L) +⇩L (snd⇩L ;⇩L snd⇩L))" 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 "(X⇩1 ×⇩L Y⇩1) +⇩L (X⇩2 ×⇩L Y⇩2) ⊆⇩L (X⇩1 +⇩L X⇩2) ×⇩L (Y⇩1 +⇩L Y⇩2)"
apply (rule_tac x="((fst⇩L ;⇩L fst⇩L) +⇩L (fst⇩L ;⇩L snd⇩L)) +⇩L ((snd⇩L ;⇩L fst⇩L) +⇩L (snd⇩L ;⇩L snd⇩L))" 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 ⟧ ⟹ get⇘Y⇙ (put⇘X⇙ s v) = put⇘X /⇩L Y⇙ (get⇘Y⇙ s) v"
proof -
assume a1: "vwb_lens Y"
assume a2: "X ⊆⇩L Y"
have "⋀l la. put⇘l ;⇩L la⇙ = (λb c. put⇘la⇙ (b::'b) (put⇘l⇙ (get⇘la⇙ b::'a) (c::'c)))"
then have "⋀l la b c. get⇘l⇙ (put⇘la ;⇩L l⇙ (b::'b) (c::'c)) = put⇘la⇙ (get⇘l⇙ 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 ⟧ ⟹ put⇘Y⇙ s (put⇘X /⇩L Y⇙ v⇩2 v⇩1) = put⇘X⇙ (put⇘Y⇙ s v⇩2) v⇩1"
proof -
assume a1: "vwb_lens Y"
assume a2: "X ⊆⇩L Y"
have f3: "⋀l b. put⇘l⇙ (b::'b) (get⇘l⇙ b::'a) = b ∨ ¬ vwb_lens l"
by force
have f4: "⋀b c. put⇘X /⇩L Y⇙ (get⇘Y⇙ b) c = get⇘Y⇙ (put⇘X⇙ b c)"
using a2 a1 by (simp add: lens_get_put_quasi_commute)
have "⋀b c a. put⇘Y⇙ (put⇘X⇙ b c) a = put⇘Y⇙ 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 "1⇩L"}.›

lemma bij_lens_inv_left:
"bij_lens X ⟹ inv⇩L X ;⇩L X = 1⇩L"
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 inv⇩L X = 1⇩L"
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 1⇩L"
apply (auto)
apply (rule lens_equivI)
apply (rule_tac x="lens_inv X" in exI)
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 "1⇩L"} 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 = 1⇩L"
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 "1⇩L"}, 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 = 1⇩L ⟧ ⟹ 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 = 1⇩L ⟧ ⟹ 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 Z⇩1 Z⇩2)
apply (rule_tac x="Z⇩1" in exI)
apply (simp)
apply (subgoal_tac "Z⇩2 ;⇩L Z⇩1 = 1⇩L")
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]:
"S⇩1 ⊕⇩L S⇩2 on 1⇩L = S⇩2"

lemma lens_override_unit [simp]:
"S⇩1 ⊕⇩L S⇩2 on 0⇩L = S⇩1"

assumes "mwb_lens Y"  "X ⊆⇩L Y"
shows "(S⇩1 ⊕⇩L S⇩2 on X) ⊕⇩L S⇩3 on Y = S⇩1 ⊕⇩L S⇩3 on Y"
using assms by (simp add: lens_override_def sublens_put_put)

lemma lens_override_irr:
assumes "X ⨝ Y"
shows "S⇩1 ⊕⇩L (S⇩2 ⊕⇩L S⇩3 on Y) on X = S⇩1 ⊕⇩L S⇩2 on X"
using assms by (simp add: lens_override_def)

assumes "mwb_lens X"
shows "(S⇩1 ⊕⇩L S⇩2 on X) ⊕⇩L S⇩3 on X = S⇩1 ⊕⇩L S⇩3 on X"

assumes "mwb_lens X"
shows "S⇩1 ⊕⇩L (S⇩2  ⊕⇩L S⇩3 on X) on X = S⇩1 ⊕⇩L S⇩3 on X"

lemma lens_override_plus:
"X ⨝ Y ⟹ S⇩1 ⊕⇩L S⇩2 on (X +⇩L Y) = (S⇩1 ⊕⇩L S⇩2 on X) ⊕⇩L S⇩2 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"

lemma lens_override_mwb_idem [simp]:
"⟦ mwb_lens X; S ∈ 𝒮⇘X⇙ ⟧ ⟹ S ⊕⇩L S on X = S"

lemma lens_override_put_right_in:
"⟦ vwb_lens A; X ⊆⇩L A ⟧ ⟹ S⇩1 ⊕⇩L (put⇘X⇙ S⇩2 v) on A = put⇘X⇙ (S⇩1 ⊕⇩L S⇩2 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 ⟧ ⟹ S⇩1 ⊕⇩L (put⇘X⇙ S⇩2 v) on A = (S⇩1 ⊕⇩L S⇩2 on A)"

lemma lens_indep_overrideI:
assumes "vwb_lens X" "vwb_lens Y" "(⋀ s⇩1 s⇩2 s⇩3. s⇩1 ⊕⇩L s⇩2 on X ⊕⇩L s⇩3 on Y = s⇩1 ⊕⇩L s⇩3 on Y ⊕⇩L s⇩2 on X)"
shows "X ⨝ Y"
using assms
apply (unfold_locales)
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 ⟷ (∀ s⇩1 s⇩2 s⇩3. s⇩1 ⊕⇩L s⇩2 on X ⊕⇩L s⇩3 on Y = s⇩1 ⊕⇩L s⇩3 on Y ⊕⇩L s⇩2 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"

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 = (∀ s⇩1 s⇩2 s⇩3. s⇩1 ⊕⇩L s⇩2 on Y ⊕⇩L s⇩3 on X = s⇩1 ⊕⇩L s⇩2 ⊕⇩L s⇩3 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 "put⇘X⇙ (put⇘Y⇙ s⇩1 (get⇘Y⇙ s⇩2)) s⇩3 = put⇘Y⇙ s⇩1 (get⇘Y⇙ (put⇘X⇙ s⇩2 s⇩3))"
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 "get⇘X⇙ (put⇘Y⇙ s⇩1 (get⇘Y⇙ s⇩2)) = get⇘X⇙ s⇩2"
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 "put⇘Y⇙ σ (get⇘Y⇙ (put⇘X⇙ (put⇘Y⇙ ρ (get⇘Y⇙ σ)) v)) = put⇘X⇙ σ 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 "get⇘X⇙ = (λσ. get⇘X⇙ (create⇘Y⇙ σ)) ∘ get⇘Y⇙"
by (rule ext, simp add: assms(1) assms(3) lens_create_def sublens'_prop2)
moreover have "put⇘X⇙ = (λσ v. put⇘Y⇙ σ (get⇘Y⇙ (put⇘X⇙ (create⇘Y⇙ (get⇘Y⇙ σ)) v)))"
by (rule ext, rule ext, simp add: assms(1) assms(2) assms(3) lens_create_def sublens'_prop3)
ultimately show ?thesis
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 = (∀ s⇩1 s⇩2. (s⇩1 ⊕⇩L s⇩2 on X = s⇩1 ⊕⇩L s⇩2 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⇙"

lemma coview_slens_compl [simp]: "𝒞⇘-⇩L a⇙ =  𝒱⇘a⇙"

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 (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 𝒱"
show "mwb_lens 𝒞"
show "𝒱 ⨝ 𝒞"
using indep_region_coregion by blast
show "pbij_lens (𝒱 +⇩L 𝒞)"
qed

lemma put_region_coregion_cover:
"put⇘𝒱⇙ (put⇘𝒞⇙ s⇩1 (get⇘𝒞⇙ s⇩2)) (get⇘𝒱⇙ s⇩2) = s⇩2"
proof -
have "put⇘𝒱⇙ (put⇘𝒞⇙ s⇩1 (get⇘𝒞⇙ s⇩2)) (get⇘𝒱⇙ s⇩2) = put⇘𝒱 +⇩L 𝒞⇙ s⇩1 (get⇘𝒱 +⇩L 𝒞⇙ s⇩2)"
also have "... = s⇩2"
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"

lemma sym_lens_compl [simp]: "sym_lens a ⟹ sym_lens (-⇩L a)"
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)"

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. get⇘X⇙ ∘ get⇘Y⇙ s
, lens_put = λ s v. put⇘Y⇙ s (λ x::'a. put⇘X⇙ (get⇘Y⇙ 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)"

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]"

lemma list_update_append_lemma2: "i < length ys ⟹ xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"

text ‹We can also prove some laws about our new operators.›

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"

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

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

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

lemma list_augment_twice:
"list_augment (list_augment xs i u) j v = (list_pad_out xs (max i j))[i:=u, j:=v]"
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"

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"

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"

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"

lemma length_list_augment_2: "k < length xs ⟹ length (list_augment xs k v) = length xs"

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"

lemma nth'_list_augment_diff: "i ≠ j ⟹ nth' (list_augment σ i v) j = nth' σ j"

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 ("hd⇩L") where "hd_lens ≡ list_lens 0"

definition tl_lens :: "'a list ⟹ 'a list" ("tl⇩L") 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 tl⇩L"

lemma source_tail_lens: "𝒮⇘tl⇩L⇙ = {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]:
"hd⇩L ⨝ tl⇩L"
apply (rule lens_indepI)
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 (hd⇩L +⇩L tl⇩L)"
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" ("typedef⇩L") where [lens_defs]: "typedef⇩L = ⦇ lens_get = Abs, lens_put = (λ s. Rep) ⦈" lemma pbij_typedef_lens [simp]: "pbij_lens typedef⇩L" by (unfold_locales, simp_all add: lens_defs Rep_inverse) lemma source_typedef_lens: "𝒮⇘typedef⇩L⇙ = A" using Rep_cases by (auto simp add: lens_source_def lens_defs Rep) lemma bij_typedef_lens_UNIV: "A = UNIV ⟹ bij_lens typedef⇩L" 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 (get⇘l⇙), lens_put = g o (put⇘l⇙) 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
(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 = "base⇩L"
val child_lensN = "more⇩L"
val all_lensN = "all⇩L"
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 =
Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt)
| T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T));

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;

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;

(* 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 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))
|> (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))
|> (fn thy => snd (add_thmss [((Binding.make (quotientsN, Position.none), map (quotient_proof tname thy) lnames), [Simplifier.simp_add])] thy))
|> (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))
|> (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)) =>
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 "+"}) --
-- 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. {(s⇩1, s⇩2). (∀ s. F s s⇩1 = F s s⇩2)}" . lift_definition coregion :: "'s scene ⇒ 's rel" is "λ F. {(s⇩1, s⇩2). (∀ s. F s⇩1 s = F s⇩2 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 "λ s⇩1 s⇩2 F. F s⇩1 s⇩2" . abbreviation (input) scene_copy :: "'a scene ⇒ 'a ⇒ ('a ⇒ 'a)" ("cp⇘_⇙") where "cp⇘A⇙ 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]: "S⇩1 ⊕⇩S S⇩2 on X ⊕⇩S S⇩3 on X = S⇩1 ⊕⇩S S⇩3 on X" by (transfer, simp) lemma scene_override_overshadow_right [simp]: "S⇩1 ⊕⇩S (S⇩2 ⊕⇩S S⇩3 on X) on X = S⇩1 ⊕⇩S S⇩3 on X" by (transfer, simp) definition scene_equiv :: "'a ⇒ 'a ⇒ ('a scene) ⇒ bool" ("_ ≈⇩S _ on _" [65,0,66] 65) where [lens_defs]: "S⇩1 ≈⇩S S⇩2 on X = (S⇩1 ⊕⇩S S⇩2 on X = S⇩1)" lemma scene_equiv_region: "idem_scene X ⟹ region X = {(S⇩1, S⇩2). S⇩1 ≈⇩S S⇩2 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. (∀ s⇩1 s⇩2 s⇩3. G (F s⇩1 s⇩2) s⇩3 = F (G s⇩1 s⇩3) s⇩2)" . lemma scene_indep_override: "X ⨝⇩S Y = (∀ s⇩1 s⇩2 s⇩3. s⇩1 ⊕⇩S s⇩2 on X ⊕⇩S s⇩3 on Y = s⇩1 ⊕⇩S s⇩3 on Y ⊕⇩S s⇩2 on X)" by (transfer, auto) lemma scene_indep_copy: "X ⨝⇩S Y = (∀ s⇩1 s⇩2. cp⇘X⇙ s⇩1 ∘ cp⇘Y⇙ s⇩2 = cp⇘Y⇙ s⇩2 ∘ cp⇘X⇙ s⇩1)" 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. (∀ s⇩1 s⇩2. G (F s⇩1 s⇩2) s⇩2 = F (G s⇩1 s⇩2) s⇩2)" . lemma scene_compat_copy: "X ##⇩S Y = (∀ s. cp⇘X⇙ s ∘ cp⇘Y⇙ s = cp⇘Y⇙ s ∘ cp⇘X⇙ 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 "S⇩1 ⊕⇩S S⇩2 on X ⊕⇩S S⇩3 on Y = S⇩1 ⊕⇩S S⇩3 on Y ⊕⇩S S⇩2 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 (∀ s⇩1 s⇩2. G (F s⇩1 s⇩2) s⇩2 = F (G s⇩1 s⇩2) s⇩2) then (λ s⇩1 s⇩2. G (F s⇩1 s⇩2) s⇩2) else (λ s⇩1 s⇩2. s⇩1)" 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]: "S⇩1 ⊕⇩S S⇩2 on ⊤⇩S = S⇩2" by (transfer, simp) lemma scene_override_unit [simp]: "S⇩1 ⊕⇩S S⇩2 on ⊥⇩S = S⇩1" by (transfer, simp) lemma scene_override_commute: "S⇩2 ⊕⇩S S⇩1 on (- X) = S⇩1 ⊕⇩S S⇩2 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 ⟹ S⇩1 ⊕⇩S S⇩2 on (X ⊔⇩S Y) = (S⇩1 ⊕⇩S S⇩2 on X) ⊕⇩S S⇩2 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 = (∀ s⇩1 s⇩2 s⇩3. s⇩1 ⊕⇩S s⇩2 on Y ⊕⇩S s⇩3 on X = s⇩1 ⊕⇩S (s⇩2 ⊕⇩S s⇩3 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"

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)
done

lemma subscene_copy_def:
assumes "idem_scene X" "idem_scene Y"
shows "X ⊆⇩S Y = (∀ s⇩1 s⇩2. cp⇘X⇙ s⇩1 ∘ cp⇘Y⇙ s⇩2 = cp⇘Y⇙ (cp⇘X⇙ s⇩1 s⇩2))"
using assms
by (simp add: less_eq_scene_def fun_eq_iff, transfer, auto)

lemma subscene_eliminate:
"⟦ idem_scene Y; X ≤ Y ⟧ ⟹ s⇩1 ⊕⇩S s⇩2 on X ⊕⇩S s⇩3 on Y = s⇩1 ⊕⇩S s⇩3 on Y"

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)

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 put⇘X⇙ a (S (get⇘X⇙ a) (get⇘X⇙ 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 s⇩1 s⇩2. if (mwb_lens X) then s⇩1 ⊕⇩L s⇩2 on X else s⇩1"
by (unfold_locales, auto simp add: lens_override_def)

lemma vwb_impl_idem_scene [simp]:
"vwb_lens X ⟹ idem_scene ⟦X⟧⇩∼"

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)
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: "⟦0⇩L⟧⇩∼ = ⊥⇩S"
by (transfer, simp)

lemma one_lens_scene: "⟦1⇩L⟧⇩∼ = ⊤⇩S"
by (transfer, simp)

lemma lens_scene_override:
"mwb_lens X ⟹ s⇩1 ⊕⇩S s⇩2 on ⟦X⟧⇩∼ = s⇩1 ⊕⇩L s⇩2 on X"
by (transfer, simp)

lemma lens_indep_scene:
assumes "vwb_lens X" "vwb_lens Y"
shows "(X ⨝ Y) ⟷ ⟦X⟧⇩∼ ⨝⇩S ⟦Y⟧⇩∼"
using assms

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"

lemma sublens'_implies_subscene: "⟦ vwb_lens X; vwb_lens Y; X ⊆⇩L' Y ⟧ ⟹ ⟦X⟧⇩∼ ≤ ⟦Y⟧⇩∼"

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" ("insert⇩S") where
"lens_insert x A = (if (⟦x⟧⇩∼ ≤ A) then ⟦x⟧⇩∼ ⊔⇩S A else A)"

lemma lens_insert_idem: "insert⇩S x (insert⇩S x A) = insert⇩S x A"
apply (auto simp add: lens_insert_def less_eq_scene_def)
apply (transfer)
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 = ((∀ s⇩1 s⇩2 s⇩3. s⇩1 ⊕⇩S s⇩2 on A ⊕⇩L s⇩3 on x = s⇩1 ⊕⇩S (s⇩2 ⊕⇩L s⇩3 on x) on A) ∧
(∀ b b'. get⇘x⇙ (b ⊕⇩S b' on A) = get⇘x⇙ b'))"

lemma lens_member_override: "x ∈⇩S A ⟹ s⇩1 ⊕⇩S s⇩2 on A ⊕⇩L s⇩3 on x = s⇩1 ⊕⇩S (s⇩2 ⊕⇩L s⇩3 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 "put⇘x⇙ 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"

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 ⟹ get⇘x⇙ (b ⊕⇩S b' on a) = get⇘x⇙ b'"

lemma lens_not_member_get_override [simp]: "x ∉⇩S a ⟹ get⇘x⇙ (b ⊕⇩S b' on a) = get⇘x⇙ b"

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 more⇩L ≈⇩L 1⇩L" (is "?P ≈⇩L ?Q")
proof -
have "?Q ≈⇩L base⇩L +⇩L more⇩L"
also have "... ≈⇩L (x +⇩L y) +⇩L more⇩L"
also have "... ≈⇩L x +⇩L y +⇩L more⇩L"
finally show ?thesis
using lens_equiv_sym by auto
qed

lemma mylens_bij_lens:
"bij_lens (x +⇩L y +⇩L more⇩L)"
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
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.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)"
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"

lemma (in wb_lens) modify_alt_def: "modify x f = State_Monad.update (update f)"