diff --git a/thys/Optics/Channel_Type.ML b/thys/Optics/Channel_Type.ML new file mode 100644 --- /dev/null +++ b/thys/Optics/Channel_Type.ML @@ -0,0 +1,103 @@ +structure Channel_Type = +struct +fun prove_prism_goal thy = + let + open Simplifier; open Global_Theory; open Lens_Lib + val ctx = Named_Target.theory_init thy + in + auto_tac (fold add_simp (get_thms thy lens_defsN) ctx) +end + +val wb_prism_suffix = "_wb_prism" +val codep_suffix = "_codeps" + +val ctor_suffix = "_C" + +fun wb_prism_proof x thms ctx = + let open Simplifier; open Prism_Lib; open Syntax + in + Goal.prove ctx [] [] + (Syntax.check_term ctx (mk_wb_prism (free x))) + (fn {context = context, prems = _} + => EVERY [ PARALLEL_ALLGOALS (full_simp_tac (fold add_simp thms context)) + , Classical.rule_tac context [@{thm wb_ctor_prism_intro}] [] 1 + , auto_tac (context delsimprocs [@{simproc unit_eq}]) + ]) + end + +fun codep_proof thms ctx (x, y) = + let open Simplifier; open Prism_Lib; open Syntax in + Goal.prove ctx [] [] + (Syntax.check_term ctx (mk_codep (free x) (free y))) + (fn {context = context, prems = _} + => EVERY [ PARALLEL_ALLGOALS (full_simp_tac (fold add_simp thms context)) + , Classical.rule_tac context [@{thm ctor_codep_intro}] [] 1 + , auto_tac ctx + ]) + + end + + + +fun mk_def ty x v = Const ("Pure.eq", ty --> ty --> Term.propT) $ Free (x, ty) $ v; + +val is_prefix = "is_"; +val un_prefix = "un_"; + +fun def qual (x, tm) ctx = + let open Specification; open Syntax + val ((_, (_, thm)), d) = definition (SOME (Binding.qualify false qual (Binding.name x), NONE, NoSyn)) [] [] ((Binding.empty, [Attrib.check_src @{context} (Token.make_src ("lens_defs", Position.none) [])]), mk_def dummyT x tm) ctx + in (thm, d) + end + + +fun defs qual inds f ctx = + fold (fn i => fn (thms, ctx) => + let val (thm, ctx') = def qual (i, f i) ctx + in (thms @ [thm], ctx') end) inds ([], ctx) + +fun compile_chantype (name, chans) ctx = + let + open BNF_FP_Def_Sugar; open BNF_FP_Rec_Sugar_Util; open BNF_LFP; open Ctr_Sugar + open Prism_Lib; open Lens_Lib; open Local_Theory; open Specification; open Syntax + val ctrs = map (fn (n, t) => (((Binding.empty, Binding.name (n ^ ctor_suffix)), [(Binding.empty, t)]), Mixfix.NoSyn)) chans + val pnames = map fst chans + val thypfx = + case (Named_Target.locale_of ctx) of + SOME loc => loc ^ "." | + NONE => Context.theory_name (Local_Theory.exit_global ctx) ^ "." + val prefix = thypfx ^ name ^ "." + val simp = Attrib.check_src @{context} (Token.make_src ("simp", Position.none) []) + val dummy_disc = absdummy dummyT @{term True} + in + (co_datatype_cmd Least_FP construct_lfp + ((K Plugin_Name.default_filter, true), + [((((([],Binding.name name), Mixfix.NoSyn), ctrs), (Binding.empty, Binding.empty, Binding.empty)),[])]) + (* The datatype package does not produce a discriminator for the second constructor when + there are two constructors. We here generate one for uniformity. *) + #> (if (length pnames = 2) + then abbreviation + Syntax.mode_default (SOME (Binding.qualify false name (Binding.name (is_prefix ^ nth pnames 1 ^ ctor_suffix)), NONE, NoSyn)) [] + (mk_def dummyT + (is_prefix ^ nth pnames 1 ^ ctor_suffix) + (const @{const_name comp} $ @{term Not} $ const (prefix ^ is_prefix ^ nth pnames 0 ^ ctor_suffix))) false + else I) + #> defs name pnames (fn x => (const @{const_name ctor_prism} + $ const (prefix ^ x ^ ctor_suffix) + $ (if (length pnames = 1) then dummy_disc else const (prefix ^ is_prefix ^ x ^ ctor_suffix)) + $ const (prefix ^ un_prefix ^ x ^ ctor_suffix))) + #> (fn (thms, ctx) => + (fold (fn x => fn thy => snd (note ((Binding.qualify false name (Binding.name (x ^ wb_prism_suffix)), [simp]), [wb_prism_proof x thms thy]) thy)) pnames + #> (snd o note ((Binding.qualify false name (Binding.name codepsN), [simp]), map (codep_proof thms ctx) (pairings pnames))) + ) ctx)) + ctx + end; + +end; + +let open Parse; open Parse_Spec; open Scan in + Outer_Syntax.command @{command_keyword chantype} "define a channel datatype" + ((name -- + (@{keyword "="} |-- repeat1 (name -- ($$$ "::" |-- !!! typ)))) + >> (fn x => Toplevel.local_theory NONE NONE (Channel_Type.compile_chantype x))) + end; \ No newline at end of file diff --git a/thys/Optics/Channel_Type.thy b/thys/Optics/Channel_Type.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Channel_Type.thy @@ -0,0 +1,32 @@ +section \ Channel Types \ + +theory Channel_Type + imports Prisms + keywords "chantype" :: "thy_defn" +begin + +text \ A channel type is a simplified algebraic datatype where each constructor has exactly + one parameter, and it is wrapped up as a prism. It a dual of an alphabet type. \ + +definition ctor_prism :: "('a \ 'd) \ ('d \ bool) \ ('d \ 'a) \ ('a \\<^sub>\ 'd)" where +[lens_defs]: +"ctor_prism ctor disc sel = \ prism_match = (\ d. if (disc d) then Some (sel d) else None) + , prism_build = ctor \" + +lemma wb_ctor_prism_intro: + assumes + "\ v. disc (ctor v)" + "\ v. sel (ctor v) = v" + "\ s. disc s \ ctor (sel s) = s" + shows "wb_prism (ctor_prism ctor disc sel)" + by (unfold_locales, simp_all add: lens_defs assms) + (metis assms(3) option.distinct(1) option.sel) + +lemma ctor_codep_intro: + assumes "\ x y. ctor1 x \ ctor2 y" + shows "ctor_prism ctor1 disc1 sel1 \ ctor_prism ctor2 disc2 sel2" + by (rule prism_diff_intro, simp add: lens_defs assms) + +ML_file "Channel_Type.ML" + +end \ No newline at end of file diff --git a/thys/Optics/Channel_Type_Example.thy b/thys/Optics/Channel_Type_Example.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Channel_Type_Example.thy @@ -0,0 +1,24 @@ +theory Channel_Type_Example + imports Channel_Type +begin + +chantype ch_buffer = + inp :: unit + outp :: nat + mod :: bool + +thm ch_buffer.inp_wb_prism + +thm ch_buffer.codeps + +locale C1 +begin + +chantype ch_buffer2 = + inp2 :: unit + outp2 :: nat + mod2 :: bool + +end + +end \ No newline at end of file diff --git a/thys/Optics/Dataspace.ML b/thys/Optics/Dataspace.ML new file mode 100644 --- /dev/null +++ b/thys/Optics/Dataspace.ML @@ -0,0 +1,87 @@ +structure Dataspace = +struct + + val achanT = TFree ("'ch", ["HOL.type"]) + + fun mk_constant_elements cds = + let + open Syntax; + val cfixes = map (fn (n, t) => (Binding.name n, SOME t, NoSyn)) cds + in [ Element.Fixes cfixes ] end; + + (* Produce a list of new elements for a locale to characterise the channels *) + fun mk_channel_elements exts chds thy = + let + open Lens_Lib; + open Prism_Lib; + open Syntax; + val ctx = Named_Target.theory_init thy + val chns = map fst chds + val chfixes = map (fn (n, t) => (Binding.name n, SOME (prismT t achanT), NoSyn)) chds + val wbs = map (mk_wb_prism o free) chns; + val simp = Attrib.check_src ctx (Token.make_src ("simp", Position.none) []) + val imps = map (fn e => Locale.check thy (e, Position.none)) exts + (* List of prisms imported *) + val ilnsls = map (filter (isPrismT o snd) o map fst o Locale.params_of thy) imps + (* Codependence axioms from imports *) + val impind = List.concat (map (pairsWith chns) (map (map fst) ilnsls)) + val codeps = map (fn (x, y) => mk_codep (free x) (free y)) + (pairings (chns) @ impind) + in + (* Fix each of the channels as prisms *) + [ Element.Fixes chfixes + (* Assume that all prisms are well-behaved and codependent (as in an algebraic datatype) *) + , Element.Assumes [((Binding.name "prisms", [simp]) + , map (fn wb => (wb, [])) wbs), + ((Binding.name "codeps", [simp]) + , map (fn dp => (dp, [])) codeps)] + ] + end + + val STATE = "STATE_TYPE" + val CHAN = "CHAN_TYPE" + + fun compile_dataspace nm exts cds assms vds chds thy = + let + open Lens_Lib; + open Syntax; + val imps = map (fn e => Locale.check thy (e, Position.none)) exts + (* When extending existing dataspaces, we instantiate their respective state and channel + types to avoid ambiguity (via a locale "where" clause) *) + val pinsts = Expression.Named + [(STATE, Logic.mk_type astateT) + ,(CHAN, Logic.mk_type achanT)] + val locexs = map (fn i => (i, (("", false), (pinsts, [])))) imps + (* We also create fixed parameters for the types so they can be instantiated later *) + val st_par = (Binding.name STATE, SOME (Term.itselfT astateT), NoSyn) + val ch_par = (Binding.name CHAN, SOME (Term.itselfT achanT), NoSyn) + in + (Local_Theory.exit_global o snd o + Expression.add_locale (Binding.name nm) Binding.empty [] (locexs, []) + (mk_constant_elements cds + @ [Element.Assumes assms] + @ Lens_Statespace.mk_statespace_elements vds exts thy + @ mk_channel_elements exts chds thy + @ [Element.Fixes [st_par, ch_par]])) thy + end + + fun dataspace_cmd nm exts cds rassms vds chds thy = + let + open Syntax; open HOLogic; + val ctx = Named_Target.theory_init thy + val assms = map (fn (b, td) => (b, map (fn (t, ts) => (mk_Trueprop (parse_term ctx t), map (mk_Trueprop o parse_term ctx) ts)) td)) rassms in + compile_dataspace nm exts (map (fn (n, t) => (n, read_typ ctx t)) cds) assms (map (fn (n, t) => (n, read_typ ctx t)) vds) (map (fn (n, t) => (n, read_typ ctx t)) chds) thy + end + +end; + +let open Parse; open Parse_Spec; open Scan in + Outer_Syntax.command @{command_keyword dataspace} "define reactive contexts" + ((name -- + ((@{keyword "="} |-- repeat (Parse.name --| @{keyword "+"})) + -- optional (@{keyword "constants"} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))) [] + -- optional (@{keyword "assumes"} |-- !!! (and_list1 (opt_thm_name ":" -- repeat1 propp))) [] + -- optional (@{keyword "variables"} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))) [] + -- optional (@{keyword "channels"} |-- repeat1 (name -- ($$$ "::" |-- !!! typ))) []) + >> (fn (nm, ((((exts, cds), assms), vds), chds)) => Toplevel.theory (Dataspace.dataspace_cmd nm exts cds assms vds chds)))) +end; diff --git a/thys/Optics/Dataspace.thy b/thys/Optics/Dataspace.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Dataspace.thy @@ -0,0 +1,14 @@ +section \ Data spaces \ + +theory Dataspace + imports Lenses Prisms + keywords "dataspace" :: "thy_defn" and "constants" "variables" "channels" +begin + +text \ A data space is like a more sophisticated version of a locale-based state space. It + allows us to introduce both variables, modelled by lenses, and channels, modelled by + prisms. It also allows local constants, and assumptions over them. \ + +ML_file "Dataspace.ML" + +end \ No newline at end of file diff --git a/thys/Optics/Dataspace_Example.thy b/thys/Optics/Dataspace_Example.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Dataspace_Example.thy @@ -0,0 +1,19 @@ +theory Dataspace_Example + imports Dataspace +begin + +dataspace C1 = + constants c1 :: string c2 :: nat + assumes a1: "c2 > 2" and a2: "c2 < 5" + variables x :: string y :: int + channels ch1 :: "int \ string" ch2 :: int + +dataspace C2 = + constants c3 :: nat + variables z :: int + channels ch4 :: int + +dataspace C3 = C1 + C2 + + variables k :: int + +end \ No newline at end of file diff --git a/thys/Optics/Dataspaces.thy b/thys/Optics/Dataspaces.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Dataspaces.thy @@ -0,0 +1,5 @@ +theory Dataspaces + imports Lenses Prisms +begin + +end \ No newline at end of file diff --git a/thys/Optics/Lens_Algebra.thy b/thys/Optics/Lens_Algebra.thy --- a/thys/Optics/Lens_Algebra.thy +++ b/thys/Optics/Lens_Algebra.thy @@ -1,418 +1,418 @@ section \Lens Algebraic Operators\ theory Lens_Algebra imports Lens_Laws begin subsection \Lens Composition, Plus, Unit, and Identity\ text \ \begin{figure} \begin{center} \includegraphics[width=7cm]{figures/Composition} \end{center} \vspace{-5ex} \caption{Lens Composition} \label{fig:Comp} \end{figure} We introduce the algebraic lens operators; for more information please see our paper~\cite{Foster16a}. Lens composition, illustrated in Figure~\ref{fig:Comp}, constructs a lens by composing the source of one lens with the view of another.\ definition lens_comp :: "('a \ 'b) \ ('b \ 'c) \ ('a \ 'c)" (infixl ";\<^sub>L" 80) where [lens_defs]: "lens_comp Y X = \ lens_get = get\<^bsub>Y\<^esub> \ 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 "+\<^sub>L" 75) where [lens_defs]: "X +\<^sub>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 "\\<^sub>L" 85) where [lens_defs]: "lens_prod X Y = \ lens_get = map_prod get\<^bsub>X\<^esub> get\<^bsub>Y\<^esub> , lens_put = \ (u, v) (x, y). (put\<^bsub>X\<^esub> u x, put\<^bsub>Y\<^esub> 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\<^sub>L") where [lens_defs]: "fst\<^sub>L = \ lens_get = fst, lens_put = (\ (\, \) u. (u, \)) \" definition snd_lens :: "'b \ 'a \ 'b" ("snd\<^sub>L") where [lens_defs]: "snd\<^sub>L = \ lens_get = snd, lens_put = (\ (\, \) u. (\, u)) \" lemma get_fst_lens [simp]: "get\<^bsub>fst\<^sub>L\<^esub> (x, y) = x" by (simp add: fst_lens_def) lemma get_snd_lens [simp]: "get\<^bsub>snd\<^sub>L\<^esub> (x, y) = y" by (simp add: snd_lens_def) text \The swap lens is a bijective lens which swaps over the elements of the product source type.\ abbreviation swap_lens :: "'a \ 'b \ 'b \ 'a" ("swap\<^sub>L") where "swap\<^sub>L \ snd\<^sub>L +\<^sub>L fst\<^sub>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\<^sub>L") where [lens_defs]: "0\<^sub>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\<^sub>L") where [lens_defs]: "1\<^sub>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 "'/\<^sub>L" 90) where [lens_defs]: "X /\<^sub>L Y = \ lens_get = \ \. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \) , lens_put = \ \ v. get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \) v) \" text \Lens inverse take a bijective lens and swaps the source and view types.\ definition lens_inv :: "('a \ 'b) \ ('b \ 'a)" ("inv\<^sub>L") where [lens_defs]: "lens_inv x = \ lens_get = create\<^bsub>x\<^esub>, lens_put = \ \. get\<^bsub>x\<^esub> \" 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\<^sub>L" by (unfold_locales, simp_all add: id_lens_def) lemma source_id_lens: "\\<^bsub>1\<^sub>L\<^esub> = UNIV" by (simp add: id_lens_def lens_source_def) lemma unit_wb_lens: "wb_lens 0\<^sub>L" by (unfold_locales, simp_all add: zero_lens_def) lemma source_zero_lens: "\\<^bsub>0\<^sub>L\<^esub> = UNIV" by (simp_all add: zero_lens_def lens_source_def) lemma comp_weak_lens: "\ weak_lens x; weak_lens y \ \ weak_lens (x ;\<^sub>L y)" by (unfold_locales, simp_all add: lens_comp_def) lemma comp_wb_lens: "\ wb_lens x; wb_lens y \ \ wb_lens (x ;\<^sub>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 ;\<^sub>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 \ \ \\<^bsub>x ;\<^sub>L y\<^esub> = {s \ \\<^bsub>y\<^esub>. get\<^bsub>y\<^esub> s \ \\<^bsub>x\<^esub>}" 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\<^sub>L" by (unfold_locales, simp_all add: id_lens_def) lemma unit_vwb_lens [simp]: "vwb_lens 0\<^sub>L" by (unfold_locales, simp_all add: zero_lens_def) lemma comp_vwb_lens: "\ vwb_lens x; vwb_lens y \ \ vwb_lens (x ;\<^sub>L y)" by (unfold_locales, simp_all add: lens_comp_def weak_lens.put_closure) lemma unit_ief_lens: "ief_lens 0\<^sub>L" by (unfold_locales, simp_all add: zero_lens_def) text \Lens plus requires that the lenses be independent to show closure.\ lemma plus_mwb_lens: assumes "mwb_lens x" "mwb_lens y" "x \ y" shows "mwb_lens (x +\<^sub>L y)" using assms apply (unfold_locales) apply (simp_all add: lens_plus_def prod.case_eq_if lens_indep_sym) apply (simp add: lens_indep_comm) done lemma plus_wb_lens: assumes "wb_lens x" "wb_lens y" "x \ y" shows "wb_lens (x +\<^sub>L y)" using assms apply (unfold_locales, simp_all add: lens_plus_def) apply (simp add: lens_indep_sym prod.case_eq_if) done lemma plus_vwb_lens [simp]: assumes "vwb_lens x" "vwb_lens y" "x \ y" shows "vwb_lens (x +\<^sub>L y)" using assms apply (unfold_locales, simp_all add: lens_plus_def) apply (simp add: lens_indep_sym prod.case_eq_if) apply (simp add: lens_indep_comm prod.case_eq_if) done lemma source_plus_lens: assumes "mwb_lens x" "mwb_lens y" "x \ y" shows "\\<^bsub>x +\<^sub>L y\<^esub> = \\<^bsub>x\<^esub> \ \\<^bsub>y\<^esub>" 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 \\<^sub>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 \\<^sub>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 \\<^sub>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 \\<^sub>L Y)" by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if) lemma fst_vwb_lens: "vwb_lens fst\<^sub>L" by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if) lemma snd_vwb_lens: "vwb_lens snd\<^sub>L" by (unfold_locales, simp_all add: snd_lens_def prod.case_eq_if) lemma id_bij_lens: "bij_lens 1\<^sub>L" by (unfold_locales, simp_all add: id_lens_def) lemma inv_id_lens: "inv\<^sub>L 1\<^sub>L = 1\<^sub>L" by (auto simp add: lens_inv_def id_lens_def lens_create_def) lemma inv_inv_lens: "bij_lens X \ inv\<^sub>L (inv\<^sub>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\<^sub>L X)" by (unfold_locales, simp_all add: lens_inv_def lens_create_def) lemma swap_bij_lens: "bij_lens swap\<^sub>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\<^sub>L"}, as the following theorems demonstrate. It also has @{term "0\<^sub>L"} as a right annihilator. \ lemma lens_comp_assoc: "X ;\<^sub>L (Y ;\<^sub>L Z) = (X ;\<^sub>L Y) ;\<^sub>L Z" by (auto simp add: lens_comp_def) lemma lens_comp_left_id [simp]: "1\<^sub>L ;\<^sub>L X = X" by (simp add: id_lens_def lens_comp_def) lemma lens_comp_right_id [simp]: "X ;\<^sub>L 1\<^sub>L = X" by (simp add: id_lens_def lens_comp_def) lemma lens_comp_anhil [simp]: "wb_lens X \ 0\<^sub>L ;\<^sub>L X = 0\<^sub>L" by (simp add: zero_lens_def lens_comp_def comp_def) lemma lens_comp_anhil_right [simp]: "wb_lens X \ X ;\<^sub>L 0\<^sub>L = 0\<^sub>L" by (simp add: zero_lens_def lens_comp_def comp_def) subsection \Independence Laws\ text \The zero lens @{term "0\<^sub>L"} is independent of any lens. This is because nothing can be observed or changed using @{term "0\<^sub>L"}. \ lemma zero_lens_indep [simp]: "0\<^sub>L \ X" by (auto simp add: zero_lens_def lens_indep_def) lemma zero_lens_indep' [simp]: "X \ 0\<^sub>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 ;\<^sub>L z) \ (y ;\<^sub>L z)" apply (rule lens_indepI) apply (auto simp add: lens_comp_def) apply (simp add: lens_indep_comm) apply (simp add: lens_indep_sym) done lemma lens_indep_right_comp: "y \ z \ (x ;\<^sub>L y) \ (x ;\<^sub>L z)" apply (auto intro!: lens_indepI simp add: lens_comp_def) using lens_indep_comm lens_indep_sym apply fastforce apply (simp add: lens_indep_sym) done lemma lens_indep_left_ext [intro]: "y \ z \ (x ;\<^sub>L y) \ z" apply (auto intro!: lens_indepI simp add: lens_comp_def) apply (simp add: lens_indep_comm) apply (simp add: lens_indep_sym) done lemma lens_indep_right_ext [intro]: "x \ z \ x \ (y ;\<^sub>L z)" by (simp add: lens_indep_left_ext lens_indep_sym) lemma lens_comp_indep_cong_left: "\ mwb_lens Z; X ;\<^sub>L Z \ Y ;\<^sub>L Z \ \ X \ Y" apply (rule lens_indepI) apply (rename_tac u v \) apply (drule_tac u=u and v=v and \="create\<^bsub>Z\<^esub> \" in lens_indep_comm) apply (simp add: lens_comp_def) apply (meson mwb_lens_weak weak_lens.view_determination) apply (rename_tac v \) apply (drule_tac v=v and \="create\<^bsub>Z\<^esub> \" in lens_indep_get) apply (simp add: lens_comp_def) apply (drule lens_indep_sym) apply (rename_tac u \) apply (drule_tac v=u and \="create\<^bsub>Z\<^esub> \" in lens_indep_get) apply (simp add: lens_comp_def) done lemma lens_comp_indep_cong: "mwb_lens Z \ (X ;\<^sub>L Z) \ (Y ;\<^sub>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\<^sub>L \ snd\<^sub>L" by (simp add: lens_indep_def fst_lens_def snd_lens_def) lemma snd_fst_lens_indep [simp]: "snd\<^sub>L \ fst\<^sub>L" by (simp add: lens_indep_def fst_lens_def snd_lens_def) lemma split_prod_lens_indep: assumes "mwb_lens X" shows "(fst\<^sub>L ;\<^sub>L X) \ (snd\<^sub>L ;\<^sub>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 +\<^sub>L Y) \ Z" apply (rule lens_indepI) apply (simp_all add: lens_plus_def prod.case_eq_if) apply (simp add: lens_indep_comm) apply (simp add: lens_indep_sym) done lemma plus_pres_lens_indep' [simp]: "\ X \ Y; X \ Z \ \ X \ Y +\<^sub>L Z" by (auto intro: lens_indep_sym plus_pres_lens_indep) text \Lens independence is preserved by product.\ lemma lens_indep_prod: "\ X\<^sub>1 \ X\<^sub>2; Y\<^sub>1 \ Y\<^sub>2 \ \ X\<^sub>1 \\<^sub>L Y\<^sub>1 \ X\<^sub>2 \\<^sub>L Y\<^sub>2" apply (rule lens_indepI) apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def) apply (simp_all add: lens_indep_sym) done subsection \ Compatibility Laws \ lemma zero_lens_compat [simp]: "0\<^sub>L ##\<^sub>L X" by (auto simp add: zero_lens_def lens_override_def lens_compat_def) lemma id_lens_compat [simp]: "vwb_lens X \ 1\<^sub>L ##\<^sub>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 +\<^sub>L Y) ;\<^sub>L Z = (X ;\<^sub>L Z) +\<^sub>L (Y ;\<^sub>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\<^sub>L ;\<^sub>L (x +\<^sub>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\<^sub>L ;\<^sub>L (x +\<^sub>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\<^sub>L ;\<^sub>L (X +\<^sub>L Y) = (Y +\<^sub>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\<^sub>L +\<^sub>L snd\<^sub>L = 1\<^sub>L" by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def) lemma swap_lens_idem: "swap\<^sub>L ;\<^sub>L swap\<^sub>L = 1\<^sub>L" by (simp add: fst_snd_id_lens lens_indep_sym lens_plus_swap) lemma swap_lens_fst: "fst\<^sub>L ;\<^sub>L swap\<^sub>L = snd\<^sub>L" by (simp add: fst_lens_plus fst_vwb_lens) lemma swap_lens_snd: "snd\<^sub>L ;\<^sub>L swap\<^sub>L = fst\<^sub>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 \\<^sub>L Y = X ;\<^sub>L fst\<^sub>L +\<^sub>L Y ;\<^sub>L snd\<^sub>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\<^sub>L \\<^sub>L 1\<^sub>L = 1\<^sub>L" by (auto simp add: lens_prod_def id_lens_def) lemma prod_lens_comp_plus: "X\<^sub>2 \ Y\<^sub>2 \ ((X\<^sub>1 \\<^sub>L Y\<^sub>1) ;\<^sub>L (X\<^sub>2 +\<^sub>L Y\<^sub>2)) = (X\<^sub>1 ;\<^sub>L X\<^sub>2) +\<^sub>L (Y\<^sub>1 ;\<^sub>L Y\<^sub>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 ;\<^sub>L Y) /\<^sub>L Y = X" by (simp add: lens_quotient_def lens_comp_def) -lemma lens_quotient_id: "weak_lens X \ (X /\<^sub>L X) = 1\<^sub>L" +lemma lens_quotient_id [simp]: "weak_lens X \ (X /\<^sub>L X) = 1\<^sub>L" by (force simp add: lens_quotient_def id_lens_def) lemma lens_quotient_id_denom: "X /\<^sub>L 1\<^sub>L = X" by (simp add: lens_quotient_def id_lens_def lens_create_def) lemma lens_quotient_unit: "weak_lens X \ (0\<^sub>L /\<^sub>L X) = 0\<^sub>L" by (simp add: lens_quotient_def zero_lens_def) lemma lens_obs_eq_zero: "s\<^sub>1 \\<^bsub>0\<^sub>L\<^esub> s\<^sub>2 = (s\<^sub>1 = s\<^sub>2)" by (simp add: lens_defs) lemma lens_obs_eq_one: "s\<^sub>1 \\<^bsub>1\<^sub>L\<^esub> s\<^sub>2" by (simp add: lens_defs) lemma lens_obs_eq_as_override: "vwb_lens X \ s\<^sub>1 \\<^bsub>X\<^esub> s\<^sub>2 \ (s\<^sub>2 = s\<^sub>1 \\<^sub>L s\<^sub>2 on X)" by (auto simp add: lens_defs; metis vwb_lens.put_eq) end \ No newline at end of file diff --git a/thys/Optics/Lens_Instances.thy b/thys/Optics/Lens_Instances.thy --- a/thys/Optics/Lens_Instances.thy +++ b/thys/Optics/Lens_Instances.thy @@ -1,345 +1,360 @@ section \Lens Instances\ theory Lens_Instances imports Lens_Order Lens_Symmetric "HOL-Eisbach.Eisbach" - keywords "alphabet" :: "thy_defn" + keywords "alphabet" "statespace" :: "thy_defn" begin text \In this section we define a number of concrete instantiations of the lens locales, including functions lenses, list lenses, and record lenses.\ subsection \Function Lens\ text \A function lens views the valuation associated with a particular domain element @{typ "'a"}. We require that range type of a lens function has cardinality of at least 2; this ensures that properties of independence are provable.\ definition fun_lens :: "'a \ ('b::two \ ('a \ 'b))" where [lens_defs]: "fun_lens x = \ lens_get = (\ f. f x), lens_put = (\ f u. f(x := u)) \" lemma fun_vwb_lens: "vwb_lens (fun_lens x)" by (unfold_locales, simp_all add: fun_lens_def) text \Two function lenses are independent if and only if the domain elements are different.\ lemma fun_lens_indep: "fun_lens x \ fun_lens y \ x \ y" proof - obtain u v :: "'a::two" where "u \ v" using two_diff by auto thus ?thesis by (auto simp add: fun_lens_def lens_indep_def) qed subsection \Function Range Lens\ text \The function range lens allows us to focus on a particular region of a function's range.\ definition fun_ran_lens :: "('c \ 'b) \ (('a \ 'b) \ '\) \ (('a \ 'c) \ '\)" where [lens_defs]: "fun_ran_lens X Y = \ lens_get = \ s. get\<^bsub>X\<^esub> \ get\<^bsub>Y\<^esub> s , lens_put = \ s v. put\<^bsub>Y\<^esub> s (\ x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \" lemma fun_ran_mwb_lens: "\ mwb_lens X; mwb_lens Y \ \ mwb_lens (fun_ran_lens X Y)" by (unfold_locales, auto simp add: fun_ran_lens_def) lemma fun_ran_wb_lens: "\ wb_lens X; wb_lens Y \ \ wb_lens (fun_ran_lens X Y)" by (unfold_locales, auto simp add: fun_ran_lens_def) lemma fun_ran_vwb_lens: "\ vwb_lens X; vwb_lens Y \ \ vwb_lens (fun_ran_lens X Y)" by (unfold_locales, auto simp add: fun_ran_lens_def) subsection \Map Lens\ text \The map lens allows us to focus on a particular region of a partial function's range. It is only a mainly well-behaved lens because it does not satisfy the PutGet law when the view is not in the domain.\ definition map_lens :: "'a \ ('b \ ('a \ 'b))" where [lens_defs]: "map_lens x = \ lens_get = (\ f. the (f x)), lens_put = (\ f u. f(x \ u)) \" lemma map_mwb_lens: "mwb_lens (map_lens x)" by (unfold_locales, simp_all add: map_lens_def) lemma source_map_lens: "\\<^bsub>map_lens x\<^esub> = {f. x \ dom(f)}" by (force simp add: map_lens_def lens_source_def) subsection \List Lens\ text \The list lens allows us to view a particular element of a list. In order to show it is mainly well-behaved we need to define to additional list functions. The following function adds a number undefined elements to the end of a list.\ definition list_pad_out :: "'a list \ nat \ 'a list" where "list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined" text \The following function is like @{term "list_update"} but it adds additional elements to the list if the list isn't long enough first.\ definition list_augment :: "'a list \ nat \ 'a \ 'a list" where "list_augment xs k v = (list_pad_out xs k)[k := v]" text \The following function is like @{term nth} but it expressly returns @{term undefined} when the list isn't long enough.\ definition nth' :: "'a list \ nat \ 'a" where "nth' xs i = (if (length xs > i) then xs ! i else undefined)" text \We can prove some additional laws about list update and append.\ lemma list_update_append_lemma1: "i < length xs \ xs[i := v] @ ys = (xs @ ys)[i := v]" by (simp add: list_update_append) lemma list_update_append_lemma2: "i < length ys \ xs @ ys[i := v] = (xs @ ys)[i + length xs := v]" by (simp add: list_update_append) text \We can also prove some laws about our new operators.\ lemma nth'_0 [simp]: "nth' (x # xs) 0 = x" by (simp add: nth'_def) lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n" by (simp add: nth'_def) lemma list_augment_0 [simp]: "list_augment (x # xs) 0 y = y # xs" by (simp add: list_augment_def list_pad_out_def) lemma list_augment_Suc [simp]: "list_augment (x # xs) (Suc n) y = x # list_augment xs n y" by (simp add: list_augment_def list_pad_out_def) lemma list_augment_twice: "list_augment (list_augment xs i u) j v = (list_pad_out xs (max i j))[i:=u, j:=v]" apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def) apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2) done lemma list_augment_last [simp]: "list_augment (xs @ [y]) (length xs) z = xs @ [z]" by (induct xs, simp_all) lemma list_augment_idem [simp]: "i < length xs \ list_augment xs i (xs ! i) = xs" by (simp add: list_augment_def list_pad_out_def) text \We can now prove that @{term list_augment} is commutative for different (arbitrary) indices.\ lemma list_augment_commute: "i \ j \ list_augment (list_augment \ j v) i u = list_augment (list_augment \ i u) j v" by (simp add: list_augment_twice list_update_swap max.commute) text \We can also prove that we can always retrieve an element we have added to the list, since @{term list_augment} extends the list when necessary. This isn't true of @{term list_update}. \ lemma nth_list_augment: "list_augment xs k v ! k = v" by (simp add: list_augment_def list_pad_out_def) lemma nth'_list_augment: "nth' (list_augment xs k v) k = v" by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def) text \ The length is expanded if not already long enough, or otherwise left as it is. \ lemma length_list_augment_1: "k \ length xs \ length (list_augment xs k v) = Suc k" by (simp add: list_augment_def list_pad_out_def) lemma length_list_augment_2: "k < length xs \ length (list_augment xs k v) = length xs" by (simp add: list_augment_def list_pad_out_def) text \We also have it that @{term list_augment} cancels itself.\ lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v" by (simp add: list_augment_def list_pad_out_def) lemma nth'_list_augment_diff: "i \ j \ nth' (list_augment \ i v) j = nth' \ j" by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def) text \Finally we can create the list lenses, of which there are three varieties. One that allows us to view an index, one that allows us to view the head, and one that allows us to view the tail. They are all mainly well-behaved lenses.\ definition list_lens :: "nat \ ('a::two \ 'a list)" where [lens_defs]: "list_lens i = \ lens_get = (\ xs. nth' xs i) , lens_put = (\ xs x. list_augment xs i x) \" abbreviation hd_lens ("hd\<^sub>L") where "hd_lens \ list_lens 0" definition tl_lens :: "'a list \ 'a list" ("tl\<^sub>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: "\\<^bsub>list_lens i\<^esub> = {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\<^sub>L" by (unfold_locales, simp_all add: tl_lens_def) lemma source_tail_lens: "\\<^bsub>tl\<^sub>L\<^esub> = {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\<^sub>L \ tl\<^sub>L" apply (rule lens_indepI) apply (simp_all add: list_lens_def tl_lens_def) apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment) apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def) apply (metis One_nat_def diff_Suc_Suc diff_zero length_0_conv length_list_augment_1 length_tl linorder_not_less list.exhaust list.sel(2) list.sel(3) list_augment_0 not_less_zero) done lemma hd_tl_lens_pbij: "pbij_lens (hd\<^sub>L +\<^sub>L tl\<^sub>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 \<^bold>\typedef\ command induces a partial bijective lens constructed using the abstraction and representation functions. \ context type_definition begin definition typedef_lens :: "'b \ 'a" ("typedef\<^sub>L") where [lens_defs]: "typedef\<^sub>L = \ lens_get = Abs, lens_put = (\ s. Rep) \" lemma pbij_typedef_lens [simp]: "pbij_lens typedef\<^sub>L" by (unfold_locales, simp_all add: lens_defs Rep_inverse) lemma source_typedef_lens: "\\<^bsub>typedef\<^sub>L\<^esub> = A" using Rep_cases by (auto simp add: lens_source_def lens_defs Rep) lemma bij_typedef_lens_UNIV: "A = UNIV \ bij_lens typedef\<^sub>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\<^bsub>l\<^esub>), lens_put = g o (put\<^bsub>l\<^esub>) 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 diff --git a/thys/Optics/Lens_Lib.ML b/thys/Optics/Lens_Lib.ML new file mode 100644 --- /dev/null +++ b/thys/Optics/Lens_Lib.ML @@ -0,0 +1,76 @@ +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 diff --git a/thys/Optics/Lens_Order.thy b/thys/Optics/Lens_Order.thy --- a/thys/Optics/Lens_Order.thy +++ b/thys/Optics/Lens_Order.thy @@ -1,634 +1,644 @@ 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 "\\<^sub>L" 55) where [lens_defs]: "sublens X Y = (\ Z :: ('a, 'b) lens. vwb_lens Z \ X = Z ;\<^sub>L Y)" text \Various lens classes are downward closed under the sublens relation.\ lemma sublens_pres_mwb: "\ mwb_lens Y; X \\<^sub>L Y \ \ mwb_lens X" by (unfold_locales, auto simp add: sublens_def lens_comp_def) lemma sublens_pres_wb: "\ wb_lens Y; X \\<^sub>L Y \ \ wb_lens X" by (unfold_locales, auto simp add: sublens_def lens_comp_def) lemma sublens_pres_vwb: "\ vwb_lens Y; X \\<^sub>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: +lemma sublens_refl [simp]: "X \\<^sub>L X" using id_vwb_lens sublens_def by fastforce lemma sublens_trans [trans]: "\ X \\<^sub>L Y; Y \\<^sub>L Z \ \ X \\<^sub>L Z" apply (auto simp add: sublens_def lens_comp_assoc) apply (rename_tac Z\<^sub>1 Z\<^sub>2) apply (rule_tac x="Z\<^sub>1 ;\<^sub>L Z\<^sub>2" in exI) apply (simp add: lens_comp_assoc) using comp_vwb_lens apply blast done text \Sublens has a least element -- @{text "0\<^sub>L"} -- and a greatest element -- @{text "1\<^sub>L"}. Intuitively, this shows that sublens orders how large a portion of the source type a particular lens views, with @{text "0\<^sub>L"} observing the least, and @{text "1\<^sub>L"} observing the most.\ lemma sublens_least: "wb_lens X \ 0\<^sub>L \\<^sub>L X" using sublens_def unit_vwb_lens by fastforce lemma sublens_greatest: "vwb_lens X \ X \\<^sub>L 1\<^sub>L" by (simp add: sublens_def) text \If $Y$ is a sublens of $X$ then any put using $X$ will necessarily erase any put using $Y$. Similarly, any two source types are observationally equivalent by $Y$ when performed following a put using $X$.\ lemma sublens_put_put: "\ mwb_lens X; Y \\<^sub>L X \ \ put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \ v) u = put\<^bsub>X\<^esub> \ u" by (auto simp add: sublens_def lens_comp_def) lemma sublens_obs_get: "\ mwb_lens X; Y \\<^sub>L X \ \ get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \ v) = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \ 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 \\<^sub>L Y; Y \ Z \ \ X \ Z" apply (auto intro!:lens_indepI simp add: sublens_def lens_comp_def lens_indep_comm) apply (simp add: lens_indep_sym) done lemma sublens_pres_indep': "\ X \\<^sub>L Y; Z \ Y \ \ Z \ X" by (meson lens_indep_sym sublens_pres_indep) lemma sublens_compat: "\ vwb_lens X; vwb_lens Y; X \\<^sub>L Y \ \ X ##\<^sub>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 \\<^sub>L Y \ \ mwb_lens (X /\<^sub>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 "\\<^sub>L" 51) where [lens_defs]: "lens_equiv X Y = (X \\<^sub>L Y \ Y \\<^sub>L X)" lemma lens_equivI [intro]: "\ X \\<^sub>L Y; Y \\<^sub>L X \ \ X \\<^sub>L Y" by (simp add: lens_equiv_def) lemma lens_equiv_refl: "X \\<^sub>L X" - by (simp add: lens_equiv_def sublens_refl) + by (simp add: lens_equiv_def) lemma lens_equiv_sym: "X \\<^sub>L Y \ Y \\<^sub>L X" by (simp add: lens_equiv_def) lemma lens_equiv_trans [trans]: "\ X \\<^sub>L Y; Y \\<^sub>L Z \ \ X \\<^sub>L Z" by (auto intro: sublens_trans simp add: lens_equiv_def) lemma lens_equiv_pres_indep: "\ X \\<^sub>L Y; Y \ Z \ \ X \ Z" using lens_equiv_def sublens_pres_indep by blast lemma lens_equiv_pres_indep': "\ X \\<^sub>L Y; Z \ Y \ \ Z \ X" using lens_equiv_def sublens_pres_indep' by blast lemma lens_comp_cong_1: "X \\<^sub>L Y \ X ;\<^sub>L Z \\<^sub>L Y ;\<^sub>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 \\<^sub>L Y \ \ (X /\<^sub>L Y) ;\<^sub>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 \\<^sub>L Z; Y \\<^sub>L Z \ \ (X +\<^sub>L Y) /\<^sub>L Z = (X /\<^sub>L Z) +\<^sub>L (Y /\<^sub>L Z)" apply (auto simp add: lens_quotient_def lens_plus_def sublens_def lens_comp_def comp_def) apply (rule ext) apply (rule ext) apply (simp add: prod.case_eq_if) done +text \Laws for for lens plus on the denominator. These laws allow us to extract compositions + of @{term "fst\<^sub>L"} and @{term "snd\<^sub>L"} terms. \ + +lemma lens_quotient_plus_den1: + "\ weak_lens x; weak_lens y; x \ y \ \ x /\<^sub>L (x +\<^sub>L y) = fst\<^sub>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 \\<^sub>L z \ \ y /\<^sub>L (x +\<^sub>L z) = (y /\<^sub>L z) ;\<^sub>L snd\<^sub>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 \\<^sub>L Z; Y \\<^sub>L Z; X \ Y \ \ (X +\<^sub>L Y) \\<^sub>L Z" apply (auto simp add: sublens_def) apply (rename_tac Z\<^sub>1 Z\<^sub>2) apply (rule_tac x="Z\<^sub>1 +\<^sub>L Z\<^sub>2" in exI) apply (auto intro!: plus_wb_lens) apply (simp add: lens_comp_indep_cong_left plus_vwb_lens) apply (simp add: plus_lens_distr) done text \Intuitively, lens plus is associative. However we cannot prove this using HOL equality due to monomorphic typing of this operator. But since sublens and lens equivalence are both heterogeneous we can now prove this in the following three lemmas.\ lemma lens_plus_sub_assoc_1: "X +\<^sub>L Y +\<^sub>L Z \\<^sub>L (X +\<^sub>L Y) +\<^sub>L Z" apply (simp add: sublens_def) apply (rule_tac x="(fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L snd\<^sub>L" in exI) apply (auto) apply (rule plus_vwb_lens) apply (simp add: comp_vwb_lens fst_vwb_lens) apply (rule plus_vwb_lens) apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens) apply (simp add: snd_vwb_lens) apply (simp add: lens_indep_left_ext) apply (rule lens_indep_sym) apply (rule plus_pres_lens_indep) using fst_snd_lens_indep fst_vwb_lens lens_indep_left_comp lens_indep_sym vwb_lens_mwb apply blast using fst_snd_lens_indep lens_indep_left_ext lens_indep_sym apply blast apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1] done lemma lens_plus_sub_assoc_2: "(X +\<^sub>L Y) +\<^sub>L Z \\<^sub>L X +\<^sub>L Y +\<^sub>L Z" apply (simp add: sublens_def) apply (rule_tac x="(fst\<^sub>L +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L)" in exI) apply (auto) apply (rule plus_vwb_lens) apply (rule plus_vwb_lens) apply (simp add: fst_vwb_lens) apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens) apply (rule lens_indep_sym) apply (rule lens_indep_left_ext) using fst_snd_lens_indep lens_indep_sym apply blast apply (auto intro: comp_vwb_lens simp add: snd_vwb_lens) apply (rule plus_pres_lens_indep) apply (simp add: lens_indep_left_ext lens_indep_sym) apply (simp add: snd_vwb_lens) apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1] done lemma lens_plus_assoc: "(X +\<^sub>L Y) +\<^sub>L Z \\<^sub>L X +\<^sub>L Y +\<^sub>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 +\<^sub>L Y \\<^sub>L Y +\<^sub>L X" apply (simp add: sublens_def) apply (rule_tac x="snd\<^sub>L +\<^sub>L fst\<^sub>L" in exI) apply (auto) - apply (simp add: fst_vwb_lens lens_indep_sym plus_vwb_lens snd_vwb_lens) + apply (simp add: fst_vwb_lens lens_indep_sym snd_vwb_lens) apply (simp add: lens_indep_sym lens_plus_swap) done lemma lens_plus_comm: "X \ Y \ X +\<^sub>L Y \\<^sub>L Y +\<^sub>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: "wb_lens Y \ X \\<^sub>L X +\<^sub>L Y" +lemma lens_plus_ub [simp]: "wb_lens Y \ X \\<^sub>L X +\<^sub>L Y" by (metis fst_lens_plus fst_vwb_lens sublens_def) lemma lens_plus_right_sublens: "\ vwb_lens Y; Y \ Z; X \\<^sub>L Z \ \ X \\<^sub>L Y +\<^sub>L Z" apply (auto simp add: sublens_def) apply (rename_tac Z') apply (rule_tac x="Z' ;\<^sub>L snd\<^sub>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 \\<^sub>L Y \ \ X +\<^sub>L Z \\<^sub>L Y +\<^sub>L Z" apply (auto simp add: sublens_def) apply (rename_tac Z') apply (rule_tac x="Z' \\<^sub>L 1\<^sub>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 \\<^sub>L Z \ \ X +\<^sub>L Y \\<^sub>L X +\<^sub>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 ;\<^sub>L Y \\<^sub>L Y" by (auto simp add: sublens_def) lemma sublens_comp [simp]: assumes "vwb_lens b" "c \\<^sub>L a" shows "(b ;\<^sub>L c) \\<^sub>L a" by (metis assms sublens_def sublens_trans) text \We can now also show that @{text "0\<^sub>L"} is the unit of lens plus\ lemma lens_unit_plus_sublens_1: "X \\<^sub>L 0\<^sub>L +\<^sub>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\<^sub>L +\<^sub>L X \\<^sub>L X" apply (auto simp add: sublens_def) apply (rule_tac x="0\<^sub>L +\<^sub>L 1\<^sub>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\<^sub>L +\<^sub>L X \\<^sub>L X" by (simp add: lens_equivI lens_unit_plus_sublens_1 lens_unit_prod_sublens_2) lemma lens_plus_right_unit: "X +\<^sub>L 0\<^sub>L \\<^sub>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\<^sub>1 \ Y\<^sub>2; X\<^sub>1 \\<^sub>L Y\<^sub>1; X\<^sub>2 \\<^sub>L Y\<^sub>2 \ \ X\<^sub>1 +\<^sub>L X\<^sub>2 \\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2" by (metis prod_lens_comp_plus prod_vwb_lens sublens_def) lemma lens_plus_eq_left: "\ X \ Z; X \\<^sub>L Y \ \ X +\<^sub>L Z \\<^sub>L Y +\<^sub>L Z" by (meson lens_equiv_def lens_plus_mono_left sublens_pres_indep) lemma lens_plus_eq_right: "\ X \ Y; Y \\<^sub>L Z \ \ X +\<^sub>L Y \\<^sub>L X +\<^sub>L Z" by (meson lens_equiv_def lens_indep_sym lens_plus_mono_right sublens_pres_indep) lemma lens_plus_cong: assumes "X\<^sub>1 \ X\<^sub>2" "X\<^sub>1 \\<^sub>L Y\<^sub>1" "X\<^sub>2 \\<^sub>L Y\<^sub>2" shows "X\<^sub>1 +\<^sub>L X\<^sub>2 \\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2" proof - have "X\<^sub>1 +\<^sub>L X\<^sub>2 \\<^sub>L Y\<^sub>1 +\<^sub>L X\<^sub>2" by (simp add: assms(1) assms(2) lens_plus_eq_left) moreover have "... \\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>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\<^sub>1 \\<^sub>L X\<^sub>2; Y\<^sub>1 \\<^sub>L Y\<^sub>2 \ \ (X\<^sub>1 \\<^sub>L Y\<^sub>1) \\<^sub>L (X\<^sub>2 \\<^sub>L Y\<^sub>2)" apply (auto simp add: sublens_def) apply (rename_tac Z\<^sub>1 Z\<^sub>2) apply (rule_tac x="Z\<^sub>1 \\<^sub>L Z\<^sub>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\<^sub>1 \\<^sub>L X\<^sub>2; Y\<^sub>1 \\<^sub>L Y\<^sub>2 \ \ (X\<^sub>1 \\<^sub>L Y\<^sub>1) \\<^sub>L (X\<^sub>2 \\<^sub>L Y\<^sub>2)" by (simp add: lens_equiv_def prod_lens_sublens_cong) text \We also have the following "exchange" law that allows us to switch over a lens product and plus.\ lemma lens_plus_prod_exchange: "(X\<^sub>1 +\<^sub>L X\<^sub>2) \\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \\<^sub>L (X\<^sub>1 \\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \\<^sub>L Y\<^sub>2)" proof (rule lens_equivI) show "(X\<^sub>1 +\<^sub>L X\<^sub>2) \\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \\<^sub>L (X\<^sub>1 \\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \\<^sub>L Y\<^sub>2)" apply (simp add: sublens_def) apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>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\<^sub>1 \\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \\<^sub>L Y\<^sub>2) \\<^sub>L (X\<^sub>1 +\<^sub>L X\<^sub>2) \\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2)" apply (simp add: sublens_def) apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>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 \\<^sub>L Y \ \ get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> s v) = put\<^bsub>X /\<^sub>L Y\<^esub> (get\<^bsub>Y\<^esub> s) v" proof - assume a1: "vwb_lens Y" assume a2: "X \\<^sub>L Y" have "\l la. put\<^bsub>l ;\<^sub>L la\<^esub> = (\b c. put\<^bsub>la\<^esub> (b::'b) (put\<^bsub>l\<^esub> (get\<^bsub>la\<^esub> b::'a) (c::'c)))" by (simp add: lens_comp_def) then have "\l la b c. get\<^bsub>l\<^esub> (put\<^bsub>la ;\<^sub>L l\<^esub> (b::'b) (c::'c)) = put\<^bsub>la\<^esub> (get\<^bsub>l\<^esub> 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 \\<^sub>L Y \ \ put\<^bsub>Y\<^esub> s (put\<^bsub>X /\<^sub>L Y\<^esub> v\<^sub>2 v\<^sub>1) = put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s v\<^sub>2) v\<^sub>1" proof - assume a1: "vwb_lens Y" assume a2: "X \\<^sub>L Y" have f3: "\l b. put\<^bsub>l\<^esub> (b::'b) (get\<^bsub>l\<^esub> b::'a) = b \ \ vwb_lens l" by force have f4: "\b c. put\<^bsub>X /\<^sub>L Y\<^esub> (get\<^bsub>Y\<^esub> b) c = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> b c)" using a2 a1 by (simp add: lens_get_put_quasi_commute) have "\b c a. put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> b c) a = put\<^bsub>Y\<^esub> 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\<^sub>L"}.\ lemma bij_lens_inv_left: "bij_lens X \ inv\<^sub>L X ;\<^sub>L X = 1\<^sub>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 ;\<^sub>L inv\<^sub>L X = 1\<^sub>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 \\<^sub>L 1\<^sub>L" apply (auto) apply (rule lens_equivI) apply (simp_all add: sublens_def) apply (rule_tac x="lens_inv X" in exI) apply (simp add: bij_lens_inv_left lens_inv_bij) apply (auto simp add: lens_equiv_def sublens_def id_lens_def lens_comp_def comp_def) apply (unfold_locales) apply (simp) apply (simp) apply (metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get) done text \For this reason, by transitivity, any two bijective lenses with the same source type must be equivalent.\ lemma bij_lens_equiv: "\ bij_lens X; X \\<^sub>L Y \ \ bij_lens Y" by (meson bij_lens_equiv_id lens_equiv_def sublens_trans) lemma bij_lens_cong: "X \\<^sub>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\<^sub>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 ;\<^sub>L Y \ X = 1\<^sub>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\<^sub>L"}, then both of the composed lenses must be bijective.\ lemma bij_lens_via_comp_id_left: "\ wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>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 ;\<^sub>L Y = 1\<^sub>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 ;\<^sub>L Y" shows "X \\<^sub>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 \\<^sub>L Y \ (\ Z. bij_lens Z \ X = Z ;\<^sub>L Y)" apply (rule iffI) apply (auto simp add: lens_equiv_def sublens_def lens_id_unique)[1] apply (rename_tac Z\<^sub>1 Z\<^sub>2) apply (rule_tac x="Z\<^sub>1" in exI) apply (simp) apply (subgoal_tac "Z\<^sub>2 ;\<^sub>L Z\<^sub>1 = 1\<^sub>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 +\<^sub>L a) \ \ pbij_lens (a +\<^sub>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\<^sub>1 \\<^sub>L S\<^sub>2 on 1\<^sub>L = S\<^sub>2" by (simp add: lens_override_def id_lens_def) lemma lens_override_unit [simp]: "S\<^sub>1 \\<^sub>L S\<^sub>2 on 0\<^sub>L = S\<^sub>1" by (simp add: lens_override_def zero_lens_def) lemma lens_override_overshadow: assumes "mwb_lens Y" "X \\<^sub>L Y" shows "(S\<^sub>1 \\<^sub>L S\<^sub>2 on X) \\<^sub>L S\<^sub>3 on Y = S\<^sub>1 \\<^sub>L S\<^sub>3 on Y" using assms by (simp add: lens_override_def sublens_put_put) lemma lens_override_irr: assumes "X \ Y" shows "S\<^sub>1 \\<^sub>L (S\<^sub>2 \\<^sub>L S\<^sub>3 on Y) on X = S\<^sub>1 \\<^sub>L S\<^sub>2 on X" using assms by (simp add: lens_override_def) lemma lens_override_overshadow_left: assumes "mwb_lens X" shows "(S\<^sub>1 \\<^sub>L S\<^sub>2 on X) \\<^sub>L S\<^sub>3 on X = S\<^sub>1 \\<^sub>L S\<^sub>3 on X" by (simp add: assms lens_override_def) lemma lens_override_overshadow_right: assumes "mwb_lens X" shows "S\<^sub>1 \\<^sub>L (S\<^sub>2 \\<^sub>L S\<^sub>3 on X) on X = S\<^sub>1 \\<^sub>L S\<^sub>3 on X" by (simp add: assms lens_override_def) lemma lens_override_plus: "X \ Y \ S\<^sub>1 \\<^sub>L S\<^sub>2 on (X +\<^sub>L Y) = (S\<^sub>1 \\<^sub>L S\<^sub>2 on X) \\<^sub>L S\<^sub>2 on Y" by (simp add: lens_indep_comm lens_override_def lens_plus_def) lemma lens_override_idem [simp]: "vwb_lens X \ S \\<^sub>L S on X = S" by (simp add: lens_override_def) lemma lens_override_mwb_idem [simp]: "\ mwb_lens X; S \ \\<^bsub>X\<^esub> \ \ S \\<^sub>L S on X = S" by (simp add: lens_override_def) lemma lens_override_put_right_in: "\ vwb_lens A; X \\<^sub>L A \ \ S\<^sub>1 \\<^sub>L (put\<^bsub>X\<^esub> S\<^sub>2 v) on A = put\<^bsub>X\<^esub> (S\<^sub>1 \\<^sub>L S\<^sub>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\<^sub>1 \\<^sub>L (put\<^bsub>X\<^esub> S\<^sub>2 v) on A = (S\<^sub>1 \\<^sub>L S\<^sub>2 on A)" by (simp add: lens_override_def lens_indep.lens_put_irr2) lemma lens_indep_overrideI: assumes "vwb_lens X" "vwb_lens Y" "(\ s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \\<^sub>L s\<^sub>2 on X \\<^sub>L s\<^sub>3 on Y = s\<^sub>1 \\<^sub>L s\<^sub>3 on Y \\<^sub>L s\<^sub>2 on X)" shows "X \ Y" using assms apply (unfold_locales) apply (simp_all add: lens_override_def) apply (metis mwb_lens_def vwb_lens_mwb weak_lens.put_get) apply (metis lens_override_def lens_override_idem mwb_lens_def vwb_lens_mwb weak_lens.put_get) apply (metis mwb_lens_weak vwb_lens_mwb vwb_lens_wb wb_lens.get_put weak_lens.put_get) done lemma lens_indep_override_def: assumes "vwb_lens X" "vwb_lens Y" shows "X \ Y \ (\ s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \\<^sub>L s\<^sub>2 on X \\<^sub>L s\<^sub>3 on Y = s\<^sub>1 \\<^sub>L s\<^sub>3 on Y \\<^sub>L s\<^sub>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 \\<^sub>L s on X = s \ \ vwb_lens X" by (unfold_locales, simp_all add: lens_defs) subsection \ Alternative Sublens Characterisation \ text \ The following definition is equivalent to the above when the two lenses are very well behaved. \ definition sublens' :: "('a \ 'c) \ ('b \ 'c) \ bool" (infix "\\<^sub>L''" 55) where [lens_defs]: "sublens' X Y = (\ s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \\<^sub>L s\<^sub>2 on Y \\<^sub>L s\<^sub>3 on X = s\<^sub>1 \\<^sub>L s\<^sub>2 \\<^sub>L s\<^sub>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 \\<^sub>L' Y" shows "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> s\<^sub>2)) s\<^sub>3 = put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> s\<^sub>2 s\<^sub>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 \\<^sub>L' Y" shows "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> s\<^sub>2)) = get\<^bsub>X\<^esub> s\<^sub>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 \\<^sub>L' Y" shows "put\<^bsub>Y\<^esub> \ (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \ (get\<^bsub>Y\<^esub> \)) v)) = put\<^bsub>X\<^esub> \ 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 \\<^sub>L' Y" shows "X \\<^sub>L Y" proof - have "vwb_lens (X /\<^sub>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 /\<^sub>L Y ;\<^sub>L Y" proof - have "get\<^bsub>X\<^esub> = (\\. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \)) \ get\<^bsub>Y\<^esub>" by (rule ext, simp add: assms(1) assms(3) lens_create_def sublens'_prop2) moreover have "put\<^bsub>X\<^esub> = (\\ v. put\<^bsub>Y\<^esub> \ (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> (get\<^bsub>Y\<^esub> \)) v)))" by (rule ext, rule ext, simp add: assms(1) assms(2) assms(3) lens_create_def sublens'_prop3) ultimately show ?thesis by (simp add: lens_quotient_def lens_comp_def) qed ultimately show ?thesis using sublens_def by blast qed lemma sublens_implies_sublens': assumes "vwb_lens Y" "X \\<^sub>L Y" shows "X \\<^sub>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 \\<^sub>L Y \ X \\<^sub>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 "\\<^sub>L''" 51) where [lens_defs]: "lens_equiv' X Y = (\ s\<^sub>1 s\<^sub>2. (s\<^sub>1 \\<^sub>L s\<^sub>2 on X = s\<^sub>1 \\<^sub>L s\<^sub>2 on Y))" lemma lens_equiv_iff_lens_equiv': assumes "vwb_lens X" "vwb_lens Y" shows "X \\<^sub>L Y \ X \\<^sub>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 \ No newline at end of file diff --git a/thys/Optics/Lens_Record.ML b/thys/Optics/Lens_Record.ML --- a/thys/Optics/Lens_Record.ML +++ b/thys/Optics/Lens_Record.ML @@ -1,341 +1,322 @@ signature LENS_UTILS = sig val add_alphabet_cmd : {overloaded: bool} -> (string * string option) list * binding -> string option -> (binding * string * mixfix) list -> theory -> theory end; structure Lens_Utils : LENS_UTILS = struct +open Syntax; +open Lens_Lib; + (* We set up the following syntactic entities that correspond to various parts of Isabelle syntax and names that we depend on. These code would need to be updated if the names of the Isabelle and lens theories and/or theorems change. *) val FLDLENS = "FLDLENS" val BASELENS = "BASELENS" val base_lensN = "base\<^sub>L" val child_lensN = "more\<^sub>L" val all_lensN = "all\<^sub>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 indepsN = "indeps" -val sublensN = "sublenses" -val quotientN = "quotients" -val compositionN = "compositions" val Trueprop = @{const_name Trueprop} val HOLeq = @{const_name HOL.eq} -val bij_lens = @{const_name bij_lens} -val vwb_lens = @{const_name vwb_lens} -val sym_lens = @{const_name sym_lens} -val lens_indep = @{const_name lens_indep} -val lens_plus = @{const_name lens_plus} -val lens_quotient = @{const_name lens_quotient} -val lens_comp = @{const_name lens_comp} -val id_lens = @{const_name id_lens} -val sublens = @{const_name sublens} -val lens_equiv = @{const_name lens_equiv} + val lens_suffix = "\<^sub>v" val lens_defsN = "lens_defs" val lens_defs = (Binding.empty, [Token.make_src (lens_defsN, Position.none) []]) val alpha_splitsN = "alpha_splits" val alpha_splits = [Token.make_src (alpha_splitsN, Position.none) []] val equivN = "equivs" val splits_suffix = ".splits" val defs_suffix = ".defs" val prod_case_eq_ifN = "prod.case_eq_if" val slens_view = "view" val slens_coview = "coview" (* The following code is adapted from the record package. We generate a record, but also create lenses for each field and prove properties about them. *) fun read_parent NONE ctxt = (NONE, ctxt) | read_parent (SOME raw_T) ctxt = (case Proof_Context.read_typ_abbrev ctxt raw_T of Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt) | T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T)); fun read_fields raw_fields ctxt = let val Ts = Syntax.read_typs ctxt (map (fn (_, raw_T, _) => raw_T) raw_fields); val fields = map2 (fn (x, _, mx) => fn T => (x, T, mx)) raw_fields Ts; val ctxt' = fold Variable.declare_typ Ts ctxt; in (fields, ctxt') end; fun add_record_cmd overloaded (raw_params, binding) raw_parent raw_fields thy = let val ctxt = Proof_Context.init_global thy; val params = map (apsnd (Typedecl.read_constraint ctxt)) raw_params; val ctxt1 = fold (Variable.declare_typ o TFree) params ctxt; val (parent, ctxt2) = read_parent raw_parent ctxt1; val (fields, ctxt3) = read_fields raw_fields ctxt2; val params' = map (Proof_Context.check_tfree ctxt3) params; in thy |> Record.add_record overloaded (params', binding) parent fields end; (* Construct a theorem and proof that a given field lens is very well-behaved *) fun lens_proof tname x thy = let open Simplifier; open Global_Theory in Goal.prove_global thy [] [] (hd (Type_Infer_Context.infer_types (Proof_Context.init_global thy) - [ Const (Trueprop, dummyT) - $ (Const (vwb_lens, dummyT) $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT))])) + [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_lens, dummyT) $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ all_lensN, 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_lens, dummyT) $ - (Const (lens_plus, dummyT) $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT) - $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ child_lensN, 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) - [ Const (Trueprop, dummyT) - $ ( Const (lens_indep, dummyT) - $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ x, dummyT) - $ Const (Context.theory_name thy ^ "." ^ tname ^ "." ^ y, dummyT) - )])) + [ 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_equiv, dummyT) + $ ( Const (lens_equivN, dummyT) $ Const (pname ^ "." ^ child_lensN, dummyT) - $ foldr1 (fn (x, y) => Const (lens_plus, dummyT) $ x $ y) + $ 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_equiv, dummyT) + $ ( Const (lens_equivN, dummyT) $ Const (theory_name thy ^ "." ^ tname ^ "." ^ base_lensN, dummyT) - $ foldr1 (fn (x, y) => Const (lens_plus, dummyT) $ x $ y) + $ 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_equiv, dummyT) - $ ( Const (lens_plus, 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_lens, 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 (sublens, 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_quotient, 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_comp, 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 - -fun pairWith _ [] = [] - | pairWith x (y :: ys) = [(x, y), (y, x)] @ pairWith x ys; - -fun pairings [] = [] - | pairings (x :: xs) = pairWith x xs @ pairings xs; - (* 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 sublensN) - @ map (fn thm => @{thm sublens_pres_indep'} OF [thm]) (get_thms thy sublensN) + fun pindeps thy = map (fn thm => @{thm sublens_pres_indep} OF [thm]) (get_thms thy sublensesN) + @ map (fn thm => @{thm sublens_pres_indep'} OF [thm]) (get_thms thy sublensesN) in thy (* Add a new record for the new alphabet lenses *) |> add_record_cmd {overloaded = false} (raw_params, binding) raw_parent fields (* Add the record definition theorems to lens_defs *) |> Named_Target.theory_map (snd o Specification.theorems_cmd "" [((Binding.empty, []), [(Facts.named (tname ^ defs_suffix), snd lens_defs)])] [] false) (* Add the record splitting theorems to the alpha_splits set for proof automation *) |> Named_Target.theory_map (snd o Specification.theorems_cmd "" [((Binding.empty, []), [(Facts.named (tname ^ splits_suffix), alpha_splits)])] [] false) (* Add definitions for each of the lenses corresponding to each record field in-situ *) |> Sign.qualified_path false binding |> Named_Target.theory_map (fold (fn (n, d) => snd o Specification.definition_cmd (SOME (Binding.make (n, Position.none), NONE, NoSyn)) [] [] (lens_defs, d) true) (map ldef lnames @ [bldef, mldef])) (* Add definition of the underlying symmetric lens *) |> Named_Target.theory_map (fold (fn (n, d) => Specification.abbreviation_cmd Syntax.mode_default (SOME (Binding.make (n, Position.none), NONE, NoSyn)) [] d true) [sldef]) (* Add a vwb lens proof for each field lens *) |> fold (fn x => fn thy => snd (add_thm ((Binding.make (x ^ vwb_lens_suffix, Position.none), lens_proof tname x thy), [Simplifier.simp_add]) thy)) (lnames @ [base_lensN, child_lensN]) (* Add a bij lens proof for the base and more lenses *) |> (fn thy => snd (add_thm ((Binding.make (base_moreN ^ bij_lens_suffix, Position.none), lens_bij_proof tname thy), [Simplifier.simp_add]) thy)) (* Add sublens proofs *) - |> (fn thy => snd (add_thmss [((Binding.make (sublensN, 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 (sublensesN, Position.none), map (sublens_proof tname pname thy plchild) plnames @ map (sublens_proof tname (Context.theory_name thy ^ "." ^ tname) thy base_lensN) lnames), [Simplifier.simp_add])] thy)) (* Add quotient proofs *) - |> (fn thy => snd (add_thmss [((Binding.make (quotientN, Position.none), map (quotient_proof tname thy) 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)) (* Add composition proofs *) - |> (fn thy => snd (add_thmss [((Binding.make (compositionN, Position.none), map (composition_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)) (* Add equivalence properties *) |> (fn thy => snd (add_thmss [((Binding.make (equivN, Position.none), (if (raw_parent = NONE) then [] else [equiv_more_proof tname pname thy lnames]) @ [equiv_base_proof tname parent thy lnames, equiv_partition_proof tname thy]), [Simplifier.simp_add])] thy)) (* Add a symmetric lens proof for the base and more lenses *) |> (fn thy => snd (add_thm ((Binding.make (all_lensN ^ sym_lens_suffix, Position.none), lens_sym_proof tname thy), [Simplifier.simp_add]) thy)) |> Sign.parent_path end; val _ = Outer_Syntax.command @{command_keyword alphabet} "define record with lenses" (Parse_Spec.overloaded -- (Parse.type_args_constrained -- Parse.binding) -- (@{keyword "="} |-- Scan.option (Parse.typ --| @{keyword "+"}) -- Scan.repeat1 Parse.const_binding) >> (fn ((overloaded, x), (y, z)) => Toplevel.theory (add_alphabet_cmd {overloaded = overloaded} x y z))); end \ No newline at end of file diff --git a/thys/Optics/Lens_Statespace.ML b/thys/Optics/Lens_Statespace.ML new file mode 100644 --- /dev/null +++ b/thys/Optics/Lens_Statespace.ML @@ -0,0 +1,66 @@ +signature LENS_STATESPACE = +sig + val mk_statespace_elements: bstring -> (bstring * typ) list -> xstring list -> theory -> Element.context_i list + val compile_statespace: bstring -> (bstring * typ) list -> xstring list -> theory -> theory + val statespace_cmd: bstring -> xstring list -> (bstring * string) list -> theory -> theory +end + +structure Lens_Statespace = +struct + (* Produce a list of new elements for a locale to characterise a state space *) + fun mk_statespace_elements vds exts thy = + let + open Lens_Lib; + open Syntax; + val ctx = Named_Target.theory_init thy + val vns = map fst vds + val vfixes = map (fn (n, t) => (Binding.name n, SOME (lensT t astateT), NoSyn)) vds + val vwbs = map (mk_vwb_lens o free) vns; + val simp = Attrib.check_src ctx (Token.make_src ("simp", Position.none) []) + val imps = map (fn e => Locale.check thy (e, Position.none)) exts + (* List of lenses imported *) + val ilnsls = map (filter (isLensT o snd) o map fst o Locale.params_of thy) imps + (* Independence axioms from imports *) + val impind = List.concat (map (pairsWith vns) (map (map fst) ilnsls)) + val indeps = map (fn (x, y) => mk_indep (free x) (free y)) + (pairings (vns) @ impind) + in + (* Fix each of the variables as lenses *) + [ Element.Fixes vfixes + (* Assume that all lenses are very well-behaved and independent (as in a product space) *) + , Element.Assumes [((Binding.name "vwbs", [simp]) + , map (fn vwb => (vwb, [])) vwbs), + ((Binding.name "indeps", [simp]) + , map (fn vwb => (vwb, [])) indeps)] + ] + end + + + (* Compile a state space from a given state space name and list of variable declarations *) + fun compile_statespace ssn vds exts thy = + let + open Lens_Lib; + open Syntax; + val imps = map (fn e => Locale.check thy (e, Position.none)) exts + val locexs = map (fn i => (i, (("", false), (Expression.Positional [], [])))) imps + in + (Local_Theory.exit_global o snd o + Expression.add_locale (Binding.name ssn) Binding.empty [] (locexs,[]) + (mk_statespace_elements vds exts thy)) thy + end + + fun statespace_cmd n exts vds thy = + let + open Syntax + val ctx = Named_Target.theory_init thy in + compile_statespace n (map (fn (n, t) => (n, read_typ ctx t)) vds) exts thy + end +end; + +let open Parse in + Outer_Syntax.command @{command_keyword statespace} "define locale-based statespace with lenses" + ((Parse.name -- + (@{keyword "="} |-- Scan.repeat (Parse.name --| @{keyword "+"}) -- + Scan.repeat (Parse.name -- ($$$ "::" |-- !!! typ)))) + >> (fn (n, (exts, vds)) => Toplevel.theory (Lens_Statespace.statespace_cmd n exts vds))) +end diff --git a/thys/Optics/Lens_Statespace_Example.thy b/thys/Optics/Lens_Statespace_Example.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Lens_Statespace_Example.thy @@ -0,0 +1,38 @@ +theory Lens_Statespace_Example + imports Lenses +begin + +statespace myss = + x :: int + y :: int + +statespace myss' = + a :: string + +statespace myss2 = myss + myss' + + z :: string + +context myss2 +begin + +lemma "x \ y" + by (simp) + +end + +statespace myss3 = myss2 + + v :: string + +text \ We can instantiate one of the statespaces with a concrete alphabet type as shown below. \ + +alphabet myss_c = + x :: int + y :: int + a :: string + z :: string + v :: string + +lemma "myss3 x y a z v" + by (simp add: myss'_def myss2_axioms_def myss2_def myss3.intro myss3_axioms.intro myss_def) + +end \ No newline at end of file diff --git a/thys/Optics/Optics.thy b/thys/Optics/Optics.thy --- a/thys/Optics/Optics.thy +++ b/thys/Optics/Optics.thy @@ -1,5 +1,5 @@ section \Optics Meta-Theory\ theory Optics - imports Lenses Prisms Scenes + imports Lenses Prisms Scenes Dataspace Channel_Type begin end \ No newline at end of file diff --git a/thys/Optics/Prism_Lib.ML b/thys/Optics/Prism_Lib.ML new file mode 100644 --- /dev/null +++ b/thys/Optics/Prism_Lib.ML @@ -0,0 +1,36 @@ +signature PRISM_LIB = +sig + val wb_prismN: string + val prism_diffN: string + val codepsN: string + + (* Prism terms *) + + val prismT: typ -> typ -> typ + val isPrismT: typ -> bool + val mk_wb_prism: term -> term (* Make a well-behaved prism term *) + val mk_codep: term -> term -> term (* Make a codependence term *) + +end + +structure Prism_Lib : PRISM_LIB = +struct + +open Syntax +open HOLogic + +val wb_prismN = @{const_name wb_prism} +val prism_diffN = @{const_name prism_diff} + +val codepsN = "codeps" + +fun prismT a b = Type (@{type_name prism_ext}, [a, b, unitT]) + +fun isPrismT (Type (n, _)) = (n = @{type_name prism_ext}) | + isPrismT _ = false + +fun mk_wb_prism t = mk_Trueprop (const wb_prismN $ t) + +fun mk_codep x y = mk_Trueprop (const prism_diffN $ x $ y) + +end diff --git a/thys/Optics/Prisms.thy b/thys/Optics/Prisms.thy --- a/thys/Optics/Prisms.thy +++ b/thys/Optics/Prisms.thy @@ -1,49 +1,152 @@ section \Prisms\ theory Prisms - imports Main + imports Lenses begin - + +subsection \ Signature and Axioms \ + text \Prisms are like lenses, but they act on sum types rather than product types. For now we do not support many properties about them. See \url{https://hackage.haskell.org/package/lens-4.15.2/docs/Control-Lens-Prism.html} for more information.\ record ('v, 's) prism = prism_match :: "'s \ 'v option" ("match\") prism_build :: "'v \ 's" ("build\") +type_notation + prism (infixr "\\<^sub>\" 0) + locale wb_prism = - fixes x :: "('v, 's) prism" (structure) + fixes x :: "'v \\<^sub>\ 's" (structure) assumes match_build: "match (build v) = Some v" and build_match: "match s = Some v \ s = build v" begin lemma build_match_iff: "match s = Some v \ s = build v" using build_match match_build by blast lemma range_build: "range build = dom match" using build_match match_build by fastforce end -definition prism_suml :: "('a, 'a + 'b) prism" where -"prism_suml = \ prism_match = (\ v. case v of Inl x \ Some x | _ \ None), prism_build = Inl \" +declare wb_prism.match_build [simp] +declare wb_prism.build_match [simp] -lemma wb_prim_suml: "wb_prism prism_suml" - apply (unfold_locales) - apply (simp_all add: prism_suml_def sum.case_eq_if) - apply (metis option.inject option.simps(3) sum.collapse(1)) -done +subsection \ Co-dependence \ -definition prism_diff :: "('a, 's) prism \ ('b, 's) prism \ bool" (infix "\" 50) where +text \ The relation states that two prisms construct disjoint elements of the source. This + can occur, for example, when the two prisms characterise different constructors of an + algebraic datatype. \ + +definition prism_diff :: "('a \\<^sub>\ 's) \ ('b \\<^sub>\ 's) \ bool" (infix "\" 50) where "prism_diff X Y = (range build\<^bsub>X\<^esub> \ range build\<^bsub>Y\<^esub> = {})" +lemma prism_diff_intro: + "(\ s\<^sub>1 s\<^sub>2. build\<^bsub>X\<^esub> s\<^sub>1 = build\<^bsub>Y\<^esub> s\<^sub>2 \ False) \ X \ Y" + by (auto simp add: prism_diff_def) + +lemma prism_diff_irrefl: "\ X \ X" + by (simp add: prism_diff_def) + +lemma prism_diff_sym: "X \ Y \ Y \ X" + by (auto simp add: prism_diff_def) + lemma prism_diff_build: "X \ Y \ build\<^bsub>X\<^esub> u \ build\<^bsub>Y\<^esub> v" by (simp add: disjoint_iff_not_equal prism_diff_def) -definition prism_plus :: "('a, 's) prism \ ('b, 's) prism \ ('a + 'b, 's) prism" (infixl "+\<^sub>P" 85) where -"X +\<^sub>P Y = \ prism_match = (\ s. case (match\<^bsub>X\<^esub> s, match\<^bsub>Y\<^esub> s) of +subsection \ Summation \ + +definition prism_plus :: "('a \\<^sub>\ 's) \ ('b \\<^sub>\ 's) \ 'a + 'b \\<^sub>\ 's" (infixl "+\<^sub>\" 85) + where +"X +\<^sub>\ Y = \ prism_match = (\ s. case (match\<^bsub>X\<^esub> s, match\<^bsub>Y\<^esub> s) of (Some u, _) \ Some (Inl u) | (None, Some v) \ Some (Inr v) | (None, None) \ None), prism_build = (\ v. case v of Inl x \ build\<^bsub>X\<^esub> x | Inr y \ build\<^bsub>Y\<^esub> y) \" + +subsection \ Instances \ + +definition prism_suml :: "('a, 'a + 'b) prism" ("Inl\<^sub>\") where +[lens_defs]: "prism_suml = \ prism_match = (\ v. case v of Inl x \ Some x | _ \ None), prism_build = Inl \" + +definition prism_sumr :: "('b, 'a + 'b) prism" ("Inr\<^sub>\") where +[lens_defs]: "prism_sumr = \ prism_match = (\ v. case v of Inr x \ Some x | _ \ None), prism_build = Inr \" + +lemma wb_prim_suml: "wb_prism Inl\<^sub>\" + apply (unfold_locales) + apply (simp_all add: prism_suml_def sum.case_eq_if) + apply (metis option.inject option.simps(3) sum.collapse(1)) + done + +lemma wb_prim_sumr: "wb_prism Inr\<^sub>\" + apply (unfold_locales) + apply (simp_all add: prism_sumr_def sum.case_eq_if) + apply (metis option.distinct(1) option.inject sum.collapse(2)) + done + +lemma prism_suml_indep_sumr [simp]: "Inl\<^sub>\ \ Inr\<^sub>\" + by (auto simp add: prism_diff_def lens_defs) + +subsection \ Lens correspondence \ + +text \ Every well-behaved prism can be represented by a partial bijective lens. We prove + this by exhibiting conversion functions and showing they are (almost) inverses. \ + +definition prism_lens :: "('a, 's) prism \ ('a \ 's)" where +"prism_lens X = \ lens_get = (\ s. the (match\<^bsub>X\<^esub> s)), lens_put = (\ s v. build\<^bsub>X\<^esub> v) \" + +definition lens_prism :: "('a \ 's) \ ('a, 's) prism" where +"lens_prism X = \ prism_match = (\ s. if (s \ \\<^bsub>X\<^esub>) then Some (get\<^bsub>X\<^esub> s) else None) + , prism_build = create\<^bsub>X\<^esub> \" + +lemma get_prism_lens: "get\<^bsub>prism_lens X\<^esub> = the \ match\<^bsub>X\<^esub>" + by (simp add: prism_lens_def fun_eq_iff) + +lemma src_prism_lens: "\\<^bsub>prism_lens X\<^esub> = range (build\<^bsub>X\<^esub>)" + by (auto simp add: prism_lens_def lens_source_def) + +lemma create_prism_lens: "create\<^bsub>prism_lens X\<^esub> = build\<^bsub>X\<^esub>" + by (simp add: prism_lens_def lens_create_def fun_eq_iff) + +lemma prism_lens_inverse: + "wb_prism X \ lens_prism (prism_lens X) = X" + unfolding lens_prism_def src_prism_lens create_prism_lens get_prism_lens + by (auto intro: prism.equality simp add: fun_eq_iff domIff wb_prism.range_build) + +text \ Function @{const lens_prism} is almost inverted by @{const prism_lens}. The $put$ + functions are identical, but the $get$ functions differ when applied to a source where + the prism @{term X} is undefined. \ + +lemma lens_prism_put_inverse: + "pbij_lens X \ put\<^bsub>prism_lens (lens_prism X)\<^esub> = put\<^bsub>X\<^esub>" + unfolding prism_lens_def lens_prism_def + by (auto simp add: fun_eq_iff pbij_lens.put_is_create) + +lemma wb_prism_implies_pbij_lens: + "wb_prism X \ pbij_lens (prism_lens X)" + by (unfold_locales, simp_all add: prism_lens_def) + +lemma pbij_lens_implies_wb_prism: + assumes "pbij_lens X" + shows "wb_prism (lens_prism X)" +proof (unfold_locales) + fix s v + show "match\<^bsub>lens_prism X\<^esub> (build\<^bsub>lens_prism X\<^esub> v) = Some v" + by (simp add: lens_prism_def weak_lens.create_closure assms) + assume a: "match\<^bsub>lens_prism X\<^esub> s = Some v" + show "s = build\<^bsub>lens_prism X\<^esub> v" + proof (cases "s \ \\<^bsub>X\<^esub>") + case True + with a assms show ?thesis + by (simp add: lens_prism_def lens_create_def, + metis mwb_lens.weak_get_put pbij_lens.put_det pbij_lens_mwb) + next + case False + with a assms show ?thesis by (simp add: lens_prism_def) + qed +qed + +ML_file \Prism_Lib.ML\ + end diff --git a/thys/Optics/Prisms_Examples.thy b/thys/Optics/Prisms_Examples.thy new file mode 100644 --- /dev/null +++ b/thys/Optics/Prisms_Examples.thy @@ -0,0 +1,42 @@ +section \ Examples using Prisms \ + +theory Prisms_Examples + imports Prisms +begin + +text \ We demonstrate prisms for manipulating an algebraic data type with three constructors . \ + +datatype D = A int | B string | C bool + +fun fromA :: "D \ int option" where "fromA (A x) = Some x" | "fromA _ = None" +fun fromB :: "D \ string option" where "fromB (B x) = Some x" | "fromB _ = None" +fun fromC :: "D \ bool option" where "fromC (C x) = Some x" | "fromC _ = None" + +text \ We create a prism for each of the three constructors. \ + +definition A\<^sub>_prism :: "int \\<^sub>\ D" ("A\<^sub>\") where +[lens_defs]: "A\<^sub>\ = \ prism_match = fromA, prism_build = A \" + +definition B_prism :: "string \\<^sub>\ D" ("B\<^sub>\") where +[lens_defs]: "B\<^sub>\ = \ prism_match = fromB, prism_build = B \" + +definition C_prism :: "bool \\<^sub>\ D" ("C\<^sub>\") where +[lens_defs]: "C\<^sub>\ = \ prism_match = fromC, prism_build = C \" + +text \ All three are well-behaved. \ + +lemma A_wb_prism [simp]: "wb_prism A\<^sub>\" + using fromA.elims by (unfold_locales, auto simp add: lens_defs) + +lemma B_wb_prism [simp]: "wb_prism B\<^sub>\" + using fromB.elims by (unfold_locales, auto simp add: lens_defs) + +lemma C_wb_prism [simp]: "wb_prism C\<^sub>\" + using fromC.elims by (unfold_locales, auto simp add: lens_defs) + +text \ All three prisms are codependent with each other. \ + +lemma D_codeps: "A\<^sub>\ \ B\<^sub>\" "A\<^sub>\ \ C\<^sub>\" "B\<^sub>\ \ C\<^sub>\" + by (rule prism_diff_intro, simp add: lens_defs)+ + +end \ No newline at end of file diff --git a/thys/Optics/ROOT b/thys/Optics/ROOT --- a/thys/Optics/ROOT +++ b/thys/Optics/ROOT @@ -1,39 +1,41 @@ (******************************************************************************) (* Project: The Optics Library *) (* File: ROOT *) (* Authors: Simon Foster (University of York, UK) *) (* Emails: simon.foster@york.ac.uk *) (******************************************************************************) (* Optics Library *) chapter AFP session "Optics" (AFP) = "HOL-Eisbach" + options [timeout = 600] sessions "HOL-Library" theories Interp Two Lens_Laws Lens_Algebra Lens_Order Lens_Instances Lens_Symmetric Lenses Prisms + Channel_Type + Dataspace Scenes Optics theories [document = false] Lens_Record_Example theories Lens_State document_files "root.bib" "root.tex" "document.sty" "figures/Lens.pdf" "figures/Composition.pdf" "figures/Sum.pdf" "figures/Independence.pdf" diff --git a/thys/Optics/Scenes.thy b/thys/Optics/Scenes.thy --- a/thys/Optics/Scenes.thy +++ b/thys/Optics/Scenes.thy @@ -1,400 +1,466 @@ 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) + 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\<^sub>1, s\<^sub>2). (\ s. F s s\<^sub>1 = F s s\<^sub>2)}" . lift_definition coregion :: "'s scene \ 's rel" is "\ F. {(s\<^sub>1, s\<^sub>2). (\ s. F s\<^sub>1 s = F s\<^sub>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" ("_ \\<^sub>S _ on _" [95,0,96] 95) is "\ s\<^sub>1 s\<^sub>2 F. F s\<^sub>1 s\<^sub>2" . +abbreviation (input) scene_copy :: "'a scene \ 'a \ ('a \ 'a)" ("cp\<^bsub>_\<^esub>") where +"cp\<^bsub>A\<^esub> s \ (\ s'. s' \\<^sub>S s on A)" + lemma scene_override_idem [simp]: "idem_scene X \ s \\<^sub>S s on X = s" by (transfer, simp) lemma scene_override_overshadow_left [simp]: "S\<^sub>1 \\<^sub>S S\<^sub>2 on X \\<^sub>S S\<^sub>3 on X = S\<^sub>1 \\<^sub>S S\<^sub>3 on X" by (transfer, simp) lemma scene_override_overshadow_right [simp]: "S\<^sub>1 \\<^sub>S (S\<^sub>2 \\<^sub>S S\<^sub>3 on X) on X = S\<^sub>1 \\<^sub>S S\<^sub>3 on X" by (transfer, simp) definition scene_equiv :: "'a \ 'a \ ('a scene) \ bool" ("_ \\<^sub>S _ on _" [65,0,66] 65) where [lens_defs]: "S\<^sub>1 \\<^sub>S S\<^sub>2 on X = (S\<^sub>1 \\<^sub>S S\<^sub>2 on X = S\<^sub>1)" lemma scene_equiv_region: "idem_scene X \ region X = {(S\<^sub>1, S\<^sub>2). S\<^sub>1 \\<^sub>S S\<^sub>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 "\\<^sub>S" 50) is "\ F G. (\ s\<^sub>1 s\<^sub>2 s\<^sub>3. G (F s\<^sub>1 s\<^sub>2) s\<^sub>3 = F (G s\<^sub>1 s\<^sub>3) s\<^sub>2)" . lemma scene_indep_override: "X \\<^sub>S Y = (\ s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \\<^sub>S s\<^sub>2 on X \\<^sub>S s\<^sub>3 on Y = s\<^sub>1 \\<^sub>S s\<^sub>3 on Y \\<^sub>S s\<^sub>2 on X)" by (transfer, auto) +lemma scene_indep_copy: + "X \\<^sub>S Y = (\ s\<^sub>1 s\<^sub>2. cp\<^bsub>X\<^esub> s\<^sub>1 \ cp\<^bsub>Y\<^esub> s\<^sub>2 = cp\<^bsub>Y\<^esub> s\<^sub>2 \ cp\<^bsub>X\<^esub> s\<^sub>1)" + by (auto simp add: scene_indep_override comp_def fun_eq_iff) + lemma scene_indep_sym: "X \\<^sub>S Y \ Y \\<^sub>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 "##\<^sub>S" 50) is "\ F G. (\ s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2 = F (G s\<^sub>1 s\<^sub>2) s\<^sub>2)" . +lemma scene_compat_copy: + "X ##\<^sub>S Y = (\ s. cp\<^bsub>X\<^esub> s \ cp\<^bsub>Y\<^esub> s = cp\<^bsub>Y\<^esub> s \ cp\<^bsub>X\<^esub> s)" + by (transfer, auto simp add: fun_eq_iff) + lemma scene_indep_compat [simp]: "X \\<^sub>S Y \ X ##\<^sub>S Y" by (transfer, auto) lemma scene_compat_refl: "X ##\<^sub>S X" by (transfer, simp) lemma scene_compat_sym: "X ##\<^sub>S Y \ Y ##\<^sub>S X" by (transfer, simp) lemma scene_override_commute_indep: assumes "X \\<^sub>S Y" shows "S\<^sub>1 \\<^sub>S S\<^sub>2 on X \\<^sub>S S\<^sub>3 on Y = S\<^sub>1 \\<^sub>S S\<^sub>3 on Y \\<^sub>S S\<^sub>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\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2 = F (G s\<^sub>1 s\<^sub>2) s\<^sub>2) then (\ s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2) else (\ s\<^sub>1 s\<^sub>2. s\<^sub>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 "\\<^sub>S" 65) where "union_scene \ sup" abbreviation inter_scene :: "'s scene \ 's scene \ 's scene" (infixl "\\<^sub>S" 70) where "inter_scene \ inf" abbreviation top_scene :: "'s scene" ("\\<^sub>S") where "top_scene \ top" abbreviation bot_scene :: "'s scene" ("\\<^sub>S") where "bot_scene \ bot" lemma uminus_scene_twice: "- (- (X :: 's scene)) = X" by (transfer, simp) lemma scene_override_id [simp]: "S\<^sub>1 \\<^sub>S S\<^sub>2 on \\<^sub>S = S\<^sub>2" by (transfer, simp) lemma scene_override_unit [simp]: "S\<^sub>1 \\<^sub>S S\<^sub>2 on \\<^sub>S = S\<^sub>1" by (transfer, simp) lemma scene_override_commute: "S\<^sub>2 \\<^sub>S S\<^sub>1 on (- X) = S\<^sub>1 \\<^sub>S S\<^sub>2 on X" by (transfer, simp) lemma scene_union_incompat: "\ X ##\<^sub>S Y \ X \\<^sub>S Y = \\<^sub>S" by (transfer, auto) lemma scene_override_union: "X ##\<^sub>S Y \ S\<^sub>1 \\<^sub>S S\<^sub>2 on (X \\<^sub>S Y) = (S\<^sub>1 \\<^sub>S S\<^sub>2 on X) \\<^sub>S S\<^sub>2 on Y" by (transfer, auto) lemma scene_union_unit: "X \\<^sub>S \\<^sub>S = X" by (transfer, simp) +lemma idem_scene_union [simp]: "\ idem_scene A; idem_scene B \ \ idem_scene (A \\<^sub>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 \\<^sub>S \\<^sub>S = \\<^sub>S" by (transfer, simp) lemma scene_union_pres_compat: "\ A ##\<^sub>S B; A ##\<^sub>S C \ \ A ##\<^sub>S (B \\<^sub>S C)" by (transfer, auto) lemma scene_indep_self_compl: "A \\<^sub>S -A" by (transfer, simp) +lemma scene_compat_self_compl: "A ##\<^sub>S -A" + by (transfer, simp) + lemma scene_union_assoc: assumes "X ##\<^sub>S Y" "X ##\<^sub>S Z" "Y ##\<^sub>S Z" shows "X \\<^sub>S (Y \\<^sub>S Z) = (X \\<^sub>S Y) \\<^sub>S Z" using assms by (transfer, auto) lemma scene_inter_indep: assumes "idem_scene X" "idem_scene Y" "X \\<^sub>S Y" shows "X \\<^sub>S Y = \\<^sub>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 \\<^sub>S X = X" by (transfer, simp) lemma scene_union_compl: "idem_scene X \ X \\<^sub>S - X = \\<^sub>S" by (transfer, auto) lemma scene_inter_idem: "X \\<^sub>S X = X" by (simp add: inf_scene_def, transfer, auto) lemma scene_union_commute: "X \\<^sub>S Y = Y \\<^sub>S X" by (transfer, auto) lemma scene_inter_compl: "idem_scene X \ X \\<^sub>S - X = \\<^sub>S" by (simp add: inf_scene_def, transfer, auto) lemma scene_demorgan1: "-(X \\<^sub>S Y) = -X \\<^sub>S -Y" by (simp add: inf_scene_def, transfer, auto) lemma scene_demorgan2: "-(X \\<^sub>S Y) = -X \\<^sub>S -Y" by (simp add: inf_scene_def, transfer, auto) lemma scene_compat_top: "idem_scene X \ X ##\<^sub>S \\<^sub>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\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \\<^sub>S s\<^sub>2 on Y \\<^sub>S s\<^sub>3 on X = s\<^sub>1 \\<^sub>S (s\<^sub>2 \\<^sub>S s\<^sub>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 "\\<^sub>S" 55) where "subscene X Y \ X \ Y" lemma subscene_refl: "X \\<^sub>S X" by (simp add: less_eq_scene_def) lemma subscene_trans: "\ idem_scene Y; X \\<^sub>S Y; Y \\<^sub>S Z \ \ X \\<^sub>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 \\<^sub>S Y; Y \\<^sub>S X \ \ X = Y" apply (simp add: less_eq_scene_def, transfer, auto) apply (rule ext) apply (rule ext) apply (metis (full_types) idem_overrider.ovr_idem overrider.ovr_overshadow_left) done +lemma subscene_copy_def: + assumes "idem_scene X" "idem_scene Y" + shows "X \\<^sub>S Y = (\ s\<^sub>1 s\<^sub>2. cp\<^bsub>X\<^esub> s\<^sub>1 \ cp\<^bsub>Y\<^esub> s\<^sub>2 = cp\<^bsub>Y\<^esub> (cp\<^bsub>X\<^esub> s\<^sub>1 s\<^sub>2))" + using assms + by (simp add: less_eq_scene_def fun_eq_iff, transfer, auto) + lemma subscene_eliminate: "\ idem_scene Y; X \ Y \ \ s\<^sub>1 \\<^sub>S s\<^sub>2 on X \\<^sub>S s\<^sub>3 on Y = s\<^sub>1 \\<^sub>S s\<^sub>3 on Y" by (metis less_eq_scene_def scene_override_overshadow_left scene_override_idem) lemma scene_bot_least: "\\<^sub>S \ X" unfolding less_eq_scene_def by (transfer, auto) lemma scene_top_greatest: "X \ \\<^sub>S" unfolding less_eq_scene_def by (transfer, auto) lemma scene_union_ub: "\ idem_scene Y; X \\<^sub>S Y \ \ X \ (X \\<^sub>S Y)" by (simp add: less_eq_scene_def, transfer, auto) (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_overshadow_right) lemma scene_le_then_compat: "\ idem_scene X; idem_scene Y; X \ Y \ \ X ##\<^sub>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 \\<^sub>S B \ A \ -B" unfolding less_eq_scene_def by (transfer, simp) +lift_definition scene_comp :: "'a scene \ ('a \ 'b) \ 'b scene" (infixl ";\<^sub>S" 80) +is "\ S X a b. if (vwb_lens X) then put\<^bsub>X\<^esub> a (S (get\<^bsub>X\<^esub> a) (get\<^bsub>X\<^esub> b)) else a" + by (unfold_locales, auto) + +lemma scene_comp_idem [simp]: "idem_scene S \ idem_scene (S ;\<^sub>S X)" + by (transfer, unfold_locales, simp_all) + +lemma scene_comp_lens_indep [simp]: "X \ Y \ (A ;\<^sub>S X) \\<^sub>S (A ;\<^sub>S Y)" + by (transfer, auto simp add: lens_indep.lens_put_comm lens_indep.lens_put_irr2) + +lemma scene_comp_indep [simp]: "A \\<^sub>S B \ (A ;\<^sub>S X) \\<^sub>S (B ;\<^sub>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" ("\_\\<^sub>\") is "\ X s\<^sub>1 s\<^sub>2. if (mwb_lens X) then s\<^sub>1 \\<^sub>L s\<^sub>2 on X else s\<^sub>1" by (unfold_locales, auto simp add: lens_override_def) lemma vwb_impl_idem_scene [simp]: "vwb_lens X \ idem_scene \X\\<^sub>\" by (transfer, unfold_locales, auto simp add: lens_override_overshadow_left lens_override_overshadow_right) lemma idem_scene_impl_vwb: "\ mwb_lens X; idem_scene \X\\<^sub>\ \ \ vwb_lens X" apply (cases "mwb_lens X") apply (transfer, unfold idem_overrider_def overrider_def, auto) apply (simp add: idem_overrider_axioms_def override_idem_implies_vwb) done lemma lens_compat_scene: "\ mwb_lens X; mwb_lens Y \ \ X ##\<^sub>L Y \ \X\\<^sub>\ ##\<^sub>S \Y\\<^sub>\" 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\<^sub>L\\<^sub>\ = \\<^sub>S" by (transfer, simp) lemma one_lens_scene: "\1\<^sub>L\\<^sub>\ = \\<^sub>S" by (transfer, simp) lemma lens_scene_override: "mwb_lens X \ s\<^sub>1 \\<^sub>S s\<^sub>2 on \X\\<^sub>\ = s\<^sub>1 \\<^sub>L s\<^sub>2 on X" by (transfer, simp) lemma lens_indep_scene: assumes "vwb_lens X" "vwb_lens Y" shows "(X \ Y) \ \X\\<^sub>\ \\<^sub>S \Y\\<^sub>\" using assms by (auto, (simp add: scene_indep_override, transfer, simp add: lens_indep_override_def)+) lemma lens_indep_impl_scene_indep [simp]: "(X \ Y) \ \X\\<^sub>\ \\<^sub>S \Y\\<^sub>\" by (transfer, auto simp add: lens_indep_comm lens_override_def) lemma lens_plus_scene: "\ vwb_lens X; vwb_lens Y; X \ Y \ \ \X +\<^sub>L Y\\<^sub>\ = \X\\<^sub>\ \\<^sub>S \Y\\<^sub>\" 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\\<^sub>\ \ \Y\\<^sub>\ \ X \\<^sub>L' Y" by (simp add: lens_defs less_eq_scene_def, transfer, simp add: lens_override_def) lemma sublens'_implies_subscene: "\ vwb_lens X; vwb_lens Y; X \\<^sub>L' Y \ \ \X\\<^sub>\ \ \Y\\<^sub>\" by (simp add: lens_defs less_eq_scene_def, auto simp add: lens_override_def lens_scene_override) lemma sublens_iff_subscene: assumes "vwb_lens X" "vwb_lens Y" shows "X \\<^sub>L Y \ \X\\<^sub>\ \ \Y\\<^sub>\" 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 \\<^sub>L Y \ \X\\<^sub>\ = \Y\\<^sub>\" proof assume a: "X \\<^sub>L Y" show "\X\\<^sub>\ = \Y\\<^sub>\" by (meson a assms lens_equiv_def sublens_iff_subscene subscene_antisym vwb_impl_idem_scene) next assume b: "\X\\<^sub>\ = \Y\\<^sub>\" show "X \\<^sub>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\<^sub>S") where +"lens_insert x A = (if (\x\\<^sub>\ \ A) then \x\\<^sub>\ \\<^sub>S A else A)" + +lemma lens_insert_idem: "insert\<^sub>S x (insert\<^sub>S x A) = insert\<^sub>S x A" + apply (auto simp add: lens_insert_def less_eq_scene_def) + apply (transfer) + apply (auto simp add: lens_override_overshadow_left) + apply (metis lens_override_overshadow_left) + done + text \ Membership operations. These have slightly hacky definitions at the moment in order to cater for @{term mwb_lens}. See if they can be generalised? \ definition lens_member :: "('a \ 'b) \ 'b scene \ bool" (infix "\\<^sub>S" 50) where [lens_defs]: "lens_member x A = ((\ s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \\<^sub>S s\<^sub>2 on A \\<^sub>L s\<^sub>3 on x = s\<^sub>1 \\<^sub>S (s\<^sub>2 \\<^sub>L s\<^sub>3 on x) on A) \ (\ b b'. get\<^bsub>x\<^esub> (b \\<^sub>S b' on A) = get\<^bsub>x\<^esub> b'))" +lemma lens_member_override: "x \\<^sub>S A \ s\<^sub>1 \\<^sub>S s\<^sub>2 on A \\<^sub>L s\<^sub>3 on x = s\<^sub>1 \\<^sub>S (s\<^sub>2 \\<^sub>L s\<^sub>3 on x) on A" + using lens_member_def by force + +lemma lens_member_put: + assumes "vwb_lens x" "idem_scene a" "x \\<^sub>S a" + shows "put\<^bsub>x\<^esub> s v \\<^sub>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 \\<^sub>S \\<^sub>S" by (auto simp add: lens_member_def) abbreviation lens_not_member :: "('a \ 'b) \ 'b scene \ bool" (infix "\\<^sub>S" 50) where "x \\<^sub>S A \ (x \\<^sub>S - A)" lemma lens_member_get_override [simp]: "x \\<^sub>S a \ get\<^bsub>x\<^esub> (b \\<^sub>S b' on a) = get\<^bsub>x\<^esub> b'" by (simp add: lens_member_def) lemma lens_not_member_get_override [simp]: "x \\<^sub>S a \ get\<^bsub>x\<^esub> (b \\<^sub>S b' on a) = get\<^bsub>x\<^esub> b" by (simp add: lens_member_def scene_override_commute) subsection \ Function Domain Scene \ -lift_definition fun_dom_scene :: "'a set \ ('a \ 'b) scene" ("fds") is +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({}) = \\<^sub>S" by (transfer, simp) lemma fun_dom_scene_union: "fds(A \ B) = fds(A) \\<^sub>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) \\<^sub>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) = \\<^sub>S" by (transfer, auto simp add: fun_eq_iff override_on_def) +lemma fun_dom_scene_indep [simp]: + "fds(A) \\<^sub>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) ##\<^sub>S fds(B)" by (transfer, simp add: override_on_def fun_eq_iff) +lemma fun_dom_scene_le [simp]: "fds(A) \\<^sub>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 \ No newline at end of file diff --git a/thys/Optics/Two.thy b/thys/Optics/Two.thy --- a/thys/Optics/Two.thy +++ b/thys/Optics/Two.thy @@ -1,50 +1,50 @@ -section \Types of Cardinality 2 or Greater\ +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 +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.\ + 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