Theory Phi_BI.Phi_BI

(*TODO: lift it to a chapter*)
chapter ‹A Bunched Implications Equipped with Satisfaction›

text ‹It also contains a simplified BI specialized for only necessary constructs required
  by ‹Multi-Term Form›.

 ‹Multi-Term Form› is the canonical form in the reasoning of φ-System, which demonstrates
  abstractions directly and clearly in a localized way. It is characterized by form,
\[ ∃a. (x1 ⦂ T1 ∗ x2 ⦂ T2 ∗ ⋯ xn ⦂ Tn) ∧ P› \]
where P› is a pure proposition only containing free variables occurring in x1,⋯,xn,a›.
It relates the concrete resource to a set of abstract objects {(x1,⋯,xn) |a. P}› if
  ‹variables a› are not free in T1,⋯,Tn.
All specifications in φ-System are in Multi-Term Form. It is so pervasive that we use a set-like
notation to denote them,
\[ (x1 ⦂ T1 ∗ x2 ⦂ T2 ∗ ⋯ xn ⦂ Tn 𝗌𝗎𝖻𝗃 a. P)› \]
Readers may read it as a set,
\[ { x1 ⦂ T1 ∗ x2 ⦂ T2 ∗ ⋯ xn ⦂ Tn |a. P }› \]

 ‹Simple Multi-Term Form› is a MTF where there is no existential quantification and the attached
  P› is trivial True›, viz., it is characterized by
  \[ x1 ⦂ T1 ∗ ⋯ ∗ xn ⦂ Tn \]
›

text ‹
Specifically, in this minimal specialized BI:

   It does not have a general additive conjunction (∧›) that connects any BI assertions,
    but only the one (A 𝗌𝗎𝖻𝗃 P›) connects a BI assertion A› and a pure assertion P›,
    because it is exactly what at most the MTF requires.

   Implication does not occur in assertions (of φ-SL), but it represents transformations of
    abstraction so has a significant role in reasoning (rules).
    We emphasize this transformation by assigning the implication with notation
    A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ≜ A ⟶ B ∧ P›, where P› is a pure assertion.
    The P› helps to capture the information (in abstract domain) lost in the
    weakening of this implication.
    Currying implications like A ⟶ B ⟶ C› are never used in φ-BI.

   Optionally we have universal quantification. It can be used to quantify free variables
    if for any reason free variables are inadmissible. The universal quantifier is typically
    not necessary in φ-BI and φ-SL, where we use free variables directly. However, in some
    situation, like when we consider transitions of resource states and we want a transition
    relation for each procedure, we need a single universally quantified assertion,
    instead of a family of assertions indexed by free variables.

   The use of a implication represents a transformation of abstraction.
    Therefore, implications are never curried or nested, always in form X ⟶ Y ∧ P›
    where X, Y› are MTF and P› is a pure proposition.
    We denote them by notation X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›.

   It only has multiplicative conjunctions, specialized additive conjunction described above,
    existential quantification, and optionally universal quantification,
    which are all the MTF requires,
    plus implications that only occur in reasoning rules.
    Any other things, should be some specific φ-Types expressing their meaning
    specifically and particularly.
›

theory Phi_BI
  imports "Phi_Logic_Programming_Reasoner.PLPR" Phi_Preliminary
  abbrevs "<:>" = "⦂"
      and "<trans>" = "𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌"
      and "<transforms>" = "𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌"
      and "<with>"  = "𝗐𝗂𝗍𝗁"
      and "<subj>" = "𝗌𝗎𝖻𝗃"
      and "<when>" = "𝗐𝗁𝖾𝗇"
      and "<remains>" = "𝗋𝖾𝗆𝖺𝗂𝗇𝗌"
      and "<get>" = "𝗀𝖾𝗍"
      and "<map>" = "𝗆𝖺𝗉"
      and "<by>" = "𝖻𝗒"
      and "<from>" = "𝖿𝗋𝗈𝗆"
      and "<remaining>" = "𝗋𝖾𝗆𝖺𝗂𝗇𝗂𝗇𝗀"
      and "<demanding>" = "𝖽𝖾𝗆𝖺𝗇𝖽𝗂𝗇𝗀"
      and "<to>" = "𝗍𝗈"
      and "<over>" = "𝗈𝗏𝖾𝗋"
      and "<subst>" = "𝗌𝗎𝖻𝗌𝗍"
      and "<for>" = "𝖿𝗈𝗋"
      and "<TP>" = "𝒯𝒫"
begin

section ‹Judgement›

datatype 'a BI = BI (dest: 'a set)
hide_const (open) dest

definition Satisfaction :: 'a  'a BI  bool (infix "" 50)
  where (x  A)  (x  BI.dest A)

lemma Satisfaction_BI_red[simp]:
  x  BI S  x  S
  unfolding Satisfaction_def by simp

lemma In_BI_dest[iff]:
  x  BI.dest S  x  S
  by (cases S; simp)

subsubsection ‹Bootstrap Basics›

lemma split_BI_all: (x. P x)  (x. P (BI x)) by (metis BI.collapse) 
lemma split_BI_ex: (x. P x)  (x. P (BI x)) by (metis BI.collapse) 

lemma split_BI_meta_all:
  (x. PROP P x)  (x. PROP P (BI x))
proof
  fix x assume x. PROP P x then show PROP P (BI x) .
next
  fix x assume x. PROP P (BI x) from this[of BI.dest x] show PROP P x by simp
qed

subsection ‹Algebraic Properties of BI›

instantiation BI :: (type) zero begin
definition zero_BI where "zero_BI = BI {}"
instance ..
end

instantiation BI :: (one) one begin
definition "one_BI = BI {1::'a}"
instance ..
end

instantiation BI :: ("{sep_disj,times}") times begin
definition "times_BI P Q = BI { x * y | x y. x  P  y  Q  x ## y }"
instance ..
end

instance BI :: ("{sep_disj,times}") mult_zero 
  by (standard; simp add: zero_BI_def times_BI_def)

instance BI :: ("{sep_magma_1,no_inverse}") no_inverse
  by (standard; simp add: one_BI_def times_BI_def set_eq_iff split_BI_meta_all;
      metis (no_types, opaque_lifting) no_inverse sep_magma_1_left sep_magma_1_right)

instantiation BI :: (type) total_sep_disj begin
definition sep_disj_BI :: 'a BI  'a BI  bool where [simp]: sep_disj_BI _ _ = True
instance by (standard; simp)
end

instance BI :: (sep_magma) sep_magma ..

instance BI :: (sep_magma_1) sep_magma_1 proof
  fix x :: 'a BI
  show 1 * x = x by (cases x; simp add: one_BI_def times_BI_def)
  show x * 1 = x by (cases x; simp add: one_BI_def times_BI_def)
  show x ## 1 by simp
  show 1 ## x by simp
qed

instance BI :: (sep_no_inverse) sep_no_inverse
  by (standard, simp add: one_BI_def times_BI_def set_eq_iff split_BI_meta_all;
      metis (no_types, opaque_lifting) sep_magma_1_left sep_magma_1_right sep_no_inverse)

instance BI :: (sep_disj_distrib) sep_disj_distrib by (standard; simp)

instance BI :: (sep_semigroup) semigroup_mult
  apply (standard; clarsimp simp add: times_BI_def algebra_simps set_eq_iff; rule; clarsimp)
  using sep_disj_multD2 sep_disj_multI2 sep_mult_assoc apply blast
  by (metis sep_disj_multD1 sep_disj_multI1 sep_mult_assoc)

instance BI :: (sep_monoid) monoid_mult
  by standard simp_all

instance BI :: (sep_ab_semigroup) ab_semigroup_mult
  apply (standard; simp add: times_BI_def set_eq_iff)
  using sep_disj_commute sep_mult_commute by blast

instance BI :: (sep_algebra) comm_monoid_mult
  by (standard; simp_all add: one_set_def times_set_def)

instantiation BI :: (type) comm_monoid_add begin
definition plus_BI x y = BI (BI.dest x  BI.dest y)
instance by standard (auto simp add: plus_BI_def zero_BI_def split_BI_meta_all)
end

instantiation BI :: (type) order begin
definition less_BI :: 'a BI  'a BI  bool
  where less_BI A B  BI.dest A < BI.dest B
definition less_eq_BI :: 'a BI  'a BI  bool
  where less_eq_BI A B  BI.dest A  BI.dest B

lemma less_BI[simp]: BI A < BI B  A < B unfolding less_BI_def by simp
lemma less_eq_BI[simp]: BI A  BI B  A  B unfolding less_eq_BI_def by simp

lemma less_eq_BI_iff: A  B  (w. w  A  w  B)
  by (cases A; cases B; auto)

instance by (standard; simp add: split_BI_meta_all; blast)
end

instance BI :: (type) ordered_comm_monoid_add
  by standard (auto simp add: plus_BI_def zero_BI_def split_BI_meta_all)

lemma plus_BI_S_S [simp]: S + S = S for S :: 'a BI by (simp add: plus_BI_def)

instance BI :: (sep_semigroup) ordered_semiring_0
  by standard (auto simp add: zero_BI_def plus_BI_def times_BI_def split_BI_meta_all)

instance BI :: (sep_monoid) semiring_1
  by standard (auto simp add: zero_BI_def one_BI_def plus_BI_def times_BI_def split_BI_meta_all)

instance BI :: (sep_ab_semigroup) ordered_comm_semiring
  by standard (auto simp add: zero_BI_def plus_BI_def times_BI_def split_BI_meta_all set_eq_iff)

instance BI :: (sep_algebra) comm_semiring_1
  by standard auto

instantiation BI :: (type) order_top begin
definition top_BI :: 'a BI where top_BI = BI top
instance by (standard; simp add: top_BI_def split_BI_meta_all)
end

instantiation BI :: (type) order_bot begin
definition bot_BI :: 'a BI where bot_BI = BI bot
instance by (standard; simp add: bot_BI_def split_BI_meta_all)
end

notation inf (infixl "" 70)
     and sup (infixl "" 65)

instantiation BI :: (type) semilattice_inf begin
definition inf_BI :: 'a BI  'a BI  'a BI
  where inf_BI A B = BI (BI.dest A  BI.dest B)

lemma inf_BI_red[simp]: BI A  BI B = BI (A  B) by (simp add: inf_BI_def)

instance by (standard; simp add: split_BI_meta_all)
end

instantiation BI :: (type) semilattice_sup begin
definition sup_BI :: 'a BI  'a BI  'a BI
  where sup_BI A B = BI (BI.dest A  BI.dest B)

lemma sup_BI_red[simp]: BI A  BI B = BI (A  B) by (simp add: sup_BI_def)

instance by (standard; simp add: split_BI_meta_all)
end

instance BI :: (type) lattice by standard

instantiation BI :: (type) complete_lattice begin

definition Inf_BI :: 'a BI set  'a BI
  where Inf_BI S = BI (Inf (BI.dest ` S))
definition Sup_BI :: 'a BI set  'a BI
  where Sup_BI S = BI (Sup (BI.dest ` S))

lemma Inf_BI_expn[iff]:
  w  Inf S  (AS. w  A)
  unfolding Inf_BI_def by (auto simp: split_BI_meta_all)

lemma Sup_BI_expn[iff]:
  w  Sup S  (AS. w  A)
  unfolding Sup_BI_def
  by (auto simp: split_BI_meta_all)

instance by (
      (standard; (simp add: split_BI_meta_all less_eq_BI_iff)?),
      meson Satisfaction_BI_red,
      metis BI.collapse Satisfaction_def,
      simp add: Inf_BI_def top_BI_def,
      simp add: Sup_BI_def bot_BI_def)
end

subsection ‹Basics›

subsubsection ‹Basic Operations & Rules›

lemma BI_eq_iff:
  S = S'  (u. u  S  u  S')
  unfolding Satisfaction_def
  by (cases S, cases S', simp add: set_eq_iff)

definition I_image :: ('a  'b)  'a BI  'b BI  (infixr "`I" 90)
  where f `I A = BI (f ` BI.dest A)

lemma I_image_red[simp]:
  f `I BI A = BI (f ` A)
  unfolding I_image_def
  by simp

lemma I_image_expn[iff, φexpns]:
  w  f `I A  (w'. w = f w'  w'  A)
  by (cases A; simp; blast)

subsubsection ‹Basic Rewrites›

lemma sep_conj_expn[simp, φexpns]:
  uv  (S * T)  (u v. uv = u * v  u  S  v  T  u ## v)
  unfolding Satisfaction_def times_BI_def
  by simp

definition Subjection :: " 'p BI  bool  'p BI " (infixl "𝗌𝗎𝖻𝗃" 15)
  where " (T 𝗌𝗎𝖻𝗃 P) = BI {p. p  T  P}"

lemma Subjection_expn[iff, φexpns]:
  p  (S 𝗌𝗎𝖻𝗃 P)  p  S  P
  by (cases S; simp add: Subjection_def)

(*
lemma Subjection_Id_on:
  ‹Id_on (S 𝗌𝗎𝖻𝗃 P) = (Id_on S 𝗌𝗎𝖻𝗃 P)›
  by (auto simp add: Subjection_expn_set)
*)

lemma Subjection_image:
  f `I (S 𝗌𝗎𝖻𝗃 P) = (f `I S 𝗌𝗎𝖻𝗃 P)
  unfolding BI_eq_iff
  by simp blast

definition ExBI :: " ('x  'c BI)  'c BI" (binder "∃*" 14)
  where "ExBI S = BI {p. (c. p  S c)}"

lemma ExBI_expn[iff, φexpns]:
  p  (ExBI S)  (x. p  S x)
  by (simp add: ExBI_def)

lemma Zero_expn[iff, φexpns]:
  ¬ (p  0)
  unfolding Satisfaction_def
  by (simp add: zero_BI_def)

lemma One_expn[iff, φexpns]:
  v  1  v = 1
  unfolding Satisfaction_def
  by (simp add: one_BI_def)

lemma Top_expn[iff, φexpns]:
  v  top
  unfolding Satisfaction_def
  by (simp add: top_BI_def)

subsubsection ‹Lift›

definition BI_lift :: 'a set  'a BI
  where BI_lift S = BI S

lemma BI_lift_expn[iff]:
  w  BI_lift S  w  S
  unfolding BI_lift_def by simp


subsection ‹Reasoning Configuration›

φreasoner_group extract_pure_sat = (%extract_pure+100, [%extract_pure+100, %extract_pure+130])
                                    for (𝗋EIF _ _, 𝗋ESC _ _)
                                     in extract_pure_all and > extract_pure
  ‹Rules extracting BI properties down to Satisfaction›

section ‹Connectives›

subsection ‹φ-Type›

type_synonym ('concrete,'abstract) φ = " 'abstract  'concrete BI "

definition φType :: "'b  ('a,'b) φ  'a BI" (infix "" 20) where " x  T  T x"

text ‹Convention of name:

In x ⦂ T›, we refer to x› as the ‹object› or the ‹φ-type term› and T› as the ‹φ-type›.
For convenience, when the context is unambiguous, we also call the entire x ⦂ T› as 'φ-type',
but as ‹φ-type assertion› to be precise.
›

subsubsection ‹Basic \& Auxiliary Rules›

lemma φType_eqI:
  (x p. p  (x  a)  p  (x  b))  a = b
  unfolding φType_def Satisfaction_def
  by (metis ext less_BI_def less_eq_BI_def order.order_iff_strict subset_iff subset_not_subset_eq)

lemma φType_protect_type_cong:
  x  x'
 x  T  x'  T
  by simp

setup Context.theory_map (PLPR_Rule_Gen.Rule_Gen_SS.map (
  Simplifier.add_cong @{thm' φType_protect_type_cong}))

ML_file ‹library/tools/simp_congruence.ML›

subsection ‹Inhabitance›

definition Satisfiable :: " 'a BI  bool "
  where "Satisfiable S = (p. p  S)"
  ― ‹Satisfiable S› should be always regarded as an atom in the view of ATPs.

      The fallback of extracting implied pure facts returns the original Satisfiable T› unchanged,
      P 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Satisfiable P› where Satisfiable P› should be regarded as an atom.›

definition Inhabited
  where Inhabited T  (x. Satisfiable (x  T))


abbreviation Inhabitance_Implication :: 'a BI  bool  bool (infix "𝗂𝗆𝗉𝗅𝗂𝖾𝗌" 10)
  where S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P  𝗋EIF (Satisfiable S) P
  ― ‹P is weaker than S. We want to get a simpler P and as strong as possible. ›

abbreviation Sufficient_Inhabitance :: bool  'a BI  bool (infix "𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌" 10)
  where P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S  𝗋ESC P (Satisfiable S)
  ― ‹P is stronger than S. We want to get a simpler P and as weak as possible. ›

declare [[
  φreason_default_pattern Satisfiable ?X  _  ERROR TEXT(‹bad form›) (100)
                      and _  Satisfiable ?X  ERROR TEXT(‹bad form›) (100)
                      and Inhabited ?T   Inhabited ?T      (100),
  φpremise_attribute once? [φreason? %local] for Inhabited _  (%φattr)
]]

φreasoner_group extract_pure_phity = (10, [10,10]) for (x  T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P, P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x  T)
  > extract_pure_fallback and < extract_pure
  ‹Entry points towards ‹Abstract_Domain› and ‹Abstract_DomainL› ›

φreasoner_group inhabited_all = (100, [10, 3000]) for (Inhabited T) ‹›
  and inhabited = (1000, [1000, 1030]) in inhabited_all ‹›
  and inhabited_derived = (40, [30,50]) in inhabited_all and < inhabited ‹›
  and inhabited_default = (10, [10,20]) in inhabited_all and < inhabited_derived ‹›

subsubsection ‹Basic Rules›

lemma Satisfiable_I:
  x  S  Satisfiable S
  unfolding Satisfiable_def ..

lemma Satisfiable_fallback:
  X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Satisfiable X
  unfolding 𝗋EIF_def by blast

lemma Suf_Satisfiable_fallback:
  Satisfiable X 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X
  unfolding 𝗋ESC_def by blast

φreasoner_ML Satisfiable_fallback default 2 (_ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 _) =
fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  if Config.get ctxt Phi_Reasoners.is_generating_extraction_rule
  then SOME ((ctxt, Thm.permute_prems 0 ~1 sequent), Seq.empty)
  else SOME ((ctxt, @{thm Satisfiable_fallback} RS sequent), Seq.empty)
)

φreasoner_ML Suf_Satisfiable_fallback default 2 (_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 _) =
fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  if Config.get ctxt Phi_Reasoners.is_generating_extraction_rule
  then SOME ((ctxt, Thm.permute_prems 0 ~1 sequent), Seq.empty)
  else SOME ((ctxt, @{thm Suf_Satisfiable_fallback} RS sequent), Seq.empty)
)

lemma [φreason 1000]:
  P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
 Satisfiable A
  unfolding 𝗋ESC_def Premise_def
  by blast

lemma inhabited_type_EIF':
  𝗋EIF (Inhabited T) (x. Satisfiable (x  T))
  unfolding Inhabited_def 𝗋EIF_def
  by blast

bundle deriving_intabited_type = inhabited_type_EIF'[φreason default %extract_pure]



paragraph ‹Sum Type›

lemma [φreason 1020]:
  A a 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
 case_sum A B (Inl a) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
  by simp

lemma [φreason 1020]:
  B b 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
 case_sum A B (Inr b) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
  by simp

lemma [φreason 1000]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  A a 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P a)
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  B b 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q b)
 case_sum A B x 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 case_sum P Q x
  by (cases x; simp)



subsection ‹Abstract Domain›

lemma typing_inhabited: "p  (x  T)  Satisfiable (x  T)"
  unfolding Satisfiable_def φType_def by blast

definition Abstract_Domain :: ('c,'a) φ  ('a  bool)  bool
  where Abstract_Domain T d  (x. x  T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 d x)
  ― ‹Upper Bound›

definition Abstract_DomainL :: ('c,'a) φ  ('a  bool)  bool
  where Abstract_DomainL T d  (x. d x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x  T)
  ― ‹Lower Bound›

declare [[
  φreason_default_pattern Abstract_Domain ?T _  Abstract_Domain ?T _ (100)
                      and Abstract_DomainL ?T _  Abstract_DomainL ?T _ (100),
  φpremise_attribute once? [φreason? %local] for Abstract_Domain  _ _  (%φattr) ,
  φpremise_attribute once? [φreason? %local] for Abstract_DomainL _ _  (%φattr)
]]

φreasoner_group abstract_domain_all = (1000, [1, 2000]) for (Abstract_Domain T d, Abstract_DomainL T d)
    ‹All reasoning rules giving ‹Abstract_Domain› or ‹Abstract_DomainL››
  and abstract_domain = (1000, [1000, 1000]) for (Abstract_Domain T d, Abstract_DomainL T d)
                                             in abstract_domain_all
    ‹Normal reasoning rules for ‹Abstract_Domain›, ‹Abstract_DomainL››
  and abstract_domain_fallback = (1, [1,1]) for (Abstract_Domain T d, Abstract_DomainL T d) < abstract_domain
                                            in abstract_domain_all
    ‹Fallbacks reasoning rules for ‹Abstract_Domain›, ‹Abstract_DomainL› ›
  and derived_abstract_domain = (60, [50,70]) for (Abstract_Domain T d, Abstract_DomainL T d)
                                              in abstract_domain_all and < abstract_domain
    ‹Automatically derived rules›

  and extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌 = (%extract_pure+40, [%extract_pure+40, %extract_pure+70])
                       for (𝗋EIF (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) Q, 𝗋ESC Q (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P),
                            𝗋EIF (A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 P) Q, 𝗋ESC Q (A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 P))
                       and > extract_pure and < extract_pure_sat ‹›


subsubsection ‹Extracting Pure Facts›

lemma Inhabitance_Implication_𝒜EIF [φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  𝗋ESC A' (Satisfiable A)
 𝗋EIF (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) (A'  P)
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Inhabitance_Implication_𝒜EIF_Sat:
  𝗋EIF (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) ((v. v  A)  P)
  unfolding 𝗋EIF_def Satisfiable_def
  by blast

lemma Inhabitance_Implication_𝒜ESC[φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  𝗋EIF (Satisfiable A) A'
 𝗋ESC (A'  P) (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P)
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Inhabitance_Implication_𝒜ESC_Sat:
  𝗋ESC ((v. v  A)  P) (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P)
  unfolding 𝗋ESC_def 𝗋EIF_def Satisfiable_def
  by blast

lemma Sufficient_Inhabitance_𝒜EIF[φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  𝗋EIF (Satisfiable A) A'
 𝗋EIF (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A) (P  A')
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Sufficient_Inhabitance_𝒜EIF_Sat:
  𝗋EIF (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A) (P  (v. v  A))
  unfolding 𝗋EIF_def 𝗋ESC_def Satisfiable_def
  by blast

lemma Sufficient_Inhabitance_𝒜ESC[φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  𝗋ESC A' (Satisfiable A)
 𝗋ESC (P  A') (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A)
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Sufficient_Inhabitance_𝒜ESC_Sat:
  𝗋ESC (P  (v. v  A)) (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A)
  unfolding 𝗋ESC_def Satisfiable_def
  by blast

bundle extracting_Inhabitance_Implication_sat =
          Inhabitance_Implication_𝒜EIF_Sat [φreason %extract_pure_sat]
          Inhabitance_Implication_𝒜ESC_Sat [φreason %extract_pure_sat]
bundle extracting_Sufficient_Inhabitance_sat =
          Sufficient_Inhabitance_𝒜EIF_Sat [φreason %extract_pure_sat]
          Sufficient_Inhabitance_𝒜ESC_Sat [φreason %extract_pure_sat]
bundle extracting_Inhabitance_sat begin
  unbundle extracting_Inhabitance_Implication_sat extracting_Sufficient_Inhabitance_sat
end

lemma [φreason %extract_pure_all]:
  (x. 𝗋EIF ((x  T) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 D x) (P x))
 𝗋EIF (Abstract_Domain T D) (All P)
  unfolding Abstract_Domain_def 𝗋EIF_def
  by blast

lemma [φreason %extract_pure_all]:
  (x. 𝗋ESC (P x) ((x  T) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 D x))
 𝗋ESC (All P) (Abstract_Domain T D)
  unfolding Abstract_Domain_def 𝗋ESC_def
  by blast

lemma [φreason %extract_pure_all]:
  (x. 𝗋EIF (D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 (x  T)) (P x))
 𝗋EIF (Abstract_DomainL T D) (All P)
  unfolding Abstract_DomainL_def 𝗋EIF_def
  by blast

lemma [φreason %extract_pure_all]:
  (x. 𝗋ESC (P x) (D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 (x  T)))
 𝗋ESC (All P) (Abstract_DomainL T D)
  unfolding Abstract_DomainL_def 𝗋ESC_def
  by blast


subsubsection ‹Basic Rules›

lemma Abstract_Domain_sub:
  (x. D x  D' x)
 Abstract_Domain T D
 Abstract_Domain T D'
  unfolding Abstract_Domain_def 𝗋EIF_def
  by auto

lemma Abstract_DomainL_sub:
  (x. D' x  D x)
 Abstract_DomainL T D
 Abstract_DomainL T D'
  unfolding Abstract_DomainL_def 𝗋ESC_def
  by auto

lemma [φreason default %extract_pure_phity]:
  Abstract_Domain T D
 x  T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 D x
  unfolding Abstract_Domain_def Action_Tag_def
  by blast

lemma [φreason default %extract_pure_phity]:
  Abstract_DomainL T D
 D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x  T
  unfolding Abstract_DomainL_def Action_Tag_def
  by blast

lemma [φreason default %inhabited_default]:
  Abstract_DomainL T D
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (x. D x)
 Inhabited T
  unfolding Inhabited_def Abstract_DomainL_def Premise_def 𝗋ESC_def
  by blast

subsubsection ‹Fallback›

lemma [φreason default %abstract_domain_fallback]:
  Abstract_Domain T (λx. Satisfiable (x  T))
  unfolding Abstract_Domain_def 𝗋EIF_def
  by simp

lemma [φreason default %abstract_domain_fallback]:
  Abstract_DomainL T (λx. Satisfiable (x  T))
  unfolding Abstract_DomainL_def 𝗋ESC_def
  by simp

subsubsection ‹Configuration›

declare [[
  φreason_default_pattern_ML ?x  ?T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 _  fn ctxt => fn tm as (_ (*Trueprop*) $ (_ (*𝗋EIF*) $ (
                            _ (*Satisfiable*) $ (_ (*φType*) $ x $ _)) $ _)) =>
      if is_Var x orelse not (Context_Position.is_visible_generic ctxt)
      then NONE
      else error (let open Pretty in string_of (chunks [
            para "Malformed Implication Rule: in ‹x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 _› the x must be a schematic variable. But given",
            Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
          ]) end) (1000),

  φreason_default_pattern_ML _ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 _  _  fn ctxt => fn tm as (_ (*Trueprop*) $ (_ (*𝗋ESC*) $ _ $ (
                            _ (*Satisfiable*) $ (_ (*φType*) $ x $ _)))) =>
      if is_Var x orelse not (Context_Position.is_visible_generic ctxt)
      then NONE
      else error (let open Pretty in string_of (chunks [
            para "Malformed Sufficiency Rule: in ‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ T› the x must be a schematic variable. But given",
            Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
          ]) end) (1000)
]]

setup PLPR_Template_Properties.add_property_kinds [
  pattern_propAbstract_Domain _ _, pattern_propAbstract_DomainL _ _
]

subsubsection ‹Template Instantiation›

lemma Satisfiable_rewr_template[φreason_template name T.inh_rewr [simp]]:
  Abstract_Domain T D
 Abstract_DomainL T D'
 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 (x. D' x = D x) @tag 𝒜_template_reason None
 Satisfiable (x  T)  D x
  unfolding 𝗋EIF_def 𝗋ESC_def Action_Tag_def Abstract_Domain_def Abstract_DomainL_def Premise_def
  by (clarsimp, smt (verit, best))


subsection ‹Auxiliary Tag›

definition φTag :: mode  ('c,'x) φ  ('c,'x) φ
  where φTag mode T  T

definition φTagA :: mode  'c BI  'c BI
  where φTagA mode T  T


subsection ‹Transformation of Abstraction›

text ‹The only meaningful implication ⟶› under the interpretation of φ data refinement›

definition Transformation :: " 'a BI  'a BI  bool  bool " ("(2_)/ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (2_)/ 𝗐𝗂𝗍𝗁 (2_)" [13,13,13] 12)
  where "(A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)  (v. v  A  v  B  P)"
  ― ‹Implementation notes: It is safe to unfold Transformation but unsafe to unfold Satisfaction.
      Transformation is always based on Satisfaction but in future when we upgrade our logic onto
      impredicativeness, the definition of Satisfaction will be changed.
      Satisfaction is the bottom abstraction layer.›

abbreviation SimpleTransformation :: " 'a BI  'a BI  bool " ("(2_)/ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (2_)" [13,13] 12)
  where SimpleTransformation T U  Transformation T U True

text ‹
Transformation x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. f x y› and its dual y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗌𝗎𝖻𝗃 x. g x y›
constitute a classical Galios connection (f,g)›. However, our method does not apply the Galios
connection directly as our method is synthetic (we do not analysis the relation between
concrete sets and abstract sets once after defining a φ-type,
but do deductions by means of transformation rules).
Comparing to analytic methods (the classical methods for data refinement), synthetic methods based
on a higher abstraction simplify representations and give more chances for automation (by means of an inference system),
and in addition, can be combined in program logics more natively.
›

text ‹The name of transformation is good in sense of corresponding to categorical natural transformation.
  If we consider the state transition of a program as a category 𝒞›, two φ-types T› and U› form
  functors over 𝒞›, and the transformation between T› and U› is the natural transformation between
  the two functors. ›

text ‹TODO: move me
Our method simplifies program verification by lifting it onto an abstract domain.
However, it is hard to universally define what are abstract and what are not.
In a transformation x ⦂ T ⟶ f(x) ⦂ U›, the abstract map f› can have various expressions and
may fall back to concrete level such as f(x) = @y(x ⦂ T ⟶ y ⦂ U)› (@› is Hilbert choice operator)
which is always a trivial solution of f›.


The criterion about what expression of f› is considered abstract can be given by user.
The abstract maps (f›) occurring in their annotations or given properties are assumed abstract.
In addition, if the abstract objects x› are defined algebraically using Bounded Natural Functor,
the implied operators including mapper, relator, predicator, etc. are also considered abstract.
The range is unfixed and may extended if reasonable.

When we say we lift the verification onto an abstract domain, precisely we mean the proof obligation
extracted by our reasoning is a boolean assertion consisting of only the abstract operators as above
plus boolean connectives and other basic primitives like projections of product type.
It basically means the reasoning is made by composition of the rules giving abstraction, and the
extracted proof obligation is a composition of the abstract operators given in the rules.
›


subsubsection ‹Rules›

lemma φType_eqI_Tr:
  (x. x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  U)
 (x. x  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T)
 T = U
  unfolding φType_def Transformation_def
  by auto (meson BI_eq_iff ext)

lemma φType_eqI_BI:
  (x. (x  T) = (x  U))
 T = U
  unfolding φType_def fun_eq_iff
  by blast

lemma transformation_refl[simp]:
  "A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A" unfolding Transformation_def by fast

lemma transformation_trans:
  "A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
 (P  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 C 𝗐𝗂𝗍𝗁 Q)
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 C 𝗐𝗂𝗍𝗁 P  Q"
  unfolding Transformation_def Premise_def by auto

lemma mk_intro_transformation:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def
  by simp

lemma mk_elim_transformation:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B
 B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def
  by simp blast

lemma transformation_weaken:
  P  P'
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P'
  unfolding Transformation_def by simp

lemma transformation_intro_inhab:
  (𝗉𝗋𝖾𝗆𝗂𝗌𝖾 Satisfiable A  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def Satisfiable_def Satisfaction_def
  by blast

lemma assertion_eq_intro:
  P 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Q
 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 P
 P = Q
  unfolding Transformation_def BI_eq_iff by blast

lemma BI_eq_ToA:
  P = Q  (P 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Q)  (Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 P)
  unfolding BI_eq_iff Transformation_def
  by blast

lemma BI_sub_transformation:
  S  S'  (S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S')
  unfolding Transformation_def Satisfaction_def subset_iff
  by (simp add: less_eq_BI_def subset_iff)

lemma BI_sub_iff:
  S  S'  (u. u  S  u  S')
  unfolding Satisfaction_def subset_iff
  by (meson less_eq_BI_def subset_eq)

lemma transformation_protector:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P .

subsubsection ‹Forms of Reasoning›

consts 𝒯𝒫  :: action ― ‹Transformation Problem, x : T --> f(x) : U, or between assertions, can be abductive
                         but never bi-abductive.›
       𝒯𝒫' :: action ― ‹Bi-abductive Transformation Problem with Remainders and Demands, x : T * W --> f(x) : U * R›
       𝒜clean :: action

abbreviation 𝒜clean' :: bool  bool ("_/ @clean" [9] 9)
  where P @clean  P @tag 𝒜clean

text ‹There are two kinds of transformation rule

 cast-rule: x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(x) ⦂ U 𝗐𝗂𝗍𝗁 P(x)› binding on pattern x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ U 𝗐𝗂𝗍𝗁 _›,
  which specifies how to transform a given φ-type x ⦂ T› into the target type U› and what is the
  resulted abstract object with yielding any auxiliary pure facts P(x)›.

 intro-rule: X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 g(y) ⦂ U' 𝗐𝗂𝗍𝗁 P ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P ∧ Q(y)› binding on
  pattern _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 _›, which specifies how to construct y ⦂ U› by construction
  from g(y) ⦂ U'›.
    
 elim-rule: g(x) ⦂ T' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ∧ Q(x)› binding on
  pattern x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›, which specifies how to destruct x ⦂ T› in sense of opening
  its encapsulated abstraction to then deduce whatever we want.

(*TODO: revise the text below!!!*)
Among the rules generated from φtype_def›, only the cast-rules are registered and activated.
Case-rule is point to point (from a specific type to another specific) so it is safe.
The intro-rule and the elim-rule reduce the abstraction level.
They cause the reasoning reduces to a lower level of abstraction.
Users can always activate the rules at their discretion.

Intro-rule and elim-rule can always be applied manually. It doesn't burden the user even a little because
the rules are used only when opening and closing an abstraction, in the case that should only happens
when building an interface or an internal operation of a data structure, where users can
write the intro-rule and the elim-rule at the beginning and the end of the program without thinking a bit.
›

text ‹In reasoning, the P› in any goal is always an OUT-argument.›


text ‹Upon above, we present in addition two extension forms providing partial transformations
  where a part of the source object may transform to only a part of the target object, leaving some
  remainder of the source and some unsolved target part for later reasoning.

 x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(x) ⦂ U›, the usual one-φtype-to-one-φtype transformation.
 x ⦂ T ∗[False] ⊤φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R› or alternatively
  x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(x) ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cr] R(x)›, the transformation with remainders
 x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R›, with both remainders and unsolved target parts.

where Cw, Cr› are boolean conditions deciding if the remainder and respectively the unsolved aims
are presented.
The forms constitute a lattice where the reasoning of the bottom reduce to the top.

Note x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R› is not admissible though it is syntactically valid.
As it is entailed by the more general x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R›, and more
important, the pattern of x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 …› also covers that of x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _› when T›
is variable, meaning inefficiency in selecting rule during reasoning, we dismiss x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 …›
for the sake of reasoning performance and reducing the total number of reasoning rules.

In this way, designers of φ-types only require to provide two forms of rules,
x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U› and x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R›

definition REMAINS :: 'a::sep_magma_1 BI  'a BI  'a BI ("_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _" [14,14] 13)
  where (X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R)  X * R
  ― ‹The C› should be a variable sending to the later reasoning which decides if the transformation
      results in some remainders. Or, exceptionally, C› can be constant True› for unital algebras
      and the later reasoning sets the remainder to 1› if it does not really results in remainders.

      It means, every reasoning procedure should prepare two versions, the one for variable C›
      and another for the C› of constant True›.

      A reasoning procedure can at any time if on a unital algebra, set a variable C› to True›
      and turns the reasoning into the unital mode.›

definition φProd :: " ('concrete::sep_magma, 'abs_a) φ  ('concrete, 'abs_b) φ  ('concrete, 'abs_a × 'abs_b) φ" (infixr "" 70)
  where "A  B = (λ(a,b). A a * B b)"

definition φProd' :: " ('concrete::sep_magma_1, 'abs_a) φ  ('concrete, 'abs_b) φ  ('concrete, 'abs_a × 'abs_b) φ" (infixr "" 67)
  where "φProd' = φProd"

lemma φProd_expn[φexpns, simp]:
  "concrete  (x  A  B)  (ca cb. concrete = ca * cb  cb  (snd x  B)  ca  (fst x  A)  ca ## cb)"
  unfolding φProd_def φType_def by (cases x; simp) blast

definition φNone :: ('v::one, 'x) φ ("") where  = (λx. 1)


text ‹In reasoning, the P,R,W› in any goal are always OUT-arguments.›

ML val phi_allow_source_object_to_be_not_variable =
          Config.declare_bool ("phi_allow_source_object_to_be_not_variable", ) (K false)

ML_file ‹library/syntax/transformation.ML›

declare [[
  (*a general checker warns if the abstract object of the source is not a variable*)
  φreason_default_pattern_ML _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _  fn ctxt =>
    fn tm as (Trueprop $ (Transformation $ (PhiTyp $ x $ _) $ _ $ _)) => (
      if not (is_Var (Term.head_of x)) andalso
         Context_Position.is_visible_generic ctxt andalso
         not (Config.get_generic ctxt phi_allow_source_object_to_be_not_variable)
      then warning (let open Pretty in string_of (chunks [
              para "The abstract object of the source of a transformation rule should be a variable.\n",
              Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
            ]) end)
      else () ;
      NONE
  ) (1000),

  φreason_default_pattern
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _  ERROR(TEXT(‹Transformation rules must be tagged by either of the following categories, 𝒯𝒫, 𝒯𝒫'›)) (10)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫 
      ERROR(TEXT(‹Malformed Rule› (?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫))) (10)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫' 
      ERROR(TEXT(‹Malformed Rule› (?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫'))) (10)

  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫 
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _  @tag 𝒯𝒫   (30)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
    ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (50)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
    ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (50)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
    ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (60)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (_  ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
    ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?var_y  ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (60)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
    ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?U 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (60)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (_  ?U) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
    ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?var_y  ?U) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (60)

  and ?x  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y  ?U  ?R 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫 
          ERROR TEXT(‹Malformed Rule. Please use›
                      (x  ?T  1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y  ?U  ?R 𝗐𝗂𝗍𝗁 ?P)
                      ‹instead of the given›
                      (?x  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y  ?U  ?R 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫)) (71)
  

  and _  ?T  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'
    _  ?T  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' (40)
  and ?var_X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'
    _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' (40)
  and (?var_x, _)  ?T  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'
    _  ?T  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?U  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' (50)
  and ?var_x  ?T  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'
    _  ?T  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?U  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' (50)


  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @clean
    ERROR TEXT(‹cannot infer the binding pattern of› (?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P)
                  ‹Please indicate manually›) (10)
  and ?var_X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _ @clean (20)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y @clean  ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean (20)
  and ?var_x  ?var_T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U 𝗐𝗂𝗍𝗁 _ @clean (25)
  and _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?var_U @clean  _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean (25)
  and ?var_X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?U 𝗐𝗂𝗍𝗁 _ @clean (25)
  and _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y @clean  _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean (25)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 @clean  ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean (100)
  and 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _ @clean (100)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _   @clean  ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean (100)
  and _   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _ @clean (100)
]]

lemma REMAINS_expn[φexpns,simp]:
  p  (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R)  (p  A * R)
  unfolding REMAINS_def
  by simp

subsubsection ‹Allocation of Priorities›

φreasoner_group
  ToA_all         = (100, [0, 4999]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _
                    ‹Rules of transformation›
  ToA_bottom      = (0, [0, 15]) in ToA_all
                    ‹System transformation rules, of the lowest priority›
  ToA             = (100, [16, 4999]) in ToA_all > ToA_bottom
                    ‹User rules for transformation›
  ToA_bk          = (100, [16, 999]) in ToA
                    ‹Backtracking rules›
  ToA_cut         = (1000, [1000, 1399]) in ToA
                    ‹Deterministic transformation rules without backtracking, meaning the reasoning
                     on the specified cases is definite and no branching.›
  NToA_tgt        = (1430, [1400, 1499]) > ToA_cut in ToA
                    ‹›
  ToA_splitting     = (1550, [1500,1599]) > ToA_cut in ToA
                    ‹Transformation rules splitting the reasoning goal into more subgoals›
  ToA_splitting_target = (1600, [1600,1601]) > ToA_splitting in ToA
                    ‹split the separation sequent in the target part and reason the tranformation for
                     each separated item one by one.›
  ToA_assertion_cut = (1700, [1700,1899]) > ToA_splitting in ToA
                    ‹Deterministic transformation rules between unsplitted assertions.›
  ToA_normalizing = (2000, [1950, 2299]) > ToA_assertion_cut in ToA
                    ‹Rules normalizing the transformation problem. A normalization rule should neither
                     branch nor yield new subgoal, i.e., always from onetransformation to another
                     transformaiton. If it branches, see %ToA_branches; if yields new assertions,
                     see %ToA_assertion_cut›
  ToA_fixes_quant = (2500, [2500, 2590]) > NToA_tgt in ToA
                    ‹Transformation rules fixing quantified variables.›
  ToA_red         = (2600, [2600, 2649]) > ToA_fixes_quant in ToA
                    ‹Transformation rules reducing literal or trivial cases.›
  ToA_success     = (3000, [2960, 3499])
                    ‹Transformation rules that are shortcuts leading to success on special cases›
  ToA_systop      = (4900, [4900, 4999]) in ToA
                    ‹System rules of the highest priority›
  ToA_assigning_var = (4100, [4100, 4110]) in ToA and < ToA_systop
                    ‹Tranformation rules assigning variable targets or sources, of the highest priority
                     as occurrences of schematic variables are usually not considered in the subsequent
                     normal process of the reasoning, and may cause unexpected exception in them.›
  ToA_refl        = (4000, [3990, 4019]) in ToA and < ToA_assigning_var and > ToA_success
                    ‹Reflexive tranformation rules›
  ToA_splitting_source = (50, [50,50]) for _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ < ToA_cut in ToA
                    ‹split the separation sequent in the source part and reason the tranformation for
                     each separated item one by one.›
  ToA_elim_intro  = (19, [19,19]) in ToA < default
                    ‹Elimination and introduction rules that unfold φ-types›
  ToA_weak        = (20, [20,24]) in ToA < default and > ToA_elim_intro
                    ‹Weak transformation rules giving some reasoning support temporarily and expecting to be orverride›
  ToA_derived     = (50, [25,79]) in ToA < default and > ToA_weak
                    ‹Automatically derived transformations. Many substructures are contained in this large range.›
  ToA_derived_red = (150, [130,170]) for _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ > ToA_derived > default in ToA
                    ‹Automatically derived transformation reductions.›
  ToA_weak_red    = (120, [120,129]) for _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ < ToA_derived_red in ToA
                    ‹Weak reduction rules giving some reasoning support temporarily and expecting to be orverride›
  ToA_user        = (100, [80,119]) in ToA and < ToA_weak_red and > ToA_derived
                    ‹default group for user rules›

declare [[
  φdefault_reasoner_group _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 : %ToA_user (10)
                      and ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 : %ToA_elim_intro (100)
                      and _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 : %ToA_elim_intro (100)
]]

φreasoner_group ToA_clean_all = (100, [10,3000]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean
      ‹All transformation cleaning wastes and debris›
  and ToA_clean = (1020, [1000,1050]) in ToA_clean_all ‹›
  and ToA_clean_fallback = (20,[10,30]) in ToA_clean_all < ToA_clean ‹›

declare [[
  φdefault_reasoner_group _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean : %ToA_clean (20)
]]

paragraph ‹Bottom Groups›

φreasoner_group
  ToA_falling_latice = (1, [0,4]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA_bottom
                    ‹Fallbacks of transformation rules›
  ToA_unified_refl = (5, [5,6]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA_bottom and > ToA_falling_latice
                     ‹Reflexive tranformation rules with unification, of a low priority because
                      unification is aggresive.›
  ToA_derv_unify_refl = (7, [7,8]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA_bottom and > ToA_unified_refl
                     ‹derived ToA_unified_refl that override the default behaviors.›
  ToA_varify_target_object = (9, [9,9]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA_bottom and > ToA_derv_unify_refl
                    ‹Varifies the fixed target object, using Object_Equiv›
  ToA_inst_qunat  = (10, [10,10]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA_bottom and > ToA_varify_target_object
                    ‹Transformation rules instantiating quantified variables. It is unsafe unless
                     all fixable variables are fixed. If any variable is fixed later than the instantiation,
                     the instantiated schematic variable cannot caputure the later fixed variable.›
  ToA_branches    = (12, [11,15]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA_bottom and > ToA_inst_qunat
                    ‹Branching transformation rules.›


paragraph ‹Fallback›

text ‹There are two trivial solutions for such problem.

  On commutative algebra, a transformation can do nothing but simply return the source to the remainder
  and demand subsequent transformation to the target. Such transformation is of the lowest priority
  serving as a fallback of the ordinary reasoning.

   x ⦂ T ∗[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, fst x) ⦂ U ∗[True] T ›

  Another trivial solution is on unital algebras, where a transformation can assign the target object
  to the identity element of the type so the source term directly go to the remainder.

   x ⦂ T ∗[False] ⊤φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (one, fst x) ⦂ U ∗[True] T › where one ⦂ U ≡ emp›

  This is the fallback rule for unital algebras that are non-commutative, and in this case when
  all transformations from T to U fail, assigning U› to identity element is the only available search
  branch so the fallback is safe. For commutative algebra, the previous fallback is applied.
  When U› is kept swapping and all source terms are passed, the still remaining U› is assigned
  with the identity element, so the case of one ⦂ U ≡ emp› is still covered.



(*Implementation note:

  By default, such rule is not activated as it really does nothing, and clients have a way
  to know if the reasoning fails. However, if such fallback is expected, one can use reasoning goal
   Try Cs (x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R) ›
  in which boolean condition Cs› returns whether the reasoning really ever made some changes.*)
 ›


text ‹Rules are given in §Reasoning/Basic Transformation Rules/Fallback›


subsubsection ‹Extracting Pure Facts Implies Inside›

lemma [φreason %extract_pure]:
  𝗋EIF A P
 𝗋EIF (A @tag 𝒯𝒫) P
  unfolding Action_Tag_def .

lemma [φreason %extract_pure]:
  𝗋EIF A P
 𝗋EIF (A @tag 𝒯𝒫') P
  unfolding Action_Tag_def .

lemma [φreason %extract_pure]:
  𝗋ESC P A
 𝗋ESC P (A @tag 𝒯𝒫)
  unfolding Action_Tag_def .

lemma [φreason %extract_pure]:
  𝗋ESC P A
 𝗋ESC P (A @tag 𝒯𝒫')
  unfolding Action_Tag_def .

text ‹This is used in φ-derivers, particularly in induction when›

lemma [φreason %extract_pure]:
  PA 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A
 B 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 PB
 𝗋EIF (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) (PA  PB  P)
  unfolding Action_Tag_def 𝗋EIF_def 𝗋ESC_def Satisfiable_def Transformation_def
  by clarsimp

ML fun extracting_elim_or_intro_ToA is_intro ctxt sequent =
  let val target = case HOLogic.dest_Trueprop (Thm.major_prem_of sequent)
                     of Const(const_name𝗋EIF, _) $ target $ _ => target
                      | _ => raise THM ("extracting_elim_or_intro_ToA", 1, [sequent])
      fun get_concl (Const(const_nameHOL.implies, _) $ _ $ X) = get_concl X
        | get_concl X = X
      val concl = get_concl target
      fun get_V (A, B) = if is_intro then A else B
      val (A, B, Var p) = Phi_Syntax.dest_transformation (fst (HOLogic.dest_imp target))
      val Var v = get_V (A, B)

      fun parse_P (Var p) = p 
        | parse_P (Const(const_nameHOL.conj, _) $ Var p $ _) = p

   in case try Phi_Syntax.dest_transformation concl
   of SOME (A', B', P') => if get_V (A', B') = Var v andalso p = parse_P P'
      then SOME ((ctxt, @{lemma' 𝗋EIF S C
                               𝗋EIF ((A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A)  S) C
                             by simp}
                          RS sequent), Seq.empty)
      else NONE
  end

φreasoner_ML TransformationI_𝒜EIF' %extract_pure+10 (𝗋EIF ((?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 ?var_P)  _) _) = fn (_, (ctxt, sequent)) => Seq.make (fn () => extracting_elim_or_intro_ToA true ctxt sequent)

φreasoner_ML TransformationE_𝒜EIF' %extract_pure+10 (𝗋EIF ((_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var 𝗐𝗂𝗍𝗁 ?var_P)  _) _) = fn (_, (ctxt, sequent)) => Seq.make (fn () => extracting_elim_or_intro_ToA false ctxt sequent)


(*TODO*)
lemma ToA_EIF_sat:
  (v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vA v : v  A)
 (v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vB v : v  B)
 𝗋EIF (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) (v. vA v  vB v  P)
  unfolding 𝗋EIF_def Satisfiable_def Transformation_def Simplify_def
  by clarsimp

lemma ToA_ESC_sat:
  (v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vA v : v  A)
 (v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vB v : v  B)
 𝗋ESC (v. vA v  vB v  P) (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
  unfolding 𝗋ESC_def Satisfiable_def Transformation_def Simplify_def
  by clarsimp

bundle ToA_extract_pure_sat = ToA_EIF_sat[φreason %extract_pure_sat]
                              ToA_ESC_sat[φreason %extract_pure_sat]


subsubsection ‹Reasoning Configure›

ML_file ‹library/tools/helper_reasoners.ML›

paragraph ‹Auxiliary Tools›

definition May_Assign :: 'a  'a  bool
  where May_Assign _ _  True

φreasoner_group may_assign__all = (100, [1,2000]) for May_Assign var val ‹›
  and may_assign_success = (2000, [2000,2000]) in may_assign__all ‹›
  and may_assign_red = (1500, [1500, 1530]) in may_assign__all ‹›
  and may_assign_fallback = (1, [1,1]) in may_assign__all ‹›

lemma [φreason %may_assign_success for May_Assign _ _]:
  May_Assign z z
  unfolding May_Assign_def ..

lemma [φreason %may_assign_fallback]:
  May_Assign x y
  unfolding May_Assign_def ..

lemma [φreason %may_assign_red]:
  May_Assign y z
 May_Assign (snd (x,y)) z
  unfolding May_Assign_def ..



paragraph ‹Inhabitance Reasoning - Part II›

(*TODO: move me!!*)

lemma [φreason 1000]:
  Generate_Implication_Reasoning (Satisfiable X  Y) (Satisfiable X) Y
  unfolding Generate_Implication_Reasoning_def
  ..

lemma [φreason 1100]:
  Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
 Generate_Implication_Reasoning (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y) (Satisfiable X) P
  unfolding Generate_Implication_Reasoning_def Transformation_def Satisfiable_def 𝗋EIF_def
  by blast

lemma [φreason 1000]:
  Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q
 Generate_Implication_Reasoning (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P) (Satisfiable X) (Q  P)
  unfolding Generate_Implication_Reasoning_def Transformation_def Satisfiable_def 𝗋EIF_def
  by blast


subsection ‹Top›

notation top ("")

subsubsection ‹Rewrites›

lemma Top_Satisfiable[simp]:
  Satisfiable   True
  unfolding Satisfiable_def
  by clarsimp

subsubsection ‹Transformation Rules›

φreasoner_group ToA_top = (%ToA_success, [%ToA_success-1, %ToA_success+1]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  𝗐𝗂𝗍𝗁 _
                          ‹Transformation rules handling ⊤›

text ‹The target part is assumed having no schematic variable, so it is safe to do such shortcuts
      comparing with the bottom-in-source.›

(*TODO!*)

declare [[φtrace_reasoning = 1]]

lemma [φreason %ToA_top]:
  Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 
  unfolding Transformation_def by blast

lemma [φreason %ToA_top]:
  Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  𝗋𝖾𝗆𝖺𝗂𝗇𝗌 1
  unfolding Transformation_def
  by simp

lemma [φreason %ToA_top]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  * B
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  * B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 1
  unfolding Transformation_def
  by simp

(*The following procedure only supports commutative semigroup*)
 
lemma [φreason %ToA_top+1 if fn (ctxt,sequent) =>
          case Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
            of (_, (_ (*times*) $ _ $ R), _)
               => let fun chk (Const(const_nametimes, _) $ X $ Const(const_nametop, _)) = chk X
                        | chk (Const(const_nametop, _)) = false
                        | chk _ = true
                   in chk R
                  end]:
  Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R *  𝗐𝗂𝗍𝗁 P
 Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  * R 𝗐𝗂𝗍𝗁 P
  for Any :: 'a::sep_ab_semigroup BI
  by (simp add: mult.commute)

(*when we reach here, it means R all consists of ⊤, so that we can eliminate them one-by-one,
  until the last one which can be done by ‹Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤› directly.
  Again we assume and only consider commutative semigroup*)

lemma [φreason %ToA_top]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P
 A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  * R 𝗐𝗂𝗍𝗁 P
  for A :: 'a::sep_ab_semigroup BI
  unfolding Transformation_def
  by (clarsimp, insert sep_disj_commuteI sep_mult_commute, blast)

lemma [φreason %ToA_top-1]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  * R 𝗐𝗂𝗍𝗁 P
  for A :: 'a::sep_algebra BI
  unfolding Transformation_def
  by clarsimp (metis mult_1_class.mult_1_left sep_magma_1_right)

lemma [φreason %fail]:
  FAIL TEXT(‹Sorry, currently we do not support solving ‹⊤ * R› problems on non-monoidal and non-commutative group.›)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  * R 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def FAIL_def
  by blast



subsection ‹Bottom›

text ‹Despite of semantically 0 = ⊥› where syntactically ⊥ ≡ {}›, but there is not syntactically
  0 ≡ {}›. We prefer to use 0› instead of the more usual ⊥› for the sake of forming
  a semiring together with 1 ≡ emp›, *›, + ≡ ∨BI, to leverage the existing automation of semiring.›

abbreviation Bottom ("BI") where Bottom  (0::'a::sep_magma BI)
abbreviation Bottom_abs ("λ") where Bottom_abs  (0 :: 'b  'a::sep_magma BI)

lemma bot_eq_BI_bot [φprogramming_base_simps, φprogramming_simps]:
  bot = BI
  unfolding zero_BI_def bot_BI_def ..

lemma zero_implies_any[simp]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 Any
  unfolding Transformation_def zero_set_def Satisfaction_def
  by (cases X; simp add: zero_BI_def)

subsubsection ‹Rewrites›

lemma Bot_Satisfiable[simp]:
  Satisfiable 0  False
  unfolding Satisfiable_def
  by clarsimp

subsubsection ‹Transformation Rules›

φreasoner_group ToA_bot = (%ToA_cut+5, [%ToA_cut, %ToA_cut+10]) for 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _
   ‹Transformation rules when the source assertion is 0.
    The rule is not of a highest priority because the target may contain schematic variables,
    and the usual reasoning procedure is still required to unfold the target connective-by-connective
    to ensure every variables inside is instantiated.›

lemma [φreason %ToA_cut for 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 False @tag 𝒯𝒫
  unfolding Action_Tag_def
  by simp


lemma [φreason %ToA_bot for 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 0 𝗐𝗂𝗍𝗁 False @tag 𝒯𝒫
  using zero_implies_any Transformation_def Action_Tag_def
  by simp


paragraph ‹Reductions›

lemma [φreason %ToA_red for 0 * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            ?var * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 0 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red for _ * 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            _ * ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 R * 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red for _ + 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            _ + ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 Y + 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red for 0 + _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            ?var + _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 0 + Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + 0 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + 0 𝗐𝗂𝗍𝗁 P
  by simp
 
lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var + _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + X 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + 0 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + 0 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                            _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var + _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 0 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  R * 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 R * 0 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  0 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 0 x * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp


subsection ‹Unit›

lemma φNone_expn[φexpns, simp]:
  p  (x  φNone)  p = 1
  unfolding φNone_def φType_def
  by simp

lemma φNone_inhabited[elim!]:
  Satisfiable (x  φNone)  C  C .

lemma Prod_φNone_red:
  x  T    fst x  T
  y    T  snd y  T
  x'    ( :: ('v::sep_magma_1, 'x) φ)  1
  for T :: ('a::sep_magma_1, 'b) φ
  unfolding atomize_eq BI_eq_iff
  by ((rule φType_eqI)?; clarsimp)+

subsubsection ‹Properties›

lemma [φreason %extract_pure]:
  1 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 True
  unfolding 𝗋EIF_def
  by blast

lemma [φreason %extract_pure]:
  True 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 1
  unfolding 𝗋ESC_def Satisfiable_def
  by simp

lemma Emp_Satisfiable[simp]:
  Satisfiable 1  True
  unfolding Satisfiable_def
  by clarsimp

subsubsection ‹Transformation Rules›

lemma [φreason %ToA_success]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 X
  for X :: 'a::sep_magma_1 BI
  unfolding REMAINS_def Action_Tag_def by simp

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 * X 𝗐𝗂𝗍𝗁 P "
  for X :: 'a::sep_magma_1 BI
  unfolding mult_1_left .

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 * X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P"
  for X :: 'a::sep_magma_1 BI
  unfolding mult_1_left .

lemma [φreason %ToA_red]:
  " R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 1 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P "
  for X :: 'a::sep_magma_1 BI
  unfolding mult_1_left .


subsection ‹Additive Disjunction›

text ‹Is the term(+) :: 'a BI  'a BI  'a BI directly›

subsubsection ‹Basic Rules›

lemma Disjunction_expn[iff, φexpns]:
  p  (A + B)  p  A  p  B
  unfolding Satisfaction_def
  by (simp add: plus_BI_def)

lemma Add_Disj_Satisfiable[simp]:
  Satisfiable (A + B)  Satisfiable A  Satisfiable B
  unfolding Satisfiable_def
  by clarsimp blast

lemma [φreason %cutting]:
  X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A
 Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 B
 X + Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A  B
  unfolding 𝗋EIF_def Satisfiable_def
  by simp blast

lemma [φreason %cutting]:
  A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X
 B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 Y
 A  B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X + Y
  unfolding 𝗋ESC_def Satisfiable_def
  by simp blast

text ‹The above two rules are reversible.›

lemma set_plus_inhabited[elim!]:
  Satisfiable (S + T)  (Satisfiable S  C)  (Satisfiable T  C)  C
  unfolding Satisfiable_def
  by (simp, blast)

lemma implies_union:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + Y 𝗐𝗂𝗍𝗁 P
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + Y 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def
  by simp_all

declare add_mono[φreason 1000]


subsubsection ‹Transformation Rules›

paragraph ‹In Source›

lemma [φreason %ToA_splitting]:
  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P2
 A + B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1  P2
  by (simp add: Transformation_def)

lemma [φreason %ToA_splitting]:
  B * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1
 A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P2
 (A + B) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1  P2
  by (simp add: Transformation_def distrib_left) blast

lemma [φreason %ToA_splitting+10]:
  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RB 𝗐𝗂𝗍𝗁 P1
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RA 𝗐𝗂𝗍𝗁 P2
 RA + RB 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 A + B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P1  P2
  by (simp add: Transformation_def Action_Tag_def; meson)

lemma [φreason %ToA_splitting+10]:
  B * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RB 𝗐𝗂𝗍𝗁 P1
 A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RA 𝗐𝗂𝗍𝗁 P2
 RA + RB 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 (A + B) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P1  P2
  by (simp add: Transformation_def Action_Tag_def; blast)

lemma [φreason add]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 0 + A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason add]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 A + 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason add]:
  A + A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A @clean
  unfolding Action_Tag_def
  by simp


paragraph ‹In Target›

lemma ToA_disj_target_A:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗐𝗂𝗍𝗁 P
  unfolding plus_set_def
  by (metis implies_union(1) plus_set_def)

lemma ToA_disj_target_B:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗐𝗂𝗍𝗁 P
  by (simp add: Transformation_def)
 
declare [[φreason ! %ToA_branches ToA_disj_target_A ToA_disj_target_B for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A + ?B 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫]]

hide_fact ToA_disj_target_A ToA_disj_target_B

lemma ToA_disj_target_A':
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def REMAINS_def Transformation_def
  by (simp add: distrib_left; blast)

lemma ToA_disj_target_B':
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def REMAINS_def Transformation_def
  by (simp add: distrib_left; blast)

declare [[φreason ! %ToA_branches ToA_disj_target_A' ToA_disj_target_B'
            for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A + ?B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]]

hide_fact ToA_disj_target_A' ToA_disj_target_B'

lemma [φreason add]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + A @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason add]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A @clean
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + 0 @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason add]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A @clean
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + A @clean
  unfolding Action_Tag_def
  by simp


subsection ‹Existential Quantification›

lemma ExBI_inhabited_E[elim!]:
  Satisfiable (ExBI S)  (x. Satisfiable (S x)  C)  C
  unfolding Satisfiable_def
  by simp blast

lemma [φreason %cutting]:
  (x. S x 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C x)
 ExBI S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Ex C
  unfolding Satisfiable_def 𝗋EIF_def
  by (simp; blast)

lemma [φreason %cutting]:
  (x. C x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S x)
 Ex C 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 ExBI S
  unfolding Satisfiable_def 𝗋ESC_def
  by (simp; blast)

lemma ExBI_Satisfiable[simp]:
  Satisfiable (∃*x. S x)  (x. Satisfiable (S x))
  unfolding Satisfiable_def
  by clarsimp blast


subsubsection ‹Syntax›

syntax
  "_SetcomprNu" :: "'a  pttrns  bool  'a BI"  ("_ 𝗌𝗎𝖻𝗃/ _./ _" [14,0,15] 14)

parse_translation [
  (syntax_const‹_SetcomprNu›, fn ctxt => fn [X,idts,P] =>
  let fun subst l Bs (Free v) =
            let val i = find_index (fn v' => v = v') Bs
             in if i = ~1 then Free v else Bound (i+l)
            end
        | subst l Bs (A $ B) = subst l Bs A $ subst l Bs B
        | subst l Bs (Abs(N,T,X)) = Abs(N,T, subst (l+1) Bs X)
        | subst l Bs X = X
      fun trans_one (Bs,C) (Const(syntax_const‹_unit›, _))
            = Abs ("", Typeunit, C [])
        | trans_one (Bs,C) (Const(const_syntaxPair, _)
                                $ (Const (syntax_const‹_constrain›, _) $ Free (A, T) $ Ac)
                                $ B)
            = Const(const_syntaxcase_prod, dummyT) $ (
                Const(syntax_const‹_constrainAbs›, dummyT)
                  $ Abs (A, T, trans_one ((A,T)::Bs, C) B)
                  $ Ac
              )
        | trans_one (Bs,C) (Const(const_syntaxPair, _)
                                $ (Const (syntax_const‹_constrain›, _)
                                      $ (Const (syntax_const‹_constrain›, _) $ Free (A, T) $ T') $ Ac)
                                $ B)
            = Const(const_syntaxcase_prod, dummyT) $ (
                Const(syntax_const‹_constrainAbs›, dummyT)
                  $ (Const(syntax_const‹_constrainAbs›, dummyT)
                      $ Abs (A, T, trans_one ((A,T)::Bs, C) B)
                      $ T')
                  $ Ac
              )
        | trans_one (Bs,C) (Const(const_syntaxPair, _)
                                $ Const (syntax_const‹_unit›, _)
                                $ B)
            = Const(const_syntaxcase_prod, dummyT) $ (
                Const(syntax_const‹_constrainAbs›, dummyT)
                  $ Abs ("", dummyT, trans_one (Bs, C) B)
                  $ Const(type_syntaxunit, dummyT)
              )
        | trans_one (Bs,C) (Const (syntax_const‹_constrain›, _) $ Free (A, T) $ Ac)
            = Const(syntax_const‹_constrainAbs›, dummyT)
                  $ Abs (A, T, C ((A,T)::Bs))
                  $ Ac
      fun trans (Const (syntax_const‹_pttrns›, _) $ A $ B) Bs
            = Const (const_syntaxExBI, dummyT) $ trans_one (Bs,trans B) A
        | trans B Bs
            = Const (const_syntaxExBI, dummyT) $ trans_one (Bs, (fn Bs =>
                case P of(* Const (syntax_const‹_constrain›, _) $ Free ("True",_) $ _
                            => subst 0 Bs X
                        |*) Const (const_syntaxtop, _)
                            => subst 0 Bs X
                        | _ => Const (const_syntaxSubjection, dummyT) $ subst 0 Bs X $ subst 0 Bs P
              )) B
   in trans idts [] end)
]

print_translation [
  (const_syntaxExBI, fn ctxt => fn [X] =>
    let fun subst l Bs (Bound i)
              = if l <= i andalso i-l <= length Bs then List.nth(Bs, i-l) else Bound i
          | subst l Bs (Abs (N,T,X)) = Abs (N,T, subst (l+1) Bs X)
          | subst l Bs (A $ B) = subst l Bs A $ subst l Bs B
          | subst l Bs X = X
        fun trans (Vs,Bs) (Const(const_syntaxcase_prod, _) $ Abs (A,T,X))
              = if T = Typeunit andalso A = ""
                then trans (Const(syntax_const‹_unit›, dummyT) :: Vs, Bs) X
                else let val bound = Const(syntax_const‹_bound›, dummyT) $ Free(A,T)
                      in trans (bound::Vs, bound::Bs) X
                     end
          | trans (Vs,Bs) (Abs(A,T, Const(const_syntaxExBI, _) $ X))
              = let val bound = Const(syntax_const‹_bound›, dummyT) $ Free(A,T)
                    val var = fold (fn v => fn v' => Const(const_syntaxPair,dummyT) $ v $ v')
                                    Vs bound
                    val (X',idts',P') = trans ([], bound :: Bs) X
                 in (X', Const(syntax_const‹_pttrns›, dummyT) $ var $ idts', P')
                end
          | trans (Vs,Bs0) (Abs(A,T,B))
              = let val bound = Const(syntax_const‹_bound›, dummyT) $ Free(A,T)
                    val v' = if T = Typeunit andalso A = ""
                             then Const(syntax_const‹_unit›, dummyT)
                             else bound
                    val var = fold (fn v => fn v' => Const(const_syntaxPair,dummyT) $ v $ v')
                                    Vs v'
                    val Bs = bound :: Bs0
                    val (X,P) = case B of Const(const_syntaxSubjection, _) $ X $ P => (X,P)
                                        | _ => (B, Const(const_syntaxtop, dummyT))
                 in (subst 0 Bs X, var, subst 0 Bs P)
                end
        val (X',idts',P') = trans ([],[]) X
     in Const(syntax_const‹_SetcomprNu›, dummyT) $ X' $ idts' $ P' end)
]


subsubsection ‹Semantic Explanation›

text ‹Semantically, an existential quantification in BI actually represents union of resources
  matching the existentially quantified assertion, as shown by the following lemma.›

lemma " BI (Union { BI.dest (S x) |x. P x }) = (S x 𝗌𝗎𝖻𝗃 x. P x) "
  by (simp add: set_eq_iff ExBI_def Subjection_def) (meson Satisfaction_def)

subsubsection ‹Basic Rules›

lemma BI_Ex_comm:
  (∃* x y. A x y) = (∃* y x. A x y)
  unfolding BI_eq_iff
  by (simp, blast)


subsubsection ‹Simplifications›

lemma ExBI_pair: "ExBI T = (∃*a b. T (a,b))"
  unfolding BI_eq_iff by clarsimp

lemma ExBI_simps[simp, φprogramming_base_simps, φsafe_simp]:
  ExBI 0 = 0
  ExBI (λ_. T) = T
  ((∃*c. X c) 𝗌𝗎𝖻𝗃 PP) = (∃*c. X c 𝗌𝗎𝖻𝗃 PP)
  (F' y 𝗌𝗎𝖻𝗃 y. embedded_func f' P' x' y) = (F' (f' x') 𝗌𝗎𝖻𝗃 P' x')
(*  ‹(∃* x. x = t ∧ P x) = P t›
"⋀P. (∃x. x = t ∧ P x) = P t"
    "⋀P. (∃x. t = x ∧ P x) = P t"*)
  unfolding BI_eq_iff embedded_func_def
  by simp_all

lemma ExBI_defined[φprogramming_base_simps, simp, φsafe_simp]:
  ― ‹only safe for source side but unsafe for target side, because it could instantiate variables
      of types parameters which could be instantiated arbitrarily?... I am not pretty sure... It is subtle here›
  (∃* x. F x 𝗌𝗎𝖻𝗃 x = y) = (F y)
  (∃* x. F x 𝗌𝗎𝖻𝗃 y = x) = (F y)
  (∃* x. F x 𝗌𝗎𝖻𝗃 x = y  P x) = (F y 𝗌𝗎𝖻𝗃 P y)
  (∃* x. F x 𝗌𝗎𝖻𝗃 y = x  P x) = (F y 𝗌𝗎𝖻𝗃 P y)
  unfolding BI_eq_iff
  by simp_all

lemma Ex_transformation_expn:
  ((∃*x. A x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)  (x. A x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
  unfolding Transformation_def ExBI_expn
  by blast

lemma ExBI_split_prod[φprogramming_base_simps, φsafe_simp]:
  (∃*x. (case x of (a,b)  f a b)) = (∃*a b. f a b)
  unfolding BI_eq_iff
  by clarsimp

lemma ExBI_subj_split_prod[φprogramming_base_simps, φsafe_simp]:
  (∃* x. A x 𝗌𝗎𝖻𝗃 (case x of (a,b)  P a b)) = (∃* a b. A (a,b) 𝗌𝗎𝖻𝗃 P a b)
  unfolding BI_eq_iff
  by clarsimp




paragraph ‹With Multiplicative Conjunction›

lemma ExBI_times_left [simp, φprogramming_base_simps, φsafe_simp]:
  "((∃* c. T c) * R) = (∃* c. T c * R )"
  by (simp add: BI_eq_iff, blast)

lemma ExBI_times_right[simp, φprogramming_base_simps, φsafe_simp]:
  "(L * (∃*c. T c)) = (∃* c. L * T c)"
  by (simp add: BI_eq_iff, blast)


paragraph ‹With Additive Disjunction›

lemma ExBI_addisj:
  A + (∃*c. B c)  ∃*c. A + B c
  (∃*c. B c) + A  ∃*c. B c + A
  unfolding atomize_eq BI_eq_iff
  by simp+


subsubsection ‹Transformation Rules›

lemma ExBI_transformation:
  (x. S x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' x 𝗐𝗂𝗍𝗁 P)
 ExBI S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExBI S' 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def by (clarsimp, blast)

lemma ExBI_transformation_I:
  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' x 𝗐𝗂𝗍𝗁 P
 S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (ExBI S') 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def by (clarsimp, blast)

lemma ExBI_transformation_I_R:
  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (ExBI S') 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def
  by (clarsimp, blast)


lemma ExBI_additive_disj:
  (∃*x. A x + B x) = (∃*x. A x) + (∃*x. B x)
  unfolding BI_eq_iff by (simp_all add: plus_fun) blast+

ML_file ‹library/tools/simproc_ExSet_expand_quantifier.ML›


subsubsection ‹ToA Reasoning›

lemma skolemize_transformation[φreason %ToA_fixes_quant]:
  "(x.  T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P x)
 ExBI T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def by simp fastforce

lemma skolemize_transformation_R[φreason %ToA_fixes_quant+5]:
  "(x.  T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R x 𝗐𝗂𝗍𝗁 P x)
 ExBI R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 ExBI T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def REMAINS_def Action_Tag_def by (simp; blast)

lemma skolemize_transformation_tR[φreason %ToA_fixes_quant+5]:
  "(x.  T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R x) 𝗐𝗂𝗍𝗁 P x)
 ExBI R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 ExBI T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR) 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def REMAINS_def φTagA_def Action_Tag_def
  by (simp; blast)

lemma [φreason %ToA_fixes_quant]:
  "(x. T x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P x)
 ExBI T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def by simp fastforce

lemma [φreason %ToA_fixes_quant+5]:
  "(x. T x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R x 𝗐𝗂𝗍𝗁 P x)
 ExBI R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 ExBI T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def Action_Tag_def by (simp; blast)

lemma [φreason %ToA_fixes_quant+5]:
  "(x. T x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R x) 𝗐𝗂𝗍𝗁 P x)
 ExBI R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 ExBI T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR) 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def φTagA_def Action_Tag_def
  by (simp; blast)

subsubsection ‹Cleaning›

lemma [φreason add]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 (∃*_. A) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  unfolding Action_Tag_def Transformation_def
  by simp

lemma [φreason add]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (∃*_. R) @clean
  unfolding Action_Tag_def Transformation_def
  by simp


text ‹Continued in \ref{supp-ex-conj}›


subsection ‹Additive Conjunction›


lemma Additive_Conj_expn[iff, φexpns]:
  p  (A  B)  p  A  p  B
  by (cases A; cases B; simp)

lemma additive_conj_inhabited_E[elim!]:
  Satisfiable (A  B)  (Satisfiable A  Satisfiable B  C)  C
  unfolding Satisfiable_def
  by simp blast

lemma [φreason %cutting]:
  A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
 B 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q
 A  B 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P  Q
  unfolding Action_Tag_def 𝗋EIF_def
  by blast

lemma
  P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A
 Q 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 B
 P  Q 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A  B
  unfolding Action_Tag_def Satisfiable_def
  oops

text ‹There is no sufficiency reasoning for additive conjunction, because the sufficient condition
  of A ⊓ B› cannot be reasoned separately (by considering A› and B› separately).›


subsubsection ‹Simplification›

paragraph ‹With ExBI›

lemma ExBI_adconj:
  A  (∃*c. B c)  ∃*c. A  B c
  (∃*c. B c)  A  ∃*c. B c  A
  unfolding atomize_eq BI_eq_iff
  by simp+


subsubsection ‹Transformation Rules›

text ‹Non-pure Additive Conjunction (excludes those are used in pure propositions), is rarely used under our
  refinement interpretation of BI assertions, because we can hardly imagine when and why an object
  has to be specified by two abstractions that cannot transform to each other (if they can,
  it is enough to use any one of them with a strong constraint over the abstraction, and transform it
  to the other when needed). We believe those abstractions if exist are specific enough to be preferably
  expressed by a specific φ-type equipped with ad-hoc reasoning rules.

  To support additive conjunction, it brings enormous branches in the reasoning so affects the
  reasoning performance. Before applying the rules introduced previously, we can add the following
  rules which are also attempted subsequently in order and applied whenever possible.
  X ⟶ A ⟹ X ⟶ B ⟹ X ⟶ A ∧ B› generates two subgoals.
  (A ⟶ Y) ∨ (B ⟶ Y) ⟹ A ∧ B ⟶ Y› branches the reasoning. Specially, when Y ≡ ∃x. P x› is an
  existential quantification containing non-pure additive conjunction (e.g. P x ≡ C x ∧ D x›),
  the priority of eliminating ∧› or instantiating ∃› is significant.
  We attempt the both priorities by a search branch.
(*  If we instantiate first, the instantiation is forced to be identical in the two branches.
  If we eliminate ∧› first, the P› can be too strong *)
  This rule is irreversible and we recall our hypothesis that φ-types between the conjunction are
  considered disjoint, i.e., we only consider (x ⦂ T) ∧ (y ⦂ U) ⟶ Y› when
  either x ⦂ T ⟶ Y› or y ⦂ U ⟶ Y›.
›

lemma [φreason %ToA_splitting]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P1
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P2
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A  B 𝗐𝗂𝗍𝗁 P1  P2
  unfolding Transformation_def
  by simp

lemma NToA_conj_src_A:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 A  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def
  by simp blast

lemma NToA_conj_src_B:
  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 A  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def
  by simp blast

text ‹Continued in \ref{supp-ex-conj}›


subsection ‹Subjection: Conjunction to a Pure Fact›

text ‹This is the only widely used additive conjunction under the interpretation of the φ data refinement›

subsubsection ‹Basic Rules›

lemma Subjection_inhabited_E[elim!]:
  Satisfiable (S 𝗌𝗎𝖻𝗃 P)  (Satisfiable S  P  C)  C
  unfolding Satisfiable_def
  by simp

lemma [φreason %cutting]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P  S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C)
 S 𝗌𝗎𝖻𝗃 P 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P  C
  unfolding Satisfiable_def Action_Tag_def Premise_def 𝗋EIF_def
  by simp

lemma [φreason %cutting]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P  C 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S)
 P  C 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S 𝗌𝗎𝖻𝗃 P
  unfolding Satisfiable_def Action_Tag_def Premise_def 𝗋ESC_def
  by simp 

lemma Subjection_imp_I:
  P
 S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗐𝗂𝗍𝗁 Q
 S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗌𝗎𝖻𝗃 P 𝗐𝗂𝗍𝗁 Q
  unfolding Transformation_def by simp


subsubsection ‹Simplification›

lemma Subjection_cong:
  P  P'  (P'  S  S')  (S 𝗌𝗎𝖻𝗃 P)  (S' 𝗌𝗎𝖻𝗃 P')
  unfolding atomize_eq BI_eq_iff by (simp, blast)

lemma Subjection_eq:
  (A 𝗌𝗎𝖻𝗃 P) = (A' 𝗌𝗎𝖻𝗃 P)  (P  A = A')
  unfolding BI_eq_iff
  by clarsimp blast

lemma Subjection_imp_simp[simp]:
  (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗌𝗎𝖻𝗃 P 𝗐𝗂𝗍𝗁 Q)  (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P  Q)
  unfolding Transformation_def by simp

lemma Subjection_True [simp, φprogramming_base_simps, φsafe_simp]:
  (T 𝗌𝗎𝖻𝗃 True) = T
  unfolding BI_eq_iff by simp

lemma Subjection_Flase[simp, φprogramming_base_simps, φsafe_simp]:
  (T 𝗌𝗎𝖻𝗃 False) = 0
  unfolding BI_eq_iff by simp

lemma Subjection_Subjection[simp, φprogramming_base_simps, φsafe_simp]:
  (S 𝗌𝗎𝖻𝗃 P 𝗌𝗎𝖻𝗃 Q) = (S 𝗌𝗎𝖻𝗃 P  Q)
  unfolding BI_eq_iff
  by simp



lemma Subjection_Zero[simp, φprogramming_base_simps, φsafe_simp]:
  (0 𝗌𝗎𝖻𝗃 P) = 0
  unfolding BI_eq_iff
  by simp

lemma Subjection_transformation:
  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗐𝗂𝗍𝗁 P
 S 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P
  unfolding Transformation_def by (simp; blast)

lemma Subjection_transformation_rewr:
  (A 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)  (Q  (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P))
  unfolding Transformation_def by (simp; blast)


subparagraph ‹With Additive Conjunction›

lemma Subjection_addconj[simp, φprogramming_base_simps, φsafe_simp]:
  (A 𝗌𝗎𝖻𝗃 P)  B  (A  B) 𝗌𝗎𝖻𝗃 P
  B  (A 𝗌𝗎𝖻𝗃 P)  (B  A) 𝗌𝗎𝖻𝗃 P
  unfolding atomize_eq BI_eq_iff
  by (clarsimp; blast)+

subparagraph ‹With Additive Disjunction›

lemma Subjection_plus_distrib:
  (A + B 𝗌𝗎𝖻𝗃 P) = (A 𝗌𝗎𝖻𝗃 P) + (B 𝗌𝗎𝖻𝗃 P)
  unfolding BI_eq_iff
  by simp blast

subparagraph ‹With Multiplicative Conjunction›

lemma Subjection_times[simp, φprogramming_base_simps, φsafe_simp]:
  (S 𝗌𝗎𝖻𝗃 P) * T = (S * T 𝗌𝗎𝖻𝗃 P)
  T * (S 𝗌𝗎𝖻𝗃 P) = (T * S 𝗌𝗎𝖻𝗃 P)
  unfolding BI_eq_iff
  by (simp, blast)+


subsubsection ‹Transformation Rules›

φreasoner_group ToA_subj = (%ToA_assertion_cut, [%ToA_assertion_cut, %ToA_assertion_cut+20]) for T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P
  ‹Transformation rules handling ‹Subjection››

lemma [φreason %ToA_subj]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (P  Q)
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def Premise_def
  by simp

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P 
    T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 True 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def by simp

lemma [φreason %ToA_subj]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (P  Q)
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 Q 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def Premise_def
  by simp

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P 
    T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 True 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def by simp

lemma [φreason %ToA_subj+10]: (*THINK: add Q in P, is good or not?*)
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 T 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 Q  P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 T 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 T 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗌𝗎𝖻𝗃 Q) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def φTagA_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+10]:
  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 (T 𝗌𝗎𝖻𝗃 Q) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 (T 𝗌𝗎𝖻𝗃 Q) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 (T 𝗌𝗎𝖻𝗃 Q) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗌𝗎𝖻𝗃 Q) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def φTagA_def Action_Tag_def
  by simp blast



subsection ‹Multiplicative Conjunction›

text ‹Is the term(*) :: ('a::sep_magma) BI  'a BI  'a BI directly›

lemma set_mult_inhabited[elim!]:
  Satisfiable (S * T)  (Satisfiable S  Satisfiable T  C)  C
  unfolding Satisfiable_def
  by (simp, blast)

lemma [φreason %cutting]:
  X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A
 Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 B
 X * Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A  B
  unfolding 𝗋EIF_def
  using set_mult_inhabited by blast

lemma [φreason %cutting]:
  X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A
 Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 B
 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A  B
  unfolding 𝗋EIF_def REMAINS_def
  using set_mult_inhabited by blast

lemma
  A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X
 B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 Y
 A  B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X * Y
  unfolding Action_Tag_def Satisfiable_def
  apply clarsimp
  oops

text ‹There is no sufficiency reasoning for multiplicative conjunction, because if we reason A and B
  separately, we loose the constraint about A and B are separatable, A ## B..›


lemma eq_left_frame:
  A = B  R * A = R * B
  by simp

lemma eq_right_frame:
  A = B  A * R = B * R
  by simp

lemma transformation_left_frame:
  "U' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P  R * U' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R * U 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def split_paired_All sep_conj_expn by blast

lemma transformation_right_frame:
  "U' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P  U' * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U * R 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def split_paired_All sep_conj_expn by blast

lemma transformation_bi_frame:
  " R' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P
 L' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 L 𝗐𝗂𝗍𝗁 Q
 L' * R' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 L * R 𝗐𝗂𝗍𝗁 P  Q "
  unfolding Transformation_def split_paired_All sep_conj_expn by blast


subsection ‹Finite Multiplicative Quantification (FMQ)›

definition Mul_Quant :: ('a  'b::sep_algebra BI)  'a set  'b BI ("")
  where Mul_Quant A S  (prod A S 𝗌𝗎𝖻𝗃 finite S)

text ‹Finite Multiplicative Quantification ✱i∈I. Ai is inductively applying separation conjunction
  over a finite family {Ai}› of assertions indexed by i∈I›, e.g., (✱i∈I. Ai) = A1 * A2 * … * An for
  I = {1,2,…,n}›

syntax
  "_Mul_Quant" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(2(_/_)./ _)" [0, 51, 14] 14)
translations ― ‹Beware of argument permutation!›
  "iA. b" == "CONST Mul_Quant (λi. b) A"

syntax
  "_qMul_Quant" :: "pttrn  bool  'a  'a"  ("(2_ | (_)./ _)" [0, 0, 14] 14)
translations
  "x|P. t" => "CONST Mul_Quant (λx. t) {x. P}"


subsubsection ‹Rewrites›

lemma sep_quant_sing[simp, φsafe_simp]:
   A {i} = A i
  unfolding Mul_Quant_def
  by simp

lemma sep_quant_empty[simp, φsafe_simp]:
   A {} = 1
  unfolding Mul_Quant_def
  by simp

lemma sep_quant_insert:
  i  I   A (insert i I) = A i *  A I
  unfolding Mul_Quant_def
  by (clarsimp simp add: Subjection_eq)

lemma sep_quant_reindex:
  inj_on f I
 if`I. A i  iI. A (f i)
  unfolding Mul_Quant_def BI_eq_iff atomize_eq
  by (clarsimp; rule; clarsimp simp add: finite_image_iff prod.reindex_cong)

lemma finite_prod_subjection:
  finite I  (iI. A i 𝗌𝗎𝖻𝗃 P i) = ((iI. A i) 𝗌𝗎𝖻𝗃 (iI. P i))
  unfolding BI_eq_iff
proof (clarify; rule; clarsimp)
  fix u
  assume finite I
  have u  (iI. A i 𝗌𝗎𝖻𝗃 P i)  u  prod A I  (xI. P x)
    by (induct arbitrary: u rule: finite_induct[OF finite I]; simp; blast)
  moreover assume u  (iI. A i 𝗌𝗎𝖻𝗃 P i)
  ultimately show u  prod A I  (xI. P x)
    by blast
qed 

lemma sep_quant_subjection[φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  (iI. A i 𝗌𝗎𝖻𝗃 P i) = ((iI. A i) 𝗌𝗎𝖻𝗃 (iI. P i))
  unfolding BI_eq_iff
  by (clarify; rule; clarsimp simp add: Mul_Quant_def finite_prod_subjection)

lemma sep_quant_ExBI[φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  (iI. ∃*j. A i j) = (∃*j. iI. A i (j i))
proof -
  have t1: u. finite I  u  (iI. ExBI (A i))  (x. u  (iI. A i (x i))) (is u. _  ?goal u)
  proof -
    fix u
    assume finite I
    show ?goal u
      apply (induct arbitrary: u rule: finite_induct[OF finite I]; clarsimp)
      apply (rule; clarsimp)
      subgoal for x F xa ua v xb
        by (rule exI[where x=λi. if i = x then xa else xb i], rule exI[where x=ua], rule exI[where x=v],
            simp, smt (verit) prod.cong)
      by blast
  qed
  show ?thesis
    unfolding BI_eq_iff Mul_Quant_def
    by (clarsimp; rule; clarsimp simp add: t1)
qed

lemma sep_quant_swap:
   finite I; finite J  (iI. jJ. A i j) = (jJ. iI. A i j)
  unfolding BI_eq_iff Mul_Quant_def
  by (clarsimp; metis prod.swap)

lemma sep_quant_scalar_assoc:
  (iI. jJ. A i j) = (((i,j)  I × J. A i j) 𝗌𝗎𝖻𝗃 finite I)
  unfolding BI_eq_iff Mul_Quant_def
  by (clarsimp; rule;
      clarsimp simp add: finite_prod_subjection ex_in_conv finite_cartesian_product_iff;
      cases I = {}; cases J = {}; simp add: prod.cartesian_product)

lemma sep_quant_sep:
  (iI. A i) * (iI. B i) = (iI. A i * B i)
  unfolding BI_eq_iff Mul_Quant_def
  proof (clarsimp; rule; clarify)
    fix u ua v
    assume finite I
    show ua  prod A I  v  prod B I  ua ## v  ua * v  (iI. A i * B i)
      by (induct arbitrary: v u ua rule: finite_induct[OF finite I] ; clarsimp ;
          smt (verit, best) sep_disj_commuteI sep_disj_multD1 sep_disj_multI1 sep_mult_assoc sep_mult_commute)
  next
    fix u
    assume finite I
    show u  (iI. A i * B i)  ua v. u = ua * v  ua  prod A I  v  prod B I  ua ## v
      by (induct arbitrary: u rule: finite_induct[OF finite I] ; clarsimp ;
          smt (verit) sep_disj_commuteI sep_disj_multD1 sep_disj_multI1 sep_mult_assoc sep_mult_commute)
qed

lemma sep_quant_merge_additive_disj:
  (iI. A i) + (iI. B i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i + B i)
  ― ‹but not held reversely›
unfolding Transformation_def Mul_Quant_def
proof (clarsimp; rule; clarsimp)
  fix v
  assume finite I
  show v  prod A I  v  (iI. A i + B i)
    by (induct arbitrary: v rule: finite_induct[OF finite I]; clarsimp; blast)
next
  fix v
  assume finite I
  show v  prod B I  v  (iI. A i + B i)
    by (induct arbitrary: v rule: finite_induct[OF finite I]; clarsimp; blast)
qed

lemma sep_quant_scalar_distr:
  I  J = {}  (iI. A i) * (jJ. B j) = (kI + J. (if k  J then B k else A k)) (*TODO: syntax priority!*)
  unfolding Mul_Quant_def plus_set_def Subjection_times Subjection_Subjection
  by (clarsimp simp add: Subjection_eq,
      smt (verit) disjoint_iff prod.cong prod.union_disjoint)


subsubsection ‹Basic Rules›

lemma [φreason %cutting]:
  (iS. A i 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P i)
 (iS. A i) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 (iS. P i)
  unfolding Mul_Quant_def Action_Tag_def Satisfiable_def meta_Ball_def Premise_def 𝗋EIF_def
  by clarsimp (metis dvdE dvd_prodI sep_conj_expn)


subsubsection ‹Transformation›

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  A x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (i{x}. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (i{}. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  A x * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (i{x}. A i) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (i{}. A i) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (i{x}. A i) 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (i{}. A i) 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (i{x}. A i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (i{}. A i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp


paragraph ‹Weak Normalization›

text ‹Source side is normalized by merging separations together
        (✱i∈I. A i) * (✱i∈I. B i) ⟶ (✱i∈I. A i * B i)›
  while the target side is normalized by splitting sep-quants into small separations
        (✱i∈I. A i * B i) ⟶ (✱i∈I. A i) * (✱i∈I. B i)›.
  It is because our reasoning strategy is splitting the target side first and scanning the source
    side φ-type-by-type for each separated individual φ›-type items.
  The first step works in assertion form while the second step is between φ-types.
  The ✱› is in assertion level, so the target side has to be split before the first step.
  Before the second step, for each individual target item (✱i∈I. x ⦂ T)› we shall apply
    sep_quant_transformation› to strip off the outer ✱› in order to enter inside into φ-type level
    so that the second step can continue.
  This sep_quant_transformation› may fail and if it fails, there is no way to enter the second step
    ‹in this unfinished reasoning mechanism right now›.

  Later after the type embedding of ✱› is completed, the reasoning of ✱› will be forwarded to the
  type embedding which provides full power of competence on that level.
›

lemma [φreason %ToA_weak_red]:
  (iI. A i * B i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (iI. A i) * (iI. B i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_sep
  by simp

lemma [φreason %ToA_weak_red]:
  (iI. A i * B i) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (iI. A i) * (iI. B i) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_sep[symmetric]
  by (simp add: mult.assoc)

lemma [φreason %ToA_weak_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i) * (iI. B i) 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i * B i) 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_sep
  by simp

lemma [φreason %ToA_weak_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i) * (iI. B i) * R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i * B i) * R 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_sep
  by simp

lemma [φreason %ToA_weak_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i) * (iI. B i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. A i * B i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_sep
  by simp




paragraph ‹Transformation Functor›

lemma sep_quant_transformation[φreason %ToA_cut]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 I = J
 (iI. A i 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B i 𝗐𝗂𝗍𝗁 P i)
 (iI. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iJ. B i) 𝗐𝗂𝗍𝗁 (iI. P i)
  unfolding Transformation_def Mul_Quant_def meta_Ball_def Premise_def 𝗋Guard_def
  proof clarsimp
    fix v
    assume finite J
    show (x. x  J  v. v  A x  v  B x  P x)
         v  prod A J  v  prod B J  (xJ. P x) 
      by (induct arbitrary: v rule: finite_induct[OF finite J]; clarsimp; blast)
  qed


lemma [φreason %ToA_cut]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 I = J
 (iJ. A i 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B i 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R i 𝗐𝗂𝗍𝗁 P i)
 (iJ. R i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 (iI. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iJ. B i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 (iJ. P i)
  unfolding REMAINS_def Premise_def 𝗋Guard_def Action_Tag_def
  subgoal premises prems proof -
    have t1: (iI. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iJ. B i) * (iJ. R i) 𝗐𝗂𝗍𝗁 (iJ. P i)
      by (insert prems, simp add: sep_quant_sep sep_quant_transformation[unfolded Premise_def 𝗋Guard_def])
    show ?thesis
      using mk_intro_transformation prems(3) t1 transformation_left_frame by blast
  qed .

thm transformation_trans[OF sep_quant_transformation, where Q=True, simplified]

paragraph ‹Scalar Associative›

lemma [φreason %ToA_normalizing]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 finite I  ((i,j)  I × J. A i j) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
 (iI. jJ. A i j) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_scalar_assoc Premise_def Subjection_transformation_rewr
  by simp

lemma [φreason %ToA_normalizing]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 finite I  ((i,j)  I × J. A i j) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
 (iI. jJ. A i j) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_scalar_assoc Premise_def Subjection_transformation_rewr Subjection_times
  by simp

lemma [φreason %ToA_normalizing]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((i,j)  I × J. B i j) 𝗐𝗂𝗍𝗁 P
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 finite I
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. jJ. B i j) 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_scalar_assoc Premise_def
  by simp

lemma [φreason %ToA_normalizing]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((i,j)  I × J. B i j) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 finite I
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. jJ. B i j) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding sep_quant_scalar_assoc Premise_def
  by simp





subsection ‹Universal Quantification›

term inf

definition AllSet :: ('a  'b BI)  'b BI (binder "BI" 10)
  where AllSet X = BI {y. x. y  X x}

lemma AllSet_expn[simp, φexpns]:
  p  (BIx. B x)  (x. p  B x)
  unfolding AllSet_def Satisfaction_def by simp

lemma AllSet_sub:
  A  (BI x. B x)  (x. A  B x)
  unfolding AllSet_def
  by (cases A; rule; simp add: subset_iff BI_sub_iff)

lemma BI_All_comm:
  (BI x y. A x y) = (BI y x. A x y)
  unfolding BI_eq_iff
  by (simp, blast)

lemma [elim!]:
  Satisfiable (AllSet S)  (Satisfiable (S x)  C)  C
  unfolding Satisfiable_def
  by clarsimp blast

lemma [φinhabitance_rule 1000]:
  S x 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C
 AllSet S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C
  unfolding Action_Tag_def 𝗋EIF_def
  by clarsimp blast


subsection ‹Supplementary Connective›

subsubsection ‹World Shift› ― ‹Functional refinement in assertion-level, functional counterpart of ‹⨾››

definition World_Shift :: ('c  'd)  'c BI  'd BI ("Ψ[_]" [10] 1000)
  where (Ψ[ψ] S) = BI {ψ u |u. u  S}
  ― ‹applying a function ψ› (usually a homomorphism) to the concrete objects (namely Kripke world)
      characterized by an assertion.›

text ‹Some thinking, what if we extend ψ› to be a relation instead of a function? Then Ψ[ψ]›
  actually becomes the assertion-level counterpart of the φ-type ⨾›. However, the difficulty is
  I cannot find the relational extension of closed homomorphism that gives us distributivity over
  *› like Ψ_Multiplicative_Conj›.›

lemma World_Shift_expn[φexpns, simp]:
  p  Ψ[ψ] S  (u. p = ψ u  u  S)
  unfolding World_Shift_def Satisfaction_def
  by clarsimp


text ‹The motivation of such modality is it is used later in Domainoid Extraction›

paragraph ‹Rewrites \& Transformations›

lemma Ψ_1:
  homo_one ψ
 Ψ[ψ] 1 = 1
  unfolding BI_eq_iff homo_one_def
  by simp

lemma Ψ_0:
  Ψ[ψ] 0 = 0
  unfolding BI_eq_iff
  by clarsimp

lemma
  Ψ[ψ] (A  B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (Ψ[ψ] A  Ψ[ψ] B)
  unfolding Transformation_def
  by (clarsimp; blast)

lemma Ψ_Multiplicative_Conj:
  closed_homo_sep ψ
 Ψ[ψ] (A * B) = Ψ[ψ] A * Ψ[ψ] B
  unfolding BI_eq_iff
  by (clarsimp simp add: closed_homo_sep_def closed_homo_sep_disj_def homo_sep_def
                         homo_sep_mult_def; rule; clarsimp; metis)

lemma Ψ_Mul_Quant:
  closed_homo_sep ψ
 homo_one ψ
 Ψ[ψ] (iS. A i) = (iS. Ψ[ψ] (A i))
proof -
  assume closed_homo_sep ψ and homo_one ψ
  { assume finite S
    have Ψ[ψ] (iS. A i) = (iS. Ψ[ψ] (A i))
      by (induct rule: finite_induct[OF finite S];
          simp add: Ψ_1 closed_homo_sep ψ homo_one ψ Ψ_Multiplicative_Conj)
  }
  then show Ψ[ψ] (iS. A i) = (iS. Ψ[ψ] (A i))
    unfolding Mul_Quant_def
    by (smt (verit, best) Subjection_Flase Subjection_True Ψ_0)
qed

lemma Ψ_Additive_Disj:
  Ψ[d] (A + B) = Ψ[d] A + Ψ[d] B
  unfolding BI_eq_iff
  by (clarsimp; metis)

lemma Ψ_ExBI:
  Ψ[d] (∃*c. S c) = (∃*c. Ψ[d] (S c))
  unfolding BI_eq_iff
  by (clarsimp; metis)

lemma Ψ_Subjection:
  Ψ[d] (S 𝗌𝗎𝖻𝗃 P) = (Ψ[d] S 𝗌𝗎𝖻𝗃 P)
  unfolding BI_eq_iff
  by (clarsimp; metis)


section ‹Basic φ-Types \& Embedding of Logic Connectives›

subsection ‹Identity φ-Type›

definition Itself :: " ('a,'a) φ " where "Itself x = BI {x}"

lemma Itself_expn[φexpns, iff]:
  "p  (x  Itself)  p = x"
  unfolding φType_def Itself_def Satisfaction_def by auto

lemma Itself_expn'[φexpns, iff]:
  "p  (Itself x)  p = x"
  unfolding Itself_def Satisfaction_def by auto

lemma Itself_inhabited_E[elim!]:
  Satisfiable (x  Itself)  C  C .

lemma Itself_inhabited[φreason %cutting, simp, intro!]:
  Satisfiable (x  Itself)
  unfolding Satisfiable_def
  by blast

lemma [φreason %cutting]:
  Abstract_Domain Itself (λ_. True)
  unfolding Abstract_Domain_def 𝗋EIF_def Satisfiable_def
  by clarsimp

lemma [φreason %abstract_domain]:
  Abstract_DomainL Itself (λ_. True)
  unfolding Abstract_DomainL_def 𝗋ESC_def Satisfiable_def
  by simp

lemma Itself_E:
  𝗉𝗋𝖾𝗆𝗂𝗌𝖾 v  (x  T)  v  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T
  unfolding Transformation_def Premise_def by simp

text ‹The introduction rule of Itself cannot be written in such ∃free-ToA form but in To-Transformation form.›

lemma satisfication_encoding:
  (x  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T 𝗐𝗂𝗍𝗁 P)  x  (y  T)  P
  unfolding Transformation_def by simp


subsubsection ‹Construction from Raw Abstraction represented by Itself ›
  ― ‹is a sort of reasoning process useful later in making initial Hoare triples from semantic raw
      representation (which are represented by Itself, i.e., no abstraction).›

φreasoner_group abstract_from_raw = (100, [16, 1399]) for v  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T
      > ToA_bottom and < ToA_splitting_target
      ‹Rules constructing abstraction from raw representations›
  and abstract_from_raw_cut = (1000, [1000, 1030]) for v  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T in abstract_from_raw
      ‹Cutting rules constructing abstraction from raw representations›
  and derived_abstract_from_raw = (70, [60,80]) for v  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T
                                                 in abstract_from_raw and < abstract_from_raw_cut
      ‹Derived rules›

declare [[φreason_default_pattern
      _  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?T 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫  _  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  ?T 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (1120)
  and _  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫  _  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 (1110)
]]

declare Itself_E[φreason default %ToA_falling_latice]

lemma [φreason default %ToA_falling_latice+1 except ?var  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @tag 𝒯𝒫]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 c = c'  c'  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A)
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 c = c'
 c  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A
  unfolding Premise_def
  by simp

declare [[φchk_source_val = false]]

lemma [φreason %abstract_from_raw_cut]:
  ca  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A
 cb  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 ca ## cb
 (ca * cb)  Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A * B
  unfolding Transformation_def Premise_def
  by (clarsimp; blast)

declare [[φchk_source_val = true]]



subsection ‹Embedding of ⊤›

definition φAny :: ('c, 'x) φ ("φ") where φ = (λ_. )

setup Sign.mandatory_path "φAny"

lemma unfold [φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  (x  φ) = 
  unfolding φAny_def φType_def ..

lemma expansion[iff]:
  p  (x  φ)  True
  unfolding φAny.unfold
  by simp

setup Sign.parent_path

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  x  φ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 True
  unfolding 𝗋EIF_def
  by simp

lemma [φreason %extract_pure]:
  True 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x  φ
  unfolding 𝗋ESC_def Satisfiable_def
  by simp

subsubsection ‹Transformation Rules›

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  φ 𝗐𝗂𝗍𝗁 P
  unfolding φAny.unfold
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  φ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding φAny.unfold
  by simp

paragraph ‹Separation Extraction›

text ‹In ToA, the φ behaviors like a wildcard that can absorb an undetermined number of φ-type items,
  and which φ-type items are absorbed cannot be determined just from the type information. Therefore,
  we require explicit annotations to be given to give the range of the absorption of φ.

TODO: make such annotation syntax.
›

lemma [φreason %ToA_top+1]:
  May_Assign (snd x) unspec
 x  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((), unspec)  φ  
  for T :: ('c::sep_magma_1, 'x) φ
  unfolding Transformation_def φProd'_def
  by clarsimp


subsection ‹Embedding of ⊥›

definition φBot :: ('c,'a) φ ("φ") where φ = (λ_. 0)

setup Sign.mandatory_path "φBot"

lemma unfold[φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  (x  φ) = 0
  unfolding φBot_def φType_def ..

lemma expansion[simp]:
  p  (x  φ)  False
  unfolding φBot.unfold
  by simp

setup Sign.parent_path

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  x  φ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 False
  unfolding 𝗋EIF_def φBot.unfold Satisfiable_def
  by simp

lemma [φreason %extract_pure]:
  False 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x  φ
  unfolding 𝗋ESC_def φBot.unfold Satisfiable_def
  by simp

subsubsection ‹Transformation Rules›

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 x  φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  unfolding φBot.unfold
  by simp

lemma [φreason %ToA_red]:
  0 * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (x  φ) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  unfolding φBot.unfold
  by simp

paragraph ‹Separation Extraction›

(*TODO: more think!*)

lemma [φreason %ToA_top]:
  May_Assign (snd x) unspec
 x  φ   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (any, unspec)  U  
  unfolding Transformation_def φProd'_def
  by clarsimp


subsection ‹Embedding of Separation Conjunction›

lemma φProd_expn' [φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  ((a,b)  A  B) = (a  A) * (b  B)
  unfolding BI_eq_iff by (simp add: set_mult_expn) blast

lemma φProd_expn'':
  NO_MATCH (xx,yy) x
 (x  A  B) = (fst x  A) * (snd x  B)
  unfolding BI_eq_iff by (cases x; simp add: set_mult_expn) blast

bundle φProd_expn = φProd_expn'[simp] φProd_expn''[simp]

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  fst x  T1 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C1
 snd x  T2 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C2
 x  T1  T2 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C1  C2
  unfolding Satisfiable_def Action_Tag_def 𝗋EIF_def
  by (cases x; simp, blast)

paragraph ‹Frame Rules›

lemma transformation_right_frame_ty:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 a = fst x  a  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(a)  U 𝗐𝗂𝗍𝗁 P(a))
 x  T  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apfst f x  U  R 𝗐𝗂𝗍𝗁 P(fst x)
  unfolding Transformation_def
  by (cases x; clarsimp; blast)

lemma transformation_left_frame_ty:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 a = snd x  a  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(a)  U 𝗐𝗂𝗍𝗁 P(a))
 x  R  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apsnd f x  R  U 𝗐𝗂𝗍𝗁 P(snd x)
  unfolding Transformation_def
  by (cases x; clarsimp; blast)

subsubsection ‹Abstract Domain›

text ‹The upper bound of the abstraction domain is simple.›
(*
lemma ― ‹will be derived later›:
  ‹ Abstract_Domain T DT
⟹ Abstract_Domain U DU
⟹ Abstract_Domain (T ∗ U) (λ(x,y). DT x ∧ DU y) ›
  unfolding Abstract_Domain_def Action_Tag_def Satisfiable_def
  by (clarsimp, blast)
*)

text ‹However, the lower bound is non-trivial, in which case we have to show the separation combination
  is compatible between the two φ-types. The compatibility is encoded by predicate Separation_Disjψ
  and Separation_Disjφ which are solved by means of the domainoid introduced later.
  So the rules are given until \cref{phi-types/Domainoid/App}.
›


subsubsection ‹Transformation Rules›

lemma destruct_φProd_φapp: (*TODO: merge this into general destruction*)
  x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst x  T) * (snd x  U)
  by (cases x; simp add: Transformation_def set_mult_expn) blast

lemma φProd_transformation:
  " x  N 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x'  N' 𝗐𝗂𝗍𝗁 Pa
 y  M 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y'  M' 𝗐𝗂𝗍𝗁 Pb
 (x,y)  N  M 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x',y')  N'  M' 𝗐𝗂𝗍𝗁 Pa  Pb"
  unfolding Transformation_def by simp blast
  (*The rule is not added into the φ-LPR because such product is solved by Structural Extract*)

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst x  N) * (snd x  M) 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  N  M 𝗐𝗂𝗍𝗁 P"
  by (cases x; simp add: φProd_expn')

lemma [φreason %ToA_red+1 for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_)  _  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                              _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  _  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x  N) * (y  M) 𝗐𝗂𝗍𝗁 P
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y)  N  M 𝗐𝗂𝗍𝗁 P"
  by (simp add: φProd_expn')

text ‹The reductions on source are not enabled as they may break the form of original source assertion›

paragraph ‹Separation Extraction›

text ‹see §Technical φ-Types required in Reasoning Transformation/Separation Extraction of ‹φ›Prod›

lemma Structural_Extract_φProd_a [φreason %ToA_cut except (_ :: ?'a::sep_semigroup BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']:
      ― ‹merely the rule for non-semigroup algebras.
          for others, see §Technical φ-Types required in Reasoning Transformation/Separation Extraction of ‹φ›Prod›
  fst a  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b  Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 a  A  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((b, snd a), unspec)  (Y  X)   𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
  for A :: ('c::sep_magma_1, 'x) φ
  unfolding Action_Tag_def Transformation_def φProd'_def
  by clarsimp blast


subsection ‹Embedding of Empty›

subsubsection ‹Rewrites›

lemma φNone_itself_is_one[simp, φsafe_simp]:
  (any  φNone) = 1
  unfolding BI_eq_iff by simp

lemma φProd_φNone:
  ((x',y)    U) = ((y  U) :: 'a::sep_magma_1 BI)
  ((x,y')  T  ) = ((x  T) :: 'b::sep_magma_1 BI)
  unfolding BI_eq_iff
  by (simp_all add: set_mult_expn)


subsubsection ‹Transformation Rules›

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (any  ) * X 𝗐𝗂𝗍𝗁 P "
  for X :: 'a::sep_magma_1 BI
  unfolding mult_1_left φNone_itself_is_one .

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (any  ) * X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P"
  for X :: 'a::sep_magma_1 BI
  unfolding mult_1_left φNone_itself_is_one .

lemma [φreason %ToA_red]:
  " R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 (any  ) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P "
  for X :: 'a::sep_magma_1 BI
  unfolding mult_1_left φNone_itself_is_one .

lemma [φreason %ToA_success]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 any   𝗋𝖾𝗆𝖺𝗂𝗇𝗌 X
  for X :: 'a::sep_magma_1 BI
  unfolding REMAINS_def Action_Tag_def by simp

lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _   𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y   𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  by simp

lemma [φreason %ToA_red]:
  1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 x   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (x  ) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  for W :: 'c::sep_magma_1 BI
  by simp

lemma [φreason %ToA_success]:
  x    U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, unspec)  U  
  unfolding φProd'_def
  by (cases x; simp add: φProd_expn')

lemma [φreason %ToA_success]:
  x  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (unspec, fst x)    T
  unfolding φProd'_def
  by (cases x; simp add: φProd_expn')


subsection ‹Injection into Unital Algebra›

definition φSome :: ('v, 'x) φ  ('v option, 'x) φ (" _" [91] 90)
  where  T = (λx. Some `I (x  T))

lemma φSome_expn[simp, φexpns]:
  p  (x   T)  (v. p = Some v  v  (x  T))
  unfolding φType_def φSome_def
  by simp

subsubsection ‹Rewrites›

lemma φSome_φProd:
   T   U =  (T  U)
  by (rule φType_eqI; clarsimp; force)

lemma φSome_eq_term_strip:
  (x   T) = (y   U)  (x  T) = (y  U)
  unfolding atomize_eq BI_eq_iff
  by clarsimp blast
  


subsubsection ‹Transformation Rules›

lemma φSome_transformation_strip:
  x   T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y   U 𝗐𝗂𝗍𝗁 P  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗐𝗂𝗍𝗁 P
  unfolding atomize_eq Transformation_def
  by clarsimp blast

lemma [φreason %ToA_cut]:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗐𝗂𝗍𝗁 P
 x   T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y   U 𝗐𝗂𝗍𝗁 P
  unfolding φSome_transformation_strip .

lemma [φreason %ToA_cut]:
  x  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U  R 𝗐𝗂𝗍𝗁 P
 x   T   W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y   U   R 𝗐𝗂𝗍𝗁 P
  by (simp add: φSome_φProd φSome_transformation_strip φProd'_def)

subsubsection ‹Properties› ― ‹Some properties have to be given early before derivers ready›

lemma Abstract_Domain_φSome[φreason %abstract_domain]:
  Abstract_Domain T D
 Abstract_Domain ( T) D
  unfolding Abstract_Domain_def 𝗋EIF_def Satisfiable_def
  by clarsimp



subsubsection ‹Conditional Empty›

definition φCond_Unital :: bool  ('v, 'x) φ  ('v::sep_magma_1, 'x) φ ("◒[_] _" [20,91] 90)
  ― ‹Conditional Unital Insertion›
  where ◒[C] T = (if C then T else )

definition φCond_UniIns :: bool  ('v, 'x) φ  ('v option, 'x) φ ("◑[_] _" [20,91] 90)
  ― ‹Conditional Unital Insertion›
  where ◑[C] T = (if C then  T else )


paragraph ‹Rewrites›

lemma φCond_Unital_unfold_simp[simp, φsafe_simp]:
  ◒[True] T  T
  ◒[False] T  
  unfolding φCond_Unital_def
  by simp+

lemma φCond_UniIns_unfold_simp[simp, φsafe_simp]:
  ◑[True]  T   T
  ◑[False] T  
  unfolding φCond_UniIns_def
  by simp+

lemma φCond_Unital_expn[simp, φexpns]:
  p  (x  ◒[C] T)  (if C then p  (x  T) else p = None)
  by clarsimp

lemma φCond_UniIns_expn[simp, φexpns]:
  p  (x  ◑[C] T)  (if C then p  (x   T) else p = None)
  by clarsimp

lemma φCond_Unital_Prod:
  ◒[C] T  ◒[C] U  ◒[C] (T  U)
  unfolding atomize_eq
  by (rule φType_eqI; cases C; clarsimp)

lemma φCond_UniIns_Prod:
  ◑[C] T  ◑[C] U  ◑[C] (T  U)
  unfolding atomize_eq
  by (rule φType_eqI; cases C; clarsimp; force)

lemma φCond_Unital_trans_rewr:
  x  ◒[C] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  ◒[C] U 𝗐𝗂𝗍𝗁 C  P  C  (x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗐𝗂𝗍𝗁 P)
  unfolding atomize_eq Transformation_def
  by (cases C; clarsimp; blast)


section ‹Basic φ-Type Properties›

text ‹The two properties are essential for reasoning the general transformation including separation extraction.›


subsection ‹Identity Element I\&E›

definition Identity_ElementI :: 'a::one BI  bool  bool where Identity_ElementI S P  (S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P)
definition Identity_ElementE :: 'a::one BI  bool where Identity_ElementE S  (1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S)

definition Identity_ElementsI :: ('c::one,'a) φ  ('a  bool)  ('a  bool)  bool
  where Identity_ElementsI T D P  (x. D x  Identity_ElementI (x  T) (P x))

definition Identity_ElementsE :: ('c::one,'a) φ  ('a  bool)  bool
  where Identity_ElementsE T D  (x. D x  Identity_ElementE (x  T))

definition Identity_Elements :: ('c::one,'a) φ  ('a  bool)  bool
  where Identity_Elements T D  Identity_ElementsI T D (λ_. True)  Identity_ElementsE T D

lemma Identity_Elements_alt_def:
  Identity_Elements T D  (x. D x  (x  T) = 1)
  unfolding Identity_Elements_def Identity_ElementsI_def Identity_ElementI_def
            Identity_ElementsE_def Identity_ElementE_def BI_eq_ToA
  by (rule; clarsimp)
  

definition Hint_Identity_Element :: ('c::one,'a) φ  'a  bool
  where Hint_Identity_Element T one  True
  ― ‹a pure syntactical hint›

declare [[ φreason_default_pattern
      Identity_ElementI ?S _  Identity_ElementI ?S _ (100)
  and Identity_ElementI (_  ?T) _  Identity_ElementI (_  ?T) _ (110)
  and Identity_ElementE ?S  Identity_ElementE ?S (100)
  and Identity_ElementE (_  ?T)  Identity_ElementE (_  ?T) (110)

  and Identity_ElementsI ?T _ _  Identity_ElementsI ?T _ _ (100)
  and Identity_ElementsE ?T _  Identity_ElementsE ?T _ (100)

  and Hint_Identity_Element ?T _  Hint_Identity_Element ?T _ (100)
  and Identity_Elements ?T _  Identity_Elements ?T _ (100)
]]

φreasoner_group identity_element = (100,[1,3000]) for (Identity_ElementI _ _, Identity_ElementE _)
    ‹Reasoning rules deducing if the given assertion can transform to or be transformed from the
     assertion of identity element.›
 and identity_element_fallback = (1,[1,1]) for (Identity_ElementI _ _, Identity_ElementE _)
     in identity_element > fail
    ‹Fallbacks of reasoning Identity_Element.›
 and identity_element_φ = (10, [10, 11]) for (Identity_ElementI _ _, Identity_ElementE _)
    ‹Turning to ‹Identity_ElementsI› and ‹Identity_ElementsE››
 and derived_identity_element = (50, [50,55]) for (Identity_ElementI _ _, Identity_ElementE _)
     in identity_element > identity_element_φ
    ‹Automatically derived Identity_Element rules›
 and identity_element_top = (2900, [2900,2999]) in identity_element ‹top›
 and identity_element_cut = (1000, [1000,1029]) for (Identity_ElementI _ _, Identity_ElementE _)
     in identity_element > derived_identity_element < identity_element_top
    ‹Cutting rules for Identity_Element›
 and identity_element_OPEN_MAKE = (1100, [1100,1100]) in identity_element
     and > identity_element_cut < identity_element_top ‹›
 and identity_element_red = (2500, [2500, 2530]) for (Identity_ElementI _ _, Identity_ElementE _)
     in identity_element > identity_element_cut
    ‹Literal Reduction›
 and identity_element_ToA = (50, [50,51]) for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ in ToA
    ‹Entry points from ToA to Identity_Element›

 and identity_element_hint = (1000, [10, 2000]) for Hint_Identity_Element T ie
    ‹syntactical hints suggesting an identity element of the given φ-type›

subsubsection ‹Extracting Pure Facts›

paragraph ‹Identity_Element›

lemma [φreason %extract_pure]:
  𝗋ESC Q (Satisfiable S)
 𝗋EIF (Identity_ElementI S P) (Q  P)
  unfolding Identity_ElementI_def 𝗋ESC_def 𝗋EIF_def Transformation_def Satisfiable_def
  by blast

lemma [φreason %extract_pure]:
  𝗋EIF (Satisfiable S) P
 𝗋EIF (Identity_ElementE S) P
  unfolding Identity_ElementE_def 𝗋ESC_def 𝗋EIF_def Transformation_def Satisfiable_def
  by blast

lemma Identity_ElementI_𝒜EIF_sat:
  𝗋EIF (Identity_ElementI S P) (v. v  S  v = 1  P)
  unfolding Identity_ElementI_def 𝗋EIF_def Transformation_def
  by blast

lemma Identity_ElementI_𝒜ESC_sat:
  𝗋ESC (v. v  S  v = 1  P) (Identity_ElementI S P)
  unfolding Identity_ElementI_def 𝗋ESC_def Transformation_def
  by blast

lemma Identity_ElementE_𝒜EIF_sat:
  𝗋EIF (Identity_ElementE S) (1  S)
  unfolding Identity_ElementE_def 𝗋EIF_def Transformation_def
  by blast

lemma Identity_ElementE_𝒜ESC_sat:
  𝗋ESC (1  S) (Identity_ElementE S)
  unfolding Identity_ElementE_def 𝗋ESC_def Transformation_def
  by blast

bundle Identity_ElementI_sat = Identity_ElementI_𝒜EIF_sat [φreason %extract_pure_sat]
                               Identity_ElementI_𝒜ESC_sat [φreason %extract_pure_sat]
bundle Identity_ElementE_sat = Identity_ElementE_𝒜EIF_sat [φreason %extract_pure_sat]
                               Identity_ElementE_𝒜ESC_sat [φreason %extract_pure_sat]

bundle Identity_Element_sat begin
  unbundle Identity_ElementI_sat Identity_ElementE_sat
end


paragraph ‹Identity_Elements›

lemma [φreason %extract_pure]:
  (x. 𝗋EIF (Identity_ElementI (x  T) (P x)) (Q x))
 𝗋EIF (Identity_ElementsI T D P) (x. D x  Q x)
  unfolding 𝗋EIF_def Identity_ElementsI_def
  by clarsimp

lemma [φreason %extract_pure]:
  (x. 𝗋EIF (Identity_ElementE (x  T)) (Q x))
 𝗋EIF (Identity_ElementsE T D) (x. D x  Q x)
  unfolding 𝗋EIF_def Identity_ElementsE_def
  by clarsimp

subsubsection ‹System Rules›

lemma Identity_ElementsI_sub:
  D'  D
 P  P'
 Identity_ElementsI T D P 
 Identity_ElementsI T D' P'
  unfolding Identity_ElementsI_def Identity_ElementI_def Transformation_def
  by (clarsimp simp add: le_fun_def; blast)

lemma [φreason %cutting]:
  Identity_ElementsI T DI P
 Identity_ElementsE T DE
 Identity_Elements T (λx. DI x  DE x)
  unfolding Identity_Elements_def
  by (smt (verit, best) Identity_ElementsE_def Identity_ElementsI_sub predicate1I)


subsubsection ‹Fallback›

lemma [φreason default %fail]:
  TRACE_FAIL TEXT(‹Fail to show› (S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1))
 Identity_ElementI S Any
  unfolding TRACE_FAIL_def
  by blast

lemma [φreason default %fail]:
  TRACE_FAIL TEXT(‹Fail to show› (1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S))
 Identity_ElementE S
  unfolding TRACE_FAIL_def
  by blast

lemma [φreason default %identity_element_fallback]:
  Identity_ElementsI T (λ_. False) (λ_. True)
  unfolding Identity_ElementsI_def
  by blast

lemma [φreason default %identity_element_fallback]:
  Identity_ElementsE T (λ_. False)
  unfolding Identity_ElementsE_def
  by blast


subsubsection ‹Termination›

lemma [φreason %identity_element_cut]:
  Identity_ElementI 0 True
  unfolding Identity_ElementI_def by simp

lemma [φreason %identity_element_cut for Identity_ElementE 1
                                         Identity_ElementE ?var ]:
  Identity_ElementE 1
  unfolding Identity_ElementE_def by simp

lemma [φreason %identity_element_cut for Identity_ElementI 1 _
                                         Identity_ElementI ?var _ ]:
  Identity_ElementI 1 True
  unfolding Identity_ElementI_def by simp

lemma Identity_ElementE_empty[φreason %identity_element_cut]:
  Identity_ElementE (any  )
  unfolding Identity_ElementE_def by simp

lemma Identity_ElementI_empty[φreason %identity_element_cut]:
  Identity_ElementI (any  ) True
  unfolding Identity_ElementI_def by simp


subsubsection ‹Special Forms›

lemma [φreason %identity_element_red for Identity_ElementI _ True]:
  Identity_ElementI X Any
 Identity_ElementI X True
  unfolding Identity_ElementI_def Transformation_def
  by simp

lemma [φreason %identity_element_cut]:
  Identity_ElementI X P
 Identity_ElementI (φTagA mode X) P
  unfolding φTagA_def .

lemma [φreason %identity_element_cut]:
  Identity_ElementE X
 Identity_ElementE (φTagA mode X)
  unfolding φTagA_def .


paragraph ‹Conditioned Branch›

subparagraph ‹Reduction›

lemma [φreason %identity_element_red]:
  Identity_ElementI A P
 Identity_ElementI (If True A B) P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementI B P
 Identity_ElementI (If False A B) P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementE A
 Identity_ElementE (If True A B)
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementE B
 Identity_ElementE (If False A B)
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsI A D P
 Identity_ElementsI (If True A B) D P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsI B D P
 Identity_ElementsI (If False A B) D P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsE A D
 Identity_ElementsE (If True A B) D
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsE B D
 Identity_ElementsE (If False A B) D
  by simp


subparagraph ‹Normalizing›

lemma [φreason %identity_element_cut]:
  Identity_ElementI (If C (x  A) (x  B)) P
 Identity_ElementI (x  If C A B) P
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  Identity_ElementE (If C (x  A) (x  B))
 Identity_ElementE (x  If C A B)
  by (cases C; simp)

subparagraph ‹Case Split›

lemma [φreason %identity_element_cut]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇  C  Identity_ElementsI A DA PA)
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬C  Identity_ElementsI B DB PB)
 Identity_ElementsI (If C A B) (if C then DA else DB) (if C then PA else PB)
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇  C  Identity_ElementsE (If C A B) DA)
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬C  Identity_ElementsE (If C A B) DB)
 Identity_ElementsE (If C A B) (If C DA DB)
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C  Identity_ElementI A Pa)
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  Identity_ElementI B Pb)
 Identity_ElementI (If C A B) (If C Pa Pb)
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C  Identity_ElementE A)
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  Identity_ElementE B)
 Identity_ElementE (If C A B)
  by (cases C; simp)

paragraph ‹Case Split of Sum Type›

subparagraph ‹Reduction›

lemma [φreason %identity_element_red]:
  Identity_ElementE (A a)
 Identity_ElementE (case_sum A B (Inl a))
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementE (B b)
 Identity_ElementE (case_sum A B (Inr b))
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementI (A a) P
 Identity_ElementI (case_sum A B (Inl a)) P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementI (B b) P
 Identity_ElementI (case_sum A B (Inr b)) P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsE (A a) D
 Identity_ElementsE (case_sum A B (Inl a)) D
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsE (B b) D
 Identity_ElementsE (case_sum A B (Inr b)) D
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsI (A a) D P
 Identity_ElementsI (case_sum A B (Inl a)) D P
  by simp

lemma [φreason %identity_element_red]:
  Identity_ElementsI (B b) D P
 Identity_ElementsI (case_sum A B (Inr b)) D P
  by simp

subparagraph ‹Case Split›

lemma [φreason %identity_element_cut]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  Identity_ElementI (A a) (P a))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  Identity_ElementI (B b) (Q b))
 Identity_ElementI (case_sum A B x) (pred_sum P Q x)
  unfolding Premise_def
  by (cases x; clarsimp)

lemma [φreason %identity_element_cut]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  Identity_ElementE (A a))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  Identity_ElementE (B b))
 Identity_ElementE (case_sum A B x)
  unfolding Premise_def
  by (cases x; clarsimp)

lemma [φreason %identity_element_cut]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  Identity_ElementsI (A a) (DA a) (P a))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  Identity_ElementsI (B b) (DB b) (Q b))
 Identity_ElementsI (case_sum A B x) (case_sum DA DB x) (case_sum P Q x)
  unfolding Premise_def
  by (cases x; clarsimp)

lemma [φreason %identity_element_cut]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  Identity_ElementsE (A a) (DA a))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  Identity_ElementsE (B b) (DB b))
 Identity_ElementsE (case_sum A B x) (case_sum DA DB x)
  unfolding Premise_def
  by (cases x; clarsimp)



subsubsection ‹ToA Entry Point›

lemma [φreason default ! %identity_element_ToA]:
  Identity_ElementI X P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Identity_ElementI_def Action_Tag_def .

lemma [φreason default ! %identity_element_ToA+1 for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var   𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Identity_ElementI X P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 unspec   𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Identity_ElementI_def Action_Tag_def
  by simp

lemma [φreason default ! %identity_element_ToA]:
  Identity_ElementI X P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x   𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Identity_ElementI_def Action_Tag_def
  by simp

lemma [φreason default ! %identity_element_ToA]:
  Identity_ElementE X
 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒯𝒫
  unfolding Identity_ElementE_def Action_Tag_def .

lemma [φreason default ! %identity_element_ToA+1 for ?var   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Identity_ElementE X
 x   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒯𝒫
  unfolding Identity_ElementE_def Action_Tag_def
  by simp

lemma [φreason default ! %identity_element_ToA]:
  Identity_ElementE X
 x   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒯𝒫
  unfolding Identity_ElementE_def Action_Tag_def
  by simp


subsubsection ‹Logic Connectives \& Basic φ-Types›

lemma [φreason %identity_element_cut]:
  Identity_ElementsI Itself (λx. x = 1) (λ_. True)
  unfolding Identity_ElementI_def Identity_ElementsI_def Transformation_def
  by clarsimp

lemma [φreason %identity_element_cut]:
  Identity_ElementsE Itself (λx. x = 1)
  unfolding Identity_ElementE_def Identity_ElementsE_def Transformation_def
  by clarsimp

lemma [φreason no explorative backtrack %identity_element_φ]:
  Identity_ElementsI T D P
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 D x
 Identity_ElementI (x  T) (P x)
  unfolding Identity_ElementI_def Identity_ElementsI_def Premise_def
  using transformation_trans by fastforce

lemma [φreason no explorative backtrack %identity_element_φ+1 for Identity_ElementI (?var  _) _]:
  Identity_ElementsI T D P
 Hint_Identity_Element T x cut True
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 D x
 Identity_ElementI (x  T) (P x)
  unfolding Identity_ElementI_def Identity_ElementsI_def Premise_def
            Orelse_shortcut_def Ant_Seq_def
  using transformation_trans by fastforce

lemma [φreason no explorative backtrack %identity_element_φ]:
  Identity_ElementsE T D
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 D x
 Identity_ElementE (x  T)
  unfolding Identity_ElementE_def Identity_ElementsE_def Premise_def
  using transformation_trans by fastforce

lemma [φreason %identity_element_cut]:
  Identity_ElementI A P1
 Identity_ElementI B P2
 Identity_ElementI (A + B) (P1  P2)
  unfolding Identity_ElementI_def Transformation_def
  by simp

lemma (*The above rule is local complete*)
  Identity_ElementI (A + B) P  Identity_ElementI A P  Identity_ElementI B P
  unfolding Identity_ElementI_def Transformation_def
  by clarsimp

lemma [φreason %identity_element_cut]:
  Identity_ElementE A  Identity_ElementE B
 Identity_ElementE (A + B)
  unfolding Identity_ElementE_def Transformation_def
  by clarsimp

lemma (*The above rule is not local complete*)
  Identity_ElementE (A + B)  Identity_ElementE A  Identity_ElementE B
  oops

lemma [φreason %identity_element_cut]:
  Identity_ElementI (A x) P
 Identity_ElementI (AllSet A) P
  unfolding Identity_ElementI_def
  by (metis AllSet_expn Transformation_def)
(*The rule is not local complete*)

lemma [φreason %identity_element_cut]:
  (x. Identity_ElementE (A x))
 Identity_ElementE (AllSet A)
  unfolding Identity_ElementE_def
  by (metis AllSet_expn Transformation_def)

lemma (*The above rule is local complete*)
  Identity_ElementE (AllSet A)  Identity_ElementE (A x)
  unfolding Identity_ElementE_def Transformation_def
  by clarsimp

lemma [φreason %identity_element_cut]:
  (x. Identity_ElementI (A x) (P x))
 Identity_ElementI (ExBI A) (Ex P)
  unfolding Identity_ElementI_def
  by (metis ExBI_expn Transformation_def)

lemma (*The above rule is local complete*)
  Identity_ElementI (ExBI A) P  Identity_ElementI (A x) P
  unfolding Identity_ElementI_def Transformation_def
  by (clarsimp; blast)

lemma [φreason %identity_element_cut]:
  Identity_ElementE (A x)
 Identity_ElementE (ExBI A)
  unfolding Identity_ElementE_def Transformation_def
  by (clarsimp; blast)

lemma (*The above rule is not local complete*)
  Identity_ElementE (ExBI A)  x. Identity_ElementE (A x)
  unfolding Identity_ElementE_def Transformation_def ExBI_expn
  by clarsimp

lemma [φreason %identity_element_cut]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P  Identity_ElementI A Q)
 Identity_ElementI (A 𝗌𝗎𝖻𝗃 P) (P  Q)
  unfolding Identity_ElementI_def Transformation_def
  by (simp; blast)

lemma
  Identity_ElementI (A 𝗌𝗎𝖻𝗃 P) (P  Q)  (P  Identity_ElementI A Q)
  unfolding Identity_ElementI_def Transformation_def Satisfiable_def
  by (cases P; clarsimp)

lemma [φreason %identity_element_cut]:
  Identity_ElementE A
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
 Identity_ElementE (A 𝗌𝗎𝖻𝗃 P)
  unfolding Identity_ElementE_def Transformation_def Premise_def
  by (clarsimp; blast)

lemma (*The above rule is local complete*)
  Identity_ElementE (A 𝗌𝗎𝖻𝗃 P)  P  Identity_ElementE A
  unfolding Identity_ElementE_def Transformation_def Premise_def
  by (clarsimp; blast)

lemma [φreason %identity_element_cut]: 
  Identity_ElementI A P
 Identity_ElementI B Q
 Identity_ElementI (A * B) (P  Q)
  for A :: 'a::sep_magma_1 BI
  unfolding Identity_ElementI_def Transformation_def
  by (clarsimp simp add: set_mult_expn, insert mult_1_class.mult_1_left; blast)
  (* It is not complete, example: algebra {e,a} where the sep conjunction is only defined
     on the unit, x ## y ⟷ x = e ∧ y = e.
     Let A = B = {e,a}, we have A * B = {e}. Both A B are not stateless but A * B is. *)

lemma [φreason %identity_element_cut]: 
  Identity_ElementE A
 Identity_ElementE B
 Identity_ElementE (A * B)
  for A :: 'a::sep_magma_1 BI
  unfolding Identity_ElementE_def Transformation_def
  by (clarsimp, insert mult_1_class.mult_1_left sep_magma_1_left, blast)

lemma (*the above rule is not local complete*)
  Identity_ElementE (A * B)  Identity_ElementE A  Identity_ElementE B
  for A :: 'a::sep_magma_1 BI
  oops

lemma [φreason %identity_element_cut]:
  Identity_ElementsI T DT P
 Identity_ElementsI U DU Q
 Identity_ElementsI (T  U) (λ(x,y). DT x  DU y) (λ(x,y). P x  Q y)
  for T :: ('a::sep_magma_1, 'b) φ
  unfolding Identity_ElementI_def Identity_ElementsI_def φProd_expn' Transformation_def
  by (simp add: set_mult_expn, insert mult_1_class.mult_1_left, blast)

lemma [φreason %identity_element_cut]: 
  Identity_ElementsE T DT
 Identity_ElementsE U DU
 Identity_ElementsE (T  U) (λ(x,y). DT x  DU y)
  for T :: 'a  'b::sep_magma_1 BI
  unfolding Identity_ElementE_def Identity_ElementsE_def Transformation_def
  by (clarsimp simp add: φProd_expn', insert set_mult_expn, fastforce)


lemma [φreason %identity_element_cut]: 
  Identity_ElementE A
 Identity_ElementE B
 Identity_ElementE (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 B)
  for A :: 'a::sep_magma_1 BI
  unfolding Identity_ElementE_def Transformation_def REMAINS_def
  by (clarsimp, insert mult_1_class.mult_1_left sep_magma_1_left, blast)

lemma [φreason %identity_element_cut]:
  Identity_ElementI A P
 Identity_ElementI B Q
 Identity_ElementI (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 B) (P  Q)
  for A :: 'a::sep_magma_1 BI
  unfolding Identity_ElementI_def Transformation_def Premise_def REMAINS_def
  by (clarsimp, insert mult_1_class.mult_1_right, blast)


lemma [φreason %identity_element_cut]: 
  Identity_ElementE A
 Identity_ElementE B
 Identity_ElementE (A  B)
  unfolding Identity_ElementE_def Transformation_def
  by (clarsimp)

lemma (*the above rule is local complete*)
  Identity_ElementE (A  B)  Identity_ElementE A  Identity_ElementE B
  unfolding Identity_ElementE_def Transformation_def
  by (clarsimp)

lemma [φreason %identity_element_cut]:
  Identity_ElementI A P  Identity_ElementI B Q
 Identity_ElementI (A  B) (P  Q)
  unfolding Identity_ElementI_def Transformation_def
  by (clarsimp, blast)

lemma (*the above rule is not local complete*)
  Identity_ElementI (A  B) True  Identity_ElementI A True  Identity_ElementI B True
  oops
  (* Auto Quickcheck found a counterexample:
  A = {a3}
  B = {a1} *)

lemma [φreason %identity_element_cut]:
  (iI. Identity_ElementI (A i) (P i))
 Identity_ElementI (iI. A i) (iI. P i)
  unfolding Identity_ElementI_def Mul_Quant_def Transformation_def meta_Ball_def Premise_def
proof clarsimp
  fix v
  assume prems: (i. i  I  v. v  A i  v = 1  P i)
                v  prod A I
     and finite I
  show v = 1  (xI. P x)
    by (insert prems; induct rule: finite_induct[OF finite I]; clarsimp; fastforce)
qed

lemma [φreason %identity_element_cut]:
  (iS. Identity_ElementE (A i))
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 finite S
 Identity_ElementE (iS. A i)
  unfolding Identity_ElementE_def Mul_Quant_def Transformation_def Premise_def meta_Ball_def
proof clarsimp
  fix v
  assume prems: (i. i  S  1  A i)
     and finite S
  show 1  prod A S
    by (insert prems;
        induct rule: finite_induct[OF finite S];
        clarsimp;
        (insert mult_1_class.mult_1_left sep_magma_1_right, blast))
qed


subsection ‹Equivalence of Objects›

definition Object_Equiv :: ('c,'a) φ  ('a  'a  bool)  bool
  where Object_Equiv T eq  (x. eq x x)  (x y. eq x y  (x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T))

text ‹φ-Deriver usually derives the object reachability relation of φ-type operators generally
  for any variable type operand, but the reachability can be wider on specific type operands, such
  as the reachability λx y. True› of List(○)› versus the version λx y. length x = length y› instantiated
  from the general rule Object_Equiv T eq ⟹ Object_Equiv (List T) (list_rel eq)› by substituting
  T› for ○› and eq› for (=)›.

  These special `singular` cases are hard to be handled by φ-type algebra who provides a general automation,
  thus demanding user rules for override. Even so, common singular cases can still be handled by ad-hoc
  optimization in the algorithm.

  Generally, when an instantiation of a type operand yields a trivial type relating empty concrete objects,
  a singular case can occur. Therefore, when we infer the reachability of a given type, we can first
  check if it is such a trivial type and if so we derive the wider relation by rule (see 𝒜_singular_unit›).
  In this way, the overall reasoning can still be powerful even when such common singular cases are not considered.


(paper)
›

declare [[
  φreason_default_pattern Object_Equiv ?T _  Object_Equiv ?T _ (100),
  φpremise_attribute once? [φreason? %local] for Object_Equiv _ _       (%φattr)
]]

φreasoner_group object_equiv = (100, [1, 3999]) for Object_Equiv T eq
    ‹Reasoning rules giving the equivalence relation (though is actually a reachability
     relation) of objects of the given φ-type.›
 and object_equiv_cut = (%cutting, [%cutting, %cutting+10]) for Object_Equiv T eq in object_equiv
    ‹Cutting rules for reasonig Object_Equiv›
 and derived_object_equiv = (50, [50,50]) for Object_Equiv T eq in object_equiv and < object_equiv_cut
    ‹Automatically derived rules for Object_Equiv›
 and object_equiv_fallback = (1, [1,1]) for Object_Equiv T eq in object_equiv and < derived_object_equiv
    ‹Fallback rules for reasonig Object_Equiv›

subsubsection ‹Variants›

consts 𝒜_singular_unit :: action

declare [[
  φreason_default_pattern Object_Equiv ?T _ @tag 𝒜_singular_unit 
                          Object_Equiv ?T _ @tag 𝒜_singular_unit (100)
]]

lemma [φreason %object_equiv_cut+1]:
  Identity_ElementsI T DI P
 Identity_ElementsE T DE
 Object_Equiv T eq
 Object_Equiv T (λx y. eq x y  DI x  (P x  DE y)) @tag 𝒜_singular_unit
  unfolding Object_Equiv_def Identity_ElementsE_def Identity_ElementsI_def Action_Tag_def
            Transformation_def Identity_ElementI_def Identity_ElementE_def
  by clarsimp blast

lemma [φreason %object_equiv_cut]: ― ‹for non-unital algebras›
  Object_Equiv T eq
 Object_Equiv T eq @tag 𝒜_singular_unit
  unfolding Action_Tag_def
  by clarsimp



subsubsection ‹Extracting Pure Facts›

lemma [φreason %extract_pure]:
  (x y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq x y  𝗋EIF (x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T) (P x y) )
 𝗋EIF (Object_Equiv T eq) ((x. eq x x)  (x y. eq x y  P x y))
  unfolding 𝗋EIF_def Object_Equiv_def Premise_def Transformation_def
  by clarsimp

lemma [φreason %extract_pure]:
  (x y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq x y  𝗋ESC (P x y) (x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T))
 𝗋ESC ((x. eq x x)  (x y. eq x y  P x y)) (Object_Equiv T eq)
  unfolding 𝗋ESC_def Object_Equiv_def Premise_def Transformation_def
  by clarsimp


subsubsection ‹Reasoning Rules›

lemma Object_Equiv_fallback[φreason default %object_equiv_fallback]:
  Object_Equiv T (=)
  unfolding Object_Equiv_def by simp

lemma [φreason %object_equiv_cut]:
  Object_Equiv  (λ_ _. True)
  unfolding Object_Equiv_def Transformation_def
  by simp

lemma [φreason %object_equiv_cut]:
  Object_Equiv T eq
 Object_Equiv ( T) eq
  unfolding Object_Equiv_def Transformation_def
  by auto

lemma [φreason %object_equiv_cut]:
  (a. Object_Equiv (λx. S x a) (R a))
 Object_Equiv (λx. ExBI (S x)) (λx y. a. R a x y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp; blast)

lemma [φreason %object_equiv_cut]:
  Object_Equiv S R
 Object_Equiv (λx. S x 𝗌𝗎𝖻𝗃 P x) (λx y. P x  R x y  P y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

lemma [φreason %object_equiv_cut]:
  Object_Equiv S1 R1
 Object_Equiv S2 R2
 Object_Equiv (λx. S1 x  S2 x) (λx y. R1 x y  R2 x y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

lemma [φreason %object_equiv_cut]:
  Object_Equiv S1 R1
 Object_Equiv S2 R2
 Object_Equiv (λx. S1 x + S2 x) (λx y. R1 x y  R2 x y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

lemma [φreason %object_equiv_cut]:
  (a. Object_Equiv (λx. S x a) (R a))
 Object_Equiv (λx. AllSet (S x)) (λx y. a. R a x y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp simp add: AllSet_expn; blast)

lemma [φreason %object_equiv_cut]:
  Object_Equiv S1 R1
 Object_Equiv S2 R2
 Object_Equiv (λx. S1 x * S2 x) (λ x y. R1 x y  R2 x y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp simp add: set_mult_expn; blast)

(* ― ‹derived automatically later›
lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv Ta Eqa
⟹ Object_Equiv Tb Eqb
⟹ Object_Equiv (Ta ∗ Tb) (λ(xa, xb) (ya, yb). Eqa xa ya ∧ Eqb xb yb) ›
  unfolding Object_Equiv_def Transformation_def
  by (clarsimp simp add: set_mult_expn; blast)
*)

lemma
  Object_Equiv S1 R1
 Object_Equiv S2 R2
 Object_Equiv (λx. BI {p. p  S1 x  p  S2 x}) (λx y. R1 y x  R2 x y)
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

lemma [φreason %object_equiv_cut]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C  Object_Equiv A Ea)
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  Object_Equiv B Eb)
 Object_Equiv (if C then A else B) (if C then Ea else Eb)
  unfolding Premise_def
  by (cases C; simp)

lemma Object_Equiv_Mul_Quant[φreason %object_equiv_cut]:
  (i x. eq i x x)
 (iS. Object_Equiv (λx. A x i) (eq i))
 Object_Equiv (λx. iS. A x i) (λx y. i. eq i x y)
  unfolding Object_Equiv_def Transformation_def φType_def
            meta_Ball_def Premise_def Mul_Quant_def
  proof (clarsimp)
    fix x y v
    assume prems: (x. x  S  xa y. eq x xa y  (v. v  A xa x  v  A y x))
                  i. eq i x y
                  v  prod (A x) S
       and finite S
    show v  prod (A y) S
      by (insert prems;
          induct arbitrary: x y v rule: finite_induct[OF finite S];
          clarsimp simp add: set_mult_expn;
          metis)
  qed


subsection ‹Equivalent Class›

definition Equiv_Class T r  (v x y. v  T x  v  T y  r x y )

lemma Equiv_Class_alt_def:
  Equiv_Class T r  (v x y. v  (x  T)  v  (y  T)  r x y)
  unfolding φType_def Equiv_Class_def
  by simp

definition Injective_on T D  Equiv_Class T (λx y. x  D  y  D  x = y)


subsubsection ‹Properties›

definition concretize :: ('c,'x) φ  'x  'c
  where concretize T = (λx. @c. c  (x  T))

lemma concretize_SAT:
  Satisfiable (x  T)
 concretize T x  (x  T)
  unfolding concretize_def Satisfiable_def
  by (meson someI_ex)
  
lemma concretize_inj:
  Injective_on T D
 Abstract_DomainL T (λx. x  D)
 inj_on (concretize T) D
  unfolding inj_on_def Equiv_Class_def concretize_def Abstract_DomainL_def 𝗋ESC_def Satisfiable_def
            φType_def Injective_on_def
  by (auto, metis someI)



subsubsection ‹Reasoning Configures›

φreasoner_group Equiv_Class_all = (100, [10,3000]) ‹›
  and Equiv_Class = (1000, [1000,1030]) in Equiv_Class_all ‹›
  and Equiv_Class_default = (25, [10,50]) in Equiv_Class_all and < Equiv_Class ‹›
  and Equiv_Class_derived = (75, [70, 80]) in Equiv_Class_all and < Equiv_Class and > Equiv_Class_default ‹›

declare [[
  φreason_default_pattern Equiv_Class ?T ?var  Equiv_Class ?T _ (100)
                      and Equiv_Class ?T _  Equiv_Class ?T ?var (80),
  φdefault_reasoner_group Equiv_Class _ _ : %Equiv_Class (100)
]]


subsubsection ‹Reasoning Rules›

lemma [φreason %Equiv_Class]:
  Equiv_Class T (λx y. x  D  y  D  x = y)
 Injective_on T D
  unfolding Injective_on_def
  by simp

lemma [φreason add]:
  Equiv_Class (λx. A (fst x) (snd x)) (λ(x1,_) (x2,_). r x1 x2)
 Equiv_Class (λx. ExBI (A x)) r
  unfolding Equiv_Class_def
  by auto blast

lemma (*the above rule is the strongest*)
  Equiv_Class (λx. ExBI (A x)) r
 Equiv_Class (λx. A (fst x) (snd x)) (λ(x1,_) (x2,_). r x1 x2)
  unfolding Equiv_Class_def
  by auto

lemma [φreason add]:
  Equiv_Class A (λx y. P x  P y  r x y)
 Equiv_Class (λx. A x 𝗌𝗎𝖻𝗃 P x) r
  unfolding Equiv_Class_def
  by auto

lemma (*the above rule is the strongest*)
  Equiv_Class (λx. A x 𝗌𝗎𝖻𝗃 P x) r
 Equiv_Class A (λx y. P x  P y  r x y)
  unfolding Equiv_Class_def
  by auto

lemma [φreason add]:
  𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (x. r x x)
 Equiv_Class Itself r
  unfolding Equiv_Class_def Premise_def
  by simp

lemma [φreason %Equiv_Class_default except Equiv_Class _ ?var ]:
  Equiv_Class T r
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (x y. r x y  r' x y)
 Equiv_Class T r'
  unfolding Premise_def Equiv_Class_def
  by auto

lemma [φreason add]:
  Equiv_Class T (λx y. x' y'. x = f x'  y = f y'  r x' y')
 Equiv_Class (λx. f x  T) r
  unfolding Equiv_Class_def φType_def
  by auto

lemma (*the above rule is the strongest*)
  Equiv_Class (λx. f x  T) r
 Equiv_Class T (λx y. x' y'. x = f x'  y = f y'  r x' y')
  unfolding Equiv_Class_def φType_def
  by auto

lemma [φreason add]:
  A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (P  (a b. r a b))
 Equiv_Class (λx. A) r
  unfolding Equiv_Class_def Premise_def 𝗋EIF_def Satisfiable_def
  by simp blast

lemma (*the above rule is the strongest*)
  Equiv_Class (λx. A) r
 Satisfiable A
 a b. r a b
  unfolding Equiv_Class_def Satisfiable_def
  by auto




section ‹Reasoning›

ML_file ‹library/syntax/Phi_Syntax0.ML›

subsection ‹Preliminary›

subsubsection ‹Mapping φ-Type Items by Transformation›

consts 𝒜_map_each_item :: action  action

declare [[φreason_default_pattern
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item _ 
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item _    (100)
  and ?X @tag 𝒜_map_each_item ?𝒜 
      ERROR TEXT(‹Bad Rule: › (?X @tag 𝒜_map_each_item ?𝒜))    (0)
]]

φreasoner_group 𝒜_map_each_item = (1050, [1010, 3000]) for (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item 𝒜)
      ‹Reasoning rules applying action ‹𝒜› onto each atomic items in ‹X››
  and 𝒜_map_each_item_fallback = (1000, [1000, 1000]) for (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item 𝒜)
      ‹Fallback rules ending 𝒜_map_each_item›

paragraph ‹Implementation›

lemma [φreason %𝒜_map_each_item]:
  1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 @tag 𝒜_map_each_item A
  unfolding Action_Tag_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 @tag 𝒜_map_each_item A
  unfolding Action_Tag_def
  by simp

lemma [φreason %𝒜_map_each_item]:
   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  @tag 𝒜_map_each_item A
  unfolding Action_Tag_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A)
 X 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A
  unfolding Action_Tag_def Premise_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜
 B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜
 A  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X  Y 𝗐𝗂𝗍𝗁 P  Q @tag 𝒜_map_each_item 𝒜
  unfolding Action_Tag_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜
 B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜
 A + B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + Y 𝗐𝗂𝗍𝗁 P  Q @tag 𝒜_map_each_item 𝒜
  unfolding Action_Tag_def Transformation_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  (c. X c 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y c 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A)
 ExBI X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExBI Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A
  unfolding Action_Tag_def
  using ExBI_transformation .

lemma [φreason %𝒜_map_each_item]:
  (c. X c 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y c 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A)
 AllSet X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 AllSet Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A
  unfolding Action_Tag_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜
 B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜
 A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗐𝗂𝗍𝗁 P  Q @tag 𝒜_map_each_item 𝒜
  unfolding Action_Tag_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item A
 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P  Q @tag 𝒜_map_each_item A
  unfolding REMAINS_def
  by (simp add: Action_Tag_def transformation_bi_frame;
      metis transformation_bi_frame transformation_weaken)

lemma [φreason %𝒜_map_each_item]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A' 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜)
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B' 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜)
 If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C A' B' 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒜_map_each_item 𝒜
  unfolding Action_Tag_def Premise_def
  by (cases C; simp)

lemma [φreason %𝒜_map_each_item]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A' a 𝗐𝗂𝗍𝗁 P a @tag 𝒜_map_each_item 𝒜)
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B' b 𝗐𝗂𝗍𝗁 Q b @tag 𝒜_map_each_item 𝒜)
 (case_sum A B x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (case_sum A' B' x) 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒜_map_each_item 𝒜
  unfolding Action_Tag_def Premise_def
  by (cases x; simp)

lemma [φreason %𝒜_map_each_item]:
  (iI. A i 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B i 𝗐𝗂𝗍𝗁 P i @tag 𝒜_map_each_item 𝒜)
 (iI. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (iI. B i) 𝗐𝗂𝗍𝗁 (i  I. P i) @tag 𝒜_map_each_item 𝒜
  unfolding Action_Tag_def Premise_def
  by (clarsimp simp add: sep_quant_transformation)

lemma [φreason %𝒜_map_each_item_fallback]: ― ‹fallback›
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag A
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A
  unfolding Action_Tag_def .


subsection ‹Cleaning›

subsubsection ‹Success›

lemma [φreason %ToA_clean for _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _   @clean
                              _   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _ @clean ]:
  a   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b   @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_clean+10 for _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean ]:
  a   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_clean+10 for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _ @clean ]:
  1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 a   @clean
  unfolding Action_Tag_def
  by simp


subsubsection ‹Fallbacks›

lemma [φreason default %ToA_clean_fallback for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @clean
  unfolding Action_Tag_def
  by simp

lemma [φreason default %ToA_clean_fallback-5 for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_)  _ @clean]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst y, snd y)  T @clean
  by simp

lemma [φreason default %ToA_clean_fallback-5 for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _ @clean]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst y, fst (snd y), snd (snd y))  T @clean
  by simp

lemma [φreason default %ToA_clean_fallback-10 for _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _ 𝗐𝗂𝗍𝗁 _ @clean]:
  𝗉𝗋𝖾𝗆𝗂𝗌𝖾 x = y
 x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T @clean
  unfolding Action_Tag_def Premise_def
  by simp


subsubsection ‹Empty Assertion›

lemma [φreason %ToA_clean]:
  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
 1 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
  for R :: 'c::sep_magma_1 BI
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_clean]:
  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
 R * 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_clean+30]:
  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
 (r  ) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
  for R :: 'c::sep_magma_1 BI
  unfolding Action_Tag_def
  by simp

lemma [φreason add]:
  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
 R * (x  ) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
  for R :: 'c::sep_magma_1 BI
  by simp


subsubsection ‹Empty Type›

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y)    U @clean
  for W :: 'c::sep_magma_1 BI
  by (simp add: φProd_expn')

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y)  T   @clean
  for W :: 'c::sep_magma_1 BI
  by (simp add: φProd_expn')

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y)  T  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y,z)  T  U   @clean
  for W :: 'c::sep_magma_1 BI
  by (simp add: φProd_expn')

lemma [φreason add]:
  y  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 (x,y)    U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  by (simp add: φProd_expn')

lemma [φreason add]:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 (x,y)  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  by (simp add: φProd_expn')

lemma [φreason add]:
  (x,y)  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 (x,y,z)  T  U   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  by (simp add: φProd_expn')

lemma [φreason add]:
  snd x  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 x    U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  by (cases x; simp add: φProd_expn')

lemma [φreason add]:
  fst x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 x  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  by (cases x; simp add: φProd_expn')

lemma [φreason add]:
  apsnd fst x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 x  T  U   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  for R :: 'c::sep_magma_1 BI
  by (cases x; simp add: φProd_expn')





subsubsection ‹Conditioned Empty›

declare [[
  φreason_default_pattern
      _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_)  ◒[?C] _  _ @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_)  ◒[?C] _  _ @clean (100)
  and _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _  ◒[?C] _  _ @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _  ◒[?C] _  _ @clean (100)
  and _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_)  _  ◒[?C] _ @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_)  _  ◒[?C] _ @clean (100)
  and _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _  _  ◒[?C] _ @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _  _  ◒[?C] _ @clean (100)
  and _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _  ◒[?C] _  _ @clean  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_,_)  _  ◒[?C] _  _ @clean (100)
  and (_,_)  ◒[?C] _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean  (_,_)  ◒[?C] _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean (100)
  and (_,_,_)  _  ◒[?C] _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean  (_,_,_)  _  ◒[?C] _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean (100)
  and (_,_)  _  ◒[?C] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean  (_,_)  _  ◒[?C] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean (100)
  and (_,_,_)  _  _  ◒[?C] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean  (_,_,_)  _  _  ◒[?C] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean (100)
  and (_,_,_)  _  ◒[?C] _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean  (_,_,_)  _  ◒[?C] _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @clean (100),
  φdefault_reasoner_group (_,_)  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @clean : %ToA_clean+10 (30)
]]



lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x   @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  ◒[False] T @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  ◒[True] T @clean
  by simp_all

lemma [φreason add]:
  x   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 x  ◒[False] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
 x  ◒[True] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R @clean
  by simp_all

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 xy  T  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 xy  ◒[True] T  U @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x, y)  ◒[False] T  U @clean
  by (simp add: φProd_expn')+

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x3  T  U  S @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x3  T  ◒[True] U  S @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 xz  T  S @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apsnd (Pair unspec) xz  T  ◒[False] U  S @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,z)  T  S @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y,z)  T  ◒[False] U  S @clean
  by (simp add: φProd_expn', cases xz, simp_all add: φProd_expn')

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x3  T  U  S @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x3  T  U  ◒[True] S @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 xy  T  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apsnd (λy. (y, unspec)) xy  T  U  ◒[False] S @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y)  T  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y,unspec)  T  U  ◒[False] S @clean
  by (simp add: φProd_expn', cases xy, simp_all add: φProd_expn')

lemma [φreason add]:
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 xy  T  U @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 xy  T  ◒[True] U @clean
  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T @clean
 W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x, y)  T  ◒[False] U @clean
  by (simp add: φProd_expn')+

lemma [φreason add]:
  x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  ◒[True] T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  snd x  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  ◒[False] T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  b  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 (a,b)  ◒[False] T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  by (cases x; simp add: φProd_expn')+

lemma [φreason add]:
  x  T  U  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  T  ◒[True] U  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  apsnd snd x  T  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  T  ◒[False] U  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  (a,c)  T  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 (a,b,c)  T  ◒[False] U  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  by (cases x; simp add: φProd_expn')+

lemma [φreason add]:
  x  T  U  S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  T  U  ◒[True] S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  apsnd fst x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  T  U  ◒[False] S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  (a,b)  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 (a,b,c)  T  U  ◒[False] S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  by (cases x; simp add: φProd_expn')+

lemma [φreason add]:
  x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  T  ◒[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  fst x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 x  T  ◒[False] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  a  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
 (a,b)  T  ◒[False] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 W @clean
  by (cases x; simp add: φProd_expn')+


subsubsection Ψ[Some]›

lemma [φreason %ToA_clean_fallback for Ψ[Some] _ * Ψ[Some] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ψ[Some] _ 𝗐𝗂𝗍𝗁 _ @clean]:
  Ψ[Some] X * Ψ[Some] Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ψ[Some] (X * Y) @clean
  unfolding Action_Tag_def
  using Transformation_def by fastforce


subsection ‹Associative Multiplication›

definition 𝗋Assoc_Mul A B C  ((A * B) * C = A * (B * C))

paragraph ‹Basic Settings›

φreasoner_group 𝗋Assoc_Mul_all = (100, [10,3000]) for 𝗋Assoc_Mul A B C ‹›
  and 𝗋Assoc_Mul = (1000, [1000,1030]) in 𝗋Assoc_Mul_all ‹›
  and 𝗋Assoc_Mul_default = (20, [10, 50]) in 𝗋Assoc_Mul_all and < 𝗋Assoc_Mul ‹›

declare [[
  φdefault_reasoner_group 𝗋Assoc_Mul _ _ _ : %𝗋Assoc_Mul (100)
]]

setup Sign.mandatory_path "𝗋Assoc_Mul"

lemma "apply":
  𝗋Assoc_Mul A B C
 A * B * C 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A * (B * C)
  unfolding 𝗋Assoc_Mul_def by simp

lemma "rev_apply":
  𝗋Assoc_Mul A B C
 A * (B * C) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A * B * C
  unfolding 𝗋Assoc_Mul_def by simp

setup Sign.parent_path

paragraph ‹Reasoning Rules›

lemma [φreason add]:
  𝗋Assoc_Mul A B C
  for A :: 'a::semigroup_mult
  unfolding 𝗋Assoc_Mul_def
  by (simp add: mult.assoc)

lemma [φreason add]:
  𝗋Assoc_Mul 1 B C
  𝗋Assoc_Mul A 1 C
  𝗋Assoc_Mul A B 1
  for A :: 'a::mult_1
  unfolding 𝗋Assoc_Mul_def
  by simp+

lemma [φreason add]:
  𝗋Assoc_Mul (x  ) B C
  𝗋Assoc_Mul A (x  ) C
  𝗋Assoc_Mul A B (x  )
  for A :: 'a::sep_magma_1 BI
  unfolding 𝗋Assoc_Mul_def
  by simp+

lemma [φreason add]:
  𝗋Assoc_Mul (x  ◒[False] T) B C
  𝗋Assoc_Mul A (x  ◒[False] T) C
  𝗋Assoc_Mul A B (x  ◒[False] T)
  for A :: 'a::sep_magma_1 BI
  unfolding 𝗋Assoc_Mul_def
  by simp+

lemma [φreason add]:
  𝗋Assoc_Mul (x  T) B C
 𝗋Assoc_Mul (x  ◒[True] T) B C
  𝗋Assoc_Mul A (x  T) C
 𝗋Assoc_Mul A (x  ◒[True] T) C
  𝗋Assoc_Mul A B (x  T)
 𝗋Assoc_Mul A B (x  ◒[True] T)
  for A :: 'a::sep_magma_1 BI
  unfolding 𝗋Assoc_Mul_def
  by simp+



subsection ‹Commutative Muiltiplication›

definition 𝗋Comm_Mul A B  (A * B = B * A)

paragraph ‹Basic Settings›

φreasoner_group 𝗋Comm_Mul_all = (100, [10,3000]) for 𝗋Comm_Mul A B ‹›
  and 𝗋Comm_Mul = (1000, [1000,1030]) in 𝗋Comm_Mul_all ‹›
  and 𝗋Comm_Mul_default = (20, [10, 50]) in 𝗋Comm_Mul_all and < 𝗋Comm_Mul ‹›

declare [[
  φdefault_reasoner_group 𝗋Comm_Mul _ _ : %𝗋Comm_Mul (100)
]]

setup Sign.mandatory_path "𝗋Comm_Mul"

lemma "apply":
  𝗋Comm_Mul A B
 A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B * A
  unfolding 𝗋Comm_Mul_def by simp

lemma "rev_apply":
  𝗋Comm_Mul B A
 A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B * A
  unfolding 𝗋Comm_Mul_def by simp

setup Sign.parent_path

paragraph ‹Reasoning Rules›

lemma [φreason add]:
  𝗋Comm_Mul A B
  for A :: 'a::ab_semigroup_mult
  unfolding 𝗋Comm_Mul_def
  by (simp add: mult.commute)

lemma [φreason add]:
  𝗋Comm_Mul 1 A
  𝗋Comm_Mul A 1
  for A :: 'a::mult_1
  unfolding 𝗋Comm_Mul_def
  by simp+

lemma [φreason add]:
  𝗋Comm_Mul (x  ) A
  𝗋Comm_Mul A (x  )
  for A :: 'a::sep_magma_1 BI
  unfolding 𝗋Comm_Mul_def
  by simp+

lemma [φreason add]:
  𝗋Comm_Mul (x  ◒[False] T) A
  𝗋Comm_Mul A (x  ◒[False] T)
  for A :: 'a::sep_magma_1 BI
  unfolding 𝗋Comm_Mul_def
  by simp+

lemma [φreason add]:
  𝗋Comm_Mul (x  T) A
 𝗋Comm_Mul (x  ◒[True] T) A
  𝗋Comm_Mul A (x  T)
 𝗋Comm_Mul A (x  ◒[True] T)
  for A :: 'a::sep_magma_1 BI
  unfolding 𝗋Comm_Mul_def
  by simp+



subsubsection ‹Separation Extraction of φ›Prod›

text ‹Using the technical auxiliaries, we can give the separation extraction for φProd›
 
lemma [φreason %ToA_cut]:
  (fst x, fst ww)  A  WY 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b  Y  B 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
 (snd b, snd ww)  B  WX 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 c  X  R 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫'
 𝗋Assoc_Mul (fst x  A) (fst ww  WY) (snd ww  WX)
 𝗋Assoc_Mul (fst b  Y) (snd b  B) (snd ww  WX)
 𝗋Assoc_Mul (fst b  Y) (fst c  X) (snd c  R)
 snd x  WW 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ww  WY  WX @clean
 x  A  WW 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((fst b, fst c), snd c)  (Y  X)  R 𝗐𝗂𝗍𝗁 (P1  P2) @tag 𝒯𝒫'
  for A :: ('a::sep_magma_1,'b) φ
  unfolding Action_Tag_def Try_def φProd'_def 𝗋Assoc_Mul_def
  apply (clarsimp simp add: φProd_expn'' φProd_expn')
  subgoal premises prems
    by (insert prems(1)[THEN transformation_right_frame, where R=snd ww  WX]
               prems(2)[THEN transformation_left_frame, where R=fst b  Y]
               prems(3)[symmetric]
               prems(4)[symmetric]
               prems(5)[symmetric]
               prems(6)[THEN transformation_left_frame, where R=fst x  A],
           cases b, simp,
           insert mk_elim_transformation transformation_trans, blast) .

lemma [φreason %ToA_cut+1]:
  (fst x, fst ww)  A  WY 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b  Y  B 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
 (snd b, snd ww)  B  WX 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 c  X  R 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫'
 snd x  WW 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ww  WY  WX @clean
 x  A  WW 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((fst b, fst c), snd c)  (Y  X)  R 𝗐𝗂𝗍𝗁 (P1  P2) @tag 𝒯𝒫'
  for A :: ('a::sep_monoid,'b) φ
  unfolding Action_Tag_def Try_def φProd'_def
  apply (clarsimp simp add: φProd_expn'' φProd_expn')
  subgoal premises prems
    by (insert prems(1)[THEN transformation_right_frame, where R=snd ww  WX]
               prems(2)[THEN transformation_left_frame, where R=fst b  Y]
               prems(3)[THEN transformation_left_frame, where R=fst x  A],
           cases b, simp add: mult.assoc,
           insert mk_elim_transformation transformation_trans, blast) .

lemma [φreason add]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 wx  WX @clean
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (unspec, wx)    WX @clean
  for WX :: ('c::sep_magma_1, 'x) φ
  unfolding Action_Tag_def
  by (clarsimp simp add: φProd_expn'' φProd_expn')

lemma [φreason add]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 wy  WY @clean
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (wy, unspec)  WY   @clean
  for WY :: ('c::sep_magma_1, 'x) φ
  unfolding Action_Tag_def
  by (clarsimp simp add: φProd_expn'' φProd_expn')


lemma [φreason %ToA_cut]:
  (fst (fst x), fst wr)  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr  Y  Rt 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
 apfst snd x  U  W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 wr  W  Ru 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫'
 𝗋Assoc_Mul (fst (fst x)  T) (snd (fst x)  U ) (snd x  W2)
 𝗋Assoc_Mul (fst (fst x)  T) (fst wr  W ) (snd wr  Ru)
 𝗋Assoc_Mul (fst yr  Y) (snd yr  Rt) (snd wr  Ru)
 (snd yr, snd wr)  Rt  Ru 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 rr  RR @clean
 x  (T  U)  W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst yr, rr)  Y  RR 𝗐𝗂𝗍𝗁 P1  P2 @tag 𝒯𝒫'
  for T :: ('a::sep_magma_1,'b) φ
  unfolding Action_Tag_def Try_def φProd'_def 𝗋Assoc_Mul_def
  apply (simp add: φProd_expn'' φProd_expn' φSome_φProd[symmetric])
  subgoal premises prems
    by (insert prems(1)[THEN transformation_right_frame, where R=snd wr  Ru]
               prems(2)[THEN transformation_left_frame, where R=fst (fst x)  T]
               prems(3)[symmetric]
               prems(4)[symmetric]
               prems(5)[symmetric]
               prems(6)[THEN transformation_left_frame, where R=(fst yr  Y)],
        simp,
        smt (z3) mk_elim_transformation mk_intro_transformation transformation_weaken) .

lemma [φreason %ToA_cut+1]:
  (fst (fst x), fst wr)  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr  Y  Rt 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
 apfst snd x  U  W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 wr  W  Ru 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫'
 (snd yr, snd wr)  Rt  Ru 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 rr  RR @clean
 x  (T  U)  W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst yr, rr)  Y  RR 𝗐𝗂𝗍𝗁 P1  P2 @tag 𝒯𝒫'
  for T :: ('a::sep_monoid,'b) φ
  unfolding Action_Tag_def Try_def φProd'_def
  apply (simp add: φProd_expn'' φProd_expn' φSome_φProd[symmetric])
  subgoal premises prems
    by (insert prems(1)[THEN transformation_right_frame, where R=snd wr  Ru]
               prems(2)[THEN transformation_left_frame, where R=fst (fst x)  T]
               prems(3)[THEN transformation_left_frame, where R=(fst yr  Y)],
        simp add: mult.assoc[symmetric],
        smt (z3) transformation_trans transformation_weaken) .

lemma [φreason add]:
  snd x  Rb 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
 x    Rb 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
  for Rb :: ('c::sep_magma_1, 'b) φ
  unfolding Action_Tag_def
  by (clarsimp simp add: φProd_expn'' φProd_expn')

lemma [φreason add]:
  fst x  Ra 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
 x  Ra   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @clean
  for Ra :: ('c::sep_magma_1, 'b) φ
  unfolding Action_Tag_def
  by (clarsimp simp add: φProd_expn'' φProd_expn')



subsection ‹Normalization of Assertions›

subsubsection ‹Declaring Simpsets›

consts assertion_simps :: mode  mode
       SOURCE :: mode
       TARGET :: mode

ML structure Assertion_SS = Simpset (
  val initial_ss = Simpset_Configure.Minimal_SS
  val binding = SOME bindingassertion_simps
  val comment = "Simplification rules normalizing an assertion. \
                       \It is applied before NToA process."
  val attribute = NONE
  val post_merging = I
)

val _ = Theory.setup (Context.theory_map (Assertion_SS.map (fn ctxt =>
      (ctxt addsimprocs [simprocNO_MATCH, simprocdefined_Ex, simprocHOL.defined_All,
                         simprocdefined_all, simprocdefined_Collect, simprocSet.defined_All,
                         simprocSet.defined_Bex, simprocunit_eq, simproccase_prod_beta,
                         simproccase_prod_eta, simprocCollect_mem,
                         Phi_Conv.move_Ex_for_set_notation]
            addsimps @{thms' Sum_Type.sum.case HOL.simp_thms})
          (*|> Simplifier.add_cong @{thm' Subjection_cong}*)
    )))

structure Assertion_SS_Source = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = SOME bindingassertion_simps_source
  val comment = "Simp rules normalizing particularly source part of an assertion."
  val attribute = NONE
  val post_merging = I
)

val _ = Theory.setup (Context.theory_map (Assertion_SS_Source.map (fn ctxt =>
      ctxt addsimps @{thms' ExBI_defined}
        |> Simplifier.add_cong @{thm' Subjection_cong}
    )))

structure Assertion_SS_Target = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = SOME bindingassertion_simps_target
  val comment = "Simp rules normalizing particularly target part of an assertion."
  val attribute = NONE
  val post_merging = I
)

lemmas [assertion_simps] =
  (*algebras*)
  mult_zero_right[where 'a='a::sep_magma BI] mult_zero_left[where 'a='a::sep_magma BI]
  mult_1_right[where 'a='a::sep_magma_1 BI]
  mult_1_left[where 'a='a::sep_magma_1 BI]
  add_0_right[where 'a='a::sep_magma BI] add_0_left[where 'a='a::sep_magma BI]
  zero_fun zero_fun_def[symmetric, where 'b='a::sep_magma BI]
  plus_fun[where 'a='a::sep_magma BI]
  distrib_right[where 'a='a::sep_semigroup BI]
  mult.assoc[where 'a='a::sep_semigroup BI]
  bot_eq_BI_bot

  (*BI connectives*)
  Subjection_Subjection Subjection_Zero Subjection_True Subjection_Flase
  Subjection_times Subjection_addconj

  ExBI_simps ExBI_split_prod ExBI_subj_split_prod

  sep_quant_subjection sep_quant_ExBI

  φProd_expn'' φProd_expn'
  HOL.if_True HOL.if_False

  φBot.unfold φAny.unfold φNone_itself_is_one

  (*Usual simps*)
  fst_conv snd_conv

lemmas [assertion_simps_source] =
  ExBI_times_left ExBI_times_right ExBI_adconj ExBI_addisj

  REMAINS_def

  sep_quant_sep

lemmas [assertion_simps_target] =
  sep_quant_sep[symmetric]

lemmas [φprogramming_base_simps, φprogramming_simps, φsafe_simp] =
  add_0_right[where 'a='a::sep_magma BI] add_0_left[where 'a='a::sep_magma BI]
  zero_fun_def[symmetric, where 'b='a::sep_magma BI]
  plus_fun[where 'a='a::sep_magma BI]
  distrib_right[where 'a='a::sep_semigroup BI]
  mult.assoc[where 'a='a::sep_semigroup BI]
  REMAINS_def

lemmas [φprogramming_base_simps] =
  mult_zero_right[where 'a='a::sep_magma BI] mult_zero_left[where 'a='a::sep_magma BI]
  mult_1_right[where 'a='a::sep_magma_1 BI] mult_1_left[where 'a='a::sep_magma_1 BI]
  zero_fun

  HOL.simp_thms

  HOL.if_True HOL.if_False


ML_file ‹library/reasoning/quantifier.ML›

simproc_setup defined_ExBI ( ExBI A ) = K BI_Quantifiers.defined_Ex

setup Context.theory_map (Phi_Programming_Simp_Hook.add 100 (fn () => fn ctxt =>
    ctxt delsimprocs [@{simproc defined_ExBI}]
         delsimps @{thms' ExBI_defined}))

setup Context.theory_map (
  Assertion_SS_Source.map (fn ctxt =>
    ctxt addsimprocs [@{simproc defined_ExBI}] ) #>
  Assertion_SS.map (fn ctxt =>
    ctxt addsimprocs [@{simproc Funcomp_Lambda}]) #>
  Phi_Safe_Simps.map (fn ctxt =>
    ctxt addsimprocs [@{simproc defined_ExBI}, @{simproc Funcomp_Lambda}]))


subsubsection ‹Reasoners›

φreasoner_ML assertion_simp_source 1300
  (Simplify (assertion_simps SOURCE) ?X' ?X)
  = Phi_Reasoners.wrap (PLPR_Simplifier.simplifier_by_ss' (K Seq.empty) (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Source.get' ctxt)) {fix_vars=false}) o snd

φreasoner_ML assertion_simp_target 1300
  (Simplify (assertion_simps TARGET) ?X' ?X)
  = Phi_Reasoners.wrap (PLPR_Simplifier.simplifier_by_ss' (K Seq.empty) (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Target.get' ctxt)) {fix_vars=false}) o snd

φreasoner_ML assertion_simp 1200
  (Premise (assertion_simps _) _ | Simplify (assertion_simps ?ANY) ?X' ?X )
  = Phi_Reasoners.wrap (PLPR_Simplifier.simplifier_by_ss' (K Seq.empty) Assertion_SS.get' {fix_vars=false}) o snd

ML fun conv_transformation_by_assertion_ss ctxt =
  let val src_ctxt = Assertion_SS_Source.enhance (Assertion_SS.equip ctxt)
      val target_ctxt = Assertion_SS_Target.enhance (Assertion_SS.equip ctxt)
   in Phi_Syntax.transformation_conv (Simplifier.rewrite src_ctxt)
                                     (Simplifier.rewrite target_ctxt)
                                     Conv.all_conv
  end

fun skolemize_transformation ctxt th =
  let fun skolem th =
       (case Phi_Syntax.dest_transformation (Thm.major_prem_of th)
          of (Const(const_nameExBI, _) $ _,
              Const(const_nameφTagA, _) $ _ $ (Const(const_nameREMAINS, _) $ _ $ _), _) =>
              skolem (@{thm' skolemize_transformation_tR} RS th)
           | (Const(const_nameExBI, _) $ _,
              Const(const_nameREMAINS, _) $ _ $ _ , _) =>
              skolem (@{thm' skolemize_transformation_R} RS th)
           | (Const(const_nameExBI, _) $ _, _, _) =>
              skolem (@{thm' skolemize_transformation} RS th)
           | _ => th)
   in th
   |> Conv.gconv_rule (Phi_Conv.hhf_concl_conv (fn ctxt =>
            conv_transformation_by_assertion_ss ctxt
          ) ctxt) 1
   |> skolem
  end


subsection ‹Transformation-based Simplification›

type_synonym forward_direction = bool (*false for backward*)

consts 𝒜simp' :: forward_direction  action
       𝒜_transitive_simp' :: forward_direction  action
                  (*rules where simplifications will be applied
                    repeatedly on the simplified results given by the previous step.
                    The annotation exists only in the literal source syntacitcally but once
                    it is added to φ-LPR, will be reduced by a rule pass
                    converting ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜_transitive_simp› to
                    ‹Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z @tag 𝒜simp ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z @tag 𝒜simp›*)
      𝒜try_simp' :: action  bool ― ‹output: made any substantial change›  action

abbreviation 𝒜simp  𝒜simp' True
abbreviation 𝒜try_simp  𝒜try_simp' 𝒜simp
abbreviation 𝒜_transitive_simp  𝒜_transitive_simp' True

abbreviation 𝒜backward_simp  𝒜simp' False
abbreviation 𝒜try_backward_simp  𝒜try_simp' 𝒜backward_simp
abbreviation 𝒜_backward_transitive_simp  𝒜_transitive_simp' False

text ‹Potentially weakening transformations designed for simplifying state sequents of the CoP.

  propx  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp

  Doing this simplification in the framework of To-Transformation benefits it by reusing the
  To-Transformation support in transformation functors, which brings the simplification into the elements.

  The simplification is very heavy.
  For the sake of performance, it is indolent and is applied only when the state sequent
  needs the simplification. There is a mechanism to detect such need. The default strategy is,
  we collect all the registered simplification rules, get the pattern of the source type of the
  transformations, and if the types of a state sequent match any of a pattern, the simplification
  is required and activated.

  This default strategy is not perfect, so we provide hooks by which users can provide ML checkers.
  The checker can bind on either the whole types or subterms of specific constant heads.
  The checker only checks the type part.

  Note propA @tag 𝒜simp requires the process to at least make one meaningful reduction
  step that at least simplifies something. Backtracking happens if fails to simplify anything.
  Use term𝒜try_simp CHANGED to try to simplify something or keep it unchanged on failure.
›

subsubsection ‹Convention›

φreasoner_group φsimp_all = (100, [1,4000]) for ( X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜simp' direction )
      ‹Simplifying the assertion by means of transformation, which may weaken the assertion and
       refine the abstraction (or backwardly strengthen by ‹𝒜backward_simp›)›
 and φsimp = (100, [80, 120]) in φsimp_all
      ‹User rules of transformation-based simplification›
 and φsimp_fallback = (10, [5,20]) in φsimp_all
      ‹Fallbacks of transformation-based simplification›
 and φsimp_derived = (50, [30,70]) in φsimp_all and > φsimp_fallback and < φsimp
      ‹Automatically derived transformation-based simplification›
 and φsimp_cut = (1000, [1000, 1030]) in φsimp_all
      ‹Cutting rules of transformation-based simplification›

declare [[ φreason_default_pattern
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  _ 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜simp' True 
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp' True (100)
  and ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  _ 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜_transitive_simp' True 
      ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_transitive_simp' True (100)

  and _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜simp' False 
      _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp' False (100)
  and _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜_transitive_simp' False 
      _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 _ @tag 𝒜_transitive_simp' False (100)

  and ?X @tag 𝒜simp' ?direction 
      ERROR TEXT(‹Bad form: › (?X @tag 𝒜simp' ?direction) 
                  ‹Expect: ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?Y 𝗌𝗎𝖻𝗃 y. ?r y) @tag 𝒜simp››) (0)
  and ?X @tag 𝒜_transitive_simp' ?direction 
      ERROR TEXT(‹Bad form: › (?X @tag 𝒜_transitive_simp' ?direction) 
                  ‹Expect: ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?Y 𝗌𝗎𝖻𝗃 y. ?r y) @tag 𝒜simp››) (0)
  and ?X @tag 𝒜try_simp' ?direction ?changed 
      ERROR TEXT(‹Bad rule, 𝒜try_simp' is preserved for internal use only.› 
                  (?X @tag 𝒜try_simp' ?direction ?changed)) (0)
]]

lemma [φreason %φsimp_cut+1 for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  _ 𝗌𝗎𝖻𝗃 y. _) @tag 𝒜try_simp' _ _]:
  𝗀𝗎𝖺𝗋𝖽 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  U 𝗌𝗎𝖻𝗃 y. R y) @tag A
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  U 𝗌𝗎𝖻𝗃 y. R y) @tag 𝒜try_simp' A True
  unfolding Action_Tag_def 𝗋Guard_def .

lemma [φreason %φsimp_cut for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  _ 𝗌𝗎𝖻𝗃 y. _) @tag 𝒜try_simp' _ _]:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y  T 𝗌𝗎𝖻𝗃 y. y = x) @tag 𝒜try_simp' A False
  unfolding Action_Tag_def 𝗋Guard_def
  by simp


subsubsection ‹Implementation›

consts 𝒜simp_if_need :: forward_direction  action
       𝒜exhausitive_simp :: forward_direction
                             bool ― ‹input: set this to False to disable the simp›
                             action
       𝒜_apply_simplication :: action

lemma [φreason %cutting for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_apply_simplication]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y' 𝗐𝗂𝗍𝗁 Any @tag 𝒜_map_each_item (𝒜exhausitive_simp True True)
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps SOURCE] Y : Y'
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜_apply_simplication
  unfolding Action_Tag_def Transformation_def Simplify_def
  by simp

lemma 𝒜simp_invoke:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Any @tag 𝒜_map_each_item (𝒜exhausitive_simp True True)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y
  unfolding Action_Tag_def
  by (simp add: transformation_weaken)

ML_file ‹library/tools/CoP_simp.ML›

context begin

private lemma 𝒜simp_chk_no_need:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒜simp_if_need direction
  unfolding Action_Tag_def
  by simp

private lemma 𝒜simp_chk_no_need':
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T 𝗌𝗎𝖻𝗃 y. y = x @tag 𝒜simp_if_need direction
  unfolding Action_Tag_def
  by (simp add: ExBI_defined)

private lemma 𝒜simp_chk_go:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜try_simp' (𝒜simp' direction) ANY
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜simp_if_need direction
  unfolding Action_Tag_def .

private lemma 𝒜simp_chk_go_transitive:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜try_simp' (𝒜simp' True) CHANGED
 y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 r y  (y  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z  Z 𝗌𝗎𝖻𝗃 z. w y z @tag 𝒜exhausitive_simp True CHANGED)
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. y. r y  w y z)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z  Z 𝗌𝗎𝖻𝗃 z. r' z @tag 𝒜exhausitive_simp True ANY
  unfolding Action_Tag_def Transformation_def Premise_def Simplify_def
  by clarsimp blast

private lemma 𝒜simp_chk_go_transitive_backward:
  (y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 w y  y  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z  Z 𝗌𝗎𝖻𝗃 z. r y z @tag 𝒜try_simp' (𝒜simp' False) CHANGED)
 x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗌𝗎𝖻𝗃 y. w y @tag 𝒜exhausitive_simp False CHANGED
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. y. w y  r y z)
 x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z  Z 𝗌𝗎𝖻𝗃 z. r' z @tag 𝒜exhausitive_simp False ANY
  unfolding Action_Tag_def Transformation_def Premise_def Simplify_def
  by clarsimp blast

private lemma 𝒜simp_chk_no_need_transitive:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒜exhausitive_simp direction ANY
  unfolding Action_Tag_def
  by simp

private lemma 𝒜simp_chk_no_need'_transitive:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T 𝗌𝗎𝖻𝗃 y. y = x @tag 𝒜exhausitive_simp direction ANY
  unfolding Action_Tag_def
  by (simp add: ExBI_defined)

φreasoner_ML 𝒜simp_if_need %cutting (_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp_if_need _) = fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val (bvs, goal) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (ToA, Const _ $ direction_term) = PLPR_Syntax.dest_action_of' (K true) goal
      val (X, Y', _) = Phi_Syntax.dest_transformation ToA
      val direction = case direction_term of Const(const_nameTrue, _) => true
                                           | Const(const_nameFalse, _) => false
                                           | _ => raise TERM ("The direction of 𝒜simp_if_need must be a literal", [direction_term])
      val (Y, ex_bound) =
            case Y' of Const(const_nameExBI, _) $ Abs (N, Ty,
                          Const(const_nameSubjection, _) $ (Y as Const(const_nameφType, _) $ Bound 0 $ _) $ _)
                         => (Y, SOME (N,Ty))
                     | _ => (Y', NONE)
   in if (if direction then Phi_CoP_Simp.is_simp_needed (Context.Proof ctxt) bvs X
                       else Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) (the_list ex_bound @ bvs) Y)
   then SOME ((ctxt, @{thm' 𝒜simp_chk_go} RS' (ctxt, sequent)), Seq.empty)
   else let val rule = if is_some ex_bound then @{thm' 𝒜simp_chk_no_need'}
                                           else @{thm' 𝒜simp_chk_no_need}
    in SOME ((ctxt, rule RS' (ctxt, sequent)), Seq.empty)
   end
  end)

φreasoner_ML 𝒜exhausitive_simp %cutting (_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜exhausitive_simp _ _) = let val norm_tail = @{lemma' x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z  Z 𝗌𝗎𝖻𝗃 z. r z @tag A
     𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps SOURCE] Z' : z  Z 𝗌𝗎𝖻𝗃 z. r z
     x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z' @tag A
        by (simp add: Action_Tag_def Simplify_def)}

 in fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val (bvs, goal) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (ToA, Const _ (*𝒜exhausitive_simp*)
                  $ direction_term
                  $ IS_NEEDED
          ) = PLPR_Syntax.dest_action_of' (K true) goal
      val (X, Y', _) = Phi_Syntax.dest_transformation ToA
      val direction = case direction_term of Const(const_nameTrue, _) => true
                                           | Const(const_nameFalse, _) => false
                                           | _ => raise TERM ("The direction of 𝒜simp_if_need must be a literal", [direction_term])
      val (Y, ex_bound) =
            case Y' of Const(const_nameExBI, _) $ Abs (N, Ty,
                          Const(const_nameSubjection, _) $ (Y as Const(const_nameφType, _) $ Bound 0 $ _) $ _)
                         => (Y, SOME (N, Ty))
                     | _ => (Y', NONE)
      val is_needed =
          IS_NEEDED <> ConstFalse andalso
         (if direction then Phi_CoP_Simp.is_simp_needed (Context.Proof ctxt) bvs X
                       else Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) (the_list ex_bound @ bvs) Y)
   in if is_needed
   then let val sequent' = if is_some ex_bound
                           then sequent
                           else norm_tail RS sequent
     in SOME ((ctxt, (if direction then @{thm' 𝒜simp_chk_go_transitive}
                                   else @{thm' 𝒜simp_chk_go_transitive_backward})
                      RS' (ctxt, sequent)), Seq.empty)
    end
   else let val rule = if is_some ex_bound then @{thm' 𝒜simp_chk_no_need'_transitive}
                                           else @{thm' 𝒜simp_chk_no_need_transitive}
    in SOME ((ctxt, rule RS' (ctxt, sequent)), Seq.empty)
   end
  end)
end

end

paragraph ‹Invoking CoP-simp in ToA reasoning›

ML val normalize_source = @{lemma
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X' @tag 𝒜_map_each_item (𝒜exhausitive_simp True True)
 X' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by (clarsimp simp: Action_Tag_def Transformation_def, blast)
}

fun normalize_source_of_ToA (ctxt, sequent) =
  let val (bvs, ToA) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (X, _, _) = Phi_Syntax.dest_transformation ToA
   in if Phi_Syntax.exists_item_of_assertion (Phi_CoP_Simp.is_simp_needed (Context.Proof ctxt)) bvs X
      then (
        Phi_Reasoner.info_print ctxt 2 (K "normalizing the source assertion of the transformation") ;
        case Phi_Reasoner.internal_reason NONE (SOME 1) (ctxt, normalize_source RS sequent)
          of NONE => (ctxt, sequent)
           | SOME (ctxt', sequent') => 
                (ctxt', Conv.gconv_rule (Phi_Conv.hhf_concl_conv (conv_transformation_by_assertion_ss) ctxt') 1 sequent'))
      else (ctxt, sequent)
  end

fun normalize_target_of_ToA parse (ctxt, sequent) =
  let val (bvs, ToA) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (Y, rule) = parse (Phi_Syntax.dest_transformation ToA)
                      (* of (_, Const(const_name‹REMAINS›, _) $ Y $ _, _) => (Y, true)
                          | (_, Y, _) => (Y, false) *)
   in if Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) bvs Y
      then (
        Phi_Reasoner.info_print ctxt 2 (K "normalizing the target assertion of the transformation") ;
        case Phi_Reasoner.internal_reason NONE (SOME 1) (ctxt, rule RS sequent)
          of NONE => (ctxt, sequent)
           | SOME ret => ret)
      else (ctxt, sequent)
  end

fun chk_target_of_ToA_requires_normalization parse_term (ctxt, sequent) =
  let val (bvs, ToA) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val target = parse_term (#2 (Phi_Syntax.dest_transformation ToA))
   in Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) bvs target orelse
      (case target
         of Const(const_nameφType, _) $ x $ T =>
              let val head = Term.head_of x
               in not (is_Var head) orelse exists_subterm (fn y => y aconv head) T
              end
          | _ => false)
  end



subsubsection ‹Simplification Protect›

definition [simplification_protect]:
  φTBS_Simp_Protect X U r direction  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp' direction

lemma [cong]:
  X  X'
 U  U'
 r  r'
 φTBS_Simp_Protect X U r direction  φTBS_Simp_Protect X' U' r' direction
  by simp

subsubsection ‹Extracting Pure›

lemma [φreason %extract_pure]:
  𝗋ESC P A
 𝗋ESC P (A @tag 𝒜simp' direction)
  unfolding Action_Tag_def
  by blast

lemma [φreason %extract_pure]:
  𝗋EIF A P
 𝗋EIF (A @tag 𝒜simp' direction) P
  unfolding Action_Tag_def
  by blast


subsection ‹Falling Lattice of Transformation Sub-procedures›

subsubsection ‹From 𝒯𝒫'› to 𝒯𝒫›

lemma [φreason default %ToA_falling_latice+3]:
  𝗀𝗎𝖺𝗋𝖽 fst x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 May_Assign (snd x) unspec
 x  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y, unspec)  U   𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
  unfolding 𝗋Guard_def Action_Tag_def φProd'_def Transformation_def
  by simp

(*TODO: optimize!*)
lemma [φreason default %ToA_falling_latice+2]:
  x  X  Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 prod.swap x  Y  X @tag 𝒯𝒫'
  for X :: ('a::sep_algebra,'b) φ
  unfolding Action_Tag_def φProd'_def φProd_def φType_def Transformation_def
  by (cases x; simp add: mult.commute)

lemma [φreason default %ToA_falling_latice+1]:
  𝗀𝗎𝖺𝗋𝖽 Push_Envir_Var prove_obligations_in_time True 𝗋
         Identity_ElementI (fst x  T) P 𝗋
         Pop_Envir_Var prove_obligations_in_time
 x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, unspec)  U   𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
  for T :: ('c::sep_magma_1, 'x) φ
  ― ‹the transformation from T to U fails, and the algebra is non-commutative, nor any methods of a higher priority,
      so T› or U› can only be identity if the reasoning can continue›
  unfolding 𝗋Guard_def Ant_Seq_def Identity_ElementI_def Transformation_def Action_Tag_def φProd'_def
  by (clarsimp; fastforce)

lemma [φreason default %ToA_falling_latice]:
  Identity_ElementE (one  U)
 x  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (one, fst x)  U  T @tag 𝒯𝒫'
  for T :: ('c::sep_magma_1, 'x) φ
  unfolding 𝗋Guard_def Ant_Seq_def Identity_ElementE_def Transformation_def Premise_def Action_Tag_def φProd'_def
  by (clarsimp; force)


subsubsection ‹From 𝒯𝒫› to 𝒯𝒫'›

lemma [φreason default %ToA_falling_latice+3]:
  (x, w)  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr  U  R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
 Identity_ElementE (w  W)
 snd yr  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RR @clean
 x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst yr  U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Premise_def Identity_ElementE_def Try_def Action_Tag_def φProd'_def REMAINS_def
  by (clarsimp simp add: φSome_transformation_strip φProd_expn'' φProd_expn',
      smt (z3) BI_eq_ToA mult_1_class.mult_1_right transformation_left_frame transformation_trans)

lemma [φreason default %ToA_falling_latice+3]:
  (x,w)  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U  R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y' : y
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y1 : fst y'
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r  : snd y'
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w  W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
 (r  R) * RR 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 RRR @clean
 (x  T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y1  U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RRR 𝗐𝗂𝗍𝗁 P2  P1 @tag 𝒯𝒫
  for A :: 'a::sep_monoid BI
  unfolding Action_Tag_def Simplify_def Action_Tag_def φProd'_def REMAINS_def
  apply (clarsimp simp: φSome_φProd φSome_transformation_strip φProd_expn' φProd_expn'' mult.assoc[symmetric])
  subgoal premises prems
  by (insert prems(1)[THEN transformation_right_frame, where R=RR]
            prems(5)[THEN transformation_left_frame, where R=x  T]
            prems(6)[THEN transformation_left_frame, where R=fst y  U],
      smt (z3) mult.assoc transformation_trans) .

lemma [φreason default %ToA_falling_latice+3]:
  (x, w)  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U  R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
 Identity_ElementI (snd y  R) Q
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w  W 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
 (x  T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y  U 𝗐𝗂𝗍𝗁 P2  Q  P1 @tag 𝒯𝒫
  for A :: 'a :: sep_magma_1 BI
  unfolding Action_Tag_def φProd_expn' Identity_ElementI_def Premise_def
            Transformation_def Try_def Ant_Seq_def φProd'_def
  by (clarsimp; fastforce)

(*
lemma (*ToA_splitting_source_no_remainder_first*)
      [no_atp, φreason %ToA_falling_latice+2 except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ :: ?'a :: sep_semigroup BI) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " R = 1 ∧𝗋 (A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫) ∨cut
    P = (P1 ∧ P2) ∧𝗋 (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫) ∧𝗋
    (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫))
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Orelse_shortcut_def Transformation_def REMAINS_def Premise_def Ant_Seq_def Action_Tag_def
  by clarsimp (metis One_expn mult_1_class.mult_1_right sep_magma_1_left)
*)

lemma [φreason default %ToA_falling_latice+2]: ― ‹when X fails to match x ⦂ T›
  R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 X * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 X * R' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  for Y :: 'c::sep_algebra BI
  unfolding Action_Tag_def REMAINS_def
  by (simp add: mult.left_commute transformation_left_frame)

lemma [φreason default %ToA_falling_latice+1]: ― ‹when X fails to match x ⦂ T›, nor a abelian semigroup›
  Identity_ElementE (var_y  U)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 var_y  U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 X @tag 𝒯𝒫
  for X :: 'c::sep_magma_1 BI
  unfolding Transformation_def Identity_ElementE_def Action_Tag_def
  by (clarsimp, force)

subsubsection ‹For Non-Unital Algeras›

lemma closed_homo_sep_Some:
  closed_homo_sep Some
  unfolding closed_homo_sep_def closed_homo_sep_disj_def homo_sep_def homo_sep_mult_def homo_sep_disj_def
  by simp

lemma [φreason default %ToA_falling_latice
               for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ * _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                   _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
               except (_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps SOURCE] X' : Ψ[Some] X
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps TARGET] Y' : Ψ[Some] Y
 X' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Transformation_def Action_Tag_def Simplify_def
  by auto

lemma [assertion_simps]:
  Ψ[Some] (x  T) = (x   T)
  unfolding BI_eq_iff
  by (auto simp: split_option_all)

lemma [assertion_simps]:
  Ψ[Some] (X * Y) = Ψ[Some] X * Ψ[Some] Y
  for X :: 'c::sep_magma BI
  by (simp add: Ψ_Multiplicative_Conj[OF closed_homo_sep_Some])

lemma [assertion_simps]:
  Ψ[Some] (A 𝗌𝗎𝖻𝗃 P) = (Ψ[Some] A 𝗌𝗎𝖻𝗃 P)
  unfolding BI_eq_iff
  by simp blast

lemma [assertion_simps]:
  Ψ[Some] (∃*x. A x) = (∃*x. Ψ[Some] (A x))
  unfolding BI_eq_iff
  by simp blast

lemma [assertion_simps]:
  Ψ[Some] (A + B) = Ψ[Some] A + Ψ[Some] B
  unfolding BI_eq_iff
  by simp blast

lemma [assertion_simps]:
  Ψ[Some] (A  B) = Ψ[Some] A  Ψ[Some] B
  unfolding BI_eq_iff
  by simp blast



subsection ‹Essential Reasoning Procedures›

subsubsection ‹Reflexive Transformation›

paragraph ‹When the target and the source are either alpha-equivalent or unified›

text ‹Applying reflexive transformation on alpha-equivalent couples of source and target is safe,
so be applied of high priority.
In contrast, unification by reflexive transformation is aggressive. Therefore, they are applied
only when no other rules are applicable.›

declare transformation_refl [φreason %ToA_refl for ?A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                                                   _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?T 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫,
                             φreason %ToA_unified_refl for _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?U 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]

lemma [φreason default %ToA_unified_refl for ?A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A' 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A
  unfolding Premise_def 𝗋Guard_def Action_Tag_def
  by simp

lemma [φreason %ToA_refl for ?A * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (?A :: ?'c::sep_magma_1 BI) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫,
       φreason default %ToA_unified_refl for ?A * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (?A' :: ?'c::sep_magma_1 BI) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  Identity_ElementI R P
 A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
  for A :: 'c::sep_magma_1 BI
  unfolding Identity_ElementI_def Transformation_def Action_Tag_def
  by clarsimp fastforce

lemma transformation_refl_assigning_remainder [
          φreason %ToA_assigning_var for ?A * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                                         (_  ?T) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫,
          φreason default %ToA_unified_refl for _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R
  unfolding REMAINS_def Action_Tag_def
  by simp

lemma transformation_refl_with_remainder [
        φreason %ToA_assigning_var for ?A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                                       _  ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y  ?T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫,
        φreason default %ToA_unified_refl for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 1
  for A :: 'a::sep_magma_1 BI
  unfolding Action_Tag_def REMAINS_def
  by simp

lemma transformation_refl_assigning_W [
        φreason %ToA_assigning_var,
        φreason default %ToA_unified_refl for _  _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (_  _)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' ]:
  x  T  U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x, unspec)  (T  U)  
  unfolding Action_Tag_def φProd'_def φProd_expn'
  by simp

lemma transformation_refl_assigning_R [
        φreason %ToA_assigning_var,
        φreason default %ToA_unified_refl for _  (_  _)  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' ]:
  May_Assign (snd x) unspec
 x  (T  U)   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst x  T  U
  unfolding Action_Tag_def φProd'_def
  by (cases x; simp add: φProd_expn')

lemma transformation_refl_with_WR [
        φreason %ToA_assigning_var+1,
        φreason default %ToA_unified_refl+1 for _  _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' ]:
        ― ‹Higher than transformation_refl› to set the condition variable Cr›
  May_Assign (snd x) unspec
 x  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T  
  unfolding Action_Tag_def
  by simp

lemma ToA_refls_by_T_eq:
  T = T'
 May_Assign (snd x2) unspec
 x2  T   𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x2  T'  
  T = T'
 (x  T) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T' 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R
  T = T'
 x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T'
  unfolding φProd'_def REMAINS_def
  by simp_all


paragraph ‹When the target is a schematic variable›

text ‹Schematic variables occurring in source are assigned with zeros, and is
  covered by §Phi_BI/Bottom/Transformation_Rules›

ML (* (⋀x. X x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 P) where ?Y is a variable.
   When X contains some quantified variables ‹x› that do not parameterize ?Y, the procedure
   existentially qualifies X, and assign ‹∃x. X x› to ?Y.
   cannot work on ‹_ ∗[_] _› (*TODO, but the thing is there is no type embedding of existence,
                                     unless we use Σ and 𝒮, but... mmmmm.... well, a lot of work.*)
 *)
fun apply_refl_by_unifying (refl, exintro', Gx, Gy) ctxt thm =
  let val (vs, _, goal) = Phi_Help.leading_antecedent (Thm.prop_of thm)
      val N = length vs
      val (X0,Y0,_) = Phi_Syntax.dest_transformation goal
      val (X, Y) = (Gx X0, Gy Y0)
      val (Var V, args) = strip_comb Y
      val bnos = map_filter (fn Bound i => SOME i | _ => NONE) args
      val bads = subtract (op =) bnos (Term.loose_bnos X)
   in if null bads
   then Phi_Reasoner.single_RS refl ctxt thm
   else case exintro'
     of NONE => Seq.empty
      | SOME exintro => let
      val N_bads = length bads
      val N_bnos = length bnos
      val (argTys, TypeBI TY) = Term.strip_type (snd V)
      val insts' = List.tabulate (N, fn i =>
            let val bi = find_index (fn k => k = i) bads
                val ci = find_index (fn k => k = i) bnos
             in if bi <> ~1
                then Bound (N_bads - 1 - bi)
                else if ci <> ~1
                then Bound (N_bads + N_bnos - 1 - ci)
                else Term.dummy (*not occur*)
            end)
      val Y'1 = subst_bounds (insts', X)
      val Y'2 = fold_rev (fn j => fn TM =>
                  let val (name,T) = List.nth (vs, N-1-j)
                   in ConstExBI T TY $ Abs (name, T, TM)
                  end) bads Y'1
      val Y'3 = fold_rev (fn (_, Bound j) => (fn TM =>
                            let val (name,T) = List.nth (vs, N-1-j)
                             in Abs (name, T, TM)
                            end)
                       | (ty, _) => (fn TM => Abs ("_", ty, TM))
                     ) (argTys ~~ args) Y'2
   in Thm.instantiate (TVars.empty, Vars.make [(V, Thm.cterm_of ctxt Y'3)]) thm
   |> funpow N_bads (fn th => exintro RS th)
   |> Phi_Reasoner.single_RS refl ctxt
   handle THM _ => Seq.empty
  end
  end

φreasoner_ML transformation_refl_var %ToA_assigning_var (_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫) = fn (_, (ctxt,thm)) => Seq.map (pair ctxt) (apply_refl_by_unifying (
          @{thm' transformation_refl[THEN Action_Tag_I[where A=𝒯𝒫]]},
          SOME @{thm' ExBI_transformation_I[THEN Action_Tag_I[where A=𝒯𝒫], OF Action_Tag_D[where A=𝒯𝒫]]},
          I, I
      ) ctxt thm)

φreasoner_ML transformation_refl_var_R %ToA_assigning_var (_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫) = fn (_, (ctxt,thm)) => Seq.map (pair ctxt) (apply_refl_by_unifying (
          @{thm' transformation_refl_assigning_remainder[THEN Action_Tag_I[where A=𝒯𝒫]]},
          SOME @{thm' ExBI_transformation_I_R[THEN Action_Tag_I[where A=𝒯𝒫], OF Action_Tag_D[where A=𝒯𝒫]]},
          (fn _ $ A $ R => A), (fn _ (*REMAINS*) $ A $ _ => A)
      ) ctxt thm)

text ‹Here, we assign the semantics of schematic variables occurring in targets and sources to be,
  a wild-card for any single separation item.›

text ‹
TODO: move me!

NToA procedure addresses the transformation between any-to-many φ-type items.
  Separation Extraction addresses that from many to one φ-type item.
  The φ-type themselves should provide the rules for one-to-one transformations, as they are primitive.
  Transformation Functor presented later provides an automation for this.

  However, a small supplementary is one-to-one with remainders.
  For unital algebras, the issue is easy as we can always force yielding remainders.
  For non-semigroups, after a reasoning branch splitting the cases for having remainder or not,
  the issue reduces immediately.
  For associative but non-unital algebras, a bit of work is required. 

›

subsubsection ‹Varify Target Object›

lemma [φreason default %ToA_varify_target_object for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                                              except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y'  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ]:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜exhausitive_simp False True
 Object_Equiv U eq
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 P : (y'. r y'  eq y' y)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
  by clarsimp metis

lemma [φreason default %ToA_varify_target_object for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                                              except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y'  _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _  @tag 𝒯𝒫]:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜exhausitive_simp False True
 Object_Equiv U eq
 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 P : (y'. r y'  eq y' y)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
  by (clarsimp; metis)


subsubsection ‹Basic Transformation Rules›

paragraph ‹Plainize›

lemma [φreason %ToA_normalizing]:
  " T1 * (T2 * R) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 (T1 * T2) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P"
  for R :: 'a::sep_semigroup BI
  unfolding mult.assoc .

lemma [φreason %ToA_normalizing]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X1 * (X2 * R) 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X1 * X2) * R 𝗐𝗂𝗍𝗁 P"
  for R :: 'a::sep_semigroup BI
  unfolding mult.assoc .

lemma [φreason %ToA_normalizing]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X1 * (X2 * X3) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X1 * X2) * X3 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P "
  for R :: 'a::sep_monoid BI
  unfolding mult.assoc .


lemma [φreason %ToA_splitting_target]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1  (R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫)
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗐𝗂𝗍𝗁 P1  P2 @tag 𝒯𝒫"
  unfolding Action_Tag_def REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
  by (clarsimp; force)


lemma [φreason %ToA_splitting_target]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R1 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1  (R1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R' 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫)
 𝗋Assoc_Mul X Y R'
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R' 𝗐𝗂𝗍𝗁 P1  P2 @tag 𝒯𝒫 "
  unfolding Action_Tag_def REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def 𝗋Assoc_Mul_def
  by (clarsimp, meson)



subsubsection ‹Entry Point of Transformation Reasoning›

setup Config.put_global (Phi_Syntax.enable_auto_chk_and_conv) false

paragraph ‹Major Implementation›

subparagraph ‹Short-cuts›

lemma [φreason %ToA_refl for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?X 𝗐𝗂𝗍𝗁 ?P
                             ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var 𝗐𝗂𝗍𝗁 ?P]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X
  unfolding Action_Tag_def using transformation_refl .

lemma [φreason %ToA_red for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗌𝗎𝖻𝗃 True 𝗐𝗂𝗍𝗁 ?P]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗌𝗎𝖻𝗃 True 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def by simp

lemma [φreason %ToA_normalizing for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Any
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y
  unfolding Action_Tag_def
  by (simp add: transformation_weaken)

subparagraph ‹ML›

ML val augment_ToA_by_implication = Attrib.setup_config_bool bindingaugment_ToA_by_implication (K false)
val under_NToA_ctxt = Config.declare_bool ("under_NToA_ctxt", ) (K false)

structure ToA_Hooks = Hooks (
  type arg = {deep: bool}
  type state = context_state
)

val NToA_init_having_Q = @{lemma
  X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q
 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  by (clarsimp simp: 𝗋EIF_def Simplify_def Identity_ElementI_def Satisfiable_def Premise_def
                     Action_Tag_def Transformation_def, blast)}


φreasoner_ML ToR_Entry_Point 2000 (?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?var_P) = fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val sequent = skolemize_transformation ctxt sequent
      val (ctxt, sequent) = normalize_source_of_ToA (ctxt, sequent)
      val sequent = @{thm' Action_Tag_D[where A=𝒯𝒫]} RS sequent
      val sequent = if Config.get ctxt augment_ToA_by_implication
                    then NToA_init_having_Q RS sequent
                    else sequent
   in SOME ((ctxt,sequent), Seq.empty)
  end
)

setup Config.put_global Phi_Syntax.enable_auto_chk_and_conv true


subsection ‹Supplementary Transformations›

subsubsection ‹Supplementary for Ex \& Conj \label{supp-ex-conj}›

ML fun ToA_ex_intro_reasoning (ctxt,sequent) =
  let val (_, X'', _) = Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
      fun parse (Const(const_nameExBI, Typefun Typefun ty _ _) $ X) = (false, ty, X)
        | parse (Const(const_nameREMAINS, _) $ (Const(const_nameExBI, Typefun Typefun ty _ _) $ X) $ _)
            = (true, ty, X)
        | parse X = parse (Envir.beta_eta_contract X)
      val (has_focus, _, X'1) = parse X''
      val X = case X'1 of Abs (_, _, X) => X | X => Term.incr_boundvars 1 X $ Bound 0
      val ex_var_is_in_obj_only = Phi_Syntax.forall_item_of_assertion_blv (fn (_,lv) =>
                                    (fn (Const(const_nameφType, _) $ _ $ T) => not (Term.loose_bvar1 (T, lv))
                                      | A => not (Term.loose_bvar1 (A, lv)))) []
      val rule0 = if has_focus
                  then if ex_var_is_in_obj_only X
                  then @{thm' ExBI_transformation_I_R[where x=id c for c,
                                      OF Action_Tag_D[where A=𝒯𝒫], THEN Action_Tag_I[where A=𝒯𝒫]]}
                  else @{thm' ExBI_transformation_I_R[
                                      OF Action_Tag_D[where A=𝒯𝒫], THEN Action_Tag_I[where A=𝒯𝒫]]}
                  else if ex_var_is_in_obj_only X
                  then @{thm' ExBI_transformation_I[where x=id c for c,
                                      OF Action_Tag_D[where A=𝒯𝒫], THEN Action_Tag_I[where A=𝒯𝒫]]}
                  else @{thm' ExBI_transformation_I[
                                      OF Action_Tag_D[where A=𝒯𝒫], THEN Action_Tag_I[where A=𝒯𝒫]]}
   in SOME ((ctxt, rule0 RS sequent), Seq.empty)
  end

φreasoner_ML ToA_ex_intro default ! %ToA_inst_qunat ( _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExBI _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
                                                    | _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExBI _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 )
  = fn stat => Seq.make (fn () => ToA_ex_intro_reasoning (snd stat))

(*diverges to 3 branches, left branch, right branch, and instantiating the Ex in the domain if any. *)
φreasoner_ML NToA_conj_src ! %ToA_branches  (_  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫) = fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val tail = (case Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
                    of (_, Const(const_nameExBI, _) $ X, _) =>
                            if Term.exists_Const (fn (const_nameinf, _) => true
                                                   | _ => false) X
                            then Seq.make (fn () => ToA_ex_intro_reasoning (ctxt,sequent))
                            else Seq.empty
                     | _ => Seq.empty)
   in SOME ((ctxt, @{thm' NToA_conj_src_A
                            [OF Action_Tag_D[where A=𝒯𝒫], THEN Action_Tag_I[where A=𝒯𝒫]]} RS sequent),
        Seq.make (fn () => SOME ((ctxt, @{thm' NToA_conj_src_B
                            [OF Action_Tag_D[where A=𝒯𝒫], THEN Action_Tag_I[where A=𝒯𝒫]]} RS sequent), tail)))
  end
  )


subsubsection ‹Evaluations›

declare [[φchk_source_val = false]]

lemma [φreason %ToA_red]:
  (y,x)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 prod.swap (x,y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  (f x, y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 apfst f (x,y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  (x, f y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 apsnd f (x,y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  x  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 fst (x,y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  y  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 snd (x,y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  (x, z)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (fst (x,y), z)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  (y, z)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (snd (x,y), z)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  (x, y)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (x, fst (y, z))  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  (x, z)  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (x, snd (y, z))  T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp
declare [[φchk_source_val = true]]

subsubsection ‹Let›

lemma [φreason %ToA_red]:
  " T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P
 Let x T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P"
  unfolding Let_def .

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U x 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Let x U 𝗐𝗂𝗍𝗁 P"
  unfolding Let_def .

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Let x U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P"
  unfolding Let_def .

subsubsection ‹Case Prod›

φreasoner_group ToA_red_caseprod =
  (%ToA_red, [%ToA_red, %ToA_red+10]) for (_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod _ _ 𝗐𝗂𝗍𝗁 _, case_prod _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _)
  ‹Transformations reducing ‹case_prod››

lemma [φreason %ToA_red_caseprod+10]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f x y 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f (x,y) 𝗐𝗂𝗍𝗁 P"
  by simp

lemma [φreason %ToA_red_caseprod+10]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f x y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f (x,y) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P"
  by simp

lemma [φreason %ToA_red_caseprod+10]:
  " A x y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
 case_prod A (x,y) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P"
  by simp

lemma [φreason %ToA_red_caseprod]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f (fst xy) (snd xy) 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f xy 𝗐𝗂𝗍𝗁 P"
  unfolding Transformation_def
  by (cases xy; simp)

lemma [φreason %ToA_red_caseprod]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f (fst xy) (snd xy) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f xy 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P"
  unfolding Transformation_def
  by (cases xy; simp)

lemma [φreason %ToA_red_caseprod]:
  " A (fst xy) (snd xy) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
 case_prod A xy 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P"
  by (cases xy; simp)


subsubsection ‹Conditional Branch›

paragraph ‹Normalization›

lemma [φreason %ToA_normalizing]:
  If C (x  A) (x  B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 x  If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by (cases C; simp)

text termx  (If C T U)  W is not reduced because the CW and W› have to be specially assigned.›

(*TODO: the following rule is limited!! W1, W2*)

lemma [φreason %ToA_normalizing]: ― ‹W› shouldn't contain schematic variable. Why a source can contain
                                      variable?›
  If C ((x  A) * W) ((x  B) * W) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 (x  If C A B) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by (cases C; simp)

lemma [φreason %ToA_normalizing]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C (x  A) (x  B) 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x  If C A B 𝗐𝗂𝗍𝗁 P
  by (cases C; simp)

paragraph ‹Reduction for constant boolean condition›

subparagraph ‹Source›

lemma NToA_cond_source_A[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
 A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 (if C then A else B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)

lemma NToA_cond_source_B[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
 B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 (if C then A else B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)

lemma NToA_cond_source_A_ty[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
 x  T  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 x  (if C then T else U)  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)

lemma NToA_cond_source_B_ty[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
 x  U  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
 x  (if C then T else U)  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)


subparagraph ‹Target›

lemma NToA_cond_target_A[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗐𝗂𝗍𝗁 P
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_B[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗐𝗂𝗍𝗁 P
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_A'[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_B'[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_A_ty[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  T  R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  (if C then T else U)  R 𝗐𝗂𝗍𝗁 P
  unfolding Premise_def 𝗋Guard_def φProd'_def
  by simp

lemma NToA_cond_target_B_ty[φreason %ToA_red]:
  𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  U  R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  (if C then T else U)  R 𝗐𝗂𝗍𝗁 P
  unfolding Premise_def 𝗋Guard_def
  by simp


paragraph ‹When the condition boolean is a variable›

text ‹The condition should be regarded as an output, and the reasoning process assigns which
the branch that it chooses to the output condition variable.›

subparagraph ‹Normalizing›

lemma [φreason %ToA_red for If (id ?var) _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  If C T U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 If (id C) T U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_red for _  If (id ?var) _ _  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']:
  x  If C T U  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
 x  If (id C) T U  W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If (id ?var) _ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C A B 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If (id C) A B 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  by simp

lemma [φreason %ToA_red for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (If (id ?var) _ _)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  (If C A B)  R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  (If (id C) A B)  R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
  by simp

subparagraph ‹Source›

text ‹the id ?x› here is the protector generated by instantiating existence in target.›

declare [[φreason ! %ToA_branches NToA_cond_source_A NToA_cond_source_B
        for (if ?var_condition then ?A else ?B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?X 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫]]

hide_fact NToA_cond_source_A NToA_cond_source_B

declare [[φreason ! %ToA_branches NToA_cond_source_A_ty NToA_cond_source_B_ty
      for _  (if ?var then _ else _)  _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']]

hide_fact NToA_cond_source_A_ty NToA_cond_source_B_ty


subparagraph ‹Target›

declare [[φreason ! %ToA_branches NToA_cond_target_A NToA_cond_target_B
            for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var_condition then ?A else ?B) 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫 ]]

hide_fact NToA_cond_target_A NToA_cond_target_B

declare [[φreason ! %ToA_branches NToA_cond_target_B' NToA_cond_target_A'
            for ?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var_condition then ?A else ?B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫 ]]

hide_fact NToA_cond_target_A' NToA_cond_target_B'

declare [[φreason ! %ToA_branches NToA_cond_target_A_ty NToA_cond_target_B_ty
            for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (if ?var then _ else _)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' ]]

hide_fact NToA_cond_target_A_ty NToA_cond_target_B_ty


paragraph ‹Case Split›

φreasoner_group ToA_splitting_If = (%ToA_splitting, [%ToA_splitting, %ToA_splitting+1])
                                   for (If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y, X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C A B)
                                    in ToA_splitting
  ‹ToA splitting ‹If› in either source or target, into two sub-goals.›

subparagraph ‹Source›

lemma ToA_cond_branch_src:
  Y = If C Ya Yb
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C  (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
 If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫
  unfolding Action_Tag_def
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

lemma ToA_cond_branch_src_R:
  Y = If C Ya Yb
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C  (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
 If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

(*lemma ToA_cond_branch_src_R':
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ P = False) ∨cut (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ Q = False) ∨cut (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)
*)

lemma [φreason %ToA_splitting_If]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C  (x  Ta  Wa 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya  U  Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'))
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  (x  Tb  Wb 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb  U  Rb 𝗐𝗂𝗍𝗁 Q  @tag 𝒯𝒫'))
 x  (If C Ta Tb)  (If C Wa Wb) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C ya yb  U  If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫'
  unfolding Try_def
  by (cases C; simp add: Premise_def Orelse_shortcut_def)
  
ML fun reasoner_ToA_conditioned_subgoals_If ctxt'N (vars,Y,RHS) =
  let val (C, Ya, Yb) = Phi_Help.dest_triop_c const_nameIf RHS
      val C_term = Thm.term_of C

      val Ya_s = map (fn ((N,i),ty) => Thm.var ((N,i+2), Thm.ctyp_of ctxt'N ty)) vars
      val Yb_s = map (fn ((N,i),ty) => Thm.var ((N,i+3), Thm.ctyp_of ctxt'N ty)) vars 
      val Y_s  = map2 (fn a => fn b =>
                   let val ty = Thm.typ_of_cterm a
                    in Thm.apply (Thm.apply (
                          Thm.apply (Thm.cterm_of ctxt'N ConstIf ty) C
                        ) a
                        ) b
                   end) Ya_s Yb_s
      val Ya' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Ya_s)) Y
      val Yb' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Yb_s)) Y
      fun mk_inst ctm Y =
        case Thm.term_of ctm
          of _ $ Free _ => mk_inst (Thm.dest_fun ctm) (Thm.lambda (Thm.dest_arg ctm) Y)
           | Var v => (v, Y)
           | _ => error "BUG: reasoner_ToA_conditioned_subgoals"
 
   in (Vars.make (mk_inst Ya Ya' :: mk_inst Yb Yb' :: (vars ~~ Y_s)), C_term)
  end


lemma If_distrib_fx:
  (If C fa fb) (If C va vb)  (If C (fa va) (fb vb))
  unfolding atomize_eq
  by (cases C; simp)

lemma If_distrib_arg:
  (If C fa fb) a  (If C (fa a) (fb a))
  unfolding atomize_eq
  by (cases C; simp)
 
φreasoner_ML ML (If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫) %ToA_splitting_If
             ( If _ _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
             | except If ?var _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫)
  = Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_cond_branch_src}, @{thm' ToA_cond_branch_src_R},
          (true, @{thms' if_cancel[folded atomize_eq]}, @{thms' if_True if_False}),
          reasoner_ToA_conditioned_subgoals_If, context) o snd


subparagraph ‹Target›

lemma [φreason %ToA_splitting_If except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var then _ else _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

lemma [φreason %ToA_splitting_If except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var then _ else _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

(*
lemma [φreason %ToA_splitting_If+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if _ then _ else _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] _ 𝗐𝗂𝗍𝗁 _›
                    except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var then _ else _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,False)) ∨cut (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,False)) ∨cut (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)*)

lemma [φreason %ToA_splitting_If except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (if ?var then _ else _)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']:
  (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya  T  Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'))
 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C  (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb  U  Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫'))
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then ya else yb)  (if C then T else U)  If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫'
  unfolding Try_def Premise_def Orelse_shortcut_def
  by (cases C; simp)


subsubsection ‹Conditioned Remains›

paragraph ‹When the conditional boolean is fixed›

φreasoner_group ToA_constant_remains = (%ToA_splitting_source, [%ToA_splitting_source-4,%ToA_splitting_source+2])
                                        for (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P)
                                         in ToA ‹›

lemma [φreason default %ToA_constant_remains except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y * R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
  unfolding REMAINS_def
  by simp


paragraph ‹Reduction›

subparagraph ‹Source›

lemma ToA_CR_src [φreason %ToA_red]:
  " Y * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 "
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp

lemma ToA_CR_src' [φreason %ToA_red]:
  " (Y * R) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 (Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 "
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp



subparagraph ‹Target›

lemma ToA_CR_target [φreason %ToA_red]:
  " Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * R 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
 Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 "
  unfolding 𝗋Guard_def Premise_def REMAINS_def
  by simp

subsubsection ‹Case Sum›

paragraph ‹Reduction›

subparagraph ‹Target›

lemma ToA_case_sum_target_L[φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inl x) 𝗐𝗂𝗍𝗁 P
  by simp

lemma ToA_case_sum_target_L'[φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inl x) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp

lemma ToA_case_sum_target_L_ty[φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  Ua c  R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  case_sum Ua Ub (Inl c)  R 𝗐𝗂𝗍𝗁 P
  by simp

lemma ToA_case_sum_target_R[φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B x 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inr x) 𝗐𝗂𝗍𝗁 P
  by simp

lemma ToA_case_sum_target_R'[φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inr x) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp

lemma ToA_case_sum_target_R_ty[φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  Ub c  R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  case_sum Ua Ub (Inr c)  R 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]: ― ‹This form can occur when reducing y ⦂ (T +φ U) ∗[C] R›
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (fst (x, y)) 𝗐𝗂𝗍𝗁 P
  by simp


subparagraph ‹Source›

lemma [φreason %ToA_red]:
  A x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 case_sum A B (Inl x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 case_sum A B (Inr x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  A x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 case_sum A B (Inl x) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 case_sum A B (Inr x) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]: ― ‹This form can occur when reducing x ⦂ (T +φ U) ∗[C] W›
  case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
 case_sum A B (fst (x, y)) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
  by simp


paragraph ‹Case Split›

subparagraph ‹Target›

lemma [φreason %ToA_splitting except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫)
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫
  by (cases x; simp)

lemma [φreason %ToA_splitting except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫]:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫)
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫)
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫
  by (cases x; simp add: Simplify_def)

lemma [φreason %ToA_splitting+1 except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (case_sum _ _ ?var)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  xx  T  Wa a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya a  Ua a  Ra a 𝗐𝗂𝗍𝗁 Pa a @tag 𝒯𝒫')
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  xx  T  Wb b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb b  Ub b  Rb b 𝗐𝗂𝗍𝗁 Pb b @tag 𝒯𝒫')
 xx  T  (case_sum Wa Wb x)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum ya yb x  (case_sum Ua Ub x)  (case_sum Ra Rb x)
    𝗐𝗂𝗍𝗁 case_sum Pa Pb x @tag 𝒯𝒫'
  unfolding Premise_def Try_def
  by (cases x; simp)


(*TODO: Type level case split on SE gonna be a disaster!
        Every type variables between the two branches have to be independent! but here, the Ra and Rb
        are forced having identical abstract type! The abstract type of Ra and Rb instead should be
        a sum type!
  TODO: the case split now is broken!
*)
(*
lemma (*TODO-0918*)
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ (xx, wa a) ⦂ T ∗[CWa a] Wa a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya a ⦂ Ua a ∗[Ca a] Ra a 𝗐𝗂𝗍𝗁 Pa a)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ (xx, wb b) ⦂ T ∗[CWb b] Wb b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb b ⦂ Ub b ∗[Cb b] Rb b 𝗐𝗂𝗍𝗁 Pb b)
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Sa ∨ Sb
⟹ (xx, case_sum (Inl o wa) (Inr o wb) x) ⦂ T ∗[case_sum CWa CWb x] (case_sum (Inlφ Wa) (Inrφ Wb) x)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum ya yb x ⦂ (case_sum Ua Ub x) ∗[case_sum Ca Cb x] (case_sum Ra Rb x) 𝗐𝗂𝗍𝗁 case_sum Pa Pb x ›
  unfolding Premise_def Try_def
  sorry
*)

lemma [φreason %ToA_splitting except _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (case_sum _ _ ?var)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫']:
  (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  xx  T  Wa a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya a  Ua a  Ra a 𝗐𝗂𝗍𝗁 Pa a @tag 𝒯𝒫')
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  xx  T  Wb b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb b  Ub b  Rb b 𝗐𝗂𝗍𝗁 Pb b @tag 𝒯𝒫')
 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Sa  Sb
 xx  T  (case_sum Wa Wb x)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum ya yb x  (case_sum Ua Ub x)  (case_sum Ra Rb x) 𝗐𝗂𝗍𝗁 case_sum Pa Pb x @tag 𝒯𝒫'
  unfolding Premise_def Try_def
  by (cases x; simp)

(*
lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›
                                     ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ (id ?var) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra a 𝗐𝗂𝗍𝗁 P a)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb b 𝗐𝗂𝗍𝗁 Q b)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def)*)


subparagraph ‹Source›

lemma ToA_case_sum_src:
  Y = case_sum Ya Yb x
 (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 P = (λ_. False) cut (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 Q = (λ_. False) cut (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
 case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

lemma ToA_case_sum_src_R:
  Y = case_sum Ya Yb x
 (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 (Ca,Ra,P) = ((λ_. True),0,(λ_. False)) cut (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 (Cb,Rb,Q) = ((λ_. True),0,(λ_. False)) cut (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
 case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

(*lemma ToA_case_sum_src_R':
  ‹ Y ≡ case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,(λ_. False))) ∨cut (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra a 𝗐𝗂𝗍𝗁 P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,(λ_. False))) ∨cut (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb b 𝗐𝗂𝗍𝗁 Q b))
⟹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def)*)
(*
lemma [φreason %ToA_splitting for ‹case_sum (λ_. _ ⦂ _ ∗[_] _) (λ_. _ ⦂ _ ∗[_] _) _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧𝗋 (ya,CWa,Wa,Ca,Ra,P) = (unspec, (λ_. True), (λ_. ⊥φ), (λ_. True), (λ_. ⊥φ), (λ_. False)) ∨cut
                                (xa a ⦂ Ta a ∗[CWa a] Wa a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya a ⦂ U ∗[Ca a] Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧𝗋 (yb,CWb,Wb,Cb,Rb,Q) = (unspec, (λ_.True), (λ_. ⊥φ), (λ_.True), (λ_. ⊥φ), (λ_. False)) ∨cut
                                (xb b ⦂ Tb b ∗[CWb b] Wb b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb b ⦂ U ∗[Cb b] Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
⟹ (case x of Inl a ⇒ xa a ⦂ Ta a ∗[CWa a] Wa a | Inr b ⇒ xb b ⦂ Tb b ∗[CWb b] Wb b)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum ya yb x ⦂ U ∗[case_sum Ca Cb x] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  unfolding Try_def Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def
  by (cases x; simp)
*)
(*
lemma [φreason %ToA_splitting+1 for ‹case_sum _ _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,(λ_. False))) ∨cut
                                (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya a ⦂ U ∗[True] Ra a 𝗐𝗂𝗍𝗁 P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,(λ_. False))) ∨cut
                                (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb b ⦂ U ∗[True] Rb b 𝗐𝗂𝗍𝗁 Q b))
⟹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum ya yb x ⦂ U ∗[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def)*)

lemma ToA_case_sum_src_W:
  Y = case_sum Ya Yb x
 (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 P = (λ_. False) cut (A a * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 Q = (λ_. False) cut (B b * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
 case_sum A B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

lemma ToA_case_sum_src_WR:
  Y = case_sum Ya Yb x
 (a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 (Ca,Ra,P) = ((λ_. True),0,(λ_. False)) cut
                                (A a * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
 (b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b  𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False 𝗋 (Cb,Rb,Q) = ((λ_. True),0,(λ_. False)) cut
                                (B b * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
 case_sum A B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

(*lemma ToA_case_sum_src_WR':
  ‹ Y ≡ case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,(λ_. False))) ∨cut (W * A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra a 𝗐𝗂𝗍𝗁 P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,(λ_. False))) ∨cut (W * B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb b 𝗐𝗂𝗍𝗁 Q b))
⟹ W * case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def)
*)
lemma case_sum_degenerate:
  (case_sum (λ_. a) (λ_. a) x)  a
  unfolding atomize_eq
  by (cases x; simp) 

lemma sum_case_distrib_fx:
  (case_sum fa fb x) (case_sum va vb x)  (case_sum (λx. fa x (va x)) (λx. fb x (vb x)) x)
  unfolding atomize_eq
  by (cases x; simp)

lemma sum_case_distrib_arg:
  (case_sum fa fb x) a  (case_sum (λx. fa x a) (λx. fb x a) x)
  unfolding atomize_eq
  by (cases x; simp)

ML (*instantiates variables vs to ‹case_sum va vb x› for each*)
fun reasoner_ToA_conditioned_subgoals_sum ctxt'N (vars,Y,RHS) =
  let val (Ya, Yb, x) = Phi_Help.dest_triop_c const_namecase_sum RHS
      val Typesum ta tb = Thm.typ_of_cterm x
      val ([Na,Nb], ctxt'N) = Variable.variant_fixes ["xa","xb"] ctxt'N
      val xa = Thm.cterm_of ctxt'N (Free (Na, ta))
      val xb = Thm.cterm_of ctxt'N (Free (Nb, tb))
      val x_term = Thm.term_of x

      val Ya_s = map (fn ((N,i),ty) => Thm.apply (Thm.var ((N,i+2), Thm.ctyp_of ctxt'N (ta --> ty))) xa) vars
      val Yb_s = map (fn ((N,i),ty) => Thm.apply (Thm.var ((N,i+3), Thm.ctyp_of ctxt'N (tb --> ty))) xb) vars 
      val Y_s  = map2 (fn a => fn b =>
                   let val ty = Thm.typ_of_cterm a
                    in Thm.apply (Thm.apply (Thm.apply (
                            Thm.cterm_of ctxt'N Constcase_sum ta ty tb) (Thm.dest_fun a)
                        ) (Thm.dest_fun b)) x
                   end) Ya_s Yb_s
      val Ya' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Ya_s)) Y
             |> Thm.lambda xa
      val Yb' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Yb_s)) Y
             |> Thm.lambda xb
      fun mk_inst ctm Y =
        case Thm.term_of ctm
          of _ $ Free _ => mk_inst (Thm.dest_fun ctm) (Thm.lambda (Thm.dest_arg ctm) Y)
           | Var v => (v, Y)
           | _ => error "BUG: reasoner_ToA_conditioned_subgoals"

   in (Vars.make (mk_inst Ya Ya' :: mk_inst Yb Yb' :: (vars ~~ Y_s)), x_term)
  end

φreasoner_ML ML (case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫) %ToA_splitting
        ( case_sum _ _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
        | except case_sum _ _ ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫)
  = Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_case_sum_src}, @{thm' ToA_case_sum_src_R}, (*@{thm' ToA_case_sum_src_R'},*)
          (true, @{thms' case_sum_degenerate}, @{thms' sum.case}),
          reasoner_ToA_conditioned_subgoals_sum, context) o snd

φreasoner_ML ML (case_sum A B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫) %ToA_splitting
        ( case_sum _ _ _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫
        | except case_sum _ _ ?var * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 )
  = Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_case_sum_src_W}, @{thm' ToA_case_sum_src_WR}, (*@{thm' ToA_case_sum_src_WR'},*)
          (true, @{thms' case_sum_degenerate}, @{thms' sum.case}),
          reasoner_ToA_conditioned_subgoals_sum, context) o snd


paragraph ‹When the sum type is a variable›

subparagraph ‹Normalizing›

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B var 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (id var) 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (id var) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R 𝗐𝗂𝗍𝗁 P
  by simp

lemma [φreason %ToA_red]:
  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  (case_sum A B var)  R 𝗐𝗂𝗍𝗁 P
 X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y  (case_sum A B (id var))  R 𝗐𝗂𝗍𝗁 P
  by simp

subparagraph ‹Major Reasoning›

declare [[
    φreason ! %ToA_branches ToA_case_sum_target_L ToA_case_sum_target_R
        for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫,
    φreason ! %ToA_branches ToA_case_sum_target_L' ToA_case_sum_target_R'
        for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫,
    φreason ! %ToA_branches ToA_case_sum_target_L_ty ToA_case_sum_target_R_ty
        for _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _  (case_sum _ _ ?var)  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'
]]

(*TODO: the source part!*)


section ‹Helpful Stuffs›

subsection ‹Methods›

method_setup represent_BI_pred_in_φType = Args.term >> (fn X => fn ctxt => Method.METHOD (K (fn th =>
  let val T = Thm.cterm_of ctxt X
      val ty_a = Thm.ctyp_of_cterm T |> Thm.dest_ctyp0
      val ty_c = Thm.ctyp_of_cterm T |> Thm.dest_ctyp1 |> Thm.dest_ctyp0
   in case Thm.prop_of th
   of Const(const_namePure.imp, _) $ _ $ _ =>
      Seq.single (Conv.gconv_rule (Conv.bottom_conv (fn _ => fn ctm =>
       case Thm.term_of ctm
         of X' $ _ => if X' aconv X
                      then Conv.rewr_conv instantiateT and x = Thm.dest_arg ctm
                                                        and 'c = ty_c and 'a = ty_a
                                                        in lemma T x  x  T for T :: ('c,'a) φ
                                                              by (simp add: φType_def) ctm
                      else Conv.all_conv ctm
          | _ => Conv.all_conv ctm
      ) ctxt) 1 th)
    | _ => Seq.empty
  end
)))

end