(*<*)
theory New_Algorithm_Proofs
imports Three_Step_MRU New_Algorithm_Defs "../HO_Transition_System"
  Heard_Of.Majorities "../Quorums"
begin
(*>*)

subsection \<open>Proofs\<close>
type_synonym p_TS_state = "(nat \<times> (process \<Rightarrow> pstate))"

definition New_Algo_TS ::
  "(round \<Rightarrow> process HO) \<Rightarrow> (round \<Rightarrow> process HO) \<Rightarrow> (round \<Rightarrow> process) \<Rightarrow> p_TS_state TS"
where
  "New_Algo_TS HOs SHOs crds = CHO_to_TS New_Algo_Alg HOs SHOs (K o crds)"

lemmas New_Algo_TS_defs = New_Algo_TS_def CHO_to_TS_def New_Algo_Alg_def CHOinitConfig_def
  NA_initState_def

definition New_Algo_trans_step where
  "New_Algo_trans_step HOs SHOs crds nxt_f snd_f stp \<equiv> \<Union>r \<mu>.
    {((r, cfg), (Suc r, cfg'))|cfg cfg'. three_step r = stp  \<and> (\<forall>p.
      \<mu> p \<in> get_msgs (snd_f r) cfg (HOs r) (SHOs r) p
      \<and> nxt_f r p (cfg p) (\<mu> p) (crds r) (cfg' p)
    )}"

lemma three_step_less_D:
  "0 < three_step r \<Longrightarrow> three_step r = 1 \<or> three_step r = 2"
  by(unfold three_step_def, arith)

lemma New_Algo_trans:
  "CSHO_trans_alt NA_sendMsg NA_nextState HOs SHOs (K \<circ> crds) =
  New_Algo_trans_step HOs SHOs crds next0 send0 0
  \<union> New_Algo_trans_step HOs SHOs crds next1 send1 1
  \<union> New_Algo_trans_step HOs SHOs crds next2 send2 2
  "
proof(rule equalityI)
  show "CSHO_trans_alt NA_sendMsg NA_nextState HOs SHOs (K \<circ> crds)
    \<subseteq> New_Algo_trans_step HOs SHOs crds next0 send0 0 \<union>
       New_Algo_trans_step HOs SHOs crds next1 send1 1 \<union>
       New_Algo_trans_step HOs SHOs crds next2 send2 2"
  by(force simp add: CSHO_trans_alt_def NA_sendMsg_def NA_nextState_def
    New_Algo_trans_step_def K_def dest!: three_step_less_D)
next
  show "New_Algo_trans_step HOs SHOs crds next0 send0 0 \<union>
    New_Algo_trans_step HOs SHOs crds next1 send1 1 \<union>
    New_Algo_trans_step HOs SHOs crds next2 send2 2
    \<subseteq> CSHO_trans_alt NA_sendMsg NA_nextState HOs SHOs (K \<circ> crds)"
  by(force simp add: CSHO_trans_alt_def NA_sendMsg_def NA_nextState_def
    New_Algo_trans_step_def K_def)
qed

type_synonym rHO = "nat \<Rightarrow> process HO"

subsubsection \<open>Refinement\<close>
(******************************************************************************)

definition new_algo_ref_rel :: "(three_step_mru_state \<times> p_TS_state)set" where
  "new_algo_ref_rel = {(sa, (r, sc)).
    opt_mru_state.next_round sa = r
    \<and> opt_mru_state.decisions sa = pstate.decide o sc
    \<and> opt_mru_state.mru_vote sa = pstate.mru_vote o sc
    \<and> (three_step r = Suc 0 \<longrightarrow> three_step_mru_state.candidates sa = ran (prop_vote o sc))
  }"

text \<open>
  Different types seem to be derived for the two \<open>mru_vote_evolution\<close> lemmas,
  so we state them separately.\<close>
lemma mru_vote_evolution0:
  "\<forall>p. next0 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> mru_vote o s' = mru_vote o s"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next2_def Let_def)

lemma mru_vote_evolution2:
  "\<forall>p. next2 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> mru_vote o s' = mru_vote o s"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next2_def Let_def)

lemma decide_evolution:
  "\<forall>p. next0 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> decide o s = decide o s'"
  "\<forall>p. next1 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> decide o s = decide o s'"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next1_def Let_def)

lemma msgs_mru_vote:
  assumes
  "\<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  shows "((msgs_to_lvs (\<mu> p)) |` HOs r p) = (mru_vote o cfg) |` HOs r p" using assms
  by(auto simp add: get_msgs_benign send0_def restrict_map_def msgs_to_lvs_def
      map_comp_def intro!: ext split: option.split)

lemma step0_ref:
  "{new_algo_ref_rel}
    (\<Union>r C. majorities.opt_mru_step0 r C),
    New_Algo_trans_step HOs HOs crds next0 send0 0 {> new_algo_ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs New_Algo_trans_step_def all_conj_distrib)
  fix r sa sc sc' \<mu>
  assume R: "(sa, (r, sc)) \<in> new_algo_ref_rel"
    and r: "three_step r = 0"
    and \<mu>: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) sc (HOs r) (HOs r) p"
        and nxt: "\<forall>p. next0 r p (sc p) (\<mu> p) (crds r) (sc' p)"
  note \<mu>nxt = \<mu> nxt
  have r_phase_step: "nr_steps * three_phase r = r" using r three_phase_step[of r]
    by(auto)
  define C where "C = ran (prop_vote o sc')"
  have guard: "\<forall>cand\<in>C. \<exists>Q. majorities.opt_mru_guard (mru_vote \<circ> sc) Q cand"
  proof(simp add: C_def ran_def, safe)
    fix p cand
    assume Some: "prop_vote (sc' p) = Some cand"

    let ?Q = "HOs r p"
    let ?lvs0 = "mru_vote o sc"

    have "?Q \<in> majs" using Some \<mu>nxt[THEN spec, where x=p]
      by(auto simp add: Let_def majs_def next0_def get_msgs_dom)

    moreover have
      "map_option snd (option_Max_by fst (ran (?lvs |` ?Q))) \<in> {None, Some cand}"
      using Some nxt[THEN spec, where x=p]
      msgs_mru_vote[where HOs=HOs and \<mu>=\<mu>, OF \<mu>[THEN spec, of p]]
      get_msgs_dom[OF \<mu>[THEN spec, of p]]
      by(auto simp add: next0_def Let_def split: option.split_asm)

    ultimately have "majorities.opt_mru_guard ?lvs0 ?Q cand"
      by(auto simp add: majorities.opt_mru_guard_def Let_def majorities.opt_mru_vote_def)
    thus "\<exists>Q. majorities.opt_mru_guard ?lvs0 Q cand"
      by blast
  qed

  define sa' where "sa' = sa\<lparr>
      next_round := Suc r,
      candidates := C
    \<rparr>"
  have "(sa, sa') \<in> majorities.opt_mru_step0 r C" using R r nxt guard
    by(auto simp add: majorities.opt_mru_step0_def sa'_def new_algo_ref_rel_def)
  moreover have "(sa', (Suc r, sc')) \<in> new_algo_ref_rel" using R nxt
    apply(auto simp add: sa'_def new_algo_ref_rel_def intro!:
      mru_vote_evolution0[OF nxt, symmetric] decide_evolution(1)[OF nxt]
    )
       apply(auto simp add: Let_def C_def o_def intro!: ext)
    done
  ultimately show
    "\<exists>sa'. (\<exists>r C. (sa, sa') \<in> majorities.opt_mru_step0 r C)
        \<and> (sa', Suc r, sc') \<in> new_algo_ref_rel"
    by blast
qed

lemma step1_ref:
  "{new_algo_ref_rel}
    (\<Union>r S v. majorities.opt_mru_step1 r S v),
    New_Algo_trans_step HOs HOs crds next1 send1 (Suc 0) {> new_algo_ref_rel}"
proof(clarsimp  simp add: PO_rhoare_defs New_Algo_trans_step_def all_conj_distrib)
  fix r sa sc sc' \<mu>
  assume R: "(sa, (r, sc)) \<in> new_algo_ref_rel"
    and r: "three_step r = Suc 0"
    and \<mu>: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) sc (HOs r) (HOs r) p"
        and nxt: "\<forall>p. next1 r p (sc p) (\<mu> p) (crds r) (sc' p)"
  note \<mu>nxt = \<mu> nxt

  define S where "S = {p. mru_vote (sc' p) \<noteq> mru_vote (sc p)}"

  have S: "S \<subseteq> {p. \<exists>Q v. Q \<subseteq> HOs r p
      \<and> (\<forall>q \<in> Q. prop_vote (sc q) = Some v)
      \<and> Q \<in> majs
      \<and> (mru_vote (sc' p) = Some (three_phase r, v))
    }"
  proof(safe)
    fix p
    assume "p \<in> S"
    then obtain Q v
      where
      "\<forall>q \<in> Q. \<mu> p q = Some (PreVote v)"
      and maj_Q: "Q \<in> majs"
      and Q_HOs: "Q \<subseteq> dom (\<mu> p)"
      and lv: "mru_vote (sc' p) = Some (three_phase r, v)" (is "?LV v")
      using nxt[THEN spec, where x=p]
      by(clarsimp simp add: next1_def Let_def S_def majs_def Q_prevotes_v_def)

    then have
      "\<forall>q \<in> Q. prop_vote (sc q) = Some v" (is "?P Q v")
      "Q \<subseteq> HOs r p"
      using \<mu>[THEN spec, where x=p]
      by(auto simp add: get_msgs_benign send1_def restrict_map_def split: option.split_asm)

    with maj_Q and lv show "\<exists>Q v. Q \<subseteq> HOs r p \<and> ?P Q v \<and> Q \<in> majs \<and> ?LV v" by blast
  qed

  obtain v where
    v: "\<forall>p \<in> S. mru_vote (sc' p) = Some (three_phase r, v) \<and> v \<in> ran (prop_vote o sc)"
  proof(cases "S = {}")
    case False
    assume asm:
      "\<And>v. \<forall>p\<in>S. pstate.mru_vote (sc' p) = Some (three_phase r, v) \<and> v \<in> ran (prop_vote o sc)
        \<Longrightarrow> thesis"
    from False obtain p where "p \<in> S" by auto
    with S nxt
      obtain Q v
      where prop_vote: "(\<forall>q \<in> Q. prop_vote (sc q) = Some v)" and maj_Q: "Q \<in> majs"
      by auto

    hence "\<forall>p\<in>S. pstate.mru_vote (sc' p) = Some (three_phase r, v)" (is "?LV(v)")
      using S
      by(fastforce dest!: subsetD dest: majorities.qintersect)

    with asm prop_vote maj_Q show thesis
      by (metis all_not_in_conv comp_eq_dest_lhs majorities.empty_not_quorum ranI)
  qed(auto)

  define sa' where "sa' = sa\<lparr> next_round := Suc r,
    opt_mru_state.mru_vote := opt_mru_state.mru_vote sa ++ const_map (three_phase r, v) S
  \<rparr>"

  have "(sa, sa') \<in> majorities.opt_mru_step1 r S v" using r R v
    by(clarsimp simp add: majorities.opt_mru_step1_def sa'_def
      new_algo_ref_rel_def ball_conj_distrib)

  moreover have "(sa', (Suc r, sc')) \<in> new_algo_ref_rel" using r R
  proof-
    have "mru_vote o sc' = ((mru_vote \<circ> sc) ++ const_map (three_phase r, v) S)"
    proof(rule ext, simp)
      fix p
      show "mru_vote (sc' p) = ((mru_vote \<circ> sc) ++ const_map (three_phase r, v) S) p"
        using v
        by(auto simp add: S_def map_add_def const_map_is_None const_map_is_Some split: option.split)
    qed
    thus ?thesis using R r nxt
      by(force simp add: new_algo_ref_rel_def sa'_def three_step_Suc intro: decide_evolution)
  qed
  ultimately show
    "\<exists>sa'. (\<exists>r S v. (sa, sa') \<in> majorities.opt_mru_step1 r S v)
        \<and> (sa', Suc r, sc') \<in> new_algo_ref_rel"
    by blast
qed

  define dec_f
    where "dec_f p = (if decide (sc' p) \<noteq> decide (sc p) then decide (sc' p) else None)" for p

  have dec_f: "(decide \<circ> sc) ++ dec_f = decide \<circ> sc'"
  proof
    fix p
    show "((decide \<circ> sc) ++ dec_f) p = (decide \<circ> sc') p" using nxt[THEN spec, of p]
      by(auto simp add: map_add_def dec_f_def next2_def Let_def split: option.split intro!: ext)
  qed

  define sa' where "sa' = sa\<lparr>
    next_round := Suc r,
    decisions := decisions sa ++ dec_f
  \<rparr>"

  have "(sa', (Suc r, sc')) \<in> new_algo_ref_rel" using R r nxt
    by(auto simp add: new_algo_ref_rel_def sa'_def dec_f three_step_Suc
      mru_vote_evolution2[OF nxt])
  moreover have "(sa, sa') \<in> majorities.opt_mru_step2 r dec_f" using r R
  proof-
    define sc_r_votes where "sc_r_votes p = (if (\<exists>v. mru_vote (sc p) = Some (three_phase r, v))
        then map_option snd (mru_vote (sc p))
        else None)" for p
    have sc_r_votes: "sc_r_votes = majorities.r_votes sa r" using R r
      by(auto simp add: new_algo_ref_rel_def sc_r_votes_def majorities.r_votes_def intro!: ext)
    have "majorities.step2_d_guard dec_f sc_r_votes"
    proof(clarsimp simp add: majorities.step2_d_guard_def)
      fix p v
      assume d_f_p: "dec_f p = Some v"
      then obtain Q where Q:
        "Q \<in> majs"
        and vote: "Q \<subseteq> HOs r p" "\<forall>q\<in>Q. \<mu> p q = Some (Vote v)"
        using nxt[THEN spec, of p] d_f_p
        by(auto simp add: next2_def dec_f_def Q'_votes_v_def Let_def majs_def)
      have mru_vote: "\<forall>q\<in>Q. mru_vote (sc q) = Some (three_phase r, v)"  using vote \<mu>[THEN spec, of p]
        by(fastforce simp add: get_msgs_benign send2_def sc_r_votes_def restrict_map_def
          split: option.split_asm if_split_asm)
      hence "dom sc_r_votes \<in> majs"
        by(auto intro!:  majorities.mono_quorum[OF Q] simp add: sc_r_votes_def)
      moreover have "v \<in> ran sc_r_votes" using Q[THEN majorities.quorum_non_empty] mru_vote
        by(force simp add: sc_r_votes_def ex_in_conv[symmetric] intro: ranI)
      ultimately show "v \<in> ran sc_r_votes \<and> dom sc_r_votes \<in> majs"
        by blast
    qed

    thus ?thesis using r R
      by(auto simp add: majorities.opt_mru_step2_def sa'_def new_algo_ref_rel_def sc_r_votes)
  qed

  ultimately show
    "\<exists>sa'. (\<exists>r dec_f. (sa, sa') \<in> majorities.opt_mru_step2 r dec_f)
        \<and> (sa', Suc r, sc') \<in> new_algo_ref_rel"
    by blast

qed

lemma New_Algo_Refines_votes:
  "PO_refines new_algo_ref_rel
    majorities.ts_mru_TS (New_Algo_TS HOs HOs crds)"
proof(rule refine_basic)
  show "init (New_Algo_TS HOs HOs crds) \<subseteq> new_algo_ref_rel `` init majorities.ts_mru_TS"
    by(auto simp add: New_Algo_TS_defs majorities.ts_mru_TS_defs new_algo_ref_rel_def)
next
  show
    "{new_algo_ref_rel} TS.trans majorities.ts_mru_TS,
      TS.trans (New_Algo_TS HOs HOs crds) {> new_algo_ref_rel}"
    apply(simp add: majorities.ts_mru_TS_defs New_Algo_TS_defs)
    apply(auto simp add: CHO_trans_alt New_Algo_trans intro!: step0_ref step1_ref step2_ref)
    done
qed

subsubsection \<open>Termination\<close>
(******************************************************************************)

theorem New_Algo_termination:
  assumes run: "HORun New_Algo_Alg rho HOs"
      and commR: "\<forall>r. HOcommPerRd New_Algo_M (HOs r)"
      and commG: "HOcommGlobal New_Algo_M HOs"
  shows "\<exists>r v. decide (rho r p) = Some v"
proof -
  from commG obtain ph where
    HOs: "\<forall>i \<in> {0..2}.
      (\<forall>p. card (HOs (nr_steps*ph+i) p) > N div 2)
      \<and> (\<forall>p q. HOs (nr_steps*ph+i) p = HOs (nr_steps*ph) q)"
    by(auto simp add: New_Algo_HOMachine_def NA_commGlobal_def)

  \<comment> \<open>The tedious bit: obtain four consecutive rounds linked by send/next functions\<close>
  define r0 where "r0 = nr_steps * ph"
  define cfg0 where "cfg0 = rho r0"
  define r1 where "r1 = Suc r0"
  define cfg1 where "cfg1 = rho r1"
  define r2 where "r2 = Suc r1"
  define cfg2 where "cfg2 = rho r2"
  define cfg3 where "cfg3 = rho (Suc r2)"

  from
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r0"]
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r1"]
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r2"]
    obtain \<mu>0 \<mu>1 \<mu>2 where
    send0: "\<forall>p. \<mu>0 p \<in> get_msgs (send0 r0) cfg0 (HOs r0) (HOs r0) p"
    and three_step0: "\<forall>p. next0 r0 p (cfg0 p) (\<mu>0 p) undefined (cfg1 p)"
    and send1: "\<forall>p. \<mu>1 p \<in> get_msgs (send1 r1) cfg1 (HOs r1) (HOs r1) p"
    and three_step1: "\<forall>p. next1 r1 p (cfg1 p) (\<mu>1 p) undefined (cfg2 p)"
    and send2: "\<forall>p. \<mu>2 p \<in> get_msgs (send2 r2) cfg2 (HOs r2) (HOs r2) p"
    and three_step2: "\<forall>p. next2 r2 p (cfg2 p) (\<mu>2 p) undefined (cfg3 p)"
    apply(auto simp add: New_Algo_Alg_def three_step_def NA_nextState_def NA_sendMsg_def all_conj_distrib
      r0_def r1_def r2_def
      cfg0_def cfg1_def cfg2_def cfg3_def mod_Suc
      )
    done

  \<comment> \<open>The proof: everybody hears the same messages (non-empty!) in r0...\<close>

  from HOs[THEN bspec, where x=0, simplified] send0
    have
    "\<forall>p q. \<mu>0 p = \<mu>0 q" "\<forall>p. N div 2 < card (dom (\<mu>0 p))"
    apply(auto simp add: get_msgs_benign send0_def r1_def r0_def dom_def restrict_map_def intro!: ext)
      apply(blast)+
    done

  \<comment> \<open>...hence everybody sets @{term prop_vote} to the same value...\<close>
  hence same_prevote:
    "\<forall>p. prop_vote (cfg1 p) \<noteq> None"
    "\<forall>p q. prop_vote (cfg1 p) = prop_vote (cfg1 q)" using three_step0
    apply(auto simp add: next1_def Let_def all_conj_distrib intro!: ext)
     apply(clarsimp simp add: next0_def all_conj_distrib Let_def)
    apply(clarsimp simp add: next0_def all_conj_distrib Let_def)
    by (metis (full_types) dom_eq_empty_conv empty_iff majoritiesE')

  \<comment> \<open>...which will become our decision value.\<close>
  then obtain dec_v where dec_v: "\<forall>p. prop_vote (cfg1 p) = Some dec_v"
    by (metis option.collapse)

  \<comment> \<open>...and since everybody hears from majority in r1...\<close>
  from HOs[THEN bspec, where x="Suc 0", simplified] send1
  have "\<forall>p q. \<mu>1 p = \<mu>1 q" "\<forall>p. N div 2 < card (dom (\<mu>1 p))"
    apply(auto simp add: get_msgs_benign send1_def r1_def r0_def dom_def restrict_map_def intro!: ext)
     apply(blast)+
    done

  \<comment> \<open>and since everybody casts a pre-vote for @{term dec_v}, everybody will vote @{term dec_v}\<close>
  have all_vote: "\<forall>p. mru_vote (cfg2 p) = Some (three_phase r2, dec_v)"
  proof
    fix p
    have r0_step: "three_step r0 = 0"
      by(auto simp add: r0_def three_step_def)
    from HOs[THEN bspec, where x="Suc 0", simplified]
    obtain Q where Q: "N div 2 < card Q" "Q \<subseteq> HOs r1 p"
      by(auto simp add: r1_def r0_def)
    hence "Q_prevotes_v (\<mu>1 p) Q dec_v" using dec_v send1[THEN spec, where x=p]
      by(auto simp add: Q_prevotes_v_def get_msgs_benign restrict_map_def send1_def)
    thus "mru_vote (cfg2 p) = Some (three_phase r2, dec_v)" using
      three_step1[THEN spec, where x=p] r0_step
      by(auto simp add: next1_def r2_def r1_def three_step_phase_Suc)
  qed

  \<comment> \<open>And finally, everybody will also decide @{term dec_v}\<close>
  have all_decide: "\<forall>p. decide (cfg3 p) = Some dec_v"
  proof
    fix p
    from HOs[THEN bspec, where x="Suc (Suc 0)", simplified]
    obtain Q where Q: "N div 2 < card Q" "Q \<subseteq> HOs r2 p"
      by(auto simp add: r2_def r1_def r0_def)
    thus "decide (cfg3 p) = Some dec_v"
    using three_step2[THEN spec, where x=p] send2[THEN spec, where x=p]
      by(auto simp add: next2_def send2_def Let_def)
  qed

  thus ?thesis
    by(auto simp add: cfg3_def)
qed

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2020,2021 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open> Metric spaces \<close>

theory MetricSpace_ZF imports Topology_ZF_1 OrderedLoop_ZF Lattice_ZF
begin

text\<open>A metric space is a set on which a distance between points is defined as a function
  $d:X \times X \to [0,\infty)$. With this definition each metric space is a topological space
  which is paracompact and Hausdorff ($T_2$), hence normal (in fact even perfectly normal).\<close>

subsection\<open> Pseudometric - definition and basic properties \<close>

text\<open>A metric on $X$ is usually defined as a function $d:X \times X \to [0,\infty)$ that satisfies
  the conditions $d(x,x) = 0$, $d(x, y) = 0 \Rightarrow  x = y$ (identity of indiscernibles),
  $d(x, y)  = d(y, x)$ (symmetry) and $d(x, y) \le d(x, z) + d(z, y)$ (triangle inequality)
  for all $x,y \in X$.  Here we are going to be a bit more general and define metric and
  pseudo-metric as a function valued in an ordered loop. \<close>

text\<open> First we define a pseudo-metric, which has the axioms of a metric, but without the second part
  of the identity of indiscernibles. In our definition \<open>IsApseudoMetric\<close> is a predicate on five sets: the function $d$,
  the set $X$ on which the metric is defined, the loop carrier $G$, the loop operation $A$
  and the order $r$ on $G$.\<close>

definition
  "IsApseudoMetric(d,X,G,A,r) \<equiv> d:X\<times>X \<rightarrow> Nonnegative(G,A,r)
    \<and> (\<forall>x\<in>X. d`\<langle>x,x\<rangle> = TheNeutralElement(G,A))
    \<and> (\<forall>x\<in>X.\<forall>y\<in>X. d`\<langle>x,y\<rangle> = d`\<langle>y,x\<rangle>)
    \<and> (\<forall>x\<in>X.\<forall>y\<in>X.\<forall>z\<in>X. \<langle>d`\<langle>x,z\<rangle>, A`\<langle>d`\<langle>x,y\<rangle>,d`\<langle>y,z\<rangle>\<rangle>\<rangle> \<in> r)"

text\<open>We add the full axiom of identity of indiscernibles to the definition of a pseudometric
  to get the definition of metric.\<close>

definition
  "IsAmetric(d,X,G,A,r) \<equiv>
    IsApseudoMetric(d,X,G,A,r) \<and> (\<forall>x\<in>X.\<forall>y\<in>X. d`\<langle>x,y\<rangle> = TheNeutralElement(G,A) \<longrightarrow> x=y)"

text\<open>A disk is defined as set of points located less than the radius from the center.\<close>

definition "Disk(X,d,r,c,R) \<equiv> {x\<in>X. \<langle>d`\<langle>c,x\<rangle>,R\<rangle> \<in> StrictVersion(r)}"

text\<open>Next we define notation for metric spaces. We will reuse the additive notation defined in
  the \<open>loop1\<close> locale adding only the assumption about $d$ being a pseudometric and notation
  for a disk centered at $c$ with radius $R$.
  Since for many theorems it is sufficient to assume the pseudometric axioms we will
  assume in this context that the sets $d,X,L,A,r$ form a pseudometric raher than a metric.\<close>

locale pmetric_space =  loop1 +
  fixes d and X

  assumes pmetricAssum: "IsApseudoMetric(d,X,L,A,r)"

  fixes disk
  defines disk_def [simp]: "disk(c,R) \<equiv> Disk(X,d,r,c,R)"

text\<open> The next lemma shows the definition of the pseudometric in the notation used in the
  \<open>metric_space\<close> context.\<close>

lemma (in pmetric_space) pmetric_properties: shows
  "d: X\<times>X \<rightarrow> L\<^sup>+"
  "\<forall>x\<in>X. d`\<langle>x,x\<rangle> = \<zero>"
  "\<forall>x\<in>X.\<forall>y\<in>X. d`\<langle>x,y\<rangle> = d`\<langle>y,x\<rangle>"
  "\<forall>x\<in>X.\<forall>y\<in>X.\<forall>z\<in>X. d`\<langle>x,z\<rangle> \<lsq> d`\<langle>x,y\<rangle> \<ra> d`\<langle>y,z\<rangle>"
  using pmetricAssum unfolding IsApseudoMetric_def by auto

text\<open>The values of the metric are in the loop.\<close>

lemma (in pmetric_space) pmetric_loop_valued: assumes "x\<in>X" "y\<in>X"
  shows "d`\<langle>x,y\<rangle> \<in> L\<^sup>+" "d`\<langle>x,y\<rangle> \<in> L"
proof -
  from assms show "d`\<langle>x,y\<rangle> \<in> L\<^sup>+" using pmetric_properties(1) apply_funtype
    by simp
  then show "d`\<langle>x,y\<rangle> \<in> L" using Nonnegative_def by auto
qed

text\<open>The definition of the disk in the notation used in the \<open>pmetric_space\<close> context:\<close>

lemma (in pmetric_space) disk_definition: shows "disk(c,R) = {x\<in>X. d`\<langle>c,x\<rangle> \<ls> R}"
proof -
  have "disk(c,R) = Disk(X,d,r,c,R)" by simp
  then have "disk(c,R) = {x\<in>X. \<langle>d`\<langle>c,x\<rangle>,R\<rangle> \<in> StrictVersion(r)}" unfolding Disk_def by simp
  moreover have "\<forall>x\<in>X. \<langle>d`\<langle>c,x\<rangle>,R\<rangle> \<in> StrictVersion(r) \<longleftrightarrow> d`\<langle>c,x\<rangle> \<ls> R"
    using def_of_strict_ver by simp
  ultimately show ?thesis by auto
qed

text\<open>If the radius is positive then the center is in disk.\<close>

lemma (in pmetric_space) center_in_disk: assumes "c\<in>X" and "R\<in>L\<^sub>+" shows "c \<in> disk(c,R)"
  using pmetricAssum assms IsApseudoMetric_def PositiveSet_def disk_definition by simp

text\<open>A technical lemma that allows us to shorten some proofs: \<close>

lemma (in pmetric_space) radius_in_loop: assumes "c\<in>X" and "x \<in> disk(c,R)"
  shows "R\<in>L" "\<zero>\<ls>R" "R\<in>L\<^sub>+" "(\<rm>d`\<langle>c,x\<rangle> \<ad> R) \<in> L\<^sub>+"
proof -
  from assms(2) have "x\<in>X" and "d`\<langle>c,x\<rangle> \<ls> R" using disk_definition by auto
  with assms(1) show "\<zero>\<ls>R" using pmetric_properties(1) apply_funtype
      nonneg_definition loop_strict_ord_trans by blast
  then show "R\<in>L" and "R\<in>L\<^sub>+" using posset_definition PositiveSet_def by auto
  from \<open>d`\<langle>c,x\<rangle> \<ls> R\<close> show "(\<rm>d`\<langle>c,x\<rangle> \<ad> R) \<in> L\<^sub>+"
    using ls_other_side(2) by simp
qed

text\<open>If a point $x$ is inside a disk $B$ and $m\leq R-d(c,x)$ then the disk centered
  at the point $x$ and with radius $m$ is contained in the disk $B$. \<close>

lemma (in pmetric_space) disk_in_disk:
  assumes "c\<in>X"  and "x \<in> disk(c,R)" and "m \<lsq> (\<rm>d`\<langle>c,x\<rangle> \<ad> R)"
  shows "disk(x,m) \<subseteq> disk(c,R)"
proof
  fix y assume "y \<in> disk(x,m)"
  then have "d`\<langle>x,y\<rangle> \<ls> m" using disk_definition by simp
  from assms(1,2) \<open>y \<in> disk(x,m)\<close> have "R\<in>L" "x\<in>X" "y\<in>X"
    using radius_in_loop(1) disk_definition by auto
  with assms(1) have "d`\<langle>c,y\<rangle> \<lsq> d`\<langle>c,x\<rangle> \<ra> d`\<langle>x,y\<rangle>" using pmetric_properties(4) by simp
  from assms(1) \<open>x\<in>X\<close> have "d`\<langle>c,x\<rangle> \<in> L"
    using pmetric_properties(1) apply_funtype nonneg_subset by auto
  with \<open>d`\<langle>x,y\<rangle> \<ls> m\<close> assms(3) have "d`\<langle>c,x\<rangle> \<ra> d`\<langle>x,y\<rangle> \<ls> d`\<langle>c,x\<rangle> \<ra> (\<rm>d`\<langle>c,x\<rangle> \<ad> R)"
    using loop_strict_ord_trans1 strict_ord_trans_inv(2) by blast
  with \<open>d`\<langle>c,x\<rangle> \<in> L\<close> \<open>R\<in>L\<close> \<open>d`\<langle>c,y\<rangle> \<lsq> d`\<langle>c,x\<rangle> \<ra> d`\<langle>x,y\<rangle>\<close> \<open>y\<in>X\<close> show "y \<in> disk(c,R)"
    using lrdiv_props(6) loop_strict_ord_trans disk_definition by simp
qed

text\<open> If we assume that the order on the group makes the positive set a meet semi-lattice (i.e.
  every two-element subset of $G_+$ has a greatest lower bound) then
  the collection of disks centered at points of the space and with radii in the positive set
  of the group satisfies the base condition. The meet semi-lattice assumption can be weakened
  to "each two-element subset of $G_+$ has a lower bound in $G_+$", but we don't do that here. \<close>

lemma (in pmetric_space) disks_form_base:
  assumes "r {down-directs} L\<^sub>+"
  defines "B \<equiv> \<Union>c\<in>X. {disk(c,R). R\<in>L\<^sub>+}"
  shows "B {satisfies the base condition}"
proof -
  { fix U V assume "U\<in>B" "V\<in>B"
    fix x assume "x\<in>U\<inter>V"
    have "\<exists>W\<in>B. x\<in>W \<and> W\<subseteq>U\<inter>V"
    proof -
      from assms(2) \<open>U\<in>B\<close> \<open>V\<in>B\<close> obtain c\<^sub>U  c\<^sub>V R\<^sub>U  R\<^sub>V
        where "c\<^sub>U \<in> X" "R\<^sub>U \<in> L\<^sub>+" "c\<^sub>V \<in> X" "R\<^sub>V \<in> L\<^sub>+" "U = disk(c\<^sub>U,R\<^sub>U)" "V = disk(c\<^sub>V,R\<^sub>V)"
        by auto
      with \<open>x\<in>U\<inter>V\<close> have "x \<in> disk(c\<^sub>U,R\<^sub>U)" and "x \<in> disk(c\<^sub>V,R\<^sub>V)" by auto
      then have "x\<in>X" "d`\<langle>c\<^sub>U,x\<rangle> \<ls> R\<^sub>U" "d`\<langle>c\<^sub>V,x\<rangle> \<ls> R\<^sub>V" using disk_definition by auto
      let ?m\<^sub>U = "\<rm> d`\<langle>c\<^sub>U,x\<rangle> \<ad> R\<^sub>U"
      let ?m\<^sub>V = "\<rm> d`\<langle>c\<^sub>V,x\<rangle> \<ad> R\<^sub>V"
      from \<open>c\<^sub>U\<in>X\<close> \<open>x\<in>disk(c\<^sub>U,R\<^sub>U)\<close> \<open>c\<^sub>V\<in>X\<close> \<open>x\<in>disk(c\<^sub>V,R\<^sub>V)\<close> have "?m\<^sub>U\<in>L\<^sub>+" and "?m\<^sub>V\<in>L\<^sub>+"
        using radius_in_loop(4) by auto
      with assms(1) obtain m where "m \<in> L\<^sub>+" "m \<lsq> ?m\<^sub>U" "m \<lsq> ?m\<^sub>V"
        unfolding DownDirects_def by auto
      let ?W = "disk(x,m)"
      from \<open>m \<in> L\<^sub>+\<close> \<open>m \<lsq> ?m\<^sub>U\<close> \<open>m \<lsq> ?m\<^sub>V\<close>
        \<open>c\<^sub>U \<in> X\<close> \<open>x \<in> disk(c\<^sub>U,R\<^sub>U)\<close> \<open>c\<^sub>V \<in> X\<close> \<open>x \<in> disk(c\<^sub>V,R\<^sub>V)\<close>
        \<open>U = disk(c\<^sub>U,R\<^sub>U)\<close> \<open>V = disk(c\<^sub>V,R\<^sub>V)\<close>
        have "?W \<subseteq> U\<inter>V" using disk_in_disk by blast
      moreover from assms(2) \<open>x\<in>X\<close> \<open>m \<in> L\<^sub>+\<close> have "?W \<in> B" and "x\<in>?W" using center_in_disk
        by auto
      ultimately show ?thesis by auto
    qed
  } then show ?thesis unfolding SatisfiesBaseCondition_def by auto
qed

text\<open>Disks centered at points farther away than the sum of radii do not overlap. \<close>
lemma (in pmetric_space) far_disks:
  assumes "x\<in>X" "y\<in>X"  "r\<^sub>x\<ra>r\<^sub>y \<lsq> d`\<langle>x,y\<rangle>"
  shows "disk(x,r\<^sub>x)\<inter>disk(y,r\<^sub>y) = 0"
proof -
  { assume "disk(x,r\<^sub>x)\<inter>disk(y,r\<^sub>y) \<noteq> 0"
    then obtain z where "z \<in> disk(x,r\<^sub>x)\<inter>disk(y,r\<^sub>y)" by auto
    then have "z\<in>X" and "d`\<langle>x,z\<rangle> \<ra> d`\<langle>y,z\<rangle> \<ls> r\<^sub>x\<ra>r\<^sub>y"
      using disk_definition add_ineq_strict by auto
    moreover from assms(1,2) \<open>z\<in>X\<close> have "d`\<langle>x,y\<rangle> \<lsq> d`\<langle>x,z\<rangle> \<ra> d`\<langle>y,z\<rangle>"
      using pmetric_properties(3,4) by auto
    ultimately have "d`\<langle>x,y\<rangle> \<ls> r\<^sub>x\<ra>r\<^sub>y" using loop_strict_ord_trans
      by simp
    with assms(3) have False using loop_strict_ord_trans by auto
  } thus ?thesis by auto
qed

text\<open> If we have a loop element that is smaller than the distance between two points, then
  we can separate these points with disks.\<close>

lemma (in pmetric_space) disjoint_disks:
  assumes "x\<in>X" "y\<in>X" "r\<^sub>x\<ls>d`\<langle>x,y\<rangle>"
  shows "(\<rm>r\<^sub>x\<ad>(d`\<langle>x,y\<rangle>)) \<in> L\<^sub>+" and "disk(x,r\<^sub>x)\<inter>disk(y,\<rm>r\<^sub>x\<ad>(d`\<langle>x,y\<rangle>)) = 0"
proof -
  from assms(3) show "(\<rm>r\<^sub>x\<ad>(d`\<langle>x,y\<rangle>)) \<in> L\<^sub>+"
    using ls_other_side posset_definition1 by simp
  from assms(1,2,3) have "r\<^sub>x\<in>L" and "d`\<langle>x,y\<rangle> \<in> L"
    using less_members(1) pmetric_loop_valued(2) by auto
  then have "r\<^sub>x\<ra>(\<rm>r\<^sub>x\<ad>(d`\<langle>x,y\<rangle>)) = d`\<langle>x,y\<rangle>" using lrdiv_props(6) by simp
  with assms(1,2) \<open>d`\<langle>x,y\<rangle> \<in> L\<close> show "disk(x,r\<^sub>x)\<inter>disk(y,\<rm>r\<^sub>x\<ad>(d`\<langle>x,y\<rangle>)) = 0"
    using loop_ord_refl far_disks by simp
qed

text\<open>Unions of disks form a topology, hence (pseudo)metric spaces are topological spaces. \<close>

theorem (in pmetric_space) pmetric_is_top:
  assumes  "r {down-directs} L\<^sub>+"
  defines "B \<equiv> \<Union>c\<in>X. {disk(c,R). R\<in>L\<^sub>+}"
  defines "T \<equiv> {\<Union>A. A \<in> Pow(B)}"
  shows "T {is a topology}"  "B {is a base for} T"  "\<Union>T = X"
proof -
  from assms  show  "T {is a topology}"  "B {is a base for} T"
    using disks_form_base Top_1_2_T1 by auto
  then have "\<Union>T = \<Union>B" using Top_1_2_L5 by simp
  moreover have "\<Union>B = X"
  proof
    from assms(2) show "\<Union>B \<subseteq> X" using disk_definition by auto
    { fix x assume "x\<in>X"
      from assms(1) obtain R where "R\<in>L\<^sub>+" unfolding DownDirects_def by blast
      with assms(2) \<open>x\<in>X\<close> have "x \<in> \<Union>B" using center_in_disk by auto
    } thus "X \<subseteq> \<Union>B" by auto
  qed
  ultimately show "\<Union>T = X" by simp
qed

text\<open>To define the \<open>metric_space\<close> locale we take the \<open>pmetric_space\<close> and add
  the assumption of identity of indiscernibles.\<close>

locale metric_space =  pmetric_space +
  assumes ident_indisc: "\<forall>x\<in>X. \<forall>y\<in>X. d`\<langle>x,y\<rangle>=\<zero> \<longrightarrow> x=y"

text\<open>In the \<open>metric_space\<close> locale $d$ is a metric.\<close>

lemma (in metric_space) d_metric: shows "IsAmetric(d,X,L,A,r)"
  using pmetricAssum ident_indisc unfolding IsAmetric_def by simp

text\<open>Distance of different points is greater than zero. \<close>

lemma (in metric_space) dist_pos: assumes "x\<in>X" "y\<in>X" "x\<noteq>y"
  shows "\<zero>\<ls>d`\<langle>x,y\<rangle>" "d`\<langle>x,y\<rangle> \<in> L\<^sub>+"
proof -
  from assms(1,2) have "d`\<langle>x,y\<rangle> \<in> L\<^sup>+"
    using pmetric_properties(1) apply_funtype by simp
  then have "\<zero> \<lsq> d`\<langle>x,y\<rangle>" using Nonnegative_def by auto
  with assms show "d`\<langle>x,y\<rangle> \<in> L\<^sub>+" and "\<zero>\<ls>d`\<langle>x,y\<rangle>"
    using ident_indisc posset_definition posset_definition1 by auto
qed

text\<open>An ordered loop valued metric space is $T_2$ (i.e. Hausdorff).\<close>

theorem (in metric_space) metric_space_T2:
    assumes "r {down-directs} L\<^sub>+"
    defines "B \<equiv> \<Union>c\<in>X. {disk(c,R). R\<in>L\<^sub>+}"
    defines "T \<equiv> {\<Union>A. A \<in> Pow(B)}"
    shows "T {is T\<^sub>2}"
proof -
  { fix x y assume "x\<in>\<Union>T" "y\<in>\<Union>T" "x\<noteq>y"
    from assms have "B\<subseteq>T" using pmetric_is_top(2) base_sets_open by auto
    moreover have "\<exists>U\<in>B. \<exists>V\<in>B. x\<in>U \<and> y\<in>V \<and> U\<inter>V = 0"
    proof -
      let ?R = "d`\<langle>x,y\<rangle>"
      from assms have "\<Union>T = X" using pmetric_is_top(3) by simp
      with \<open>x\<in>\<Union>T\<close> \<open>y\<in>\<Union>T\<close> have "x\<in>X" "y\<in>X" by auto
      with \<open>x\<noteq>y\<close> have "?R\<in>L\<^sub>+" using dist_pos by simp
      with assms(2) \<open>x\<in>X\<close> \<open>y\<in>X\<close> have "disk(x,?R) \<in> B" and "disk(y,?R) \<in> B"
        by auto
      { assume "disk(x,?R) \<inter> disk(y,?R) = 0"
        moreover from assms(2) \<open>x\<in>X\<close> \<open>y\<in>X\<close> \<open>?R\<in>L\<^sub>+\<close> have
            "disk(x,?R)\<in>B" "disk(y,?R)\<in>B" "x\<in>disk(x,?R)" "y\<in>disk(y,?R)"
          using center_in_disk by auto
        ultimately have "\<exists>U\<in>B. \<exists>V\<in>B. x\<in>U \<and> y\<in>V \<and> U\<inter>V = 0" by auto
      }
      moreover
      { assume "disk(x,?R) \<inter> disk(y,?R) \<noteq> 0"
        then obtain z where "z \<in> disk(x,?R)" and "z \<in> disk(y,?R)"
          by auto
        then have "d`\<langle>x,z\<rangle> \<ls> ?R" using disk_definition by simp
        then have "\<zero> \<ls> \<rm>d`\<langle>x,z\<rangle>\<ad>?R" using ls_other_side(1) by simp
        let ?r = "\<rm>d`\<langle>x,z\<rangle>\<ad>?R"
        have "?r\<ls>?R"
        proof -
          from \<open>z \<in> disk(y,?R)\<close> \<open>x\<in>X\<close> \<open>y\<in>X\<close> have "z\<in>X" "x\<noteq>z"
            using disk_definition pmetric_properties(3) by auto
          with \<open>x\<in>X\<close> \<open>y\<in>X\<close> \<open>z\<in>X\<close> show ?thesis
            using pmetric_loop_valued dist_pos(1) subtract_pos(2) by simp
        qed
        with \<open>x\<in>X\<close> \<open>y\<in>X\<close> have "disk(x,?r)\<inter>disk(y,\<rm>?r\<ad>?R) = 0"
          by (rule disjoint_disks)
        moreover
        from \<open>\<zero>\<ls>?r\<close> \<open>?r\<ls>?R\<close> have "?r\<in>L\<^sub>+" "(\<rm>?r\<ad>?R) \<in> L\<^sub>+"
          using ls_other_side posset_definition1 by auto
        with assms(2) \<open>x\<in>X\<close> \<open>y\<in>X\<close> have
            "disk(x,?r)\<in>B" "disk(y,\<rm>?r\<ad>(d`\<langle>x,y\<rangle>))\<in>B" and
            "x\<in>disk(x,?r)" "y\<in>disk(y,\<rm>?r\<ad>(d`\<langle>x,y\<rangle>))"
          using center_in_disk by auto
        ultimately have "\<exists>U\<in>B. \<exists>V\<in>B. x\<in>U \<and> y\<in>V \<and> U\<inter>V = 0" by auto
      }
      ultimately show ?thesis by auto
    qed
    ultimately have "\<exists>U\<in>T. \<exists>V\<in>T. x\<in>U \<and> y\<in>V \<and> U\<inter>V = 0" by auto
  } then show ?thesis unfolding isT2_def by simp
qed

end


(*  Title: ODEs with lenses *)

section \<open> ODEs with lenses \<close>

text \<open> We use shallow expressions to rephrase the properties for hybrid systems in a
cleaner presentation. \<close>

theory Framed_Dyn_Sys
  imports
    Dynamical_Systems
    "Hybrid-Library.Cont_Lens"
    "Shallow-Expressions.Shallow_Expressions"
begin

text \<open> In this section we use type @{typ 's} for the state space,
type @{typ 'c} for a sub-region of @{typ 's}, and types @{typ 't} and
@{typ 'v} for generic representations of time and a value domain. With
lenses @{term "x :: 'c \<Longrightarrow> 's"}, we lift entities from @{typ 'c} to
@{typ 's} and frame others from @{typ 's} to @{typ 'c}. \<close>

no_notation id_lens ("1\<^sub>L")
notation id_lens ("\<one>\<^sub>L")

subsection \<open> Framing and lifting \<close>

definition lframe_fun :: "('c \<Longrightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 'v) \<Rightarrow> 's \<Rightarrow> ('c \<Rightarrow> 'v)" (infixr "\<down>\<^sub>F\<index>" 100)
  where "(F\<down>\<^sub>F\<^bsub>x\<^esub> s) c = F (put\<^bsub>x\<^esub> s c)"

lemma lframe_fun_alt [expr_defs]: "(F\<down>\<^sub>F\<^bsub>x\<^esub> s) = (\<lambda>c. F (put\<^bsub>x\<^esub> s c))"
  by (auto simp: lframe_fun_def)

definition llift_fun :: "('c \<Longrightarrow> 's) \<Rightarrow> ('c \<Rightarrow> 'v) \<Rightarrow> ('s \<Rightarrow> 'v)" (infixr "\<up>\<^sub>F\<index>" 100)
  where [expr_defs]: "F\<up>\<^sub>F\<^bsub>x\<^esub> s \<equiv>  F (get\<^bsub>x\<^esub> s)"

definition lframe_set :: "('c \<Longrightarrow> 's) \<Rightarrow> 's set \<Rightarrow> 'c set" ("_\<down>\<^sub>S\<^sub>e\<^sub>t\<index>" [100] 100)
  where [expr_defs]: "X\<down>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub> = \<P> get\<^bsub>x\<^esub> X"

definition llift_set :: "('c \<Longrightarrow> 's) \<Rightarrow> 'c set \<Rightarrow> 's \<Rightarrow> 's set" (infixr "\<up>\<^sub>S\<^sub>e\<^sub>t\<index>" 100)
  where [expr_defs]: "X\<up>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub> s \<equiv> \<P> (\<lambda>c. put\<^bsub>x\<^esub> s c) X"

definition lframe_pred :: "('c \<Longrightarrow> 's) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> bool)" ("_\<down>\<^sub>P\<index>" [100] 1000)
  where [expr_defs]: "P\<down>\<^sub>P\<^bsub>x\<^esub> c \<longleftrightarrow> c \<in> {s. P s}\<down>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub>"

lemma lframe_pred_iff_pred_as_fun:
  "vwb_lens x \<Longrightarrow> P\<down>\<^sub>P\<^bsub>x\<^esub> c \<longleftrightarrow> (\<exists>s. (P\<down>\<^sub>F\<^bsub>x\<^esub> s) c)"
  by (expr_auto add: image_iff)
    (metis vwb_lens_def wb_lens.get_put)

lemma lframe_set_Collect_llift_fun:
  "vwb_lens x \<Longrightarrow> \<P> get\<^bsub>x\<^esub> UNIV = UNIV \<Longrightarrow> {s. P\<up>\<^sub>F\<^bsub>x\<^esub> s}\<down>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub> = {c. P c}"
  by expr_auto

lemma llift_set_Collect_lframe_pred:
  "vwb_lens x \<Longrightarrow> {c. P\<down>\<^sub>P\<^bsub>x\<^esub> c}\<up>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub> s = {put\<^bsub>x\<^esub> s (get\<^bsub>x\<^esub> s') |s'. P s'}"
  by expr_auto

lemma Un_llift_set_lframe_pred_supset:
  "vwb_lens x \<Longrightarrow> {s. P s} \<subseteq> (\<Union>s. {c. P\<down>\<^sub>P\<^bsub>x\<^esub> c}\<up>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub> s)"
  by (auto simp: lframe_pred_def llift_set_def image_iff lframe_set_def)
    (metis vwb_lens.put_eq)

text \<open> Localise a substitution using a lens. Useful for localising both ODEs and flows. \<close>

definition lframe_subst :: "('c \<Longrightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> ('c \<Rightarrow> 'c)" (infixr "\<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<index>" 100)
  where "(\<sigma>\<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s) c \<equiv> get\<^bsub>x\<^esub> ((\<sigma> \<down>\<^sub>F\<^bsub>x\<^esub> s) c)"

lemma lframe_subst_alt [expr_defs]:
  "(\<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub>) \<sigma> \<equiv> (\<lambda>s c. get\<^bsub>x\<^esub> (\<sigma> (put\<^bsub>x\<^esub> s c)))"
  unfolding lframe_subst_def
  by expr_simp

abbreviation tsubst2vecf :: "('c::real_normed_vector \<Longrightarrow> 's)
  \<Rightarrow> (real \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> real \<Rightarrow> 'c \<Rightarrow> 'c" (infixr "\<down>\<^sub>V\<^sub>e\<^sub>c\<index>" 100)
  where "(F\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t c \<equiv> (F t \<down>\<^sub>S\<^sub>u\<^sub>b\<^sub>s\<^sub>t\<^bsub>x\<^esub> s) c"

lemma tsubst2vecf_eq: "F\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s = (\<lambda> t c. get\<^bsub>x\<^esub> (F t (put\<^bsub>x\<^esub> s c)))"
  by (auto simp: lframe_subst_def fun_eq_iff lframe_fun_def)

subsection \<open> Framed orbitals  \<close>

text \<open> A version of orbital localised by a lens \<close>

definition g_orbital_on :: "('c::real_normed_vector \<Longrightarrow> 's)
  \<Rightarrow> (real \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> real set) \<Rightarrow> 'c set \<Rightarrow> real \<Rightarrow> 's \<Rightarrow> 's set"
  where "g_orbital_on x F G U S t\<^sub>0 s
    = (g_orbital (F\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) (G\<down>\<^sub>F\<^bsub>x\<^esub> s) U S t\<^sub>0 (get\<^bsub>x\<^esub> s))\<up>\<^sub>S\<^sub>e\<^sub>t\<^bsub>x\<^esub> s"

lemma g_orbital_on_eq: "g_orbital_on x f G U S t\<^sub>0 s
  = {put\<^bsub>x\<^esub> s (X t) |t X. t \<in> U (get\<^bsub>x\<^esub> s)
    \<and> \<P> (\<lambda>t. put\<^bsub>x\<^esub> s (X t)) (down (U (get\<^bsub>x\<^esub> s)) t) \<subseteq> {s. G s}
    \<and> X \<in> Sols U S (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t\<^sub>0 (get\<^bsub>x\<^esub> s)}"
  unfolding g_orbital_on_def g_orbital_eq image_le_pred
  by (auto simp: image_def tsubst2vecf_eq llift_set_def lframe_fun_def)

lemma g_orbital_on_id_lens: "g_orbital_on \<one>\<^sub>L = g_orbital"
  by (simp add: g_orbital_on_eq tsubst2vecf_eq g_orbital_eq fun_eq_iff lens_defs)

lemma g_orbital_onI:
  assumes "X \<in> Sols U S (\<lambda>t c. get\<^bsub>x\<^esub> (f t (put\<^bsub>x\<^esub> s c))) t\<^sub>0 (get\<^bsub>x\<^esub> s)"
    and "t \<in> U (get\<^bsub>x\<^esub> s)" and "(\<P> (\<lambda>\<tau>. put\<^bsub>x\<^esub> s (X \<tau>)) (down (U (get\<^bsub>x\<^esub> s)) t) \<subseteq> Collect G)"
  shows "put\<^bsub>x\<^esub> s (X t) \<in> g_orbital_on x f G U S t\<^sub>0 s"
  using assms unfolding g_orbital_on_eq tsubst2vecf_eq by auto

subsection \<open> Framed differential invariants \<close>

definition diff_inv_on :: "('c:: real_normed_vector \<Longrightarrow> 's) \<Rightarrow> (real \<Rightarrow> 's \<Rightarrow> 's)
  \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> real set) \<Rightarrow> 'c set \<Rightarrow> real \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
  where "diff_inv_on x f G U S t\<^sub>0 I \<equiv> (\<Union> \<circ> (\<P> (g_orbital_on x f G U S t\<^sub>0))) {s. I s} \<subseteq> {s. I s}"

lemma diff_inv_on_eq: "diff_inv_on x f G U S t\<^sub>0 I =
  (\<forall>s. I s \<longrightarrow> (\<forall>X\<in>Sols U S (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t\<^sub>0 (get\<^bsub>x\<^esub> s).
    (\<forall>t\<in>U (get\<^bsub>x\<^esub> s).(\<forall>\<tau>\<in>(down (U (get\<^bsub>x\<^esub> s)) t). G (put\<^bsub>x\<^esub> s (X \<tau>))) \<longrightarrow> I (put\<^bsub>x\<^esub> s (X t)))))"
  unfolding diff_inv_on_def g_orbital_on_eq image_le_pred
  by (auto simp: image_def tsubst2vecf_eq)

lemma diff_inv_on_id_lens: "diff_inv_on \<one>\<^sub>L f G U S t\<^sub>0 I = diff_inv U S G f t\<^sub>0 I"
  by (simp add: diff_inv_on_def diff_inv_def g_orbital_on_id_lens)

lemma diff_inv_on_iff:
  assumes"vwb_lens x"
  shows "diff_inv_on x f G U S t\<^sub>0 I \<longleftrightarrow>
  (\<forall>s. diff_inv U S (\<lambda>c. G (put\<^bsub>x\<^esub> s c)) (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t\<^sub>0 (\<lambda>c. I (put\<^bsub>x\<^esub> s c)))"
proof(intro iffI, goal_cases "(\<Rightarrow>)" "(\<Leftarrow>)")
  case ("(\<Rightarrow>)")
  then show ?case
    using assms
    by (auto simp: diff_inv_on_eq diff_inv_eq tsubst2vecf_eq)
next
  case "(\<Leftarrow>)"
  thus ?case
    apply(clarsimp simp: diff_inv_on_eq diff_inv_eq)
    apply (erule_tac x=s in allE, erule_tac x="get\<^bsub>x\<^esub> s" in allE)
    using assms by auto
qed

named_theorems diff_inv_on_intros "intro rules for certifying (localised) differential invariants"

lemma diff_inv_on_eq0I:
  fixes \<mu> :: "_ \<Rightarrow> 'c::real_inner"
  assumes "vwb_lens x"
    and Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and dX: "\<And>X t s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow>
  \<forall>\<tau>\<in>(down (U (X t\<^sub>0)) t). G (put\<^bsub>x\<^esub> s (X \<tau>)) \<Longrightarrow> (D (\<lambda>\<tau>. \<mu> (put\<^bsub>x\<^esub> s (X \<tau>))) = (\<lambda>t. 0) on U (X t\<^sub>0))"
  shows "diff_inv_on x f G U S t\<^sub>0 (\<mu> = 0)\<^sub>e"
  unfolding diff_inv_on_iff[OF assms(1)]
  apply (clarsimp, subst diff_inv_eq0I[OF Uhyp]; simp?)
  using dX by force

lemma diff_inv_on_eqI [diff_inv_on_intros]:
  fixes \<mu> \<nu> :: "_ \<Rightarrow> 'c::real_inner"
  assumes "vwb_lens x" (* do we need derivative rules for loc_subst then? *)
    and Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and dX: "\<And>X t s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow>
  \<forall>\<tau>\<in>(down (U (X t\<^sub>0)) t). G (put\<^bsub>x\<^esub> s (X \<tau>)) \<Longrightarrow> (D (\<lambda>\<tau>. \<mu> (put\<^bsub>x\<^esub> s (X \<tau>))-\<nu>(put\<^bsub>x\<^esub> s (X \<tau>))) = (\<lambda>t. 0) on U (X t\<^sub>0))"
  shows "diff_inv_on x f G U S t\<^sub>0 (\<mu> = \<nu>)\<^sub>e"
  using assms diff_inv_on_eq0I[OF assms(1,2), where \<mu>="\<lambda>s. \<mu> s - \<nu> s"]
  by auto

lemma diff_inv_on_leqI [diff_inv_on_intros]:
  fixes \<mu> ::"_ \<Rightarrow> real"
  assumes "vwb_lens x"
    and Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and Gg: "\<And>X t s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U (X t\<^sub>0))
      \<Longrightarrow> (\<forall>\<tau>\<in>U(X t\<^sub>0). \<tau> > t\<^sub>0 \<longrightarrow> G (put\<^bsub>x\<^esub> s (X \<tau>)) \<longrightarrow> \<nu>' (put\<^bsub>x\<^esub> s (X \<tau>)) \<le> \<mu>' (put\<^bsub>x\<^esub> s (X \<tau>)))"
    and Gl: "\<And>X s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U(X t\<^sub>0))
      \<Longrightarrow> (\<forall>\<tau>\<in>U(X t\<^sub>0). \<tau> < t\<^sub>0 \<longrightarrow> \<mu>' (put\<^bsub>x\<^esub> s (X \<tau>)) \<le> \<nu>' (put\<^bsub>x\<^esub> s (X \<tau>)))"
    and dX: "\<And>X t s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U (X t\<^sub>0))
      \<Longrightarrow> (D (\<lambda>\<tau>. \<mu> (put\<^bsub>x\<^esub> s (X \<tau>)) - \<nu> (put\<^bsub>x\<^esub> s (X \<tau>))) = (\<lambda>\<tau>. \<mu>' (put\<^bsub>x\<^esub> s (X \<tau>)) - \<nu>' (put\<^bsub>x\<^esub> s (X \<tau>))) on U (X t\<^sub>0))"
  shows "diff_inv_on x f G U S t\<^sub>0 (\<nu> \<le> \<mu>)\<^sub>e"
  apply (clarsimp simp: diff_inv_on_iff[OF assms(1)])
  apply (rule diff_inv_leq_alt[OF Uhyp, where \<mu>'="\<lambda>c. \<mu>' (put\<^bsub>x\<^esub> _ c)" and \<nu>'="\<lambda>c. \<nu>' (put\<^bsub>x\<^esub> _ c)"])
  using assms by auto

lemma diff_inv_on_lessI [diff_inv_on_intros]:
  fixes \<mu> ::"_ \<Rightarrow> real"
  assumes "vwb_lens x"
    and Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and Gg: "\<And>X t s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U (X t\<^sub>0))
      \<Longrightarrow> (\<forall>\<tau>\<in>U(X t\<^sub>0). \<tau> > t\<^sub>0 \<longrightarrow> G (put\<^bsub>x\<^esub> s (X \<tau>)) \<longrightarrow> \<nu>' (put\<^bsub>x\<^esub> s (X \<tau>)) \<le> \<mu>' (put\<^bsub>x\<^esub> s (X \<tau>)))"
    and Gl: "\<And>X s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U(X t\<^sub>0))
      \<Longrightarrow> (\<forall>\<tau>\<in>U(X t\<^sub>0). \<tau> < t\<^sub>0 \<longrightarrow> \<mu>' (put\<^bsub>x\<^esub> s (X \<tau>)) \<le> \<nu>' (put\<^bsub>x\<^esub> s (X \<tau>)))"
    and dX: "\<And>X t s. (D X = (\<lambda>\<tau>. (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) \<tau> (X \<tau>)) on U (X t\<^sub>0))
      \<Longrightarrow> (D (\<lambda>\<tau>. \<mu> (put\<^bsub>x\<^esub> s (X \<tau>)) - \<nu> (put\<^bsub>x\<^esub> s (X \<tau>))) = (\<lambda>\<tau>. \<mu>' (put\<^bsub>x\<^esub> s (X \<tau>)) - \<nu>' (put\<^bsub>x\<^esub> s (X \<tau>))) on U (X t\<^sub>0))"
  shows "diff_inv_on x f G U S t\<^sub>0 (\<nu> < \<mu>)\<^sub>e "
  apply (clarsimp simp: diff_inv_on_iff[OF assms(1)])
  apply (rule diff_inv_less_alt[OF Uhyp, where \<mu>'="\<lambda>c. \<mu>' (put\<^bsub>x\<^esub> _ c)" and \<nu>'="\<lambda>c. \<nu>' (put\<^bsub>x\<^esub> _ c)"])
  using assms by auto

lemma diff_inv_on_nleq_iff:
  fixes \<mu>::"_ \<Rightarrow> real"
  shows "diff_inv_on x f G U S t\<^sub>0 (\<not> \<nu> \<le> \<mu>)\<^sub>e \<longleftrightarrow> diff_inv_on x f G U S t\<^sub>0 (\<nu> > \<mu>)\<^sub>e"
  unfolding approximation_preproc_push_neg(2) by presburger

lemma diff_inv_on_neqI [diff_inv_on_intros]:
  fixes \<mu>::"_ \<Rightarrow> real"
  assumes "vwb_lens x"
    and "diff_inv_on x f G U S t\<^sub>0 (\<nu> < \<mu>)\<^sub>e"
    and "diff_inv_on x f G U S t\<^sub>0 (\<nu> > \<mu>)\<^sub>e"
  shows "diff_inv_on x f G U S t\<^sub>0 (\<nu> \<noteq> \<mu>)\<^sub>e"
  using assms unfolding diff_inv_on_iff[OF assms(1)]
  using diff_inv_neqI by force

lemma
  assumes "diff_inv_on x f G U S t\<^sub>0 (I\<^sub>1)\<^sub>e"
    and "diff_inv_on x f G U S t\<^sub>0 (I\<^sub>2)\<^sub>e"
  shows diff_inv_on_conjI [diff_inv_on_intros]: "diff_inv_on x f G U S t\<^sub>0 (I\<^sub>1 \<and> I\<^sub>2)\<^sub>e"
    and diff_inv_on_disjI [diff_inv_on_intros]: "diff_inv_on x f G U S t\<^sub>0 (I\<^sub>1 \<or> I\<^sub>2)\<^sub>e"
  using assms unfolding diff_inv_on_eq by auto

lemmas diff_inv_on_raw_eqI = diff_inv_on_eqI[unfolded expr_defs]
lemmas diff_inv_on_raw_leqI = diff_inv_on_leqI[unfolded expr_defs]
lemmas diff_inv_on_raw_lessI = diff_inv_on_lessI[unfolded expr_defs]
lemmas diff_inv_on_raw_conjI = diff_inv_on_conjI[unfolded expr_defs]
lemmas diff_inv_on_raw_disjjI = diff_inv_on_disjI[unfolded expr_defs]

subsubsection \<open> Non-framed-but-lensified differential invariant rules \<close>

named_theorems diff_inv_laws "encapsulating rules for (non-localised) differential invariants"

lemma diff_inv_eq_law [diff_inv_laws]:
  fixes \<mu>::"_ \<Rightarrow> real"
  assumes Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and dX: "\<And>X t. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U(X t\<^sub>0)) \<Longrightarrow>
  \<forall>\<tau>\<in>(down (U(X t\<^sub>0)) t). G (X \<tau>) \<Longrightarrow> D (\<lambda>\<tau>. \<mu> (X \<tau>) - \<nu> (X \<tau>)) = (\<lambda>\<tau>. \<tau> *\<^sub>R 0) on U(X t\<^sub>0)"
  shows "diff_inv U S G f t\<^sub>0 (\<mu> = \<nu>)\<^sub>e"
  using assms by (simp add: SEXP_def, rule diff_inv_eqI, simp_all)

thm diff_inv_eq_law diff_inv_eqI[unfolded ] diff_inv_eq_law[unfolded expr_defs]
thm diff_inv_eqI[THEN ssubst[OF SEXP_def[of "\<lambda>s. \<mu> s = \<nu> s"], where P="\<lambda>q. diff_inv U S G f t\<^sub>0 q"]]

lemma diff_inv_leq_law [diff_inv_laws]:
  fixes \<mu>::"'a::banach \<Rightarrow> real"
  assumes Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and Gg: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> (\<forall>\<tau>\<in>U (X t\<^sub>0). \<tau> > t\<^sub>0 \<longrightarrow> G (X \<tau>) \<longrightarrow> \<mu>' (X \<tau>) \<ge> \<nu>' (X \<tau>))"
    and Gl: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> (\<forall>\<tau>\<in>U (X t\<^sub>0). \<tau> < t\<^sub>0 \<longrightarrow> \<mu>' (X \<tau>) \<le> \<nu>' (X \<tau>))"
    and dX: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> D (\<lambda>\<tau>. \<mu>(X \<tau>)-\<nu>(X \<tau>)) = (\<lambda>\<tau>. \<mu>'(X \<tau>)-\<nu>'(X \<tau>)) on U (X t\<^sub>0)"
  shows "diff_inv U S G f t\<^sub>0 (\<nu> \<le> \<mu>)\<^sub>e"
  using assms
  by (simp add: SEXP_def, rule diff_inv_leq_alt, simp_all)

lemma diff_inv_less_law [diff_inv_laws]:
  fixes \<mu>::"'a::banach \<Rightarrow> real"
  assumes Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)"
    and Gg: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> (\<forall>\<tau>\<in>U (X t\<^sub>0). \<tau> > t\<^sub>0 \<longrightarrow> G (X \<tau>) \<longrightarrow> \<mu>' (X \<tau>) \<ge> \<nu>' (X \<tau>))"
    and Gl: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> (\<forall>\<tau>\<in>U (X t\<^sub>0). \<tau> < t\<^sub>0 \<longrightarrow> \<mu>' (X \<tau>) \<le> \<nu>' (X \<tau>))"
    and dX: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> D (\<lambda>\<tau>. \<mu>(X \<tau>)-\<nu>(X \<tau>)) = (\<lambda>\<tau>. \<mu>'(X \<tau>)-\<nu>'(X \<tau>)) on U (X t\<^sub>0)"
  shows "diff_inv U S G f t\<^sub>0 (\<nu> < \<mu>)\<^sub>e"
  using assms
  by (simp add: SEXP_def, rule diff_inv_less_alt, simp_all)

lemma diff_inv_nleq_law:
  fixes \<mu>::"'a::banach \<Rightarrow> real"
  shows "diff_inv U S G f t\<^sub>0 (\<not> \<nu> \<le> \<mu>)\<^sub>e \<longleftrightarrow> diff_inv U S G f t\<^sub>0 (\<nu> > \<mu>)\<^sub>e"
  by (simp add: SEXP_def, subst diff_inv_nleq_iff, simp_all)

lemma diff_inv_neq_law [diff_inv_laws]:
  fixes \<mu>::"'a::banach \<Rightarrow> real"
  assumes "diff_inv U S G f t\<^sub>0 (\<nu> < \<mu>)\<^sub>e"
    and "diff_inv U S G f t\<^sub>0 (\<nu> > \<mu>)\<^sub>e"
  shows "diff_inv U S G f t\<^sub>0 (\<nu> \<noteq> \<mu>)\<^sub>e"
  using assms apply(simp add: SEXP_def)
  by (rule diff_inv_neqI, simp_all)

lemma diff_inv_neq_law_converse:
  fixes \<mu>::"'a::banach \<Rightarrow> real"
  assumes Uhyp: "\<And>s. s \<in> S \<Longrightarrow> is_interval (U s)" "\<And>s t. s \<in> S \<Longrightarrow> t \<in> U s \<Longrightarrow> t\<^sub>0 \<le> t"
    and conts: "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> continuous_on (\<P> X (U (X t\<^sub>0))) \<nu>"
      "\<And>X. (D X = (\<lambda>\<tau>. f \<tau> (X \<tau>)) on U (X t\<^sub>0)) \<Longrightarrow> continuous_on (\<P> X (U (X t\<^sub>0))) \<mu>"
    and dI:"diff_inv U S G f t\<^sub>0 (\<nu> \<noteq> \<mu>)\<^sub>e"
  shows "diff_inv U S G f t\<^sub>0 (\<nu> < \<mu>)\<^sub>e"
  using assms apply(simp add: SEXP_def)
  by (rule diff_inv_neqE, simp_all)

lemma
  assumes "diff_inv U S G f t\<^sub>0 (I\<^sub>1)\<^sub>e"
    and "diff_inv U S G f t\<^sub>0 (I\<^sub>2)\<^sub>e"
  shows diff_inv_conj_law [diff_inv_laws]: "diff_inv U S G f t\<^sub>0 (I\<^sub>1 \<and> I\<^sub>2)\<^sub>e"
    and diff_inv_disj_law [diff_inv_laws]: "diff_inv U S G f t\<^sub>0 (I\<^sub>1 \<or> I\<^sub>2)\<^sub>e"
  using assms unfolding diff_inv_eq by auto

end


header {* Implementing Graphs by Maps *}
theory GraphByMap
imports
  GraphSpec
  GraphGA
begin

definition "map_Sigma M1 F2 \<equiv> {
  (x,y). \<exists>v. M1 x = Some v \<and> y\<in>F2 v
}"

lemma map_Sigma_alt: "map_Sigma M1 F2 = Sigma (dom M1) (\<lambda>x.
  F2 (the (M1 x)))"
  unfolding map_Sigma_def
  by auto

(* TODO: Move to Misc *)
lemma ranE:
  assumes "v\<in>ran m"
  obtains k where "m k = Some v"
  using assms
by (metis ran_restrictD restrict_map_self)
lemma option_bind_alt:
  "Option.bind x f = (case x of None \<Rightarrow> None | Some v \<Rightarrow> f v)"
  by (auto split: option.split)

locale GraphByMapDefs =
  m1!: StdMapDefs m1_ops +
  m2!: StdMapDefs m2_ops +
  s3!: StdSetDefs s3_ops
  for m1_ops::"('V,'m2,'m1,_) map_ops_scheme"
  and m2_ops::"('V,'s3,'m2,_) map_ops_scheme"
  and s3_ops::"('W,'s3,_) set_ops_scheme"
  and m1_mvif :: "('V \<Rightarrow> 'm2 \<rightharpoonup> 'm2) \<Rightarrow> 'm1 \<Rightarrow> 'm1"
begin
  definition gbm_\<alpha> :: "('V,'W,'m1) graph_\<alpha>" where
    "gbm_\<alpha> m1 \<equiv>
    \<lparr> nodes = dom (m1.\<alpha> m1),
      edges = {(v,w,v').
        \<exists>m2 s3. m1.\<alpha> m1 v = Some m2
          \<and> m2.\<alpha> m2 v' = Some s3
          \<and> w\<in>s3.\<alpha> s3
      }
    \<rparr>"

  definition "gbm_invar m1 \<equiv>
    m1.invar m1 \<and>
    (\<forall>m2\<in>ran (m1.\<alpha> m1). m2.invar m2 \<and>
      (\<forall>s3\<in>ran (m2.\<alpha> m2). s3.invar s3)
    ) \<and> valid_graph (gbm_\<alpha> m1)"

  definition gbm_empty :: "('V,'W,'m1) graph_empty" where
    "gbm_empty \<equiv> m1.empty"

  definition gbm_add_node :: "('V,'W,'m1) graph_add_node" where
    "gbm_add_node v g \<equiv> case m1.lookup v g of
    None \<Rightarrow> m1.update v (m2.empty ()) g |
    Some _ \<Rightarrow> g"

  definition gbm_delete_node :: "('V,'W,'m1) graph_delete_node" where
    "gbm_delete_node v g \<equiv> let g=m1.delete v g in
    m1_mvif (\<lambda>_ m2. Some (m2.delete v m2)) g"

  definition gbm_add_edge :: "('V,'W,'m1) graph_add_edge" where
    "gbm_add_edge v e v' g \<equiv>
    let g = (case m1.lookup v' g of
      None \<Rightarrow> m1.update v' (m2.empty ()) g | Some _ \<Rightarrow> g
    ) in
    case m1.lookup v g of
      None \<Rightarrow> (m1.update v (m2.sng v' (s3.sng e)) g) |
      Some m2 \<Rightarrow> (case m2.lookup v' m2 of
        None \<Rightarrow> m1.update v (m2.update v' (s3.sng e) m2) g |
        Some s3 \<Rightarrow> m1.update v (m2.update v' (s3.ins e s3) m2) g)
    "

  definition gbm_delete_edge :: "('V,'W,'m1) graph_delete_edge" where
    "gbm_delete_edge v e v' g \<equiv>
    case m1.lookup v g of
      None \<Rightarrow> g |
      Some m2 \<Rightarrow> (
        case m2.lookup v' m2 of
          None \<Rightarrow> g |
          Some s3 \<Rightarrow> m1.update v (m2.update v' (s3.delete e s3) m2) g
      )
    "

  definition gbm_nodes_list_it
    :: "('V,'W,'V list,'m1) graph_nodes_it"
    where
    "gbm_nodes_list_it g \<equiv> map_iterator_dom (m1.iteratei g)"
  local_setup {* Locale_Code.lc_decl_del @{term gbm_nodes_list_it} *}

  definition gbm_edges_list_it
    :: "('V,'W,('V\<times>'W\<times>'V) list,'m1) graph_edges_it"
    where
    "gbm_edges_list_it g \<equiv> set_iterator_image
      (\<lambda>((v1,m1),(v2,m2),w). (v1,w,v2))
      (set_iterator_product (m1.iteratei g)
        (\<lambda>(v,m2). set_iterator_product
          (m2.iteratei m2) (\<lambda>(w,s3). s3.iteratei s3)))
    "
  local_setup {* Locale_Code.lc_decl_del @{term gbm_edges_list_it} *}

  definition gbm_succ_list_it ::
    "('V,'W,('W\<times>'V) list,'m1) graph_succ_it"
    where
  "gbm_succ_list_it g v \<equiv> case m1.lookup v g of
    None \<Rightarrow> set_iterator_emp |
    Some m2 \<Rightarrow>
      set_iterator_image (\<lambda>((v',m2),w). (w,v'))
        (set_iterator_product (m2.iteratei m2) (\<lambda>(v',s). s3.iteratei s))
    "
  local_setup {* Locale_Code.lc_decl_del @{term gbm_succ_list_it} *}

  definition
    "gbm_from_list \<equiv> gga_from_list gbm_empty gbm_add_node gbm_add_edge"

  lemma gbm_nodes_list_it_unf:
    "it_to_it (gbm_nodes_list_it g)
    \<equiv> map_iterator_dom (it_to_it (m1.list_it g))"
    apply (rule eq_reflection)
    apply (rule it_to_it_fold)
    unfolding gbm_nodes_list_it_def m1.iteratei_def
    by (intro icf_proper_iteratorI)

  lemma gbm_edges_list_it_unf:
    "it_to_it (gbm_edges_list_it g)
    \<equiv> set_iterator_image
      (\<lambda>((v1,m1),(v2,m2),w). (v1,w,v2))
      (set_iterator_product (it_to_it (m1.list_it g))
        (\<lambda>(v,m2). set_iterator_product
          (it_to_it (m2.list_it m2)) (\<lambda>(w,s3). (it_to_it (s3.list_it s3)))))
    "
    apply (rule eq_reflection)
    apply (rule it_to_it_fold)
    unfolding gbm_edges_list_it_def
      m1.iteratei_def m2.iteratei_def s3.iteratei_def
    apply (intro icf_proper_iteratorI allI impI, (simp split: prod.split)?)+
    done

  lemma gbm_succ_list_it_unf:
  "it_to_it (gbm_succ_list_it g v) \<equiv>
    case m1.lookup v g of
      None \<Rightarrow> set_iterator_emp |
      Some m2 \<Rightarrow>
        set_iterator_image (\<lambda>((v',m2),w). (w,v'))
          (set_iterator_product (it_to_it (m2.list_it m2))
            (\<lambda>(v',s). (it_to_it (s3.list_it s))))
      "
    apply (rule eq_reflection)
    apply (rule it_to_it_fold)
    unfolding gbm_succ_list_it_def
      m2.iteratei_def s3.iteratei_def
    apply (simp split: prod.split option.split)
    apply (intro icf_proper_iteratorI allI impI conjI,
      (simp split: prod.split option.split)?)+
    done

end

sublocale GraphByMapDefs < graph_nodes_it_defs gbm_nodes_list_it .
sublocale GraphByMapDefs < graph_edges_it_defs gbm_edges_list_it .
sublocale GraphByMapDefs < graph_succ_it_defs gbm_succ_list_it .
sublocale GraphByMapDefs
  < gga_to_list_defs_loc gbm_nodes_list_it gbm_edges_list_it .

context GraphByMapDefs
begin

  definition [icf_rec_def]: "gbm_ops \<equiv> \<lparr>
    gop_\<alpha> = gbm_\<alpha>,
    gop_invar = gbm_invar,
    gop_empty = gbm_empty,
    gop_add_node = gbm_add_node,
    gop_delete_node = gbm_delete_node,
    gop_add_edge = gbm_add_edge,
    gop_delete_edge = gbm_delete_edge,
    gop_from_list = gbm_from_list,
    gop_to_list = gga_to_list,
    gop_nodes_list_it = gbm_nodes_list_it,
    gop_edges_list_it = gbm_edges_list_it,
    gop_succ_list_it  = gbm_succ_list_it
    \<rparr>"
  local_setup {* Locale_Code.lc_decl_del @{term gbm_ops} *}
end

locale GraphByMap = GraphByMapDefs m1_ops m2_ops s3_ops m1_mvif +
  m1!: StdMap m1_ops +
  m2!: StdMap m2_ops +
  s3!: StdSet s3_ops +
  m1!: map_value_image_filter m1.\<alpha> m1.invar m1.\<alpha> m1.invar m1_mvif
  for m1_ops::"('V,'m2,'m1,_) map_ops_scheme"
  and m2_ops::"('V,'s3,'m2,_) map_ops_scheme"
  and s3_ops::"('W,'s3,_) set_ops_scheme"
  and m1_mvif :: "('V \<Rightarrow> 'm2 \<rightharpoonup> 'm2) \<Rightarrow> 'm1 \<Rightarrow> 'm1"
begin
  lemma gbm_invar_split:
    assumes "gbm_invar g"
    shows
    "m1.invar g"
    "\<And>v m2. m1.\<alpha> g v = Some m2 \<Longrightarrow> m2.invar m2"
    "\<And>v m2 v' s3. m1.\<alpha> g v = Some m2 \<Longrightarrow> m2.\<alpha> m2 v' = Some s3 \<Longrightarrow> s3.invar s3"
    "valid_graph (gbm_\<alpha> g)"
    using assms unfolding gbm_invar_def
    by (auto intro: ranI)

end

sublocale GraphByMap < graph gbm_\<alpha> gbm_invar
proof
  fix g
  assume INV: "gbm_invar g"
  then interpret vg!: valid_graph "(gbm_\<alpha> g)" by (simp add: gbm_invar_def)

  from vg.E_valid
  show "fst ` edges (gbm_\<alpha> g) \<subseteq> nodes (gbm_\<alpha> g)" and
    "snd ` snd ` edges (gbm_\<alpha> g) \<subseteq> nodes (gbm_\<alpha> g)" .

  from INV show "finite (nodes (gbm_\<alpha> g))"
    unfolding gbm_invar_def gbm_\<alpha>_def by auto

  note [simp] = gbm_invar_split[OF INV]

  show "finite (edges (gbm_\<alpha> g))"
    apply (rule finite_imageD[where f="\<lambda>(v,e,v'). (v,v',e)"])
    apply (rule finite_subset[where B=
      "map_Sigma (m1.\<alpha> g) (\<lambda>m2. map_Sigma (m2.\<alpha> m2) (s3.\<alpha>))"])
    apply (auto simp add: map_Sigma_def gbm_\<alpha>_def) []
    apply (unfold map_Sigma_alt)
    apply (auto intro!: finite_SigmaI inj_onI)
    done
qed

context GraphByMap
begin

  lemma gbm_empty_impl:
    "graph_empty gbm_\<alpha> gbm_invar gbm_empty"
    apply (unfold_locales)
    unfolding gbm_\<alpha>_def gbm_invar_def gbm_empty_def
    apply (auto simp: m1.correct Graph.empty_def)
    apply (unfold_locales)
    apply auto
    done

  lemma gbm_add_node_impl:
    "graph_add_node gbm_\<alpha> gbm_invar gbm_add_node"
  proof
    fix g v
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_add_node v g) = add_node v (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_add_node_def
      by (auto simp: m1.correct m2.correct s3.correct add_node_def
        split: option.split split_if_asm)

    thus "gbm_invar (gbm_add_node v g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_add_node_def add_node_def
      apply (auto simp: m1.correct m2.correct s3.correct add_node_def
        split: option.split split_if_asm elim!: ranE)
      done
  qed

  lemma gbm_delete_node_impl:
    "graph_delete_node gbm_\<alpha> gbm_invar gbm_delete_node"
  proof
    fix g v
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_delete_node v g) = delete_node v (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_delete_node_def
      by (auto simp: restrict_map_def option_bind_alt
        m1.correct m2.correct s3.correct m1.map_value_image_filter_correct
        delete_node_def
        split: option.split split_if_asm option.split_asm)

    thus "gbm_invar (gbm_delete_node v g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_delete_node_def delete_node_def
      apply (auto simp: restrict_map_def option_bind_alt
        m1.correct m2.correct s3.correct m1.map_value_image_filter_correct
        split: option.split split_if_asm option.split_asm elim!: ranE)
      done
  qed

  lemma gbm_add_edge_impl:
    "graph_add_edge gbm_\<alpha> gbm_invar gbm_add_edge"
  proof
    fix g v e v'
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_add_edge v e v' g) = add_edge v e v' (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_add_edge_def
      apply (auto simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split split_if_asm)
      unfolding add_edge_def
      (* Strange: This is at the limit of auto's capabilities:
        Iterated auto [] works., but auto on all goals seems not to
        terminate. Using fastforce instead.
        *)
      apply (fastforce split: split_if_asm
        simp: m1.correct m2.correct s3.correct
      )+
      done

    thus "gbm_invar (gbm_add_edge v e v' g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_add_edge_def
      apply (force simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split split_if_asm elim!: ranE)
      done
  qed

  lemma gbm_delete_edge_impl:
    "graph_delete_edge gbm_\<alpha> gbm_invar gbm_delete_edge"
  proof
    fix g v e v'
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_delete_edge v e v' g) = delete_edge v e v' (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_delete_edge_def delete_edge_def
      apply (auto simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split split_if_asm)
      done

    thus "gbm_invar (gbm_delete_edge v e v' g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_delete_edge_def
      apply (auto simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split split_if_asm elim!: ranE)
      done
  qed

  lemma gbm_nodes_list_it_impl:
    shows "graph_nodes_it gbm_\<alpha> gbm_invar gbm_nodes_list_it"
  proof
    fix g
    assume "gbm_invar g"
    hence MINV: "map_op_invar m1_ops g" unfolding gbm_invar_def by auto
    from map_iterator_dom_correct[OF m1.iteratei_correct[OF MINV]]
    show "set_iterator (gbm_nodes_list_it g) (nodes (gbm_\<alpha> g))"
      unfolding gbm_nodes_list_it_def gbm_\<alpha>_def by simp
  qed

  lemma gbm_edges_list_it_impl:
    shows "graph_edges_it gbm_\<alpha> gbm_invar gbm_edges_list_it"
  proof
    fix g
    assume INV: "gbm_invar g"

    from INV have I1: "m1.invar g" unfolding gbm_invar_def by auto
    from INV have I2: "\<And>v m2. (v,m2)\<in>map_to_set (m1.\<alpha> g) \<Longrightarrow> m2.invar m2"
      unfolding gbm_invar_def map_to_set_def
      by (auto simp: ran_def)
    from INV have I3: "\<And>v m2 v' s. \<lbrakk>
      (v,m2)\<in>map_to_set (m1.\<alpha> g);
      (v',s)\<in>map_to_set (m2.\<alpha> m2)\<rbrakk>
      \<Longrightarrow> s3.invar s"
      unfolding gbm_invar_def map_to_set_def
      by (auto simp: ran_def)

    show "set_iterator (gbm_edges_list_it g) (edges (gbm_\<alpha> g))"
      unfolding gbm_edges_list_it_def
      apply (rule set_iterator_image_correct)
      apply (rule set_iterator_product_correct)
      apply (rule m1.iteratei_correct)
      apply (rule I1)
      apply (case_tac a)
      apply clarsimp
      apply (rule set_iterator_product_correct)
      apply (drule I2)
      apply (subgoal_tac "map_iterator (m2.iteratei ba)
        (map_op_\<alpha> m2_ops (snd (aa,ba)))")
      apply assumption
      apply (simp add: m2.iteratei_correct)

      apply (case_tac a)
      apply clarsimp
      apply (subgoal_tac "set_iterator (s3.iteratei bb)
        (s3.\<alpha> (snd (ab,bb)))")
      apply assumption
      apply (simp add: s3.iteratei_correct I3)

      apply (auto simp: inj_on_def map_to_set_def) []

      apply (force simp: gbm_\<alpha>_def map_to_set_def) []
      done
    qed

  lemma gbm_succ_list_it_impl:
    shows "graph_succ_it gbm_\<alpha> gbm_invar gbm_succ_list_it"
  proof
    fix g v
    assume INV: "gbm_invar g"
    hence I1[simp]: "m1.invar g" unfolding gbm_invar_def by auto

    show "set_iterator (gbm_succ_list_it g v) (succ (gbm_\<alpha> g) v)"
    proof (cases "m1.lookup v g")
      case None hence "(succ (gbm_\<alpha> g) v) = {}"
        unfolding succ_def gbm_\<alpha>_def by (auto simp: m1.lookup_correct)
      with None show ?thesis unfolding gbm_succ_list_it_def
        by (auto simp: set_iterator_emp_correct)
    next
      case (Some m2)
      hence [simp]: "m2.invar m2" using gbm_invar_split[OF INV]
        by (simp add: m1.lookup_correct)

      from INV Some have
        I2: "\<And>v' s. (v', s) \<in> map_to_set (map_op_\<alpha> m2_ops m2) \<Longrightarrow> s3.invar s"
        unfolding gbm_invar_def
        by (auto simp: map_to_set_def ran_def m1.lookup_correct)

      from Some show ?thesis
        unfolding gbm_succ_list_it_def apply simp
        apply (rule set_iterator_image_correct)
        apply (rule set_iterator_product_correct)
        apply (rule m2.iteratei_correct)
        apply simp
        apply (case_tac a, simp)
        apply (subgoal_tac "set_iterator (s3.iteratei b) (s3.\<alpha> (snd (aa, b)))")
        apply assumption
        apply simp
        apply (rule s3.iteratei_correct)
        apply (simp add: I2)

        apply (auto simp: inj_on_def map_to_set_def) []

        apply (force simp: succ_def gbm_\<alpha>_def map_to_set_def m1.lookup_correct)
        done
    qed
  qed

  lemma gbm_from_list_impl:
    shows "graph_from_list gbm_\<alpha> gbm_invar gbm_from_list"
    unfolding gbm_from_list_def
    apply (rule gga_from_list_correct)
    apply (rule gbm_empty_impl gbm_add_node_impl gbm_add_edge_impl)+
    done

end

sublocale GraphByMap < graph_nodes_it gbm_\<alpha> gbm_invar gbm_nodes_list_it
  by (rule gbm_nodes_list_it_impl)
sublocale GraphByMap < graph_edges_it gbm_\<alpha> gbm_invar gbm_edges_list_it
  by (rule gbm_edges_list_it_impl)
sublocale GraphByMap < graph_succ_it gbm_\<alpha> gbm_invar gbm_succ_list_it
  by (rule gbm_succ_list_it_impl)

sublocale GraphByMap
  < gga_to_list_loc gbm_\<alpha> gbm_invar gbm_nodes_list_it gbm_edges_list_it
  by unfold_locales

context GraphByMap
begin
  lemma gbm_to_list_impl: "graph_to_list gbm_\<alpha> gbm_invar gga_to_list"
    by (rule gga_to_list_correct)

  lemma gbm_ops_impl: "StdGraph gbm_ops"
    apply (rule StdGraph.intro)
    apply (simp_all add: icf_rec_unf)
    apply icf_locales
    apply (rule gbm_empty_impl gbm_add_node_impl gbm_delete_node_impl
      gbm_add_edge_impl gbm_delete_edge_impl gbm_from_list_impl
      gbm_to_list_impl)+
    done
end

setup {*
  (Record_Intf.add_unf_thms_global @{thms
    GraphByMapDefs.gbm_nodes_list_it_unf
    GraphByMapDefs.gbm_edges_list_it_unf
    GraphByMapDefs.gbm_succ_list_it_unf
  })
*}

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Typed Functions\<close>
theory TFunctions
  imports
    HOL_Basics.LFunctions
    HOTG.Axioms
    Soft_Types.Soft_Types_HOL
begin

overloading
  injective_on_set \<equiv> "injective_on :: set \<Rightarrow> (set \<Rightarrow> 'a) \<Rightarrow> bool"
  injective_on_type \<equiv> "injective_on :: 'a type \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
begin
  definition "injective_on_set A (f :: set \<Rightarrow> 'a) \<equiv> injective_on (mem_of A) f"
  definition "injective_on_type (T :: 'a type) (f :: 'a \<Rightarrow> 'b) \<equiv>
    injective_on (type_pred T) f"
end

lemma injective_on_set_eq_injective_on_pred [simp]:
  "(injective_on :: set \<Rightarrow> (set \<Rightarrow> 'a) \<Rightarrow> bool) A = injective_on (mem_of A)"
  unfolding injective_on_set_def by simp

lemma injective_on_set_iff_injective_on_pred [iff]:
  "injective_on (A :: set) (f :: set \<Rightarrow> 'a) \<longleftrightarrow> injective_on (mem_of A) f"
  by simp

lemma injective_on_type_eq_injective_on_pred [simp]:
  "(injective_on :: 'a type \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool) T = injective_on (type_pred T)"
  unfolding injective_on_type_def by simp

lemma injective_on_type_iff_injective_on_pred [iff]:
  "injective_on (T :: 'a type) (f :: 'a \<Rightarrow> 'b) \<longleftrightarrow> injective_on (type_pred T) f"
  by simp

overloading
  inverse_on_set \<equiv> "inverse_on :: set \<Rightarrow> (set \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> set) \<Rightarrow> bool"
  inverse_on_type \<equiv> "inverse_on :: 'a type \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "inverse_on_set A (f :: set \<Rightarrow> 'a) \<equiv> inverse_on (mem_of A) f"
  definition "inverse_on_type (T :: 'a type) (f :: 'a \<Rightarrow> 'b) \<equiv>
    inverse_on (type_pred T) f"
end

lemma inverse_on_set_eq_inverse_on_pred [simp]:
  "(inverse_on :: set \<Rightarrow> (set \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> set) \<Rightarrow> bool) A = inverse_on (mem_of A)"
  unfolding inverse_on_set_def by simp

lemma inverse_on_set_iff_inverse_on_pred [iff]:
  "inverse_on (A :: set) (f :: set \<Rightarrow> 'a) g \<longleftrightarrow> inverse_on (mem_of A) f g"
  by simp

lemma inverse_on_type_eq_inverse_on_pred [simp]:
  "(inverse_on :: 'a type \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool) T = inverse_on (type_pred T)"
  unfolding inverse_on_type_def by simp

lemma inverse_on_type_iff_inverse_on_pred [iff]:
  "inverse_on (T :: 'a type) (f :: 'a \<Rightarrow> 'b) g \<longleftrightarrow> inverse_on (type_pred T) f g"
  by simp

overloading
  restrict_left_set \<equiv> "restrict_left :: (set \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> set \<Rightarrow>
    (set \<Rightarrow> 'a \<Rightarrow> bool)"
  restrict_left_type \<equiv> "restrict_left :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a type \<Rightarrow>
    ('a \<Rightarrow> 'b \<Rightarrow> bool)"
begin
  definition "restrict_left_set (R :: set \<Rightarrow> _) (A :: set) \<equiv> R\<restriction>\<^bsub>mem_of A\<^esub>"
  definition "restrict_left_type (R :: 'a \<Rightarrow> _) (T :: 'a type) \<equiv> R\<restriction>\<^bsub>type_pred T\<^esub>"
end

lemma restrict_left_set_eq_restrict_left_pred [simp]:
  "restrict_left (R :: set \<Rightarrow> _) (A :: set) = R\<restriction>\<^bsub>mem_of A\<^esub>"
  unfolding restrict_left_set_def by simp

lemma restrict_left_set_iff_restrict_left_pred [iff]:
  "restrict_left (R :: set \<Rightarrow> _) (A :: set) x y \<longleftrightarrow> R\<restriction>\<^bsub>mem_of A\<^esub> x y"
  by simp

lemma restrict_left_type_eq_restrict_left_pred [simp]:
  "restrict_left (R :: 'a \<Rightarrow> _) (T :: 'a type) = R\<restriction>\<^bsub>type_pred T\<^esub>"
  unfolding restrict_left_type_def by simp

lemma restrict_left_type_iff_restrict_left_pred [iff]:
  "restrict_left (R :: 'a \<Rightarrow> _) (T :: 'a type) x y \<longleftrightarrow> R\<restriction>\<^bsub>type_pred T\<^esub> x y"
  by simp

subsection \<open>Types and Monotonicity\<close>

lemma dep_mono_wrt_pred_type_pred_if_Dep_fun_type:
  assumes "f : (x : A) \<Rightarrow> B x"
  shows "([x \<Colon> type_pred A] \<Rrightarrow>\<^sub>m type_pred (B x)) f"
  using assms by (intro dep_mono_wrt_predI) auto

lemma Dep_fun_type_if_dep_mono_wrt_pred_type_pred:
  assumes "([x \<Colon> type_pred A] \<Rrightarrow>\<^sub>m type_pred (B x)) f"
  shows "f : (x : A) \<Rightarrow> B x"
  using assms by auto

corollary dep_mono_wrt_pred_type_pred_iff_Dep_fun_type:
  "([x \<Colon> type_pred A] \<Rrightarrow>\<^sub>m type_pred (B x)) f \<longleftrightarrow> f : (x : A) \<Rightarrow> B x"
  using dep_mono_wrt_pred_type_pred_if_Dep_fun_type
    Dep_fun_type_if_dep_mono_wrt_pred_type_pred
  by blast

soft_type_translation
  "([x \<Colon> type_pred A] \<Rrightarrow>\<^sub>m type_pred (B x)) f" \<rightleftharpoons> "f : (x : A) \<Rightarrow> B x"
  using dep_mono_wrt_pred_type_pred_iff_Dep_fun_type by auto

end


(*  Title:      Word_Type_Copies.thy
    Author:     Florian Haftmann, TU Muenchen
*)

chapter \<open>Systematic approach towards type copies of word type\<close>

theory Word_Type_Copies
  imports
    "HOL-Library.Word"
    "Word_Lib.Most_significant_bit"
    "Word_Lib.Least_significant_bit"
    "Word_Lib.Generic_set_bit"
    "Word_Lib.Bit_Comprehension"
    "Code_Target_Word_Base"
begin

text \<open>The lifting machinery is not localized, hence the abstract proofs are carried out using morphisms.\<close>

locale word_type_copy =
  fixes of_word :: \<open>'b::len word \<Rightarrow> 'a\<close>
    and word_of :: \<open>'a \<Rightarrow> 'b word\<close>
  assumes type_definition: \<open>type_definition word_of of_word UNIV\<close>
begin

lemma word_of_word:
  \<open>word_of (of_word w) = w\<close>
  using type_definition by (simp add: type_definition_def)

lemma of_word_of [code abstype]:
  \<open>of_word (word_of p) = p\<close>
    \<comment> \<open>Use an abstract type for code generation to disable pattern matching on \<^term>\<open>of_word\<close>.\<close>
  using type_definition by (simp add: type_definition_def)

lemma word_of_eqI:
  \<open>p = q\<close> if \<open>word_of p = word_of q\<close>
proof -
  from that have \<open>of_word (word_of p) = of_word (word_of q)\<close>
    by simp
  then show ?thesis
    by (simp add: of_word_of)
qed

lemma eq_iff_word_of:
  \<open>p = q \<longleftrightarrow> word_of p = word_of q\<close>
  by (auto intro: word_of_eqI)

end

bundle constraintless
begin

declaration \<open>
  let
    val cs = map (rpair NONE o fst o dest_Const)
      [\<^term>\<open>0\<close>, \<^term>\<open>(+)\<close>, \<^term>\<open>uminus\<close>, \<^term>\<open>(-)\<close>,
       \<^term>\<open>1\<close>, \<^term>\<open>(*)\<close>, \<^term>\<open>(div)\<close>, \<^term>\<open>(mod)\<close>,
       \<^term>\<open>HOL.equal\<close>, \<^term>\<open>(\<le>)\<close>, \<^term>\<open>(<)\<close>,
       \<^term>\<open>(dvd)\<close>, \<^term>\<open>of_bool\<close>, \<^term>\<open>numeral\<close>, \<^term>\<open>of_nat\<close>,
       \<^term>\<open>bit\<close>,
       \<^term>\<open>Bit_Operations.not\<close>, \<^term>\<open>Bit_Operations.and\<close>, \<^term>\<open>Bit_Operations.or\<close>, \<^term>\<open>Bit_Operations.xor\<close>, \<^term>\<open>mask\<close>,
       \<^term>\<open>push_bit\<close>, \<^term>\<open>drop_bit\<close>, \<^term>\<open>take_bit\<close>,
       \<^term>\<open>Bit_Operations.set_bit\<close>, \<^term>\<open>unset_bit\<close>, \<^term>\<open>flip_bit\<close>,
       \<^term>\<open>msb\<close>, \<^term>\<open>lsb\<close>, \<^term>\<open>size\<close>, \<^term>\<open>Generic_set_bit.set_bit\<close>, \<^term>\<open>set_bits\<close>]
  in
    K (Context.mapping I (fold Proof_Context.add_const_constraint cs))
  end
\<close>

end

locale word_type_copy_ring = word_type_copy
  opening constraintless +
  constrains word_of :: \<open>'a \<Rightarrow> 'b::len word\<close>
  assumes word_of_0 [code]: \<open>word_of 0 = 0\<close>
    and word_of_1 [code]: \<open>word_of 1 = 1\<close>
    and word_of_add [code]: \<open>word_of (p + q) = word_of p + word_of q\<close>
    and word_of_minus [code]: \<open>word_of (- p) = - (word_of p)\<close>
    and word_of_diff [code]: \<open>word_of (p - q) = word_of p - word_of q\<close>
    and word_of_mult [code]: \<open>word_of (p * q) = word_of p * word_of q\<close>
    and word_of_div [code]: \<open>word_of (p div q) = word_of p div word_of q\<close>
    and word_of_mod [code]: \<open>word_of (p mod q) = word_of p mod word_of q\<close>
    and equal_iff_word_of [code]: \<open>HOL.equal p q \<longleftrightarrow> HOL.equal (word_of p) (word_of q)\<close>
    and less_eq_iff_word_of [code]: \<open>p \<le> q \<longleftrightarrow> word_of p \<le> word_of q\<close>
    and less_iff_word_of [code]: \<open>p < q \<longleftrightarrow> word_of p < word_of q\<close>
begin

lemma of_class_comm_ring_1:
  \<open>OFCLASS('a, comm_ring_1_class)\<close>
  by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1
    word_of_add word_of_minus word_of_diff word_of_mult algebra_simps)

lemma of_class_semiring_modulo:
  \<open>OFCLASS('a, semiring_modulo_class)\<close>
  by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1
    word_of_add word_of_minus word_of_diff word_of_mult word_of_mod word_of_div algebra_simps
    mod_mult_div_eq)

lemma of_class_equal:
  \<open>OFCLASS('a, equal_class)\<close>
  by standard (simp add: eq_iff_word_of equal_iff_word_of equal)

lemma of_class_linorder:
  \<open>OFCLASS('a, linorder_class)\<close>
  by standard (auto simp add: eq_iff_word_of less_eq_iff_word_of less_iff_word_of)

end

locale word_type_copy_bits = word_type_copy_ring
  opening constraintless bit_operations_syntax +
  constrains word_of :: \<open>'a::{comm_ring_1, semiring_modulo, equal, linorder} \<Rightarrow> 'b::len word\<close>
  fixes signed_drop_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  assumes bit_eq_word_of [code]: \<open>bit p = bit (word_of p)\<close>
    and word_of_not [code]: \<open>word_of (NOT p) = NOT (word_of p)\<close>
    and word_of_and [code]: \<open>word_of (p AND q) = word_of p AND word_of q\<close>
    and word_of_or [code]: \<open>word_of (p OR q) = word_of p OR word_of q\<close>
    and word_of_xor [code]: \<open>word_of (p XOR q) = word_of p XOR word_of q\<close>
    and word_of_mask [code]: \<open>word_of (mask n) = mask n\<close>
    and word_of_push_bit [code]: \<open>word_of (push_bit n p) = push_bit n (word_of p)\<close>
    and word_of_drop_bit [code]: \<open>word_of (drop_bit n p) = drop_bit n (word_of p)\<close>
    and word_of_signed_drop_bit [code]: \<open>word_of (signed_drop_bit n p) = Word.signed_drop_bit n (word_of p)\<close>
    and word_of_take_bit [code]: \<open>word_of (take_bit n p) = take_bit n (word_of p)\<close>
    and word_of_set_bit [code]: \<open>word_of (Bit_Operations.set_bit n p) = Bit_Operations.set_bit n (word_of p)\<close>
    and word_of_unset_bit [code]: \<open>word_of (unset_bit n p) = unset_bit n (word_of p)\<close>
    and word_of_flip_bit [code]: \<open>word_of (flip_bit n p) = flip_bit n (word_of p)\<close>
begin

lemma word_of_bool:
  \<open>word_of (of_bool n) = of_bool n\<close>
  by (simp add: word_of_0 word_of_1)

lemma word_of_nat:
  \<open>word_of (of_nat n) = of_nat n\<close>
  by (induction n) (simp_all add: word_of_0 word_of_1 word_of_add)

lemma word_of_numeral [simp]:
  \<open>word_of (numeral n) = numeral n\<close>
proof -
  have \<open>word_of (of_nat (numeral n)) = of_nat (numeral n)\<close>
    by (simp only: word_of_nat)
  then show ?thesis by simp
qed

lemma word_of_power:
  \<open>word_of (p ^ n) = word_of p ^ n\<close>
  by (induction n) (simp_all add: word_of_1 word_of_mult)

lemma even_iff_word_of:
  \<open>2 dvd p \<longleftrightarrow> 2 dvd word_of p\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?P
  then obtain q where \<open>p = 2 * q\<close> ..
  then show ?Q by (simp add: word_of_mult)
next
  assume ?Q
  then obtain w where \<open>word_of p = 2 * w\<close> ..
  then have \<open>of_word (word_of p) = of_word (2 * w)\<close>
    by simp
  then have \<open>p = 2 * of_word w\<close>
    by (simp add: eq_iff_word_of word_of_word word_of_mult)
  then show ?P
    by simp
qed

lemma of_class_ring_bit_operations:
  \<open>OFCLASS('a, ring_bit_operations_class)\<close>
proof -
  have induct: \<open>P p\<close> if stable: \<open>(\<And>p. p div 2 = p \<Longrightarrow> P p)\<close>
      and rec: \<open>(\<And>p b. P p \<Longrightarrow> (of_bool b + 2 * p) div 2 = p \<Longrightarrow> P (of_bool b + 2 * p))\<close>
    for p :: 'a and P
  proof -
    from stable have stable': \<open>(\<And>p. word_of p div 2 = word_of p \<Longrightarrow> P p)\<close>
      by (simp add: eq_iff_word_of word_of_div)
    from rec have rec': \<open>(\<And>p b. P p \<Longrightarrow> (of_bool b + 2 * word_of p) div 2 = word_of p \<Longrightarrow> P (of_bool b + 2 * p))\<close>
      by (simp add: eq_iff_word_of word_of_add word_of_bool word_of_mult word_of_div)
    define w where \<open>w = word_of p\<close>
    then have \<open>p = of_word w\<close>
      by (simp add: of_word_of)
    also have \<open>P (of_word w)\<close>
    proof (induction w rule: bits_induct)
      case (stable w)
      show ?case
        by (rule stable') (simp add: word_of_word stable)
    next
      case (rec w b)
      have \<open>P (of_bool b + 2 * of_word w)\<close>
        by (rule rec') (simp_all add: word_of_word rec)
      also have \<open>of_bool b + 2 * of_word w = of_word (of_bool b + 2 * w)\<close>
        by (simp add: eq_iff_word_of word_of_word word_of_add word_of_1 word_of_mult word_of_0)
      finally show ?case .
    qed
    finally show \<open>P p\<close> .
  qed
  have \<open>class.semiring_parity_axioms (+) (0::'a) (*) 1 (mod)\<close>
    by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1 even_iff_word_of word_of_mod even_iff_mod_2_eq_zero)
  with of_class_semiring_modulo have \<open>OFCLASS('a, semiring_parity_class)\<close>
    by (rule semiring_parity_class.intro)
  moreover have \<open>class.semiring_bits_axioms (+) (-) (0::'a) (*) 1 (div) (mod) bit\<close>
    apply (standard, fact induct)
    apply (simp_all only: eq_iff_word_of word_of_0 word_of_1 word_of_bool word_of_numeral
      word_of_add word_of_diff word_of_mult word_of_div word_of_mod word_of_power even_iff_word_of
      bit_eq_word_of push_bit_take_bit drop_bit_take_bit
      even_drop_bit_iff_not_bit
      flip: push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod mask_eq_exp_minus_1)
               apply (auto simp add: ac_simps bit_simps drop_bit_exp_eq)
    done
  ultimately have \<open>OFCLASS('a, semiring_bits_class)\<close>
    by (rule semiring_bits_class.intro)
  moreover have \<open>class.semiring_bit_operations_axioms (+) (-) (*) (1::'a) (div) (mod) bit (AND) (OR) (XOR) mask Bit_Operations.set_bit unset_bit flip_bit push_bit drop_bit take_bit\<close>
    by standard
      (simp_all add: eq_iff_word_of word_of_push_bit word_of_power
      bit_eq_word_of word_of_and word_of_or word_of_xor word_of_mask word_of_diff word_of_1 bit_simps
      word_of_set_bit set_bit_eq_or word_of_unset_bit word_of_flip_bit flip_bit_eq_xor
      word_of_mult
      word_of_drop_bit word_of_div word_of_take_bit word_of_mod
      flip: mask_eq_exp_minus_1 push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod)
  ultimately have \<open>OFCLASS('a, semiring_bit_operations_class)\<close>
    by (rule semiring_bit_operations_class.intro)
  moreover have \<open>OFCLASS('a, ring_parity_class)\<close>
    using \<open>OFCLASS('a, semiring_parity_class)\<close> by (rule ring_parity_class.intro) standard
  moreover have \<open>class.ring_bit_operations_axioms (+) (-) (0::'a) (*) 1 bit uminus NOT\<close>
    by standard (simp_all add: eq_iff_word_of word_of_power
      bit_eq_word_of word_of_diff word_of_1 bit_simps linorder_not_le
      word_of_not word_of_0
      word_of_minus minus_eq_not_minus_1)
  ultimately show \<open>OFCLASS('a, ring_bit_operations_class)\<close>
    by (rule ring_bit_operations_class.intro)
qed

lemma [code]:
  \<open>mask (Suc n) = push_bit n (1 :: 'a) OR mask n\<close>
  \<open>mask 0 = (0 :: 'a)\<close>
  by (simp_all add: eq_iff_word_of word_of_mask word_of_or word_of_push_bit word_of_0 word_of_1 mask_Suc_exp)

lemma [code]:
  \<open>Bit_Operations.set_bit n w = w OR push_bit n 1\<close> for w :: 'a
  by (simp add: eq_iff_word_of word_of_set_bit word_of_or word_of_push_bit word_of_1 set_bit_eq_or)

lemma [code]:
  \<open>unset_bit n w = w AND NOT (push_bit n 1)\<close> for w :: 'a
  by (simp add: eq_iff_word_of word_of_unset_bit word_of_and word_of_not word_of_push_bit word_of_1 unset_bit_eq_and_not)

lemma [code]:
  \<open>flip_bit n w = w XOR push_bit n 1\<close> for w :: 'a
  by (simp add: eq_iff_word_of word_of_flip_bit word_of_xor word_of_push_bit word_of_1 flip_bit_eq_xor)

end

locale word_type_copy_more = word_type_copy_bits +
  constrains word_of :: \<open>'a::{ring_bit_operations, equal, linorder} \<Rightarrow> 'b::len word\<close>
  fixes of_nat :: \<open>nat \<Rightarrow> 'a\<close> and nat_of :: \<open>'a \<Rightarrow> nat\<close>
    and of_int :: \<open>int \<Rightarrow> 'a\<close> and int_of :: \<open>'a \<Rightarrow> int\<close>
    and of_integer :: \<open>integer \<Rightarrow> 'a\<close> and integer_of :: \<open>'a \<Rightarrow> integer\<close>
  assumes word_of_nat_eq: \<open>word_of (of_nat n) = word_of_nat n\<close>
    and nat_of_eq_word_of: \<open>nat_of p = unat (word_of p)\<close>
    and word_of_int_eq: \<open>word_of (of_int k) = word_of_int k\<close>
    and int_of_eq_word_of: \<open>int_of p = uint (word_of p)\<close>
    and word_of_integer_eq: \<open>word_of (of_integer l) = word_of_integer l\<close>
    and integer_of_eq_word_of: \<open>integer_of p = unsigned (word_of p)\<close>
begin

lemma of_word_numeral [code_post]:
  \<open>of_word (numeral n) = numeral n\<close>
  by (simp add: eq_iff_word_of word_of_word)

lemma of_word_0 [code_post]:
  \<open>of_word 0 = 0\<close>
  by (simp add: eq_iff_word_of word_of_0 word_of_word)

lemma of_word_1 [code_post]:
  \<open>of_word 1 = 1\<close>
  by (simp add: eq_iff_word_of word_of_1 word_of_word)

text \<open>Use pretty numerals from integer for pretty printing\<close>

lemma numeral_eq_integer [code_unfold]:
  \<open>numeral n = of_integer (numeral n)\<close>
  by (simp add: eq_iff_word_of word_of_integer_eq)

lemma neg_numeral_eq_integer [code_unfold]:
  \<open>- numeral n = of_integer (- numeral n)\<close>
  by (simp add: eq_iff_word_of word_of_integer_eq word_of_minus)

end

locale word_type_copy_misc = word_type_copy_more
  opening constraintless bit_operations_syntax +
  constrains word_of :: \<open>'a::{ring_bit_operations, equal, linorder} \<Rightarrow> 'b::len word\<close>
  fixes size :: nat and set_bits_aux :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
    assumes size_eq_length: \<open>size = LENGTH('b::len)\<close>
    and msb_iff_word_of [code]: \<open>msb p \<longleftrightarrow> msb (word_of p)\<close>
    and lsb_iff_word_of [code]: \<open>lsb p \<longleftrightarrow> lsb (word_of p)\<close>
    and size_eq_word_of: \<open>Nat.size (p :: 'a) = Nat.size (word_of p)\<close>
    and word_of_generic_set_bit [code]: \<open>word_of (Generic_set_bit.set_bit p n b) = Generic_set_bit.set_bit (word_of p) n b\<close>
    and word_of_set_bits: \<open>word_of (set_bits P) = set_bits P\<close>
    and word_of_set_bits_aux: \<open>word_of (set_bits_aux P n p) = Bit_Comprehension.set_bits_aux P n (word_of p)\<close>
begin

lemma size_eq [code]:
  \<open>Nat.size p = size\<close> for p :: 'a
  by (simp add: size_eq_length size_eq_word_of word_size)

lemma set_bits_aux_code [code]:
  \<open>set_bits_aux f n w =
  (if n = 0 then w
   else let n' = n - 1 in set_bits_aux f n' (push_bit 1 w OR (if f n' then 1 else 0)))\<close>
  by (simp add: eq_iff_word_of word_of_set_bits_aux Let_def word_of_mult word_of_or word_of_0 word_of_1 set_bits_aux_rec [of f n])

lemma set_bits_code [code]: \<open>set_bits P = set_bits_aux P size 0\<close>
  by (simp add: fun_eq_iff eq_iff_word_of word_of_set_bits word_of_set_bits_aux word_of_0 size_eq_length set_bits_conv_set_bits_aux)

lemma of_class_lsb:
  \<open>OFCLASS('a, lsb_class)\<close>
  by standard (simp add: fun_eq_iff lsb_iff_word_of even_iff_word_of lsb_odd)

lemma of_class_set_bit:
  \<open>OFCLASS('a, set_bit_class)\<close>
  by standard (simp add: eq_iff_word_of word_of_generic_set_bit bit_eq_word_of word_of_power word_of_0 bit_simps linorder_not_le)

lemma of_class_bit_comprehension:
  \<open>OFCLASS('a, bit_comprehension_class)\<close>
  by standard (simp add: eq_iff_word_of word_of_set_bits bit_eq_word_of set_bits_bit_eq)

end

end