theory regexp_RecNil
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (s :: A list) . ~ (recognise Nil2 s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Init_ODE_Solver
imports
  Concrete_Reachability_Analysis_C1
  Refine_Reachability_Analysis_C1
  Refine_Rigorous_Numerics_Aform
begin

subsection \<open>``Final'' Theorems, stated outside of refinement framework.\<close>

lemma br_Times_Univ: "br a I \<times>\<^sub>r (UNIV::(_ \<times> unit) set) = br (\<lambda>(x, _). (a x, ())) (\<lambda>(x, _). I x)"
  by (auto simp: br_def)

lemma TRANSFER_refl: "TRANSFER (x \<le> (x::_nres))" by (auto simp: )
lemma init_ode_ops: "(y \<Longrightarrow> x) \<Longrightarrow> (init_ode_ops x y odo, odo) \<in> ode_ops_rel"
  by (auto simp: ode_ops_rel_def init_ode_ops_def)

context approximate_sets begin

context includes autoref_syntax begin

theorem solves_poincare_map_ncc:
  fixes sctni pos ivli ssc XS ph rl ru dRi CXS X0 S trap
  defines "P \<equiv> set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)"
  defines "Sa \<equiv> below_halfspace (map_sctn eucl_of_list S)::'n::enum rvec set"
  defines "X0 \<equiv> c1_info_of_apprse XS"
  defines "X1 \<equiv> flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi)"
  assumes ncc: "ncc_precond TYPE('n rvec)" "ncc_precond TYPE('n vec1)"
  assumes ret: "solves_poincare_map odo symstart [S] guards ivli sctni roi XS (rl, ru) dRi"
  assumes symstart: "(symstart, symstarta::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres) \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>dres_nres_rel"
  assumes symstart_spec: "\<And>X0. X0 \<subseteq> Csafe odo \<times> UNIV \<Longrightarrow> symstarta X0 \<le> SPEC (\<lambda>(CX, X). flowsto odo (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
  assumes trapprop: "stable_on odo (Csafe odo - P) trap"
  assumes invar: "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X"
  assumes lens: "length (ode_e odo) = CARD('n)" "length (normal sctni) = CARD('n)" "length (fst ivli) = CARD('n)" "length (snd ivli) = CARD('n)"
    "length (normal S) = CARD('n)" "length rl = CARD('n)" "length ru = CARD('n)"
     "lvivl'_invar (CARD('n)*CARD('n)) dRi"
    "\<And>a xs b ba ro. (xs, ro) \<in> set guards \<Longrightarrow> ((a, b), ba) \<in> set xs \<Longrightarrow> length a = CARD('n) \<and> length b = CARD('n) \<and> length (normal ba) = CARD('n)"
  shows "poincare_mapsto odo P (X0 - trap \<times> UNIV) Sa (Csafe odo - P) X1"
proof -
  define guardsa::"('n rvec set \<times> unit) list"  where "guardsa \<equiv> map (\<lambda>(x, y). (\<Union>x\<in>set x. case x of (x, y) \<Rightarrow> (case x of (x, y) \<Rightarrow> set_of_ivl (eucl_of_list x, eucl_of_list y)) \<inter> plane_of (map_sctn eucl_of_list y), ())) guards"
  define roa where "roa = ()"
  have spm:
    "(XS, X0) \<in> clw_rel (appr1e_rel)"
    "([S], Sa) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
    "(guards, guardsa) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r reach_optns_rel\<rangle>list_rel"
    "(ivli, set_of_lvivl ivli::'n rvec set) \<in> lvivl_rel"
    "(sctni, map_sctn eucl_of_list sctni::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
    "(roi, roa) \<in> reach_optns_rel"
    "(\<lambda>x. nres_of (symstart x), symstarta) \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
    "((), trap) \<in> ghost_rel"
    using lens symstart[THEN dres_nres_rel_nres_relD]
    by (auto simp: X0_def X1_def Sa_def P_def appr_rel_br set_rel_br
        br_chain o_def clw_rel_br  lv_rel_def sctn_rel_br ivl_rel_br set_of_lvivl_def
        halfspaces_rel_def list_set_rel_brp below_halfspaces_def ghost_relI
        br_rel_prod br_list_rel guardsa_def Id_br inter_rel_br plane_rel_br
        roa_def br_Times_Univ reach_options_rel_def
        split: sctn.splits
        intro!: brI list_allI clw_rel_appr1e_relI assms)

  have ivls: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> lvivl_rel"
    "(dRi, set_of_lvivl' dRi::(('n rvec), 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
    by (auto intro!: lvivl_relI lvivl_default_relI lens simp: lens set_of_lvivl_def set_of_ivl_def
        split: option.splits)

  from lens(1) have wd: "wd odo TYPE('n rvec)" by (auto simp: wd_def)
  from lens(1) have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
    by (auto simp: D_def)
  have pmspec: "poincare_onto_from_in_ivl $ odo $ symstarta $ trap $ S $ guards $ ivl $ sctn $ ro $ XS0 $ IVL $ dIVL
  \<le> SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto odo (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe odo - ivl \<inter> plane_of sctn)
                      (flow1_of_vec1 ` (IVL \<times> dIVL)))"
    if trapprop: "stable_on odo (Csafe odo - ivl \<inter> plane_of sctn) trap"
    for ivl sctn XS0 S guards ro IVL dIVL
    using poincare_onto_from_in_ivl[OF wd symstart_spec trapprop order_refl,
        of S guards ro XS0 IVL dIVL]
    by auto

  have odo_init: "(init_ode_ops True (carries_c1 (hd XS)) odo, odo) \<in> ode_ops_rel"
    by (auto simp: intro!: init_ode_ops)
  from nres_rel_trans2[OF
      pmspec
      poincare_onto_from_in_ivl_impl.refine[OF DIM_precond ncc odo_init spm(1-7) TRANSFER_refl spm(8) ivls]
      ] ret trapprop
  show ?thesis
    by (auto simp: solves_poincare_map_def nres_rel_def P_def X1_def)
qed

lemma solves_poincare_map'_ncc:
  "ncc_precond TYPE('n::enum rvec) \<Longrightarrow>
  ncc_precond TYPE('n vec1) \<Longrightarrow>
  solves_poincare_map' odo S guards ivli sctni roi XS (rl, ru) dRi \<Longrightarrow>
  (\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X) \<Longrightarrow>
  length (ode_e odo) = CARD('n) \<Longrightarrow>
  length (normal sctni) = CARD('n) \<Longrightarrow>
  length (fst ivli) = CARD('n) \<Longrightarrow>
  length (snd ivli) = CARD('n) \<Longrightarrow>
  length (normal S) = CARD('n) \<Longrightarrow>
  length (rl) = CARD('n) \<Longrightarrow>
  length (ru) = CARD('n) \<Longrightarrow>
  lvivl'_invar (CARD('n)*CARD('n)) dRi \<Longrightarrow>
  (\<And>a xs b ba ro.
      (xs, ro) \<in> set guards \<Longrightarrow>
      ((a, b), ba) \<in> set xs \<Longrightarrow>
      length a = CARD('n) \<and>
      length b = CARD('n) \<and> length (normal ba) = CARD('n)) \<Longrightarrow>
  poincare_mapsto odo
   (set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)::'n rvec set)
   (c1_info_of_apprse XS) (below_halfspace (map_sctn eucl_of_list S))
   (Csafe odo - set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni))
   (flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi))"
  by (rule solves_poincare_map_ncc[OF _ _ _
        empty_symstart_dres_nres_rel[unfolded empty_symstart_def op_empty_coll_def mk_coll_def]
         empty_symstart_flowsto,
    folded solves_poincare_map'_def, simplified])
    auto

lemma one_step_until_time_ivl_in_ivl_spec[le, refine_vcg]:
  "one_step_until_time_ivl_in_ivl odo (X0::'n::enum eucl1 set) t1 t2 R dR \<le> SPEC (\<lambda>b. b \<longrightarrow>
    (\<forall>(x0, d0) \<in> X0. {t1 .. t2} \<subseteq> existence_ivl0 odo x0 \<and>
      (\<forall>t \<in> {t1 .. t2}. (flow0 odo x0 t, Dflow odo x0 t o\<^sub>L d0) \<in> flow1_of_vec1 ` (R \<times> dR))))"
  if [simp]: "length (ode_e odo) = CARD('n::enum)"
proof -
  have wd[refine_vcg]: "wd odo TYPE((real, 'n) vec)" by (simp add: wd_def)
  show ?thesis
    unfolding one_step_until_time_ivl_in_ivl_def
    apply (refine_vcg, clarsimp_all)
    subgoal for X CX Y CY CY' x0 d0
        apply (drule bspec, assumption, clarsimp)
      subgoal for t
          apply (drule bspec[where x=t], force)
        by (simp add: subset_iff )
      done
    done
qed

theorem one_step_in_ivl_ncc:
  "t \<in> existence_ivl0 odo x0 \<and> (flow0 odo x0 t::'n rvec) \<in> R \<and> Dflow odo x0 t o\<^sub>L d0 \<in> dR"
  if ncc: "ncc_precond TYPE('n::enum rvec)" "ncc_precond TYPE('n vec1)"
   and t: "t \<in> {t0 .. t1}"
   and x0: "(x0, d0) \<in> c1_info_of_appre X"
   and invar: "c1_info_invare CARD('n) X"
   and R: "{eucl_of_list rl .. eucl_of_list ru} \<subseteq> R"
   and lens: "length rl = CARD('n)" "length ru = CARD('n)"
   and dRinvar: "lvivl'_invar (CARD('n)*CARD('n)) dRi"
   and dR: "blinfun_of_vmatrix ` set_of_lvivl' dRi \<subseteq> dR"
   and len_ode: "length (ode_e odo) = CARD('n)"
   and chk: "one_step_until_time_ivl_in_ivl_check odo X t0 t1 (rl, ru) dRi"
proof -
  have ivl: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> \<langle>lv_rel\<rangle>ivl_rel"
    apply (rule lv_relivl_relI)
    using lens
    by auto
  from dRinvar have "lvivl'_invar DIM(((real, 'n) vec, 'n) vec) dRi" by simp
  note dRi = lvivl_default_relI[OF this]
  from len_ode have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
    by (auto simp: D_def)
  have odo: "(init_ode_ops True (carries_c1 X) odo, odo) \<in> ode_ops_rel"
    by (auto intro!: init_ode_ops)
  from one_step_until_time_ivl_in_ivl_impl_refine[param_fo, OF DIM_precond ncc odo appr1e_relI[OF invar] IdI IdI ivl dRi, of t0 t1]
  have "nres_of (one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 (rl, ru) dRi)
    \<le> one_step_until_time_ivl_in_ivl odo (c1_info_of_appre X) t0 t1 {eucl_of_list rl::'n rvec..eucl_of_list ru} (set_of_lvivl' dRi)"
    by (auto simp: nres_rel_def)
  also note one_step_until_time_ivl_in_ivl_spec[OF len_ode order_refl]
  also have "one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 (rl, ru) dRi = dRETURN True"
    unfolding one_step_until_time_ivl_in_ivl_check_def[symmetric]
    using chk .
  finally show ?thesis
    using t R dR
    by (auto dest!: bspec[OF _ x0] bspec[where x=t] simp: vec1_of_flow1_def)
qed

subsection \<open>Poincare onto (from the outside)\<close>

theorem solves_poincare_map_onto_ncc:
  fixes sctni pos ivli ssc XS ph rl ru dRi CXS X0
  defines "P \<equiv> set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)"
  defines "X0 \<equiv> c1_info_of_apprse XS"
  defines "X1 \<equiv> flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi)"
  assumes ncc: "ncc_precond TYPE('n::enum rvec)" "ncc_precond TYPE('n vec1)"
  assumes ret: "solves_poincare_map_onto odo guards ivli sctni roi XS (rl, ru) dRi"
  assumes invar: "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X"
  assumes lens: "length (ode_e odo) = CARD('n)" "length (normal sctni) = CARD('n)" "length (fst ivli) = CARD('n)" "length (snd ivli) = CARD('n)"
    "length rl = CARD('n)" "length ru = CARD('n)"
     "lvivl'_invar (CARD('n)*CARD('n)) dRi"
    "\<And>a xs b ba ro. (xs, ro) \<in> set guards \<Longrightarrow> ((a, b), ba) \<in> set xs \<Longrightarrow> length a = CARD('n) \<and> length b = CARD('n) \<and> length (normal ba) = CARD('n)"
  shows "poincare_maps_onto odo P (X0::('n rvec \<times> _)set) X1"
proof -
  define guardsa::"('n rvec set \<times> unit) list"  where "guardsa \<equiv> map (\<lambda>(x, y). (\<Union>x\<in>set x. case x of (x, y) \<Rightarrow> (case x of (x, y) \<Rightarrow> set_of_ivl (eucl_of_list x, eucl_of_list y)) \<inter> plane_of (map_sctn eucl_of_list y), ())) guards"
  define roa where "roa = ()"
  have spm:
    "(XS, X0) \<in> clw_rel (appr1e_rel)"
    "(guards, guardsa) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r reach_optns_rel\<rangle>list_rel"
    "(ivli, set_of_lvivl ivli::'n rvec set) \<in> lvivl_rel"
    "(sctni, map_sctn eucl_of_list sctni::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
    "(roi, roa) \<in> reach_optns_rel"
    using lens
    by (auto simp: X0_def X1_def P_def appr_rel_br set_rel_br
        br_chain o_def clw_rel_br  lv_rel_def sctn_rel_br ivl_rel_br set_of_lvivl_def
        halfspaces_rel_def list_set_rel_brp below_halfspaces_def ghost_relI
        br_rel_prod br_list_rel guardsa_def Id_br inter_rel_br plane_rel_br
        reach_options_rel_def br_Times_Univ
        split: sctn.splits
        intro!: brI list_allI clw_rel_appr1e_relI assms)

  have ivls: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> lvivl_rel"
    "(dRi, set_of_lvivl' dRi::(('n rvec), 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
    by (auto intro!: lvivl_relI lvivl_default_relI lens simp: lens set_of_lvivl_def set_of_ivl_def
        split: option.splits)

  have pmspec: "poincare_onto_in_ivl odo guards ivl sctn ro XS0 IVL dIVL
  \<le> SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto odo (ivl \<inter> plane_of sctn) (XS0) UNIV (Csafe odo - ivl \<inter> plane_of sctn)
                      (flow1_of_vec1 ` (IVL \<times> dIVL)))"
    for ivl::"'n rvec set" and sctn XS0 guards ro IVL dIVL
    using poincare_onto_in_ivl[OF lens(1) order_refl, of guards ivl sctn ro XS0 IVL dIVL]
    by auto
  from lens(1) have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
    by (auto simp: D_def)
  have odo: "(init_ode_ops True (carries_c1 (hd XS)) odo, odo) \<in> ode_ops_rel"
    by (auto intro!: init_ode_ops)
  from nres_rel_trans2[OF
      pmspec
      poincare_onto_in_ivl_impl.refine[OF DIM_precond ncc odo spm(1-5) ivls]
      ] ret
  show ?thesis
    by (auto simp: poincare_maps_onto_def solves_poincare_map_onto_def nres_rel_def P_def X1_def)
qed

end
end

subsection \<open>Executable definitions for ODE solver based on affine arithmetic\<close>

global_interpretation aform: approximate_sets aform_ops Joints aforms_rel optns for optns
  defines solves_poincare_map_aform = aform.solves_poincare_map
    and solves_poincare_map_aform' = aform.solves_poincare_map'
    and solves_poincare_map_onto_aform = aform.solves_poincare_map_onto
    and solves_one_step_until_time_aform = aform.one_step_until_time_ivl_in_ivl_check
    and solve_poincare_map_aform = aform.poincare_onto_from_impl
    and one_step_until_time_ivl_in_ivl_impl_aform = aform.one_step_until_time_ivl_in_ivl_impl
    and poincare_onto_from_in_ivl_impl_aform = aform.poincare_onto_from_in_ivl_impl
    and poincare_onto_in_ivl_impl_aform = aform.poincare_onto_in_ivl_impl
    and solve_poincare_onto_aform = aform.poincare_onto_impl
    and solve_one_step_until_time_aform = aform.one_step_until_time_ivl
    and one_step_until_time_impl_aform = aform.one_step_until_time_impl
    and op_image_fst_coll_nres_impl_aform = aform.op_image_fst_coll_nres_impl
    and poincare_onto_series_impl_aform = aform.poincare_onto_series_impl
    and poincare_start_on_impl_aform = aform.poincare_start_on_impl
    and leaves_halfspace_impl_aform = aform.leaves_halfspace_impl
    and approximate_sets_aform = aform.subset_spec_ivl_collc
    and subset_spec_plane_impl_aform = aform.subset_spec_plane_impl
    and disjoints_spec_impl_aform = aform.disjoints_spec_impl
    and partition_set_impl_aform = aform.partition_set_impl
    and fst_safe_coll_impl_aform = aform.fst_safe_coll_impl
    and choose_step1_impl_aform = aform.choose_step1_impl
    and ivl_rep_of_set_coll_impl_aform = aform.ivl_rep_of_set_coll_impl
    and ode_set_impl_aform = aform.ode_set_impl
    and mk_safe_impl_aform = aform.mk_safe_impl
    and subset_spec_ivlc_aform = aform.subset_spec_ivlc
    and sbelow_sctn_impl_aform = aform.sbelow_sctn_impl
    and below_sctn_impl_aform = aform.below_sctn_impl
    and split_under_threshold_impl_aform = aform.split_under_threshold_impl
    and do_intersection_coll_impl_aform = aform.do_intersection_coll_impl
    and partition_ivl_impl_aform = aform.partition_ivl_impl
    and mk_safe_coll_impl_aform = aform.mk_safe_coll_impl
    and choose_step_impl_aform = aform.choose_step_impl
    and reach_cont_impl_aform = aform.reach_cont_impl
    and vec1reps_impl_aform = aform.vec1reps_impl
    and ivl_rep_of_sets_impl_aform = aform.ivl_rep_of_sets_impl
    and ivl_rep_of_set_impl_aform = aform.ivl_rep_of_set_impl
    and ivls_of_sets_impl_aform = aform.ivls_of_sets_impl
    and tolerate_error_impl_aform = aform.tolerate_error_impl
    and tolerate_error1_impl_aform = aform.tolerate_error1_impl
    and pre_intersection_step_impl_aform = aform.pre_intersection_step_impl
    and split_spec_param1_impl_aform = aform.split_spec_param1_impl
    and do_intersection_impl_aform = aform.do_intersection_impl
    and resolve_step_impl_aform = aform.resolve_step_impl
    and euler_step_impl_aform = aform.euler_step_impl
    and rk2_step_impl_aform = aform.rk2_step_impl
    and op_eventually_within_sctn_impl_aform = aform.op_eventually_within_sctn_impl
    and solve_poincare_plane_impl_aform = aform.solve_poincare_plane_impl
    and cert_stepsize_impl_dres_aform = aform.cert_stepsize_impl_dres
    and step_adapt_time_impl_aform = aform.step_adapt_time_impl
    and inter_sctn1_impl_aform = aform.inter_sctn1_impl
    and step_split_impl_aform = aform.step_split_impl
    and intersects_impl_aform = aform.intersects_impl
    and above_sctn_impl_aform = aform.above_sctn_impl
    and nonzero_component_impl_aform = aform.nonzero_component_impl
    and P_iter_impl_aform = aform.P_iter_impl
    and partition_sets_impl_aform = aform.partition_sets_impl
    and reach_conts_impl_aform = aform.reach_conts_impl
    and subsets_iplane_coll_impl_aform = aform.subsets_iplane_coll_impl
    and reach_cont_symstart_impl_aform = aform.reach_cont_symstart_impl
    and subset_iplane_coll_impl_aform = aform.subset_iplane_coll_impl
    and symstart_coll_impl_aform = aform.symstart_coll_impl
    and subset_spec_ivls_clw_impl_aform = aform.subset_spec_ivls_clw_impl
    and poincare_onto2_impl_aform = aform.poincare_onto2_impl
    and poincare_onto_empty_impl_aform = aform.poincare_onto_empty_impl
    and resolve_ivlplanes_impl_aform = aform.resolve_ivlplanes_impl
    and empty_remainders_impl_aform = aform.empty_remainders_impl
    and adapt_stepsize_fa_aform = aform.adapt_stepsize_fa
    and split_spec_param1e_impl_aform = aform.split_spec_param1e_impl
    and setse_of_ivlse_impl_aform = aform.setse_of_ivlse_impl
    and ivlse_of_setse_impl_aform = aform.ivlse_of_setse_impl
    and choose_step1e_impl_aform = aform.choose_step1e_impl
    and vec1repse_impl_aform = aform.vec1repse_impl
    and scaleR2_rep1_impl_aform = aform.scaleR2_rep1_impl
    and list_of_appr1e_aform = aform.list_of_appr1e
    and list_of_appr1_aform = aform.list_of_appr1
    and nonzero_component_within_impl_aform = aform.nonzero_component_within_impl
    and approx_fas_impl_aform = aform.approx_slp_appr_impl
    and mig_set_impl_aform = aform.mig_set_impl
    and op_eucl_of_list_image_pad_aform = aform.op_eucl_of_list_image_pad
    and reach_cont_par_impl_aform = aform.reach_cont_par_impl
    and do_intersection_core_impl_aform = aform.do_intersection_core_impl
    and reduce_spec1e_impl_aform = aform.reduce_spec1e_impl
    and reduce_spec1_impl_aform = aform.reduce_spec1_impl
    and one_step_until_time_ivl_impl_aform = aform.one_step_until_time_ivl_impl
    and subset_spec1_collc_aform = aform.subset_spec1_collc
    and ivl_of_appr1_coll_impl_aform = aform.ivl_of_appr1_coll_impl
    and do_intersection_body_impl_aform = aform.do_intersection_body_impl
    and ode_slp_impl_aform = aform.ode_slp_impl
    and print_msg_impl_aform = aform.print_msg_impl
    and ode_e_impl_aform = aform.ode_e_impl
    and safe_form_impl_aform = aform.safe_form_impl
    and D_impl_aform = aform.D_impl
    and safe_set_appr_aform = aform.safe_set_appr
    and var_ode_ops_impl = aform.var_ode_ops_impl
    and start_stepsize_impl_aform = aform.start_stepsize_impl
    and poincare_slp_impl_aform = aform.poincare_slp_impl
    and rk2_param_impl_aform = aform.rk2_param_impl

  unfolding aform_approximate_sets_def[symmetric]
  by (rule aform_approximate_sets)

lemma aform_ncc[autoref_rules_raw]: "aform.ncc_precond TYPE('a::executable_euclidean_space)"
  using aform.appr_rel_nonempty
  by (auto simp: aform.ncc_precond_def aform.ncc_def aform.appr_rel_br br_def compact_Affine
    convex_Affine
      eucl_of_list_image_Joints)

fun parts::"nat\<Rightarrow>'a list\<Rightarrow>'a list list"
  where
    "parts n [] = []"
| "parts 0 xs = [xs]"
| "parts n xs = take n xs # parts n (drop n xs)"

lemma Joints_in_lv_rel_set_relD:
  "(Joints xs, X) \<in> \<langle>lv_rel\<rangle>set_rel \<Longrightarrow> X = Affine (eucl_of_list_aform xs)"
  apply (auto simp: )
   apply (subst eucl_of_list_image_Joints[symmetric])
  unfolding lv_rel_def set_rel_br
    apply (auto simp: br_def )
  using aform.length_set_of_appr apply auto[1]
  apply (subst (asm) eucl_of_list_image_Joints[symmetric])
  unfolding lv_rel_def set_rel_br
   apply (auto simp: br_def )
  using aform.length_set_of_appr apply auto[1]
  done

lemma ncc_precond: "aform.ncc_precond TYPE('a::executable_euclidean_space)"
  apply (auto simp: aform.ncc_precond_def aform.ncc_def aform.appr_rel_def)
  apply (auto simp: aforms_rel_def br_def)
  subgoal by (auto simp: compact_Affine dest!: Joints_in_lv_rel_set_relD)
  subgoal by (auto simp: convex_Affine dest!: Joints_in_lv_rel_set_relD)
  done

lemma fst_eucl_of_list_aform_map: "fst (eucl_of_list_aform (map (\<lambda>x. (fst x, asdf x)) x)) =
  fst (eucl_of_list_aform x)"
  by (auto simp: eucl_of_list_aform_def o_def)

lemma
  Affine_pdevs_of_list:\<comment> \<open>TODO: move!\<close>
  "Affine (fst x, pdevs_of_list (map snd (list_of_pdevs (snd x)))) = Affine x"
  by (auto simp: Affine_def valuate_def aform_val_def
      elim: pdevs_val_of_list_of_pdevs2[where X = "snd x"]
        pdevs_val_of_list_of_pdevs[where X = "snd x"])

lemmas one_step_in_ivl = aform.one_step_in_ivl_ncc[OF ncc_precond ncc_precond]
lemmas solves_poincare_map = aform.solves_poincare_map_ncc[OF ncc_precond ncc_precond]
lemmas solves_poincare_map' = aform.solves_poincare_map'_ncc[OF ncc_precond ncc_precond]
lemmas solves_poincare_map_onto = aform.solves_poincare_map_onto_ncc[OF ncc_precond ncc_precond]

end


(*
Copyright 2018

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
(*
  Partially inspired by Simon Foster's lens theory
*)
theory Lenses
  imports Option_Monad
  keywords "define_lenses" :: thy_decl
begin

  section \<open>Lenses\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  (*declare lens.intro_rls[intro]*)

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

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

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

  subsection \<open>Lens Algebra\<close>

  subsubsection \<open>Identity Lens\<close>

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

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

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

  subsubsection \<open>Lens Composition\<close>

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

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

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

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

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

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

  subsubsection \<open>Monoid Laws\<close>

  thm prod.splits

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

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

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

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

  subsubsection \<open>Independence\<close>

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

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

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

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

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

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

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

  end

  declare lens_indep.simps[simp]

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

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

  lemmas lens_indep_comm = lens_indep.comm

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

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

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

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

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

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

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

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

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

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

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

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

  subsection \<open>Lens Instances\<close>

  subsubsection \<open>Function\<close>

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

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

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

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

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

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

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

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

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

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

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

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

  subsubsection \<open>Lists\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    ML \<open>
      structure Datatype_Lens = struct

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        in
          lthy
        end

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

      end
    \<close>

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

  end

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

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

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

  context begin

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

    private define_lenses test
    print_theorems

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

end