theory EWD840
  imports "HOL-TLA.TLA"
begin

section Utilities

text \<open>A handful of general lemmas that were useful along the way.\<close>

lemma temp_impI:
  assumes "sigma \<Turnstile> P \<Longrightarrow> sigma \<Turnstile> Q"
  shows "sigma \<Turnstile> P \<longrightarrow> Q"
  using assms by simp

lemma imp_leadsto_reflexive: "\<turnstile> S \<longrightarrow> (F \<leadsto> F)" using LatticeReflexivity [where F = F] by auto

lemma imp_leadsto_transitive:
  assumes "\<turnstile> S \<longrightarrow> (F \<leadsto> G)" "\<turnstile> S \<longrightarrow> (G \<leadsto> H)"
  shows "\<turnstile> S \<longrightarrow> (F \<leadsto> H)"
proof (intro tempI temp_impI)
  fix sigma
  assume S: "S sigma"
  with assms have 1: "sigma \<Turnstile> (F \<leadsto> G)" "sigma \<Turnstile> (G \<leadsto> H)"
    by (auto simp add: Valid_def)

  from 1 LatticeTransitivity [where F = F and G = G and H = H]
  show "sigma \<Turnstile> F \<leadsto> H"
    by (auto simp add: Valid_def)
qed

lemma imp_leadsto_diamond:
  assumes "\<turnstile> S \<longrightarrow> (A \<leadsto> (B \<or> C))"
  assumes "\<turnstile> S \<longrightarrow> (B \<leadsto> D)"
  assumes "\<turnstile> S \<longrightarrow> (C \<leadsto> D)"
  shows   "\<turnstile> S \<longrightarrow> (A \<leadsto> D)"
proof (intro tempI temp_impI)
  fix sigma
  assume S: "sigma \<Turnstile> S"
  with assms have
    ABC: "sigma \<Turnstile> A \<leadsto> (B \<or> C)" and
    BD:  "sigma \<Turnstile> B \<leadsto> D" and
    CD:  "sigma \<Turnstile> C \<leadsto> D"
    by (auto simp add: Valid_def)
  with LatticeDiamond [where A = A and B = B and C = C and D = D]
  show "sigma \<Turnstile> A \<leadsto> D"
    by (auto simp add: Valid_def)
qed

lemma temp_conj_eq_imp:
  assumes "\<turnstile> P \<longrightarrow> (Q = R)"
  shows "\<turnstile> (P \<and> Q) = (P \<and> R)"
  using assms by (auto simp add: Valid_def)

text \<open>The following lemma is particularly useful for a system that makes
some progress which either reaches the desired state directly or which leaves it in
a state that is definitely not the desired state but from which it can reach the desired state via
some further progress.\<close>

lemma imp_leadsto_triangle_excl:
  assumes AB: "\<turnstile> S \<longrightarrow> (A \<leadsto> B)"
  assumes BC: "\<turnstile> S \<longrightarrow> ((B \<and> \<not>C) \<leadsto> C)"
  shows "\<turnstile> S \<longrightarrow> (A \<leadsto> C)"
proof -
  have "\<turnstile> ((B \<and> \<not>C) \<or> (B \<and> C)) = B" by auto
  from inteq_reflection [OF this] AB have ABCBC: "\<turnstile> S \<longrightarrow> (A \<leadsto> ((B \<and> \<not>C) \<or> (B \<and> C)))" by simp

  show ?thesis
  proof (intro imp_leadsto_diamond [OF ABCBC] BC)
    from ImplLeadsto_simple [where F = "LIFT (B \<and> C)"]
    show "\<turnstile> S \<longrightarrow> (B \<and> C \<leadsto> C)"
      by (auto simp add: Valid_def)
  qed
qed

text \<open>An action that updates a single value of a function.\<close>

definition updatedFun :: "('a \<Rightarrow> 'b) stfun \<Rightarrow> 'a \<Rightarrow> 'b trfun \<Rightarrow> action" where
  "updatedFun f x v \<equiv> ACT (\<forall>n. id<f$,#n> = (if #n = #x then v else id<$f,#n>))"

section Nodes

text \<open>There is a fixed, finite, set of nodes, which are numbered. Introduce a distinct type
for node identifiers, and an ordering relation, and an induction principle.\<close>

axiomatization NodeCount :: nat where NodeCount_positive: "NodeCount > 0"

typedef Node = "{0..<NodeCount}" using NodeCount_positive by auto

definition FirstNode    :: Node where "FirstNode == Abs_Node 0"
definition LastNode     :: Node where "LastNode  == Abs_Node (NodeCount-1)"
definition PreviousNode :: "Node \<Rightarrow> Node" where "PreviousNode == \<lambda>n. Abs_Node (Rep_Node n - 1)"

instantiation Node :: linorder
begin
definition less_eq_Node :: "Node \<Rightarrow> Node \<Rightarrow> bool" where "n \<le> m \<equiv> Rep_Node n \<le> Rep_Node m"
definition less_Node    :: "Node \<Rightarrow> Node \<Rightarrow> bool" where "n < m \<equiv> Rep_Node n < Rep_Node m"

instance proof
  show "\<And>(x::Node) y. (x < y) = (x \<le> y \<and> \<not> y \<le> x)" using less_Node_def less_eq_Node_def by force
  show "\<And>(x::Node). x \<le> x" using less_eq_Node_def by force
  show "\<And>(x::Node) y z. x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z" using less_eq_Node_def by force
  show "\<And>(x::Node) y. x \<le> y \<or> y \<le> x" using less_eq_Node_def by force
  show "\<And>(x::Node) y. x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y" using less_Node_def less_eq_Node_def
    by (simp add: Rep_Node_inject)
qed
end

lemma PreviousNode_fixed_point:
  assumes "n = PreviousNode n"
  shows "n = FirstNode"
  using assms
  unfolding PreviousNode_def FirstNode_def
  by (metis Abs_Node_inject One_nat_def Rep_Node Rep_Node_inverse atLeastLessThan_iff cancel_comm_monoid_add_class.diff_cancel diff_Suc_less diff_le_self le_less_trans le_neq_implies_less not_le)

lemma Node_gt_PreviousNode:
  assumes "n \<noteq> FirstNode"
  shows "m > (PreviousNode n) = (m > n \<or> m = n)"
  using assms unfolding PreviousNode_def less_Node_def FirstNode_def
  by (smt Abs_Node_inverse Rep_Node Rep_Node_inject atLeastLessThan_iff diff_Suc_1 diff_is_0_eq' diff_le_self le_add_diff_inverse less_Suc_eq_le not_le_imp_less not_less_iff_gr_or_eq)

lemma Node_gt_ne: "(m::Node) > n \<Longrightarrow> m \<noteq> n" unfolding less_Node_def by blast

lemma Node_gt_LastNode [simp]: "n > LastNode = False"
  unfolding LastNode_def less_Node_def
  using Abs_Node_inverse NodeCount_positive Rep_Node not_less_eq by auto

lemma Node_induct [case_names FirstNode PreviousNode]:
  assumes FirstNode: "P FirstNode"
  assumes PreviousNode: "\<And>n. n \<noteq> FirstNode \<Longrightarrow> P (PreviousNode n) \<Longrightarrow> P n"
  shows "P n"
proof -
  define n_num where "n_num == Rep_Node n"
  have n_eq: "n = Abs_Node n_num"
    by (simp add: Rep_Node_inverse n_num_def)

  have "n_num < NodeCount" using Rep_Node n_num_def by auto
  thus ?thesis
    unfolding n_eq
  proof (induct n_num)
    case 0 with FirstNode show ?case by (simp add: FirstNode_def)
  next
    case (Suc n_num)
    hence hyp: "P (Abs_Node n_num)" by auto

    show ?case
    proof (rule PreviousNode)
      show "Abs_Node (Suc n_num) \<noteq> FirstNode" unfolding FirstNode_def
        by (simp add: Abs_Node_inject NodeCount_positive Suc.prems)
      from hyp Suc.prems show " P (PreviousNode (Abs_Node (Suc n_num)))"
        unfolding PreviousNode_def by (simp add: Abs_Node_inverse)
    qed
  qed
qed

datatype TerminationState = MaybeTerminated | NotTerminated

axiomatization
  isNodeActive  :: "(Node \<Rightarrow> bool) stfun" and
  nodeState     :: "(Node \<Rightarrow> TerminationState) stfun" and
  tokenPosition :: "Node stfun" and
  tokenState    :: "TerminationState stfun"
  where
  ewd_basevars: "basevars (isNodeActive, nodeState, tokenPosition, tokenState)"

definition StartState :: stpred where
  "StartState == PRED tokenPosition = #FirstNode \<and> tokenState = #NotTerminated"

definition InitiateProbe :: action where
  "InitiateProbe == ACT
    (($tokenPosition = #FirstNode)
    \<and> ($tokenState = #NotTerminated \<or> id<$nodeState,#FirstNode> = #NotTerminated)
    \<and> tokenPosition$ = #LastNode
    \<and> tokenState$ = #MaybeTerminated
    \<and> (unchanged isNodeActive)
    \<and> (updatedFun nodeState FirstNode (const MaybeTerminated)))"

definition PassToken :: "Node \<Rightarrow> action" where
  "PassToken i == ACT
    (($tokenPosition = #i)
    \<and> ($tokenPosition \<noteq> #FirstNode)
    \<and> (\<not> id<$isNodeActive,#i> \<or> id<$nodeState,#i> = #NotTerminated \<or> $tokenState = #NotTerminated)
    \<and> (tokenPosition$ = PreviousNode<$tokenPosition>)
    \<and> (tokenState$ = (if id<$nodeState,#i> = #NotTerminated then #NotTerminated else $tokenState))
    \<and> (unchanged isNodeActive)
    \<and> (updatedFun nodeState i (const MaybeTerminated)))"

definition SendMsg :: "Node \<Rightarrow> action" where
  "SendMsg i == ACT
    id<$isNodeActive,#i>
    \<and> (\<exists> j. #j \<noteq> #i \<and> (updatedFun isNodeActive j (const True))
                     \<and> (updatedFun nodeState i (ACT if #i < #j then #NotTerminated else id<$nodeState,#i>)))
    \<and> unchanged (tokenPosition, tokenState)"

definition Deactivate :: "Node \<Rightarrow> action" where
  "Deactivate i == ACT
    id<$isNodeActive,#i>
    \<and> (updatedFun isNodeActive i (const False))
    \<and> unchanged (tokenPosition, tokenState, nodeState)"

definition Controlled :: action where
  "Controlled \<equiv> ACT (InitiateProbe \<or> (\<exists> n. PassToken n))"

definition Environment :: action where
  "Environment \<equiv> ACT (\<exists> n. SendMsg n \<or> Deactivate n)"

definition Next :: action where
  "Next \<equiv> ACT (Controlled \<or> Environment)"

definition Fairness :: temporal where
  "Fairness \<equiv> TEMP WF(Controlled)_(isNodeActive,nodeState,tokenPosition,tokenState)"

definition Spec :: temporal where
  "Spec \<equiv> TEMP (Init StartState \<and> \<box>[Next]_(isNodeActive,nodeState,tokenPosition,tokenState) \<and> Fairness)"

definition TerminationDetected :: stpred where
  "TerminationDetected \<equiv> PRED
    (tokenPosition = #FirstNode
    \<and> tokenState = #MaybeTerminated
    \<and> id<nodeState,#FirstNode> = #MaybeTerminated
    \<and> \<not> id<isNodeActive,#FirstNode>)"

lemma angle_Controlled_lifted: "\<turnstile> <Controlled>_(isNodeActive, nodeState, tokenPosition, tokenState) = Controlled"
  unfolding angle_def Controlled_def InitiateProbe_def PassToken_def updatedFun_def
  using PreviousNode_fixed_point by auto

lemmas angle_Controlled = inteq_reflection [OF angle_Controlled_lifted]

lemma basevars_arbitrary:
  assumes "\<And>u. \<lbrakk> tokenPosition u = A; tokenState u = B; isNodeActive u = C; nodeState u = D \<rbrakk> \<Longrightarrow> P"
  shows P
  using assms ewd_basevars unfolding basevars_def surj_def apply auto by metis

lemma enabled_controlled_lifted:
  "\<turnstile> Enabled Controlled
      = (tokenState = #NotTerminated \<or> id<nodeState, tokenPosition> = #NotTerminated \<or> (tokenPosition \<noteq> #FirstNode \<and> \<not> id<isNodeActive, tokenPosition>))"
proof -
  have 1: "\<turnstile> Enabled Controlled = (Enabled InitiateProbe \<or> Enabled (\<exists>n. PassToken n))"
    unfolding Controlled_def
    using enabled_disj by simp

  have 2: "\<turnstile> Enabled InitiateProbe = (tokenPosition = #FirstNode \<and> (tokenState = #NotTerminated \<or> id<nodeState, #FirstNode> = #NotTerminated))"
  proof (intro intI)
    fix w
    show "w \<Turnstile> Enabled InitiateProbe = (tokenPosition = #FirstNode \<and> (tokenState = #NotTerminated \<or> id<nodeState, #FirstNode> = #NotTerminated))"
      apply (rule basevars_arbitrary [of LastNode MaybeTerminated "isNodeActive w" "\<lambda>n. if n = FirstNode then MaybeTerminated else nodeState w n"])
      unfolding InitiateProbe_def enabled_def updatedFun_def
      by auto
  qed

  have 3: "\<turnstile> Enabled (\<exists>n. PassToken n) = ((tokenPosition \<noteq> #FirstNode \<and> (\<not> id<isNodeActive, tokenPosition> \<or> id<nodeState, tokenPosition> = #NotTerminated \<or> tokenState = #NotTerminated)))"
  proof (intro intI)
    fix w
    show "w \<Turnstile> Enabled (\<exists>n. PassToken n) = ((tokenPosition \<noteq> #FirstNode \<and> (\<not> id<isNodeActive, tokenPosition> \<or> id<nodeState, tokenPosition> = #NotTerminated \<or> tokenState = #NotTerminated)))"
      apply (rule basevars_arbitrary [of "PreviousNode (tokenPosition w)" "if nodeState w (tokenPosition w) = NotTerminated then NotTerminated else tokenState w" "isNodeActive w" "\<lambda>n. if n = tokenPosition w then MaybeTerminated else nodeState w n"])
      unfolding PassToken_def enabled_def updatedFun_def
      by auto
  qed

  have 4:
    "\<turnstile> Enabled Controlled = ((tokenPosition = #FirstNode \<and> (tokenState = #NotTerminated \<or> id<nodeState, #FirstNode> = #NotTerminated))
          \<or> (tokenPosition \<noteq> #FirstNode \<and> (\<not> id<isNodeActive, tokenPosition> \<or> id<nodeState, tokenPosition> = #NotTerminated \<or> tokenState = #NotTerminated)))"
    unfolding inteq_reflection [OF 1]
      inteq_reflection [OF 2]
      inteq_reflection [OF 3]
    by auto

  show ?thesis
    unfolding inteq_reflection [OF 4] by auto
qed

lemmas enabled_controlled = inteq_reflection [OF enabled_controlled_lifted]

section Safety

text \<open>The safety property of the algorithm says that termination is detected only if all nodes
are inactive. The proof works by showing that the safety invariant is actually an invariant,
and that this invariant implies the desired safety property.\<close>

definition AllNodesInactive :: stpred where
  "AllNodesInactive \<equiv> PRED (\<forall> n. \<not> id<isNodeActive,#n>)"

definition SafetyInvariant where
  "SafetyInvariant \<equiv> PRED
    (\<forall> n. (tokenPosition < #n) \<longrightarrow> \<not> id<isNodeActive,#n>)
    \<or> (\<exists> n. #n \<le> tokenPosition \<and> id<nodeState,#n> = #NotTerminated)
    \<or> tokenState = #NotTerminated"

lemma safety:
  shows "\<turnstile> Spec \<longrightarrow> \<box>(TerminationDetected \<longrightarrow> AllNodesInactive)"
proof -
  have "\<turnstile> Spec \<longrightarrow> \<box>SafetyInvariant"
  proof invariant
    fix sigma
    assume s: "Spec sigma"
    thus "sigma \<Turnstile> Init SafetyInvariant"
      by (auto simp add: Spec_def SafetyInvariant_def StartState_def Init_def)

    show "sigma \<Turnstile> stable SafetyInvariant"
    proof (intro Stable)
      from s show "sigma \<Turnstile> \<box>[Next]_(isNodeActive, nodeState, tokenPosition, tokenState)"
        by (simp add: Spec_def)

      show "\<turnstile> $SafetyInvariant \<and> [Next]_(isNodeActive, nodeState, tokenPosition, tokenState) \<longrightarrow> SafetyInvariant$"
      proof clarsimp
        fix s t
        assume s: "SafetyInvariant s"
          and st: "(s, t) \<Turnstile> [Next]_(isNodeActive, nodeState, tokenPosition, tokenState)"

        from st have
          "((s, t) \<Turnstile> InitiateProbe)
           \<or> (\<exists>n. (s, t) \<Turnstile> PassToken n)
           \<or> (\<exists>n. (s, t) \<Turnstile> SendMsg n)
           \<or> (\<exists>n. (s, t) \<Turnstile> Deactivate n)
           \<or> ((s, t) \<Turnstile> unchanged (isNodeActive, nodeState, tokenPosition, tokenState))"
          by (auto simp add: square_def Next_def Controlled_def Environment_def)

        thus "SafetyInvariant t"
        proof (elim disjE conjE exE)
          assume "(s, t) \<Turnstile> unchanged (isNodeActive, nodeState, tokenPosition, tokenState)"
          with s show "SafetyInvariant t" by (simp add: SafetyInvariant_def)
        next
          assume "InitiateProbe (s, t)"
          hence step:
                "tokenPosition s = FirstNode" "tokenState s = NotTerminated \<or> nodeState s FirstNode = NotTerminated"
                "tokenPosition t = LastNode" "tokenState t = MaybeTerminated" "isNodeActive t = isNodeActive s"
                "\<And>n. nodeState t n = (if n = FirstNode then MaybeTerminated else nodeState s n)"
            unfolding InitiateProbe_def updatedFun_def
            by auto

          note step_simps[simp] = `tokenPosition s = FirstNode` `tokenPosition t = LastNode` `tokenState t = MaybeTerminated` `isNodeActive t = isNodeActive s`
            `\<And>n. nodeState t n = (if n = FirstNode then MaybeTerminated else nodeState s n)`

          show "SafetyInvariant t"
            unfolding SafetyInvariant_def
            apply (auto simp add: less_Node_def LastNode_def)
            by (metis Abs_Node_inverse Rep_Node Suc_pred atLeastLessThan_iff diff_Suc_less less_or_eq_imp_le neq0_conv not_less_eq)

        next
          fix n assume "Deactivate n (s, t)"
          hence step:
            "tokenPosition t = tokenPosition s" "tokenState t = tokenState s" "nodeState t = nodeState s" "\<And>n. isNodeActive t n \<Longrightarrow> isNodeActive s n"
            unfolding Deactivate_def updatedFun_def apply auto
            by (metis id_apply unl_before unl_con unl_lift2)

          from s show "SafetyInvariant t" by (auto simp add: less_Node_def LastNode_def SafetyInvariant_def step)

        next
          fix sender assume step: "SendMsg sender (s, t)"
          from step have step_simps[simp]: "tokenPosition t = tokenPosition s" "tokenState t = tokenState s" by (auto simp add: SendMsg_def)
          from step have n_active: "isNodeActive s sender" by (simp add: SendMsg_def)

          from step obtain receiver where receiver: "receiver \<noteq> sender"
            "\<And>m. isNodeActive t m = (m = receiver \<or> isNodeActive s m)"
            "\<And>m. nodeState t m = (if m = sender \<and> receiver > sender then NotTerminated else nodeState s m)"
            unfolding SendMsg_def updatedFun_def by auto

          show ?thesis
          proof (cases "receiver < tokenPosition s")
            case False
            with s show ?thesis
              unfolding SafetyInvariant_def less_Node_def
              apply auto
                apply (metis le_less_trans less_Node_def n_active not_le receiver(2) receiver(3))
              by (metis receiver(3))
          next
            case True
            with s receiver show ?thesis unfolding SafetyInvariant_def less_Node_def by fastforce
          qed

        next
          fix n assume step: "PassToken n (s,t)"

          hence step_tokenPosition[simp]: "tokenPosition s = n" "tokenPosition t = PreviousNode n" "n \<noteq> FirstNode" unfolding PassToken_def by auto

          from step have step_active[simp]: "isNodeActive t = isNodeActive s" unfolding PassToken_def by auto

          from step have step_colour: "\<And>m. nodeState t m = (if m = n then MaybeTerminated else nodeState s m)"
            by (simp add: PassToken_def updatedFun_def)

          from step have step_tokenState: "tokenState t = (if nodeState s n = NotTerminated then NotTerminated else tokenState s)"
            unfolding PassToken_def by simp

          show ?thesis
          proof (cases "nodeState s n = NotTerminated \<or> tokenState s = NotTerminated")
            case True with step_tokenState show ?thesis by (auto simp add: SafetyInvariant_def)
          next
            case False
            with TerminationState.exhaust have whites: "nodeState s n = MaybeTerminated" "tokenState s = MaybeTerminated" by auto

            from whites step_colour step_tokenState have step_simps[simp]:
              "nodeState t = nodeState s" "tokenState t = tokenState s" by auto

            from step whites have n_inactive: "\<not>isNodeActive s n" unfolding PassToken_def by auto

            from step_tokenPosition(3)
            have gt1: "\<And>m. m < n = (m < (PreviousNode n) \<or> m = PreviousNode n)"
              using Node_gt_PreviousNode not_less_iff_gr_or_eq by blast

            have gt2: "\<And>m. n < m = ((PreviousNode n) < m \<and> m \<noteq> n)"
              using Node_gt_PreviousNode step_tokenPosition(3) by blast

            from s n_inactive show ?thesis
              unfolding SafetyInvariant_def
              apply (clarsimp simp add: gt1 gt2)
              by (metis TerminationState.simps(2) gt2 leD leI whites(1))
          qed
        qed
      qed
    qed
  qed

  moreover have "\<turnstile> \<box>SafetyInvariant \<longrightarrow> \<box>(TerminationDetected \<longrightarrow> AllNodesInactive)"
    unfolding SafetyInvariant_def
  proof (intro STL4, clarsimp, intro conjI impI)
    fix w
    assume inactive_gt: "\<forall>n. (tokenPosition w < n) \<longrightarrow> \<not> isNodeActive w n"
    show "TerminationDetected w \<Longrightarrow> AllNodesInactive w"
      unfolding TerminationDetected_def AllNodesInactive_def
    proof clarsimp
      fix n assume a: "isNodeActive w n" "tokenPosition w = FirstNode" "\<not> isNodeActive w FirstNode"
      with inactive_gt have "\<not> n > FirstNode" by auto
      hence "n = FirstNode"
        unfolding less_Node_def FirstNode_def
        by (metis Abs_Node_inverse NodeCount_positive Rep_Node Rep_Node_inject atLeastLessThan_iff le_numeral_extra(3) nat_less_le)
      with a show False by simp
    qed
  next
    fix w
    assume "tokenState w = NotTerminated"
    thus "TerminationDetected w \<Longrightarrow> AllNodesInactive w"
      unfolding TerminationDetected_def
      by auto
  next
    fix w
    assume "\<exists>n. (n \<le> tokenPosition w) \<and> nodeState w n = NotTerminated"
    then obtain n where n: "n \<le> tokenPosition w" "nodeState w n = NotTerminated" by auto
    thus "TerminationDetected w \<Longrightarrow> AllNodesInactive w"
      unfolding TerminationDetected_def AllNodesInactive_def
    proof clarsimp
      assume "tokenPosition w = FirstNode" "nodeState w FirstNode = MaybeTerminated"
      with n show False
        by (metis Abs_Node_inverse TerminationState.distinct(2) FirstNode_def NodeCount_positive Rep_Node_inverse atLeastLessThan_iff le_zero_eq less_eq_Node_def)
    qed
  qed

  ultimately show ?thesis by (simp add: Valid_def)
qed

section Liveness

text \<open>When all nodes become inactive the algorithm runs through up to three further distinct
phases before detecting termination. The first phase is simply to return the token to the first
node, without any constraints on its state or the states of the nodes. The second phase
passes the token around the ring once more which sets each node's state to $MaybeTerminated$,
although the token itself may be ``contaminated'' by a $NotTerminated$ state. The third phase
passes the token around the ring one last time to remove any such contamination.\<close>

text \<open>The following predicates correspond to each step of each of these phases.\<close>

definition AllNodesInactiveAndTokenAt where "AllNodesInactiveAndTokenAt n \<equiv> PRED
  (AllNodesInactive \<and> tokenPosition = #n)"

definition NodeCleaningRunAt where "NodeCleaningRunAt n \<equiv> PRED
  (AllNodesInactiveAndTokenAt n
  \<and> id<nodeState,#FirstNode> = #MaybeTerminated
  \<and> (\<forall> m. #n < #m \<longrightarrow> id<nodeState,#m> = #MaybeTerminated))"

definition TokenCleaningRunAt where "TokenCleaningRunAt n \<equiv> PRED
  (AllNodesInactiveAndTokenAt n
  \<and> tokenState = #MaybeTerminated
  \<and> (\<forall> m. id<nodeState,#m> = #MaybeTerminated))"

text \<open>The liveness proof now shows that each phase completes and either detects termination
or leads to the next phase.\<close>

lemma step:
  assumes "\<turnstile> P \<longrightarrow> AllNodesInactive"
  assumes "\<turnstile> P \<longrightarrow> \<not> TerminationDetected"
  assumes "\<turnstile> $P \<and> unchanged (isNodeActive, nodeState, tokenPosition, tokenState) \<longrightarrow> P$"
  assumes "\<turnstile> $P \<and> Controlled \<longrightarrow> Q$"
  shows   "\<turnstile> Spec \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> (\<box>[Next]_(isNodeActive, nodeState, tokenPosition, tokenState)
    \<and> WF(Controlled)_(isNodeActive, nodeState, tokenPosition, tokenState)) \<longrightarrow> (P \<leadsto> Q)"
  proof (intro WF1)
    from assms have no_Environment: "\<And>s t. s \<Turnstile> P \<Longrightarrow> (s, t) \<Turnstile> Environment \<Longrightarrow> False"
      by (auto simp add: Environment_def AllNodesInactive_def Valid_def SendMsg_def Deactivate_def)

    with assms
    show "\<turnstile> $P \<and> [Next]_(isNodeActive, nodeState, tokenPosition, tokenState) \<longrightarrow> P$ \<or> Q$"
      "\<turnstile> ($P \<and> [Next]_(isNodeActive, nodeState, tokenPosition, tokenState)) \<and> <Controlled>_(isNodeActive, nodeState, tokenPosition, tokenState) \<longrightarrow> Q$"
      "\<turnstile> $P \<and> [Next]_(isNodeActive, nodeState, tokenPosition, tokenState) \<longrightarrow> $Enabled (<Controlled>_(isNodeActive, nodeState, tokenPosition, tokenState))"
      unfolding angle_Controlled enabled_controlled Next_def square_def Valid_def AllNodesInactive_def TerminationDetected_def
        apply simp_all
        apply (meson TerminationState.exhaust, blast)
      by (metis (full_types) TerminationState.exhaust)
  qed

  thus ?thesis
    by (auto simp add: Spec_def Fairness_def)
qed

lemma liveness: "\<turnstile> Spec \<longrightarrow> (AllNodesInactive \<leadsto> TerminationDetected)"
proof -
  note [simp] = TokenCleaningRunAt_def NodeCleaningRunAt_def
            AllNodesInactiveAndTokenAt_def AllNodesInactive_def
            square_def Controlled_def InitiateProbe_def PassToken_def updatedFun_def
            TerminationDetected_def

  have "\<turnstile> Spec \<longrightarrow> (AllNodesInactive \<leadsto> AllNodesInactiveAndTokenAt FirstNode)"
  proof -
    have "\<turnstile> AllNodesInactive = (\<exists>n. AllNodesInactiveAndTokenAt n)" unfolding AllNodesInactiveAndTokenAt_def by auto
    hence "\<turnstile> (AllNodesInactive \<leadsto> AllNodesInactiveAndTokenAt FirstNode)
            = (\<forall>n. (AllNodesInactiveAndTokenAt n \<leadsto> AllNodesInactiveAndTokenAt FirstNode))"
      by (metis inteq_reflection leadsto_exists)

    moreover {
      fix n
      have "\<turnstile> Spec \<longrightarrow> (AllNodesInactiveAndTokenAt n \<leadsto> AllNodesInactiveAndTokenAt FirstNode)"
      proof (induct n rule: Node_induct)
        case FirstNode show ?case by (intro imp_leadsto_reflexive)
      next
        case (PreviousNode n)
        hence "\<turnstile> Spec \<longrightarrow> (AllNodesInactiveAndTokenAt n \<leadsto> AllNodesInactiveAndTokenAt (PreviousNode n))"
          by (intro step, auto)
        with PreviousNode show ?case by (metis imp_leadsto_transitive)
      qed
    }

    ultimately show ?thesis by (auto simp add: Valid_def)
  qed

  moreover have "\<turnstile> Spec \<longrightarrow> ((AllNodesInactiveAndTokenAt FirstNode \<and> \<not> TerminationDetected) \<leadsto> NodeCleaningRunAt LastNode)"
    by (intro step, auto)

  moreover have "\<And>n. \<turnstile> Spec \<longrightarrow> (NodeCleaningRunAt n \<leadsto> NodeCleaningRunAt FirstNode)"
  proof -
    fix n show "?thesis n"
    proof (induct n rule: Node_induct)
      case FirstNode
      with LatticeReflexivity show ?case by auto
    next
      case (PreviousNode n)
      with Node_gt_PreviousNode Node_gt_ne
      have "\<turnstile> Spec \<longrightarrow> (NodeCleaningRunAt n \<leadsto> NodeCleaningRunAt (PreviousNode n))"
        by (intro step, auto)
      with PreviousNode show ?case by (metis imp_leadsto_transitive)
    qed
  qed

  moreover have "\<turnstile> Spec \<longrightarrow> (NodeCleaningRunAt FirstNode \<and> \<not> TerminationDetected \<leadsto> TokenCleaningRunAt LastNode)"
  proof -
    have firstNode_min: "\<And>n. n = FirstNode \<or> FirstNode < n"
      using Abs_Node_inverse FirstNode_def NodeCount_positive le_less less_eq_Node_def by fastforce

    hence "\<turnstile> NodeCleaningRunAt FirstNode
      = (AllNodesInactiveAndTokenAt FirstNode \<and> (\<forall> m. id<nodeState,#m> = #MaybeTerminated))"
      by (auto, force)
    thus ?thesis by (intro step, auto, metis firstNode_min)
  qed

  moreover have "\<And>n. \<turnstile> Spec \<longrightarrow> (TokenCleaningRunAt n \<leadsto> TerminationDetected)"
  proof -
    fix n
    show "?thesis n"
    proof (induct n rule: Node_induct)
      case FirstNode
      have "\<turnstile> TokenCleaningRunAt FirstNode \<longrightarrow> TerminationDetected" by auto
      hence "\<turnstile> TokenCleaningRunAt FirstNode \<leadsto> TerminationDetected"
        using ImplLeadsto_simple by auto
      thus ?case by (auto simp add: ImplLeadsto_simple intI tempD)
    next
      case (PreviousNode n)
      hence "\<turnstile> Spec \<longrightarrow> (TokenCleaningRunAt n \<leadsto> TokenCleaningRunAt (PreviousNode n))"
        by (intro step, auto, blast)
      with PreviousNode show ?case by (metis imp_leadsto_transitive)
    qed
  qed

  ultimately show ?thesis
    by (metis imp_leadsto_transitive imp_leadsto_triangle_excl)
qed

end


(*  Title:      HOL/Metis_Examples/Proxies.thy
    Author:     Jasmin Blanchette, TU Muenchen

Example that exercises Metis's and Sledgehammer's logical symbol proxies for
rudimentary higher-order reasoning.
*)

section {*
Example that Exercises Metis's and Sledgehammer's Logical Symbol Proxies for
Rudimentary Higher-Order Reasoning.
*}

theory Proxies
imports Type_Encodings
begin

sledgehammer_params [prover = spass, blocking, fact_filter = mepo, timeout = 30,
                     preplay_timeout = 0, dont_minimize]

text {* Extensionality and set constants *}

lemma plus_1_not_0: "n + (1\<Colon>nat) \<noteq> 0"
by simp

definition inc :: "nat \<Rightarrow> nat" where
"inc x = x + 1"

lemma "inc \<noteq> (\<lambda>y. 0)"
sledgehammer [expect = some] (inc_def plus_1_not_0)
by (metis_exhaust inc_def plus_1_not_0)

lemma "inc = (\<lambda>y. y + 1)"
sledgehammer [expect = some]
by (metis_exhaust inc_def)

definition add_swap :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add_swap = (\<lambda>x y. y + x)"

lemma "add_swap m n = n + m"
sledgehammer [expect = some] (add_swap_def)
by (metis_exhaust add_swap_def)

definition "A = {xs\<Colon>'a list. True}"

lemma "xs \<in> A"
(* The "add:" argument is unfortunate. *)
sledgehammer [expect = some] (add: A_def mem_Collect_eq)
by (metis_exhaust A_def mem_Collect_eq)

definition "B (y::int) \<equiv> y \<le> 0"
definition "C (y::int) \<equiv> y \<le> 1"

lemma int_le_0_imp_le_1: "x \<le> (0::int) \<Longrightarrow> x \<le> 1"
by linarith

lemma "B \<le> C"
sledgehammer [expect = some]
by (metis_exhaust B_def C_def int_le_0_imp_le_1 predicate1I)

text {* Proxies for logical constants *}

lemma "id (op =) x x"
sledgehammer [type_enc = erased, expect = none] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis (full_types) id_apply)

lemma "id True"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "\<not> id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "x = id True \<or> x = id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id x = id True \<or> id x = id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "P True \<Longrightarrow> P False \<Longrightarrow> P x"
sledgehammer [type_enc = erased, expect = none] ()
sledgehammer [type_enc = poly_args, expect = none] ()
sledgehammer [type_enc = poly_tags??, expect = some] ()
sledgehammer [type_enc = poly_tags, expect = some] ()
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] ()
sledgehammer [type_enc = mono_tags??, expect = some] ()
sledgehammer [type_enc = mono_tags, expect = some] ()
sledgehammer [type_enc = mono_guards??, expect = some] ()
sledgehammer [type_enc = mono_guards, expect = some] ()
by (metis (full_types))

lemma "id (\<not> a) \<Longrightarrow> \<not> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> \<not> a) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by metis_exhaust

lemma "id (\<not> (id (\<not> a))) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<and> b) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<and> b) \<Longrightarrow> id b"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id a \<Longrightarrow> id b \<Longrightarrow> id (a \<and> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id a \<Longrightarrow> id (a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id b \<Longrightarrow> id (a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> a) \<Longrightarrow> id (\<not> b) \<Longrightarrow> id (\<not> (a \<or> b))"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> a) \<Longrightarrow> id (a \<longrightarrow> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<longrightarrow> b) \<longleftrightarrow> id (\<not> a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

end


section \<open>Relators\<close>
theory Relators
imports "../Lib/Refine_Lib"
begin

text \<open>
  We define the concept of relators. The relation between a concrete type and
  an abstract type is expressed by a relation of type \<open>('c\<times>'a) set\<close>.
  For each composed type, say \<open>'a list\<close>, we can define a {\em relator},
  that takes as argument a relation for the element type, and returns a relation
  for the list type. For most datatypes, there exists a {\em natural relator}.
  For algebraic datatypes, this is the relator that preserves the structure
  of the datatype, and changes the components. For example,
  \<open>list_rel::('c\<times>'a) set \<Rightarrow> ('c list\<times>'a list) set\<close> is the natural
  relator for lists.

  However, relators can also be used to change the representation, and thus
  relate an implementation with an abstract type. For example, the relator
  \<open>list_set_rel::('c\<times>'a) set \<Rightarrow> ('c list\<times>'a set) set\<close> relates lists
  with the set of their elements.

  In this theory, we define some basic notions for relators, and
  then define natural relators for all HOL-types, including the function type.
  For each relator, we also show a single-valuedness property, and initialize a
  solver for single-valued properties.
\<close>

subsection \<open>Basic Definitions\<close>

text \<open>
  For smoother handling of relator unification, we require relator arguments to
  be applied by a special operator, such that we avoid higher-order
  unification problems. We try to set up some syntax to make this more
  transparent, and give relators a type-like prefix-syntax.
\<close>

definition relAPP
  :: "(('c1\<times>'a1) set \<Rightarrow> _) \<Rightarrow> ('c1\<times>'a1) set \<Rightarrow> _"
  where "relAPP f x \<equiv> f x"

syntax "_rel_APP" :: "args \<Rightarrow> 'a \<Rightarrow> 'b" ("\<langle>_\<rangle>_" [0,900] 900)

translations
  "\<langle>x,xs\<rangle>R" == "\<langle>xs\<rangle>(CONST relAPP R x)"
  "\<langle>x\<rangle>R" == "CONST relAPP R x"

ML \<open>
  structure Refine_Relators_Thms = struct
    structure rel_comb_def_rules = Named_Thms (
      val name = @{binding refine_rel_defs}
      val description = "Refinement Framework: " ^
          "Relator definitions"
    );
  end
\<close>

setup Refine_Relators_Thms.rel_comb_def_rules.setup

subsection \<open>Basic HOL Relators\<close>
subsubsection \<open>Function\<close>
definition fun_rel where
  fun_rel_def_internal: "fun_rel A B \<equiv> { (f,f'). \<forall>(a,a')\<in>A. (f a, f' a')\<in>B }"
abbreviation fun_rel_syn (infixr "\<rightarrow>" 60) where "A\<rightarrow>B \<equiv> \<langle>A,B\<rangle>fun_rel"

lemma fun_rel_def[refine_rel_defs]:
  "A\<rightarrow>B \<equiv> { (f,f'). \<forall>(a,a')\<in>A. (f a, f' a')\<in>B }"
  by (simp add: relAPP_def fun_rel_def_internal)

lemma fun_relI[intro!]: "\<lbrakk>\<And>a a'. (a,a')\<in>A \<Longrightarrow> (f a,f' a')\<in>B\<rbrakk> \<Longrightarrow> (f,f')\<in>A\<rightarrow>B"
  by (auto simp: fun_rel_def)

lemma fun_relD:
  shows " ((f,f')\<in>(A\<rightarrow>B)) \<Longrightarrow>
  (\<And>x x'. \<lbrakk> (x,x')\<in>A \<rbrakk> \<Longrightarrow> (f x, f' x')\<in>B)"
  apply rule
  by (auto simp: fun_rel_def)

lemma fun_relD1:
  assumes "(f,f')\<in>Ra\<rightarrow>Rr"
  assumes "f x = r"
  shows "\<forall>x'. (x,x')\<in>Ra \<longrightarrow> (r,f' x')\<in>Rr"
  using assms by (auto simp: fun_rel_def)

lemma fun_relD2:
  assumes "(f,f')\<in>Ra\<rightarrow>Rr"
  assumes "f' x' = r'"
  shows "\<forall>x. (x,x')\<in>Ra \<longrightarrow> (f x,r')\<in>Rr"
  using assms by (auto simp: fun_rel_def)

lemma fun_relE1:
  assumes "(f,f')\<in>Id \<rightarrow> Rv"
  assumes "t' = f' x"
  shows "(f x,t')\<in>Rv" using assms
  by (auto elim: fun_relD)

lemma fun_relE2:
  assumes "(f,f')\<in>Id \<rightarrow> Rv"
  assumes "t = f x"
  shows "(t,f' x)\<in>Rv" using assms
  by (auto elim: fun_relD)

subsubsection \<open>Terminal Types\<close>
abbreviation unit_rel :: "(unit\<times>unit) set" where "unit_rel == Id"

abbreviation "nat_rel \<equiv> Id::(nat\<times>_) set"
abbreviation "int_rel \<equiv> Id::(int\<times>_) set"
abbreviation "bool_rel \<equiv> Id::(bool\<times>_) set"

subsubsection \<open>Product\<close>
definition prod_rel where
  prod_rel_def_internal: "prod_rel R1 R2
    \<equiv> { ((a,b),(a',b')) . (a,a')\<in>R1 \<and> (b,b')\<in>R2 }"

abbreviation prod_rel_syn (infixr "\<times>\<^sub>r" 70) where "a\<times>\<^sub>rb \<equiv> \<langle>a,b\<rangle>prod_rel"

lemma prod_rel_def[refine_rel_defs]:
  "(\<langle>R1,R2\<rangle>prod_rel) \<equiv> { ((a,b),(a',b')) . (a,a')\<in>R1 \<and> (b,b')\<in>R2 }"
  by (simp add: prod_rel_def_internal relAPP_def)

lemma prod_relI: "\<lbrakk>(a,a')\<in>R1; (b,b')\<in>R2\<rbrakk> \<Longrightarrow> ((a,b),(a',b'))\<in>\<langle>R1,R2\<rangle>prod_rel"
  by (auto simp: prod_rel_def)
lemma prod_relE:
  assumes "(p,p')\<in>\<langle>R1,R2\<rangle>prod_rel"
  obtains a b a' b' where "p=(a,b)" and "p'=(a',b')"
  and "(a,a')\<in>R1" and "(b,b')\<in>R2"
  using assms
  by (auto simp: prod_rel_def)

lemma prod_rel_simp[simp]:
  "((a,b),(a',b'))\<in>\<langle>R1,R2\<rangle>prod_rel \<longleftrightarrow> (a,a')\<in>R1 \<and> (b,b')\<in>R2"
  by (auto intro: prod_relI elim: prod_relE)

lemma in_Domain_prod_rel_iff[iff]: "(a,b)\<in>Domain (A\<times>\<^sub>rB) \<longleftrightarrow> a\<in>Domain A \<and> b\<in>Domain B"
  by (auto simp: prod_rel_def)

lemma prod_rel_comp: "(A \<times>\<^sub>r B) O (C \<times>\<^sub>r D) = (A O C) \<times>\<^sub>r (B O D)"
  unfolding prod_rel_def
  by auto

subsubsection \<open>Option\<close>
definition option_rel where
  option_rel_def_internal:
  "option_rel R \<equiv> { (Some a,Some a') | a a'. (a,a')\<in>R } \<union> {(None,None)}"

lemma option_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>option_rel \<equiv> { (Some a,Some a') | a a'. (a,a')\<in>R } \<union> {(None,None)}"
  by (simp add: option_rel_def_internal relAPP_def)

lemma option_relI:
  "(None,None)\<in>\<langle>R\<rangle> option_rel"
  "\<lbrakk> (a,a')\<in>R \<rbrakk> \<Longrightarrow> (Some a, Some a')\<in>\<langle>R\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_relE:
  assumes "(x,x')\<in>\<langle>R\<rangle>option_rel"
  obtains "x=None" and "x'=None"
  | a a' where "x=Some a" and "x'=Some a'" and "(a,a')\<in>R"
  using assms by (auto simp: option_rel_def)

lemma option_rel_simp[simp]:
  "(None,a)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> a=None"
  "(c,None)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> c=None"
  "(Some x,Some y)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> (x,y)\<in>R"
  by (auto intro: option_relI elim: option_relE)

subsubsection \<open>Sum\<close>
definition sum_rel where sum_rel_def_internal:
  "sum_rel Rl Rr
   \<equiv> { (Inl a, Inl a') | a a'. (a,a')\<in>Rl } \<union>
     { (Inr a, Inr a') | a a'. (a,a')\<in>Rr }"

lemma sum_rel_def[refine_rel_defs]:
  "\<langle>Rl,Rr\<rangle>sum_rel \<equiv>
     { (Inl a, Inl a') | a a'. (a,a')\<in>Rl } \<union>
     { (Inr a, Inr a') | a a'. (a,a')\<in>Rr }"
  by (simp add: sum_rel_def_internal relAPP_def)

lemma sum_rel_simp[simp]:
  "\<And>a a'. (Inl a, Inl a') \<in> \<langle>Rl,Rr\<rangle>sum_rel \<longleftrightarrow> (a,a')\<in>Rl"
  "\<And>a a'. (Inr a, Inr a') \<in> \<langle>Rl,Rr\<rangle>sum_rel \<longleftrightarrow> (a,a')\<in>Rr"
  "\<And>a a'. (Inl a, Inr a') \<notin> \<langle>Rl,Rr\<rangle>sum_rel"
  "\<And>a a'. (Inr a, Inl a') \<notin> \<langle>Rl,Rr\<rangle>sum_rel"
  unfolding sum_rel_def by auto

lemma sum_relI:
  "(l,l')\<in>Rl \<Longrightarrow> (Inl l, Inl l') \<in> \<langle>Rl,Rr\<rangle>sum_rel"
  "(r,r')\<in>Rr \<Longrightarrow> (Inr r, Inr r') \<in> \<langle>Rl,Rr\<rangle>sum_rel"
  by simp_all

lemma sum_relE:
  assumes "(x,x')\<in>\<langle>Rl,Rr\<rangle>sum_rel"
  obtains
    l l' where "x=Inl l" and "x'=Inl l'" and "(l,l')\<in>Rl"
  | r r' where "x=Inr r" and "x'=Inr r'" and "(r,r')\<in>Rr"
  using assms by (auto simp: sum_rel_def)

subsubsection \<open>Lists\<close>
definition list_rel where list_rel_def_internal:
  "list_rel R \<equiv> {(l,l'). list_all2 (\<lambda>x x'. (x,x')\<in>R) l l'}"

lemma list_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>list_rel \<equiv> {(l,l'). list_all2 (\<lambda>x x'. (x,x')\<in>R) l l'}"
  by (simp add: list_rel_def_internal relAPP_def)

lemma list_rel_induct[induct set,consumes 1, case_names Nil Cons]:
  assumes "(l,l')\<in>\<langle>R\<rangle> list_rel"
  assumes "P [] []"
  assumes "\<And>x x' l l'. \<lbrakk> (x,x')\<in>R; (l,l')\<in>\<langle>R\<rangle>list_rel; P l l' \<rbrakk>
    \<Longrightarrow> P (x#l) (x'#l')"
  shows "P l l'"
  using assms unfolding list_rel_def
  apply simp
  by (rule list_all2_induct)

lemma list_rel_eq_listrel: "list_rel = listrel"
  apply (rule ext)
  apply safe
proof goal_cases
  case (1 x a b) thus ?case
    unfolding list_rel_def_internal
    apply simp
    apply (induct a b rule: list_all2_induct)
    apply (auto intro: listrel.intros)
    done
next
  case 2 thus ?case
    apply (induct)
    apply (auto simp: list_rel_def_internal)
    done
qed

lemma list_relI:
  "([],[])\<in>\<langle>R\<rangle>list_rel"
  "\<lbrakk> (x,x')\<in>R; (l,l')\<in>\<langle>R\<rangle>list_rel \<rbrakk> \<Longrightarrow> (x#l,x'#l')\<in>\<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def)

lemma list_rel_simp[simp]:
  "([],l')\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> l'=[]"
  "(l,[])\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> l=[]"
  "([],[])\<in>\<langle>R\<rangle>list_rel"
  "(x#l,x'#l')\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> (x,x')\<in>R \<and> (l,l')\<in>\<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def)

lemma list_relE1:
  assumes "(l,[])\<in>\<langle>R\<rangle>list_rel" obtains "l=[]" using assms by auto

lemma list_relE2:
  assumes "([],l)\<in>\<langle>R\<rangle>list_rel" obtains "l=[]" using assms by auto

lemma list_relE3:
  assumes "(x#xs,l')\<in>\<langle>R\<rangle>list_rel" obtains x' xs' where
  "l'=x'#xs'" and "(x,x')\<in>R" and "(xs,xs')\<in>\<langle>R\<rangle>list_rel"
  using assms
  apply (cases l')
  apply auto
  done

lemma list_relE4:
  assumes "(l,x'#xs')\<in>\<langle>R\<rangle>list_rel" obtains x xs where
  "l=x#xs" and "(x,x')\<in>R" and "(xs,xs')\<in>\<langle>R\<rangle>list_rel"
  using assms
  apply (cases l)
  apply auto
  done

lemmas list_relE = list_relE1 list_relE2 list_relE3 list_relE4

lemma list_rel_imp_same_length:
    "(l, l') \<in> \<langle>R\<rangle>list_rel \<Longrightarrow> length l = length l'"
  unfolding list_rel_eq_listrel relAPP_def
  by (rule listrel_eq_len)

lemma list_rel_split_right_iff:
  "(x#xs,l)\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> (\<exists>y ys. l=y#ys \<and> (x,y)\<in>R \<and> (xs,ys)\<in>\<langle>R\<rangle>list_rel)"
  by (cases l) auto
lemma list_rel_split_left_iff:
  "(l,y#ys)\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> (\<exists>x xs. l=x#xs \<and> (x,y)\<in>R \<and> (xs,ys)\<in>\<langle>R\<rangle>list_rel)"
  by (cases l) auto

subsubsection \<open>Sets\<close>
text \<open>Pointwise refinement: The abstract set is the image of
  the concrete set, and the concrete set only contains elements that
  have an abstract counterpart\<close>

definition set_rel where
  set_rel_def_internal:
    "set_rel R \<equiv> {(A,B). (\<forall>x\<in>A. \<exists>y\<in>B. (x,y)\<in>R) \<and> (\<forall>y\<in>B. \<exists>x\<in>A. (x,y)\<in>R)}"

term set_rel

lemma set_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>set_rel \<equiv> {(A,B). (\<forall>x\<in>A. \<exists>y\<in>B. (x,y)\<in>R) \<and> (\<forall>y\<in>B. \<exists>x\<in>A. (x,y)\<in>R)}"
  by (simp add: set_rel_def_internal relAPP_def)

lemma set_rel_alt: "\<langle>R\<rangle>set_rel = {(A,B). A \<subseteq> R\<inverse>``B \<and> B \<subseteq> R``A}"
  unfolding set_rel_def by auto

lemma set_relI[intro?]:
  assumes "\<And>x. x\<in>A \<Longrightarrow> \<exists>y\<in>B. (x,y)\<in>R"
  assumes "\<And>y. y\<in>B \<Longrightarrow> \<exists>x\<in>A. (x,y)\<in>R"
  shows "(A,B)\<in>\<langle>R\<rangle>set_rel"
  using assms unfolding set_rel_def by blast

text \<open>Original definition of \<open>set_rel\<close> in refinement framework.
  Abandoned in favour of more symmetric definition above: \<close>
definition old_set_rel where old_set_rel_def_internal:
  "old_set_rel R \<equiv> {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"

lemma old_set_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>old_set_rel \<equiv> {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"
  by (simp add: old_set_rel_def_internal relAPP_def)

text \<open>Old definition coincides with new definition for single-valued
  element relations. This is probably the reason why the old definition worked
  for most applications.\<close>
lemma old_set_rel_sv_eq: "single_valued R \<Longrightarrow> \<langle>R\<rangle>old_set_rel = \<langle>R\<rangle>set_rel"
  unfolding set_rel_def old_set_rel_def single_valued_def
  by blast

lemma set_rel_simp[simp]:
  "({},{})\<in>\<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def)

lemma set_rel_empty_iff[simp]:
  "({},y)\<in>\<langle>A\<rangle>set_rel \<longleftrightarrow> y={}"
  "(x,{})\<in>\<langle>A\<rangle>set_rel \<longleftrightarrow> x={}"
  by (auto simp: set_rel_def; fastforce)+

lemma set_relD1: "(s,s')\<in>\<langle>R\<rangle>set_rel \<Longrightarrow> x\<in>s \<Longrightarrow> \<exists>x'\<in>s'. (x,x')\<in>R"
  unfolding set_rel_def by blast

lemma set_relD2: "(s,s')\<in>\<langle>R\<rangle>set_rel \<Longrightarrow> x'\<in>s' \<Longrightarrow> \<exists>x\<in>s. (x,x')\<in>R"
  unfolding set_rel_def by blast

lemma set_relE1[consumes 2]:
  assumes "(s,s')\<in>\<langle>R\<rangle>set_rel" "x\<in>s"
  obtains x' where "x'\<in>s'" "(x,x')\<in>R"
  using set_relD1[OF assms] ..

lemma set_relE2[consumes 2]:
  assumes "(s,s')\<in>\<langle>R\<rangle>set_rel" "x'\<in>s'"
  obtains x where "x\<in>s" "(x,x')\<in>R"
  using set_relD2[OF assms] ..

subsection \<open>Automation\<close>
subsubsection \<open>A solver for relator properties\<close>
lemma relprop_triggers:
  "\<And>R. single_valued R \<Longrightarrow> single_valued R"
  "\<And>R. R=Id \<Longrightarrow> R=Id"
  "\<And>R. R=Id \<Longrightarrow> Id=R"
  "\<And>R. Range R = UNIV \<Longrightarrow> Range R = UNIV"
  "\<And>R. Range R = UNIV \<Longrightarrow> UNIV = Range R"
  "\<And>R R'. R\<subseteq>R' \<Longrightarrow> R\<subseteq>R'"
  by auto

ML \<open>
  structure relator_props = Named_Thms (
    val name = @{binding relator_props}
    val description = "Additional relator properties"
  )

  structure solve_relator_props = Named_Thms (
    val name = @{binding solve_relator_props}
    val description = "Relator properties that solve goal"
  )

\<close>
setup relator_props.setup
setup solve_relator_props.setup

declaration \<open>
  Tagged_Solver.declare_solver
    @{thms relprop_triggers}
    @{binding relator_props_solver}
    "Additional relator properties solver"
    (fn ctxt => (REPEAT_ALL_NEW (CHANGED o (
      match_tac ctxt (solve_relator_props.get ctxt) ORELSE'
      match_tac ctxt (relator_props.get ctxt)
    ))))
\<close>

declaration \<open>
  Tagged_Solver.declare_solver
    []
    @{binding force_relator_props_solver}
    "Additional relator properties solver (instantiate schematics)"
    (fn ctxt => (REPEAT_ALL_NEW (CHANGED o (
      resolve_tac ctxt (solve_relator_props.get ctxt) ORELSE'
      match_tac ctxt (relator_props.get ctxt)
    ))))
\<close>

lemma
  relprop_id_orient[relator_props]: "R=Id \<Longrightarrow> Id=R" and
  relprop_eq_refl[solve_relator_props]: "t = t"
  by auto

lemma
  relprop_UNIV_orient[relator_props]: "R=UNIV \<Longrightarrow> UNIV=R"
  by auto

subsubsection \<open>ML-Level utilities\<close>

ML \<open>
  signature RELATORS = sig
    val mk_relT: typ * typ -> typ
    val dest_relT: typ -> typ * typ

    val mk_relAPP: term -> term -> term
    val list_relAPP: term list -> term -> term
    val strip_relAPP: term -> term list * term
    val mk_fun_rel: term -> term -> term

    val list_rel: term list -> term -> term

    val rel_absT: term -> typ
    val rel_concT: term -> typ

    val mk_prodrel: term * term -> term
    val is_prodrel: term -> bool
    val dest_prodrel: term -> term * term

    val strip_prodrel_left: term -> term list
    val list_prodrel_left: term list -> term

    val declare_natural_relator:
      (string*string) -> Context.generic -> Context.generic
    val remove_natural_relator: string -> Context.generic -> Context.generic
    val natural_relator_of: Proof.context -> string -> string option

    val mk_natural_relator: Proof.context -> term list -> string -> term option

    val setup: theory -> theory
  end

  structure Relators :RELATORS = struct
    val mk_relT = HOLogic.mk_prodT #> HOLogic.mk_setT

    fun dest_relT (Type (@{type_name set},[Type (@{type_name prod},[cT,aT])]))
      = (cT,aT)
      | dest_relT ty = raise TYPE ("dest_relT",[ty],[])

    fun mk_relAPP x f = let
      val xT = fastype_of x
      val fT = fastype_of f
      val rT = range_type fT
    in
      Const (@{const_name relAPP},fT-->xT-->rT)$f$x
    end

    val list_relAPP = fold mk_relAPP

    fun strip_relAPP R = let
      fun aux @{mpat "\<langle>?R\<rangle>?S"} l = aux S (R::l)
        | aux R l = (l,R)
    in aux R [] end

    val rel_absT = fastype_of #> HOLogic.dest_setT #> HOLogic.dest_prodT #> snd
    val rel_concT = fastype_of #> HOLogic.dest_setT #> HOLogic.dest_prodT #> fst

    fun mk_fun_rel r1 r2 = let
      val (r1T,r2T) = (fastype_of r1,fastype_of r2)
      val (c1T,a1T) = dest_relT r1T
      val (c2T,a2T) = dest_relT r2T
      val (cT,aT) = (c1T --> c2T, a1T --> a2T)
      val rT = mk_relT (cT,aT)
    in
      list_relAPP [r1,r2] (Const (@{const_name fun_rel},r1T-->r2T-->rT))
    end

    val list_rel = fold_rev mk_fun_rel

    fun mk_prodrel (A,B) = @{mk_term "?A \<times>\<^sub>r ?B"}
    fun is_prodrel @{mpat "_ \<times>\<^sub>r _"} = true | is_prodrel _ = false
    fun dest_prodrel @{mpat "?A \<times>\<^sub>r ?B"} = (A,B) | dest_prodrel t = raise TERM("dest_prodrel",[t])

    fun strip_prodrel_left @{mpat "?A \<times>\<^sub>r ?B"} = strip_prodrel_left A @ [B]
      | strip_prodrel_left @{mpat (typs) "unit_rel"} = []
      | strip_prodrel_left R = [R]

    val list_prodrel_left = Refine_Util.list_binop_left @{term unit_rel} mk_prodrel

    structure natural_relators = Generic_Data (
      type T = string Symtab.table
      val empty = Symtab.empty
      val extend = I
      val merge = Symtab.join (fn _ => fn (_,cn) => cn)
    )

    fun declare_natural_relator tcp =
      natural_relators.map (Symtab.update tcp)

    fun remove_natural_relator tname =
      natural_relators.map (Symtab.delete_safe tname)

    fun natural_relator_of ctxt =
      Symtab.lookup (natural_relators.get (Context.Proof ctxt))

    (* [R1,\<dots>,Rn] T is mapped to \<langle>R1,\<dots>,Rn\<rangle> Trel *)
    fun mk_natural_relator ctxt args Tname =
      case natural_relator_of ctxt Tname of
        NONE => NONE
      | SOME Cname => SOME let
          val argsT = map fastype_of args
          val (cTs, aTs) = map dest_relT argsT |> split_list
          val aT = Type (Tname,aTs)
          val cT = Type (Tname,cTs)
          val rT = mk_relT (cT,aT)
        in
          list_relAPP args (Const (Cname,argsT--->rT))
        end

    fun
      natural_relator_from_term (t as Const (name,T)) = let
        fun err msg = raise TERM (msg,[t])

        val (argTs,bodyT) = strip_type T
        val (conTs,absTs) = argTs |> map (HOLogic.dest_setT #> HOLogic.dest_prodT) |> split_list
        val (bconT,babsT) = bodyT |> HOLogic.dest_setT |> HOLogic.dest_prodT
        val (Tcon,bconTs) = dest_Type bconT
        val (Tcon',babsTs) = dest_Type babsT

        val _ = Tcon = Tcon' orelse err "Type constructors do not match"
        val _ = conTs = bconTs orelse err "Concrete types do not match"
        val _ = absTs = babsTs orelse err "Abstract types do not match"

      in
        (Tcon,name)
      end
    | natural_relator_from_term t =
        raise TERM ("Expected constant",[t]) (* TODO: Localize this! *)

    local
      fun decl_natrel_aux t context = let
        fun warn msg = let
          val tP =
            Context.cases Syntax.pretty_term_global Syntax.pretty_term
              context t
          val m = Pretty.block [
            Pretty.str "Ignoring invalid natural_relator declaration:",
            Pretty.brk 1,
            Pretty.str msg,
            Pretty.brk 1,
            tP
          ] |> Pretty.string_of
          val _ = warning m
        in context end
      in
        declare_natural_relator (natural_relator_from_term t) context
        handle
          TERM (msg,_) => warn msg
        | exn => if Exn.is_interrupt exn then Exn.reraise exn else warn ""
      end
    in
      val natural_relator_attr = Scan.repeat1 Args.term >> (fn ts =>
        Thm.declaration_attribute ( fn _ => fold decl_natrel_aux ts)
      )
    end

    val setup = I
      #> Attrib.setup
        @{binding natural_relator} natural_relator_attr "Declare natural relator"

  end
\<close>

setup Relators.setup

subsection \<open>Setup\<close>
subsubsection "Natural Relators"

declare [[natural_relator
  unit_rel int_rel nat_rel bool_rel
  fun_rel prod_rel option_rel sum_rel list_rel
  ]]

(*declaration {* let open Relators in
  fn _ =>
     declare_natural_relator (@{type_name unit},@{const_name unit_rel})
  #> declare_natural_relator (@{type_name fun},@{const_name fun_rel})
  #> declare_natural_relator (@{type_name prod},@{const_name prod_rel})
  #> declare_natural_relator (@{type_name option},@{const_name option_rel})
  #> declare_natural_relator (@{type_name sum},@{const_name sum_rel})
  #> declare_natural_relator (@{type_name list},@{const_name list_rel})

end
*}*)

ML_val \<open>
  Relators.mk_natural_relator
    @{context}
    [@{term "Ra::('c\<times>'a) set"},@{term "\<langle>Rb\<rangle>option_rel"}]
    @{type_name prod}
  |> the
  |> Thm.cterm_of @{context}
;
  Relators.mk_fun_rel @{term "\<langle>Id\<rangle>option_rel"} @{term "\<langle>Id\<rangle>list_rel"}
  |> Thm.cterm_of @{context}
\<close>

subsubsection "Additional Properties"
lemmas [relator_props] =
  single_valued_Id
  subset_refl
  refl

(* TODO: Move *)
lemma eq_UNIV_iff: "S=UNIV \<longleftrightarrow> (\<forall>x. x\<in>S)" by auto

lemma fun_rel_sv[relator_props]:
  assumes RAN: "Range Ra = UNIV"
  assumes SV: "single_valued Rv"
  shows "single_valued (Ra \<rightarrow> Rv)"
proof (intro single_valuedI ext impI allI)
  fix f g h x'
  assume R1: "(f,g)\<in>Ra\<rightarrow>Rv"
  and R2: "(f,h)\<in>Ra\<rightarrow>Rv"

  from RAN obtain x where AR: "(x,x')\<in>Ra" by auto
  from fun_relD[OF R1 AR] have "(f x,g x') \<in> Rv" .
  moreover from fun_relD[OF R2 AR] have "(f x,h x') \<in> Rv" .
  ultimately show "g x' = h x'" using SV by (auto dest: single_valuedD)
qed

lemmas [relator_props] = Range_Id

lemma fun_rel_id[relator_props]: "\<lbrakk>R1=Id; R2=Id\<rbrakk> \<Longrightarrow> R1 \<rightarrow> R2 = Id"
  by (auto simp: fun_rel_def)

lemma fun_rel_id_simp[simp]: "Id\<rightarrow>Id = Id" by tagged_solver

lemma fun_rel_comp_dist[relator_props]:
  "(R1\<rightarrow>R2) O (R3\<rightarrow>R4) \<subseteq> ((R1 O R3) \<rightarrow> (R2 O R4))"
  by (auto simp: fun_rel_def)

lemma fun_rel_mono[relator_props]: "\<lbrakk> R1\<subseteq>R2; R3\<subseteq>R4 \<rbrakk> \<Longrightarrow> R2\<rightarrow>R3 \<subseteq> R1\<rightarrow>R4"
  by (force simp: fun_rel_def)

lemma prod_rel_sv[relator_props]:
  "\<lbrakk>single_valued R1; single_valued R2\<rbrakk> \<Longrightarrow> single_valued (\<langle>R1,R2\<rangle>prod_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: prod_rel_def)

lemma prod_rel_id[relator_props]: "\<lbrakk>R1=Id; R2=Id\<rbrakk> \<Longrightarrow> \<langle>R1,R2\<rangle>prod_rel = Id"
  by (auto simp: prod_rel_def)

lemma prod_rel_id_simp[simp]: "\<langle>Id,Id\<rangle>prod_rel = Id" by tagged_solver

lemma prod_rel_mono[relator_props]:
"\<lbrakk> R2\<subseteq>R1; R3\<subseteq>R4 \<rbrakk> \<Longrightarrow> \<langle>R2,R3\<rangle>prod_rel \<subseteq> \<langle>R1,R4\<rangle>prod_rel"
  by (auto simp: prod_rel_def)

lemma prod_rel_range[relator_props]: "\<lbrakk>Range Ra=UNIV; Range Rb=UNIV\<rbrakk>
  \<Longrightarrow> Range (\<langle>Ra,Rb\<rangle>prod_rel) = UNIV"
  apply (auto simp: prod_rel_def)
  by (metis Range_iff UNIV_I)+

lemma option_rel_sv[relator_props]:
  "\<lbrakk>single_valued R\<rbrakk> \<Longrightarrow> single_valued (\<langle>R\<rangle>option_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: option_rel_def)

lemma option_rel_id[relator_props]:
  "R=Id \<Longrightarrow> \<langle>R\<rangle>option_rel = Id" by (auto simp: option_rel_def)

lemma option_rel_id_simp[simp]: "\<langle>Id\<rangle>option_rel = Id" by tagged_solver

lemma option_rel_mono[relator_props]: "R\<subseteq>R' \<Longrightarrow> \<langle>R\<rangle>option_rel \<subseteq> \<langle>R'\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_rel_range: "Range R = UNIV \<Longrightarrow> Range (\<langle>R\<rangle>option_rel) = UNIV"
  apply (auto simp: option_rel_def Range_iff)
  by (metis Range_iff UNIV_I option.exhaust)

lemma option_rel_inter[simp]: "\<langle>R1 \<inter> R2\<rangle>option_rel = \<langle>R1\<rangle>option_rel \<inter> \<langle>R2\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_rel_constraint[simp]:
  "(x,x)\<in>\<langle>UNIV\<times>C\<rangle>option_rel \<longleftrightarrow> (\<forall>v. x=Some v \<longrightarrow> v\<in>C)"
  by (auto simp: option_rel_def)

lemma sum_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rl; single_valued Rr\<rbrakk> \<Longrightarrow> single_valued (\<langle>Rl,Rr\<rangle>sum_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: sum_rel_def)

lemma sum_rel_id[relator_props]: "\<lbrakk>Rl=Id; Rr=Id\<rbrakk> \<Longrightarrow> \<langle>Rl,Rr\<rangle>sum_rel = Id"
  apply (auto elim: sum_relE)
  apply (case_tac b)
  apply simp_all
  done

lemma sum_rel_id_simp[simp]: "\<langle>Id,Id\<rangle>sum_rel = Id" by tagged_solver

lemma sum_rel_mono[relator_props]:
  "\<lbrakk> Rl\<subseteq>Rl'; Rr\<subseteq>Rr' \<rbrakk> \<Longrightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<subseteq> \<langle>Rl',Rr'\<rangle>sum_rel"
  by (auto simp: sum_rel_def)

lemma sum_rel_range[relator_props]:
  "\<lbrakk> Range Rl=UNIV; Range Rr=UNIV \<rbrakk> \<Longrightarrow> Range (\<langle>Rl,Rr\<rangle>sum_rel) = UNIV"
  apply (auto simp: sum_rel_def Range_iff)
  by (metis Range_iff UNIV_I sumE)

lemma list_rel_sv_iff:
  "single_valued (\<langle>R\<rangle>list_rel) \<longleftrightarrow> single_valued R"
  apply (intro iffI[rotated] single_valuedI allI impI)
  apply (clarsimp simp: list_rel_def)
proof -
  fix x y z
  assume SV: "single_valued R"
  assume "list_all2 (\<lambda>x x'. (x, x') \<in> R) x y" and
    "list_all2 (\<lambda>x x'. (x, x') \<in> R) x z"
  thus "y=z"
    apply (induct arbitrary: z rule: list_all2_induct)
    apply simp
    apply (case_tac z)
    apply force
    apply (force intro: single_valuedD[OF SV])
    done
next
  fix x y z
  assume SV: "single_valued (\<langle>R\<rangle>list_rel)"
  assume "(x,y)\<in>R" "(x,z)\<in>R"
  hence "([x],[y])\<in>\<langle>R\<rangle>list_rel" and "([x],[z])\<in>\<langle>R\<rangle>list_rel"
    by (auto simp: list_rel_def)
  with single_valuedD[OF SV] show "y=z" by blast
qed

lemma list_rel_sv[relator_props]:
  "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>list_rel)"
  by (simp add: list_rel_sv_iff)

lemma list_rel_id[relator_props]: "\<lbrakk>R=Id\<rbrakk> \<Longrightarrow> \<langle>R\<rangle>list_rel = Id"
  by (auto simp add: list_rel_def list_all2_eq[symmetric])

lemma list_rel_id_simp[simp]: "\<langle>Id\<rangle>list_rel = Id" by tagged_solver

lemma list_rel_mono[relator_props]:
  assumes A: "R\<subseteq>R'"
  shows "\<langle>R\<rangle>list_rel \<subseteq> \<langle>R'\<rangle>list_rel"
proof clarsimp
  fix l l'
  assume "(l,l')\<in>\<langle>R\<rangle>list_rel"
  thus "(l,l')\<in>\<langle>R'\<rangle>list_rel"
    apply induct
    using A
    by auto
qed

lemma list_rel_range[relator_props]:
  assumes A: "Range R = UNIV"
  shows "Range (\<langle>R\<rangle>list_rel) = UNIV"
proof (clarsimp simp: eq_UNIV_iff)
  fix l
  show "l\<in>Range (\<langle>R\<rangle>list_rel)"
    apply (induct l)
    using A[unfolded eq_UNIV_iff]
    by (auto simp: Range_iff intro: list_relI)
qed

lemma bijective_imp_sv:
  "bijective R \<Longrightarrow> single_valued R"
  "bijective R \<Longrightarrow> single_valued (R\<inverse>)"
  by (simp_all add: bijective_alt)

(* TODO: Move *)
declare bijective_Id[relator_props]
declare bijective_Empty[relator_props]

text \<open>Pointwise refinement for set types:\<close>

lemma set_rel_sv[relator_props]:
  "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>set_rel)"
  unfolding single_valued_def set_rel_def by blast

lemma set_rel_id[relator_props]: "R=Id \<Longrightarrow> \<langle>R\<rangle>set_rel = Id"
  by (auto simp add: set_rel_def)

lemma set_rel_id_simp[simp]: "\<langle>Id\<rangle>set_rel = Id" by tagged_solver

lemma set_rel_csv[relator_props]:
  "\<lbrakk> single_valued (R\<inverse>) \<rbrakk>
  \<Longrightarrow> single_valued ((\<langle>R\<rangle>set_rel)\<inverse>)"
  unfolding single_valued_def set_rel_def converse_iff
  by fast

subsection \<open>Invariant and Abstraction\<close>

text \<open>
  Quite often, a relation can be described as combination of an
  abstraction function and an invariant, such that the invariant describes valid
  values on the concrete domain, and the abstraction function maps valid
  concrete values to its corresponding abstract value.
\<close>
definition build_rel where
  "build_rel \<alpha> I \<equiv> {(c,a) . a=\<alpha> c \<and> I c}"
abbreviation "br\<equiv>build_rel"
lemmas br_def[refine_rel_defs] = build_rel_def

lemma in_br_conv: "(c,a)\<in>br \<alpha> I \<longleftrightarrow> a=\<alpha> c \<and> I c"
  by (auto simp: br_def)

lemma brI[intro?]: "\<lbrakk> a=\<alpha> c; I c \<rbrakk> \<Longrightarrow> (c,a)\<in>br \<alpha> I"
  by (simp add: br_def)

lemma br_id[simp]: "br id (\<lambda>_. True) = Id"
  unfolding build_rel_def by auto

lemma br_chain:
  "(build_rel \<beta> J) O (build_rel \<alpha> I) = build_rel (\<alpha>\<circ>\<beta>) (\<lambda>s. J s \<and> I (\<beta> s))"
  unfolding build_rel_def by auto

lemma br_sv[simp, intro!,relator_props]: "single_valued (br \<alpha> I)"
  unfolding build_rel_def
  apply (rule single_valuedI)
  apply auto
  done

lemma converse_br_sv_iff[simp]:
  "single_valued (converse (br \<alpha> I)) \<longleftrightarrow> inj_on \<alpha> (Collect I)"
  by (auto intro!: inj_onI single_valuedI dest: single_valuedD inj_onD
    simp: br_def) []

lemmas [relator_props] = single_valued_relcomp

lemma br_comp_alt: "br \<alpha> I O R = { (c,a) . I c \<and> (\<alpha> c,a)\<in>R }"
  by (auto simp add: br_def)

lemma br_comp_alt':
  "{(c,a) . a=\<alpha> c \<and> I c} O R = { (c,a) . I c \<and> (\<alpha> c,a)\<in>R }"
  by auto

lemma single_valued_as_brE:
  assumes "single_valued R"
  obtains \<alpha> invar where "R=br \<alpha> invar"
  apply (rule that[of "\<lambda>x. THE y. (x,y)\<in>R" "\<lambda>x. x\<in>Domain R"])
  using assms unfolding br_def
  by (auto dest: single_valuedD
    intro: the_equality[symmetric] theI)

lemma sv_add_invar:
  "single_valued R \<Longrightarrow> single_valued {(c, a). (c, a) \<in> R \<and> I c}"
  by (auto dest: single_valuedD intro: single_valuedI)

lemma br_Image_conv[simp]: "br \<alpha> I `` S = {\<alpha> x | x. x\<in>S \<and> I x}"
  by (auto simp: br_def)

subsection \<open>Miscellanneous\<close>
lemma rel_cong: "(f,g)\<in>Id \<Longrightarrow> (x,y)\<in>Id \<Longrightarrow> (f x, g y)\<in>Id" by simp
lemma rel_fun_cong: "(f,g)\<in>Id \<Longrightarrow> (f x, g x)\<in>Id" by simp
lemma rel_arg_cong: "(x,y)\<in>Id \<Longrightarrow> (f x, f y)\<in>Id" by simp

subsection \<open>Conversion between Predicate and Set Based Relators\<close>
text \<open>
  Autoref uses set-based relators of type @{typ \<open>('a\<times>'b) set\<close>}, while the
  transfer and lifting package of Isabelle/HOL uses predicate based relators
  of type @{typ \<open>'a \<Rightarrow> 'b \<Rightarrow> bool\<close>}. This section defines some utilities
  to convert between the two.
\<close>

definition "rel2p R x y \<equiv> (x,y)\<in>R"
definition "p2rel P \<equiv> {(x,y). P x y}"

lemma rel2pD: "\<lbrakk>rel2p R a b\<rbrakk> \<Longrightarrow> (a,b)\<in>R" by (auto simp: rel2p_def)
lemma p2relD: "\<lbrakk>(a,b) \<in> p2rel R\<rbrakk> \<Longrightarrow> R a b" by (auto simp: p2rel_def)

lemma rel2p_inv[simp]:
  "rel2p (p2rel P) = P"
  "p2rel (rel2p R) = R"
  by (auto simp: rel2p_def[abs_def] p2rel_def)

named_theorems rel2p
named_theorems p2rel

lemma rel2p_dflt[rel2p]:
  "rel2p Id = (=)"
  "rel2p (A\<rightarrow>B) = rel_fun (rel2p A) (rel2p B)"
  "rel2p (A\<times>\<^sub>rB) = rel_prod (rel2p A) (rel2p B)"
  "rel2p (\<langle>A,B\<rangle>sum_rel) = rel_sum (rel2p A) (rel2p B)"
  "rel2p (\<langle>A\<rangle>option_rel) = rel_option (rel2p A)"
  "rel2p (\<langle>A\<rangle>list_rel) = list_all2 (rel2p A)"
  by (auto
    simp: rel2p_def[abs_def]
    intro!: ext
    simp: fun_rel_def rel_fun_def
    simp: sum_rel_def elim: rel_sum.cases
    simp: option_rel_def elim: option.rel_cases
    simp: list_rel_def
    simp: set_rel_def rel_set_def Image_def
    )

lemma p2rel_dflt[p2rel]:
  "p2rel (=) = Id"
  "p2rel (rel_fun A B) = p2rel A \<rightarrow> p2rel B"
  "p2rel (rel_prod A B) = p2rel A \<times>\<^sub>r p2rel B"
  "p2rel (rel_sum A B) = \<langle>p2rel A, p2rel B\<rangle>sum_rel"
  "p2rel (rel_option A) = \<langle>p2rel A\<rangle>option_rel"
  "p2rel (list_all2 A) = \<langle>p2rel A\<rangle>list_rel"
  by (auto
    simp: p2rel_def[abs_def]
    simp: fun_rel_def rel_fun_def
    simp: sum_rel_def elim: rel_sum.cases
    simp: option_rel_def elim: option.rel_cases
    simp: list_rel_def
    )

lemma [rel2p]: "rel2p (\<langle>A\<rangle>set_rel) = rel_set (rel2p A)"
  unfolding set_rel_def rel_set_def rel2p_def[abs_def]
  by blast

lemma [p2rel]: "left_unique A \<Longrightarrow> p2rel (rel_set A) = (\<langle>p2rel A\<rangle>set_rel)"
  unfolding set_rel_def rel_set_def p2rel_def[abs_def]
  by blast

lemma rel2p_comp: "rel2p A OO rel2p B = rel2p (A O B)"
  by (auto simp: rel2p_def[abs_def] intro!: ext)

lemma rel2p_inj[simp]: "rel2p A = rel2p B \<longleftrightarrow> A=B"
  by (auto simp: rel2p_def[abs_def]; meson)

subsection \<open>More Properties\<close>
(* TODO: Do compp-lemmas for other standard relations *)
lemma list_rel_compp: "\<langle>A O B\<rangle>list_rel = \<langle>A\<rangle>list_rel O \<langle>B\<rangle>list_rel"
  using list.rel_compp[of "rel2p A" "rel2p B"]
  by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *)

lemma option_rel_compp: "\<langle>A O B\<rangle>option_rel = \<langle>A\<rangle>option_rel O \<langle>B\<rangle>option_rel"
  using option.rel_compp[of "rel2p A" "rel2p B"]
  by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *)

lemma prod_rel_compp: "\<langle>A O B, C O D\<rangle>prod_rel = \<langle>A,C\<rangle>prod_rel O \<langle>B,D\<rangle>prod_rel"
  using prod.rel_compp[of "rel2p A" "rel2p B" "rel2p C" "rel2p D"]
  by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *)

lemma sum_rel_compp: "\<langle>A O B, C O D\<rangle>sum_rel = \<langle>A,C\<rangle>sum_rel O \<langle>B,D\<rangle>sum_rel"
  using sum.rel_compp[of "rel2p A" "rel2p B" "rel2p C" "rel2p D"]
  by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *)

lemma set_rel_compp: "\<langle>A O B\<rangle>set_rel = \<langle>A\<rangle>set_rel O \<langle>B\<rangle>set_rel"
  using rel_set_OO[of "rel2p A" "rel2p B"]
  by (auto simp: rel2p(2-)[symmetric] rel2p_comp) (* TODO: Not very systematic proof *)

lemma map_in_list_rel_conv:
  shows "(l, map \<alpha> l) \<in> \<langle>br \<alpha> I\<rangle>list_rel \<longleftrightarrow> (\<forall>x\<in>set l. I x)"
  by (induction l) (auto simp: in_br_conv)

lemma br_set_rel_alt: "(s',s)\<in>\<langle>br \<alpha> I\<rangle>set_rel \<longleftrightarrow> (s=\<alpha>`s' \<and> (\<forall>x\<in>s'. I x))"
  by (auto simp: set_rel_def br_def)

(* TODO: Find proof that does not depend on br, and move to Misc *)
lemma finite_Image_sv: "single_valued R \<Longrightarrow> finite s \<Longrightarrow> finite (R``s)"
  by (erule single_valued_as_brE) simp

lemma finite_set_rel_transfer: "\<lbrakk>(s,s')\<in>\<langle>R\<rangle>set_rel; single_valued R; finite s\<rbrakk> \<Longrightarrow> finite s'"
  unfolding set_rel_alt
  by (blast intro: finite_subset[OF _ finite_Image_sv])

lemma finite_set_rel_transfer_back: "\<lbrakk>(s,s')\<in>\<langle>R\<rangle>set_rel; single_valued (R\<inverse>); finite s'\<rbrakk> \<Longrightarrow> finite s"
  unfolding set_rel_alt
  by (blast intro: finite_subset[OF _ finite_Image_sv])

end


(*  Title:      HOL/Algebra/Subrings.thy
    Authors:    Martin Baillon and Paulo Emílio de Vilhena
*)

theory Subrings
  imports Ring RingHom QuotRing
begin

section \<open>Subrings\<close>

subsection \<open>Definitions\<close>

locale subring =
  subgroup H "add_monoid R" + submonoid H R for H and R (structure)

locale subcring = subring +
  assumes sub_m_comm: "\<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 = h2 \<otimes> h1"

locale subdomain = subcring +
  assumes sub_one_not_zero [simp]: "\<one> \<noteq> \<zero>"
  assumes subintegral: "\<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 = \<zero> \<Longrightarrow> h1 = \<zero> \<or> h2 = \<zero>"

locale subfield = subdomain K R for K and R (structure) +
  assumes subfield_Units: "Units (R \<lparr> carrier := K \<rparr>) = K - { \<zero> }"

subsection \<open>Basic Properties\<close>

subsubsection \<open>Subrings\<close>

lemma (in ring) subringI:
  assumes "H \<subseteq> carrier R"
    and "\<one> \<in> H"
    and "\<And>h. h \<in> H \<Longrightarrow> \<ominus> h \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<oplus> h2 \<in> H"
  shows "subring H R"
  using add.subgroupI[OF assms(1) _ assms(3, 5)] assms(2)
        submonoid.intro[OF assms(1, 4, 2)]
  unfolding subring_def by auto

lemma subringE:
  assumes "subring H R"
  shows "H \<subseteq> carrier R"
    and "\<zero>\<^bsub>R\<^esub> \<in> H"
    and "\<one>\<^bsub>R\<^esub> \<in> H"
    and "H \<noteq> {}"
    and "\<And>h. h \<in> H \<Longrightarrow> \<ominus>\<^bsub>R\<^esub> h \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<oplus>\<^bsub>R\<^esub> h2 \<in> H"
  using subring.axioms[OF assms]
  unfolding submonoid_def subgroup_def a_inv_def by auto

lemma (in ring) carrier_is_subring: "subring (carrier R) R"
  by (simp add: subringI)

lemma (in ring) subring_inter:
  assumes "subring I R" and "subring J R"
  shows "subring (I \<inter> J) R"
  using subringE[OF assms(1)] subringE[OF assms(2)] subringI[of "I \<inter> J"] by auto

lemma (in ring) subring_Inter:
  assumes "\<And>I. I \<in> S \<Longrightarrow> subring I R" and "S \<noteq> {}"
  shows "subring (\<Inter>S) R"
proof (rule subringI, auto simp add: assms subringE[of _ R])
  fix x assume "\<forall>I \<in> S. x \<in> I" thus "x \<in> carrier R"
    using assms subringE(1)[of _ R] by blast
qed

(* NEW ======================= *)
lemma (in ring) subring_is_ring:
  assumes "subring H R" shows "ring (R \<lparr> carrier := H \<rparr>)"
proof -
  interpret group "add_monoid (R \<lparr> carrier := H \<rparr>)" + monoid "R \<lparr> carrier := H \<rparr>"
    using subgroup.subgroup_is_group[OF subring.axioms(1) add.is_group] assms
          submonoid.submonoid_is_monoid[OF subring.axioms(2) monoid_axioms] by auto
  show ?thesis
    using subringE(1)[OF assms]
    by (unfold_locales, simp_all add: subringE(1)[OF assms] add.m_comm subset_eq l_distr r_distr)
qed

lemma (in ring) ring_incl_imp_subring:
  assumes "H \<subseteq> carrier R"
    and "ring (R \<lparr> carrier := H \<rparr>)"
  shows "subring H R"
  using group.group_incl_imp_subgroup[OF add.group_axioms, of H] assms(1)
        monoid.monoid_incl_imp_submonoid[OF monoid_axioms assms(1)]
        ring.axioms(1, 2)[OF assms(2)] abelian_group.a_group[of "R \<lparr> carrier := H \<rparr>"]
  unfolding subring_def by auto

(* PROOF ====================== *)
lemma (in ring) subring_iff:
  assumes "H \<subseteq> carrier R"
  shows "subring H R \<longleftrightarrow> ring (R \<lparr> carrier := H \<rparr>)"
  using subring_is_ring ring_incl_imp_subring[OF assms] by auto

subsubsection \<open>Subcrings\<close>

lemma (in ring) subcringI:
  assumes "subring H R"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 = h2 \<otimes> h1"
  shows "subcring H R"
  unfolding subcring_def subcring_axioms_def using assms by simp+

lemma (in cring) subcringI':
  assumes "subring H R"
  shows "subcring H R"
  using subcringI[OF assms] subringE(1)[OF assms] m_comm by auto

lemma subcringE:
  assumes "subcring H R"
  shows "H \<subseteq> carrier R"
    and "\<zero>\<^bsub>R\<^esub> \<in> H"
    and "\<one>\<^bsub>R\<^esub> \<in> H"
    and "H \<noteq> {}"
    and "\<And>h. h \<in> H \<Longrightarrow> \<ominus>\<^bsub>R\<^esub> h \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<oplus>\<^bsub>R\<^esub> h2 \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 = h2 \<otimes>\<^bsub>R\<^esub> h1"
  using subringE[OF subcring.axioms(1)[OF assms]] subcring.sub_m_comm[OF assms] by simp+

lemma (in cring) carrier_is_subcring: "subcring (carrier R) R"
  by (simp add: subcringI' carrier_is_subring)

lemma (in ring) subcring_inter:
  assumes "subcring I R" and "subcring J R"
  shows "subcring (I \<inter> J) R"
  using subcringE[OF assms(1)] subcringE[OF assms(2)]
        subcringI[of "I \<inter> J"] subringI[of "I \<inter> J"] by auto

lemma (in ring) subcring_Inter:
  assumes "\<And>I. I \<in> S \<Longrightarrow> subcring I R" and "S \<noteq> {}"
  shows "subcring (\<Inter>S) R"
proof (rule subcringI)
  show "subring (\<Inter>S) R"
    using subcring.axioms(1)[of _ R] subring_Inter[of S] assms by auto
next
  fix h1 h2 assume h1: "h1 \<in> \<Inter>S" and h2: "h2 \<in> \<Inter>S"
  obtain S' where S': "S' \<in> S"
    using assms(2) by blast
  hence "h1 \<in> S'" "h2 \<in> S'"
    using h1 h2 by blast+
  thus "h1 \<otimes> h2 = h2 \<otimes> h1"
    using subcring.sub_m_comm[OF assms(1)[OF S']] by simp
qed

lemma (in ring) subcring_iff:
  assumes "H \<subseteq> carrier R"
  shows "subcring H R \<longleftrightarrow> cring (R \<lparr> carrier := H \<rparr>)"
proof
  assume A: "subcring H R"
  hence ring: "ring (R \<lparr> carrier := H \<rparr>)"
    using subring_iff[OF assms] subcring.axioms(1)[OF A] by simp
  moreover have "comm_monoid (R \<lparr> carrier := H \<rparr>)"
    using monoid.monoid_comm_monoidI[OF ring.is_monoid[OF ring]]
          subcring.sub_m_comm[OF A] by auto
  ultimately show "cring (R \<lparr> carrier := H \<rparr>)"
    using cring_def by blast
next
  assume A: "cring (R \<lparr> carrier := H \<rparr>)"
  hence "subring H R"
    using cring.axioms(1) subring_iff[OF assms] by simp
  moreover have "comm_monoid (R \<lparr> carrier := H \<rparr>)"
    using A unfolding cring_def by simp
  hence"\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 = h2 \<otimes> h1"
    using comm_monoid.m_comm[of "R \<lparr> carrier := H \<rparr>"] by auto
  ultimately show "subcring H R"
    unfolding subcring_def subcring_axioms_def by auto
qed

subsubsection \<open>Subdomains\<close>

lemma (in ring) subdomainI:
  assumes "subcring H R"
    and "\<one> \<noteq> \<zero>"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 = \<zero> \<Longrightarrow> h1 = \<zero> \<or> h2 = \<zero>"
  shows "subdomain H R"
  unfolding subdomain_def subdomain_axioms_def using assms by simp+

lemma (in domain) subdomainI':
  assumes "subring H R"
  shows "subdomain H R"
proof (rule subdomainI[OF subcringI[OF assms]], simp_all)
  show "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes> h2 = h2 \<otimes> h1"
    using m_comm subringE(1)[OF assms] by auto
  show "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H; h1 \<otimes> h2 = \<zero> \<rbrakk> \<Longrightarrow> (h1 = \<zero>) \<or> (h2 = \<zero>)"
    using integral subringE(1)[OF assms] by auto
qed

lemma subdomainE:
  assumes "subdomain H R"
  shows "H \<subseteq> carrier R"
    and "\<zero>\<^bsub>R\<^esub> \<in> H"
    and "\<one>\<^bsub>R\<^esub> \<in> H"
    and "H \<noteq> {}"
    and "\<And>h. h \<in> H \<Longrightarrow> \<ominus>\<^bsub>R\<^esub> h \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<oplus>\<^bsub>R\<^esub> h2 \<in> H"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 = h2 \<otimes>\<^bsub>R\<^esub> h1"
    and "\<And>h1 h2. \<lbrakk> h1 \<in> H; h2 \<in> H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 = \<zero>\<^bsub>R\<^esub> \<Longrightarrow> h1 = \<zero>\<^bsub>R\<^esub> \<or> h2 = \<zero>\<^bsub>R\<^esub>"
    and "\<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>"
  using subcringE[OF subdomain.axioms(1)[OF assms]] assms
  unfolding subdomain_def subdomain_axioms_def by auto

lemma (in ring) subdomain_iff:
  assumes "H \<subseteq> carrier R"
  shows "subdomain H R \<longleftrightarrow> domain (R \<lparr> carrier := H \<rparr>)"
proof
  assume A: "subdomain H R"
  hence cring: "cring (R \<lparr> carrier := H \<rparr>)"
    using subcring_iff[OF assms] subdomain.axioms(1)[OF A] by simp
  thus "domain (R \<lparr> carrier := H \<rparr>)"
    using domain.intro[OF cring] subdomain.subintegral[OF A] subdomain.sub_one_not_zero[OF A]
    unfolding domain_axioms_def by auto
next
  assume A: "domain (R \<lparr> carrier := H \<rparr>)"
  hence subcring: "subcring H R"
    using subcring_iff[OF assms] unfolding domain_def by simp
  thus "subdomain H R"
    using subdomain.intro[OF subcring] domain.integral[OF A] domain.one_not_zero[OF A]
    unfolding subdomain_axioms_def by auto
qed

lemma (in domain) subring_is_domain:
  assumes "subring H R" shows "domain (R \<lparr> carrier := H \<rparr>)"
  using subdomainI'[OF assms] unfolding subdomain_iff[OF subringE(1)[OF assms]] .

(* NEW ====================== *)
lemma (in ring) subdomain_is_domain:
  assumes "subdomain H R" shows "domain (R \<lparr> carrier := H \<rparr>)"
  using assms unfolding subdomain_iff[OF subdomainE(1)[OF assms]] .

subsubsection \<open>Subfields\<close>

lemma (in ring) subfieldI:
  assumes "subcring K R" and "Units (R \<lparr> carrier := K \<rparr>) = K - { \<zero> }"
  shows "subfield K R"
proof (rule subfield.intro)
  show "subfield_axioms K R"
    using assms(2) unfolding subfield_axioms_def .
  show "subdomain K R"
  proof (rule subdomainI[OF assms(1)], auto)
    have subM: "submonoid K R"
      using subring.axioms(2)[OF subcring.axioms(1)[OF assms(1)]] .

    show contr: "\<one> = \<zero> \<Longrightarrow> False"
    proof -
      assume one_eq_zero: "\<one> = \<zero>"
      have "\<one> \<in> K" and "\<one> \<otimes> \<one> = \<one>"
        using submonoid.one_closed[OF subM] by simp+
      hence "\<one> \<in> Units (R \<lparr> carrier := K \<rparr>)"
        unfolding Units_def by (simp, blast)
      hence "\<one> \<noteq> \<zero>"
        using assms(2) by simp
      thus False
        using one_eq_zero by simp
    qed

    fix k1 k2 assume k1: "k1 \<in> K" and k2: "k2 \<in> K" "k2 \<noteq> \<zero>" and k12: "k1 \<otimes> k2 = \<zero>"
    obtain k2' where k2': "k2' \<in> K" "k2' \<otimes> k2 = \<one>" "k2 \<otimes> k2' = \<one>"
      using assms(2) k2 unfolding Units_def by auto
    have  "\<zero> = (k1 \<otimes> k2) \<otimes> k2'"
      using k12 k2'(1) submonoid.mem_carrier[OF subM] by fastforce
    also have  "... = k1"
      using k1 k2(1) k2'(1,3) submonoid.mem_carrier[OF subM] by (simp add: m_assoc)
    finally have "\<zero> = k1" .
    thus "k1 = \<zero>" by simp
  qed
qed

lemma (in field) subfieldI':
  assumes "subring K R" and "\<And>k. k \<in> K - { \<zero> } \<Longrightarrow> inv k \<in> K"
  shows "subfield K R"
proof (rule subfieldI)
  show "subcring K R"
    using subcringI[OF assms(1)] m_comm subringE(1)[OF assms(1)] by auto
  show "Units (R \<lparr> carrier := K \<rparr>) = K - { \<zero> }"
  proof
    show "K - { \<zero> } \<subseteq> Units (R \<lparr> carrier := K \<rparr>)"
    proof
      fix k assume k: "k \<in> K - { \<zero> }"
      hence inv_k: "inv k \<in> K"
        using assms(2) by simp
      moreover have "k \<in> carrier R - { \<zero> }"
        using subringE(1)[OF assms(1)] k by auto
      ultimately have "k \<otimes> inv k = \<one>" "inv k \<otimes> k = \<one>"
        by (simp add: field_Units)+
      thus "k \<in> Units (R \<lparr> carrier := K \<rparr>)"
        unfolding Units_def using k inv_k by auto
    qed
  next
    show "Units (R \<lparr> carrier := K \<rparr>) \<subseteq> K - { \<zero> }"
    proof
      fix k assume k: "k \<in> Units (R \<lparr> carrier := K \<rparr>)"
      then obtain k' where k': "k' \<in> K" "k \<otimes> k' = \<one>"
        unfolding Units_def by auto
      hence "k \<in> carrier R" and "k' \<in> carrier R"
        using k subringE(1)[OF assms(1)] unfolding Units_def by auto
      hence "\<zero> = \<one>" if "k = \<zero>"
        using that k'(2) by auto
      thus "k \<in> K - { \<zero> }"
        using k unfolding Units_def by auto
    qed
  qed
qed

lemma (in field) carrier_is_subfield: "subfield (carrier R) R"
  by (auto intro: subfieldI[OF carrier_is_subcring] simp add: field_Units)

lemma subfieldE:
  assumes "subfield K R"
  shows "subring K R" and "subcring K R"
    and "K \<subseteq> carrier R"
    and "\<And>k1 k2. \<lbrakk> k1 \<in> K; k2 \<in> K \<rbrakk> \<Longrightarrow> k1 \<otimes>\<^bsub>R\<^esub> k2 = k2 \<otimes>\<^bsub>R\<^esub> k1"
    and "\<And>k1 k2. \<lbrakk> k1 \<in> K; k2 \<in> K \<rbrakk> \<Longrightarrow> k1 \<otimes>\<^bsub>R\<^esub> k2 = \<zero>\<^bsub>R\<^esub> \<Longrightarrow> k1 = \<zero>\<^bsub>R\<^esub> \<or> k2 = \<zero>\<^bsub>R\<^esub>"
    and "\<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>"
  using subdomain.axioms(1)[OF subfield.axioms(1)[OF assms]] subcring_def
        subdomainE(1, 8, 9, 10)[OF subfield.axioms(1)[OF assms]] by auto

lemma (in ring) subfield_m_inv:
  assumes "subfield K R" and "k \<in> K - { \<zero> }"
  shows "inv k \<in> K - { \<zero> }" and "k \<otimes> inv k = \<one>" and "inv k \<otimes> k = \<one>"
proof -
  have K: "subring K R" "submonoid K R"
    using subfieldE(1)[OF assms(1)] subring.axioms(2) by auto
  have monoid: "monoid (R \<lparr> carrier := K \<rparr>)"
    using submonoid.submonoid_is_monoid[OF subring.axioms(2)[OF K(1)] is_monoid] .

  have "monoid R"
    by (simp add: monoid_axioms)

  hence k: "k \<in> Units (R \<lparr> carrier := K \<rparr>)"
    using subfield.subfield_Units[OF assms(1)] assms(2) by blast
  hence unit_of_R: "k \<in> Units R"
    using assms(2) subringE(1)[OF subfieldE(1)[OF assms(1)]] unfolding Units_def by auto
  have "inv\<^bsub>(R \<lparr> carrier := K \<rparr>)\<^esub> k \<in> Units (R \<lparr> carrier := K \<rparr>)"
    by (simp add: k monoid monoid.Units_inv_Units)
  hence "inv\<^bsub>(R \<lparr> carrier := K \<rparr>)\<^esub> k \<in> K - { \<zero> }"
    using subfield.subfield_Units[OF assms(1)] by blast
  thus "inv k \<in> K - { \<zero> }" and "k \<otimes> inv k = \<one>" and "inv k \<otimes> k = \<one>"
    using Units_l_inv[OF unit_of_R] Units_r_inv[OF unit_of_R]
    using monoid.m_inv_monoid_consistent[OF monoid_axioms k K(2)] by auto
qed

lemma (in ring) subfield_m_inv_simprule:
  assumes "subfield K R"
  shows "\<lbrakk> k \<in> K - { \<zero> }; a \<in> carrier R \<rbrakk> \<Longrightarrow> k \<otimes> a \<in> K \<Longrightarrow> a \<in> K"
proof -
  note subring_props = subringE[OF subfieldE(1)[OF assms]]

  assume A: "k \<in> K - { \<zero> }" "a \<in> carrier R" "k \<otimes> a \<in> K"
  then obtain k' where k': "k' \<in> K" "k \<otimes> a = k'" by blast
  have inv_k: "inv k \<in> K" "inv k \<otimes> k = \<one>"
    using subfield_m_inv[OF assms A(1)] by auto
  hence "inv k \<otimes> (k \<otimes> a) \<in> K"
    using k' A(3) subring_props(6) by auto
  thus "a \<in> K"
    using m_assoc[of "inv k" k a] A(2) inv_k subring_props(1)
    by (metis (no_types, hide_lams) A(1) Diff_iff l_one subsetCE)
qed

lemma (in ring) subfield_iff:
  shows "\<lbrakk> field (R \<lparr> carrier := K \<rparr>); K \<subseteq> carrier R \<rbrakk> \<Longrightarrow> subfield K R"
    and "subfield K R \<Longrightarrow> field (R \<lparr> carrier := K \<rparr>)"
proof-
  assume A: "field (R \<lparr> carrier := K \<rparr>)" "K \<subseteq> carrier R"
  have "\<And>k1 k2. \<lbrakk> k1 \<in> K; k2 \<in> K \<rbrakk> \<Longrightarrow> k1 \<otimes> k2 = k2 \<otimes> k1"
    using comm_monoid.m_comm[OF cring.axioms(2)[OF fieldE(1)[OF A(1)]]]  by simp
  moreover have "subring K R"
    using ring_incl_imp_subring[OF A(2) cring.axioms(1)[OF fieldE(1)[OF A(1)]]] .
  ultimately have "subcring K R"
    using subcringI by simp
  thus "subfield K R"
    using field.field_Units[OF A(1)] subfieldI by auto
next
  assume A: "subfield K R"
  have cring: "cring (R \<lparr> carrier := K \<rparr>)"
    using subcring_iff[OF subringE(1)[OF subfieldE(1)[OF A]]] subfieldE(2)[OF A] by simp
  thus "field (R \<lparr> carrier := K \<rparr>)"
    using cring.cring_fieldI[OF cring] subfield.subfield_Units[OF A] by simp
qed

subsection \<open>Subring Homomorphisms\<close>

(* PROOF ====================== *)
lemma (in ring) hom_imp_img_subring:
  assumes "h \<in> ring_hom R S" and "subring K R"
  shows "ring (S \<lparr> carrier := h ` K, zero := h \<zero> \<rparr>)"
proof -
  have "ring (R \<lparr> carrier := K \<rparr>)"
    using subring_is_ring[OF assms(2)] by simp
  moreover have "h \<in> ring_hom (R \<lparr> carrier := K \<rparr>) S"
    using assms subringE(1)[OF assms (2)] unfolding ring_hom_def
    apply simp
    apply blast
    done
  ultimately show ?thesis
    using ring.ring_hom_imp_img_ring[of "R \<lparr> carrier := K \<rparr>" h S] by simp
qed

lemma (in ring_hom_ring) img_is_subring:
  assumes "subring K R" shows "subring (h ` K) S"
proof -
  have "ring (S \<lparr> carrier := h ` K \<rparr>)"
    using R.hom_imp_img_subring[OF homh assms] hom_zero hom_one by simp
  moreover have "h ` K \<subseteq> carrier S"
    using ring_hom_memE(1)[OF homh] subringE(1)[OF assms] by auto
  ultimately show ?thesis
    using ring_incl_imp_subring by simp
qed

(* PROOF ====================== *)
lemma (in ring_hom_ring) img_is_subfield:
  assumes "subfield K R" and "\<one>\<^bsub>S\<^esub> \<noteq> \<zero>\<^bsub>S\<^esub>"
  shows "inj_on h K" and "subfield (h ` K) S"
proof -
  have K: "K \<subseteq> carrier R" "subring K R" "subring (h ` K) S"
    using subfieldE(1)[OF assms(1)] subringE(1) img_is_subring by auto
  have field: "field (R \<lparr> carrier := K \<rparr>)"
   and ring: "ring (R \<lparr> carrier := K \<rparr>)" "ring (S \<lparr> carrier := h ` K \<rparr>)"
    using R.subfield_iff assms(1)
          R.subring_is_ring[OF K(2)]
          S.subring_is_ring[OF K(3)] by auto

  hence h: "h \<in> ring_hom (R \<lparr> carrier := K \<rparr>) (S \<lparr> carrier := h ` K \<rparr>)"
    unfolding ring_hom_def apply auto
    using ring_hom_memE[OF homh] K
    by (meson contra_subsetD)+
  hence ring_hom: "ring_hom_ring (R \<lparr> carrier := K \<rparr>) (S \<lparr> carrier := h ` K \<rparr>) h"
    using ring_axioms ring ring_hom_ringI2 by blast
  have "h ` K \<noteq> { \<zero>\<^bsub>S\<^esub> }"
    using subfieldE(1, 5)[OF assms(1)] subringE(3) assms(2)
    by (metis hom_one image_eqI singletonD)
  thus "inj_on h K"
    using ring_hom_ring.non_trivial_field_hom_imp_inj[OF ring_hom field] by auto

  hence "h \<in> ring_iso (R \<lparr> carrier := K \<rparr>) (S \<lparr> carrier := h ` K \<rparr>)"
    using h unfolding ring_iso_def bij_betw_def by auto
  hence "field (S \<lparr> carrier := h ` K \<rparr>)"
    using field.ring_iso_imp_img_field[OF field, of h "S \<lparr> carrier := h ` K \<rparr>"] by auto
  thus "subfield (h ` K) S"
    using S.subfield_iff[of "h ` K"] K(1) ring_hom_memE(1)[OF homh] by blast
qed

(* NEW ========================================================================== *)
lemma (in ring_hom_ring) induced_ring_hom:
  assumes "subring K R" shows "ring_hom_ring (R \<lparr> carrier := K \<rparr>) S h"
proof -
  have "h \<in> ring_hom (R \<lparr> carrier := K \<rparr>) S"
    using homh subringE(1)[OF assms] unfolding ring_hom_def
    by (auto, meson hom_mult hom_add subsetCE)+
  thus ?thesis
    using R.subring_is_ring[OF assms] ring_axioms
    unfolding ring_hom_ring_def ring_hom_ring_axioms_def by auto
qed

(* NEW ========================================================================== *)
lemma (in ring_hom_ring) inj_on_subgroup_iff_trivial_ker:
  assumes "subring K R"
  shows "inj_on h K \<longleftrightarrow> a_kernel (R \<lparr> carrier := K \<rparr>) S h = { \<zero> }"
  using ring_hom_ring.inj_iff_trivial_ker[OF induced_ring_hom[OF assms]] by simp

lemma (in ring_hom_ring) inv_ring_hom:
  assumes "inj_on h K" and "subring K R"
  shows "ring_hom_ring (S \<lparr> carrier := h ` K \<rparr>) R (inv_into K h)"
proof (intro ring_hom_ringI[OF _ R.ring_axioms], auto)
  show "ring (S \<lparr> carrier := h ` K \<rparr>)"
    using subring_is_ring[OF img_is_subring[OF assms(2)]] .
next
  show "inv_into K h \<one>\<^bsub>S\<^esub> = \<one>\<^bsub>R\<^esub>"
    using assms(1) subringE(3)[OF assms(2)] hom_one by (simp add: inv_into_f_eq)
next
  fix k1 k2
  assume k1: "k1 \<in> K" and k2: "k2 \<in> K"
  with \<open>k1 \<in> K\<close> show "inv_into K h (h k1) \<in> carrier R"
    using assms(1) subringE(1)[OF assms(2)] by (simp add: subset_iff)

  from \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close>
  have "h k1 \<oplus>\<^bsub>S\<^esub> h k2 = h (k1 \<oplus>\<^bsub>R\<^esub> k2)" and "k1 \<oplus>\<^bsub>R\<^esub> k2 \<in> K"
   and "h k1 \<otimes>\<^bsub>S\<^esub> h k2 = h (k1 \<otimes>\<^bsub>R\<^esub> k2)" and "k1 \<otimes>\<^bsub>R\<^esub> k2 \<in> K"
    using subringE(1,6,7)[OF assms(2)] by (simp add: subset_iff)+
  thus "inv_into K h (h k1 \<oplus>\<^bsub>S\<^esub> h k2) = inv_into K h (h k1) \<oplus>\<^bsub>R\<^esub> inv_into K h (h k2)"
   and "inv_into K h (h k1 \<otimes>\<^bsub>S\<^esub> h k2) = inv_into K h (h k1) \<otimes>\<^bsub>R\<^esub> inv_into K h (h k2)"
    using assms(1) k1 k2 by simp+
qed

end