theory Proof_5_8
  imports Proof_5
begin

abbreviation s where "s s0 requestButton_value \<equiv> (toEnv
          (setPstate
            (setVarBool (setVarBool (setVarAny s0 requestButton_value) minimalRed PRESSED) redAfterMinimalRed
              NOT_PRESSED)
            Ctrl green)) "

lemma VC8_R5_aux1: "toEnvP s0 \<and>  getPstate (setVarAny s0 requestButton_value) Ctrl = redToGreen \<and>
RED_TO_GREEN_TIME_LIMIT \<le> ltimeEnv (setVarAny s0 requestButton_value) Ctrl \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = redToGreen \<longrightarrow>
           0 < ltimeEnv s1 Ctrl \<and> ltimeEnv s1 Ctrl \<le> RED_TO_GREEN_TIME_LIMIT) \<Longrightarrow>
ltimeEnv s0 Ctrl = RED_TO_GREEN_TIME_LIMIT"
  using substate_refl by auto

lemma VC8_R5_aux2: "toEnvP s2 \<and>substate s2 s3 \<and>  s3 = s s0 requestButton_value \<and> toEnvNum s2 s3 < T1 \<and> substate s2 s0 \<Longrightarrow>
toEnvNum s2 s0 < T1 - 1"
  apply auto
   apply(simp split: if_splits)
  using substate_refl substate_asym[of s0 "s s0 requestButton_value"] by auto

lemma VC8_R5_aux3: "toEnvP s2 \<and> toEnvP s0 \<and> substate s2 s0 \<and> toEnvNum s2 s3 < T1 \<and> s3 = s s0 requestButton_value \<Longrightarrow>
toEnvNum s2 s0 < T1"
  apply auto
  apply(simp split: if_splits)
  using substate_refl substate_asym[of s0 "s s0 requestButton_value"] by  auto

lemma VC8_R5: " ((toEnvP s0 \<and>
         (\<forall>s1 s2 s3.
             substate s1 s2 \<and>
             substate s2 s3 \<and>
             substate s3 s0 \<and>
             toEnvP s1 \<and>
             toEnvP s2 \<and>
             toEnvP s3 \<and>
             toEnvNum s1 s2 = Ctrl \<and>
             toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<longrightarrow>
             getVarBool s3 minimalRed = NOT_PRESSED)) \<and>
        toEnvP s0 \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = minimalRed \<longrightarrow>
              0 < ltimeEnv s1 Ctrl \<and> ltimeEnv s1 Ctrl \<le> MINIMAL_RED_TIME_LIMIT) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = minimalRed \<longrightarrow>
              (\<exists>s2. toEnvP s2 \<and>
                    substate s2 s1 \<and>
                    toEnvNum s2 s1 = ltimeEnv s1 Ctrl \<and> getPstate s2 Ctrl = green \<and> ltimeEnv s2 Ctrl = T2) \<or>
              (\<forall>s2. toEnvP s2 \<and> substate s2 s1 \<longrightarrow> getPstate s2 Ctrl = minimalRed)) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and> substate s2 s0 \<and> getPstate s2 Ctrl = minimalRed \<and> toEnvNum s1 s2 < ltimeEnv s2 Ctrl \<longrightarrow>
            getPstate s1 Ctrl = minimalRed) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and>
            substate s2 s0 \<and> (\<forall>s3. toEnvP s3 \<and> substate s1 s3 \<and> substate s3 s2 \<longrightarrow> getPstate s3 Ctrl = minimalRed) \<longrightarrow>
            toEnvNum s1 s2 = ltimeEnv s2 Ctrl - ltimeEnv s1 Ctrl) \<and>
        (\<forall>s1. toEnvP s1 \<and>
              substate s1 s0 \<and>
              getPstate s1 Ctrl = redAfterMinimalRed \<and> getVarBool s1 redAfterMinimalRed = NOT_PRESSED \<longrightarrow>
              (\<exists>s2. toEnvP s2 \<and>
                    substate s2 s1 \<and>
                    getPstate s2 Ctrl = minimalRed \<and>
                    ltimeEnv s2 Ctrl = MINIMAL_RED_TIME_LIMIT \<and>
                    getVarBool s2 redAfterMinimalRed = NOT_PRESSED \<and>
                    (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s1 \<and> s2 \<noteq> s3 \<longrightarrow>
                          getPstate s3 Ctrl = redAfterMinimalRed \<and>
                          getVarBool s3 redAfterMinimalRed = NOT_PRESSED \<and> getVarBool s3 Ctrl = NOT_PRESSED))) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = redToGreen \<longrightarrow>
              0 < ltimeEnv s1 Ctrl \<and> ltimeEnv s1 Ctrl \<le> RED_TO_GREEN_TIME_LIMIT) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = redToGreen \<longrightarrow>
              (\<exists>s2. toEnvP s2 \<and>
                    substate s2 s1 \<and>
                    toEnvNum s2 s1 = ltimeEnv s1 Ctrl \<and>
                    getPstate s2 Ctrl = redAfterMinimalRed \<and>
                    (getVarBool s2 redAfterMinimalRed = PRESSED \<or> getVarBool s2 Ctrl = PRESSED))) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and> substate s2 s0 \<and> toEnvNum s1 s2 < ltimeEnv s2 Ctrl \<and> getPstate s2 Ctrl = redToGreen \<longrightarrow>
            getPstate s1 Ctrl = redToGreen) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and>
            substate s2 s0 \<and> (\<forall>s3. toEnvP s3 \<and> substate s1 s3 \<and> substate s3 s2 \<longrightarrow> getPstate s3 Ctrl = redToGreen) \<longrightarrow>
            toEnvNum s1 s2 = ltimeEnv s2 Ctrl - ltimeEnv s1 Ctrl) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = green \<longrightarrow>
              0 < ltimeEnv s1 Ctrl \<and> ltimeEnv s1 Ctrl \<le> T2) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = green \<longrightarrow>
              (\<exists>s2. toEnvP s2 \<and>
                    substate s2 s1 \<and>
                    toEnvNum s2 s1 = ltimeEnv s1 Ctrl \<and>
                    getPstate s2 Ctrl = redToGreen \<and> ltimeEnv s2 Ctrl = RED_TO_GREEN_TIME_LIMIT)) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and> substate s2 s0 \<and> getPstate s2 Ctrl = green \<and> toEnvNum s1 s2 < ltimeEnv s2 Ctrl \<longrightarrow>
            getPstate s1 Ctrl = green) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and>
            substate s2 s0 \<and> (\<forall>s3. toEnvP s3 \<and> substate s1 s3 \<and> substate s3 s2 \<longrightarrow> getPstate s3 Ctrl = green) \<longrightarrow>
            toEnvNum s1 s2 = ltimeEnv s2 Ctrl - ltimeEnv s1 Ctrl) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = green \<longrightarrow> getVarBool s1 minimalRed = PRESSED) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl \<noteq> green \<longrightarrow> getVarBool s1 minimalRed = NOT_PRESSED) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<longrightarrow>
              getPstate s1 Ctrl = minimalRed \<or>
              getPstate s1 Ctrl = redAfterMinimalRed \<or> getPstate s1 Ctrl = redToGreen \<or> getPstate s1 Ctrl = green) \<and>
        (\<forall>s1 s2.
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            substate s1 s2 \<and>
            substate s2 s0 \<and>
            toEnvNum s1 s2 < ltimeEnv s2 Ctrl - Ctrl \<and>
            getPstate s2 Ctrl = minimalRed \<and> getVarBool s2 redAfterMinimalRed = NOT_PRESSED \<longrightarrow>
            getVarBool s1 Ctrl = NOT_PRESSED) \<and>
        (\<forall>s2. toEnvP s2 \<and>
              substate s2 s0 \<and> getPstate s2 Ctrl = minimalRed \<and> getVarBool s2 redAfterMinimalRed = PRESSED \<longrightarrow>
              (\<exists>s1. toEnvP s1 \<and>
                    substate s1 s2 \<and> toEnvNum s1 s2 < ltimeEnv s2 Ctrl - Ctrl \<and> getVarBool s1 Ctrl = PRESSED)) \<and>
        (\<forall>s1. toEnvP s1 \<and>
              substate s1 s0 \<and> getPstate s1 Ctrl = redAfterMinimalRed \<and> getVarBool s1 redAfterMinimalRed \<longrightarrow>
              (\<exists>s2. toEnvP s2 \<and>
                    substate s2 s1 \<and>
                    toEnvNum s2 s1 = Ctrl \<and>
                    getPstate s2 Ctrl = minimalRed \<and>
                    ltimeEnv s2 Ctrl = MINIMAL_RED_TIME_LIMIT \<and>
                    (getVarBool s2 redAfterMinimalRed \<or> getVarBool s1 Ctrl = PRESSED))) \<and>
        (\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 Ctrl = green \<longrightarrow>
              getVarBool s1 redAfterMinimalRed = NOT_PRESSED)) \<and>
       env (setVarAny s0 requestButton_value) requestButton_value \<and>
       getPstate (setVarAny s0 requestButton_value) Ctrl = redToGreen \<and>
       RED_TO_GREEN_TIME_LIMIT \<le> ltimeEnv (setVarAny s0 requestButton_value) Ctrl \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2 s3 \<and>
       substate s3 (s s0 requestButton_value) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvP s3 \<and>
       toEnvNum s1 s2 = Ctrl \<and>
       toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<Longrightarrow>
       getVarBool s3 minimalRed = NOT_PRESSED"

  apply(cases "s3 = s s0 requestButton_value")
   apply(cases "s2 = s s0 requestButton_value")
    apply blast
   apply(rule cut_rl[of "substate s2 s0"])
    apply(rule cut_rl[of "toEnvNum s1 s0 < T1"])
apply(rule cut_rl[of "\<forall>s2. toEnvP s2 \<and> substate s2 s0 \<and> toEnvNum s2 s0 \<le> T1
 \<longrightarrow>      getVarBool s2 minimalRed = NOT_PRESSED"])
apply (meson less_or_eq_imp_le substate_trans)
     apply(rule cut_rl[of "\<forall>s2. toEnvP s2 \<and> substate s2 s0 \<and> toEnvNum s2 s0 \<le> MINIMAL_RED_TIME_LIMIT + ltimeEnv s0 Ctrl
 \<longrightarrow>      getVarBool s2 minimalRed = NOT_PRESSED"])
      apply(rule cut_rl[of "ltimeEnv s0 Ctrl = RED_TO_GREEN_TIME_LIMIT"])
       apply metis
      apply(rule VC8_R5_aux1)
      apply fast
     apply(rule redToGreen_red_at_least_T1[of _ s0])
     apply(rule cut_rl[of "getPstate s0 Ctrl = redToGreen"])
  using substate_refl apply fast
     apply (smt (verit) getPstate.simps(6))
    apply(rule cut_rl[of "toEnvNum s2 s0 < T1 - 1"])
  using toEnvNum3[of s1 s2 s0] apply arith
    apply(rule VC8_R5_aux2)
    apply blast
apply (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))
  apply(rule cut_rl [of "substate s3 s0"])
   apply meson
by (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))

theorem proof_5_8: "VC8 inv5 s0 requestButton_value"
  apply(simp only: VC8_def inv5_def R5_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
  apply(rule conjI)
   apply simp
  apply((rule allI);(rule allI);(rule allI))
  apply(rule impI)
   apply((rule VC8_R5);assumption)


theory Impl_List_Playground_ChairNetwork_statefulpolicy_example
imports "../TopoS_Impl"
begin

text\<open>An example of our chair network [simplified]\<close>

text\<open>Our access control view on the network\<close>
  definition ChairNetwork_empty :: "string list_graph" where
    "ChairNetwork_empty \<equiv> \<lparr> nodesL = [''WebSrv'', ''FilesSrv'', ''Printer'',
                                ''Students'',
                                ''Employees'',
                                ''Internet''],
                      edgesL = [] \<rparr>"

  lemma "wf_list_graph ChairNetwork_empty" by eval

subsection\<open>Our security requirements\<close>
  subsubsection\<open>We have a server with confidential data\<close>
    definition ConfidentialChairData::"(string SecurityInvariant)" where
      "ConfidentialChairData \<equiv> new_configured_list_SecurityInvariant SINVAR_BLPtrusted_impl.SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = [''FilesSrv'' \<mapsto> \<lparr> security_level = 1, trusted = False \<rparr>,
                             ''Employees'' \<mapsto> \<lparr> security_level = 0, trusted = True \<rparr>]
          \<rparr> ''confidential data''"

  subsubsection\<open>accessibly by employees and students\<close>
    definition "PrintingACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''Printer'' \<mapsto> Master [''Employees'', ''Students''],
                             ''Employees'' \<mapsto> Care,
                             ''Students'' \<mapsto> Care]
          \<rparr> ''printing acl''"

  subsubsection\<open>Printers are information sinks\<close>
    definition "PrintingSink \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_Sink \<lparr>
          node_properties = [''Printer'' \<mapsto> Sink]
          \<rparr> ''printing sink''"

  subsubsection\<open>Students and Employees may access each other but are not accessible from the outside\<close>
    definition "InternalSubnet \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = [''Students'' \<mapsto> Member, ''Employees'' \<mapsto> Member]
          \<rparr> ''internal subnet''"

  subsubsection\<open>The files server is only accessibly by employees\<close>
    definition "FilesSrvACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''FilesSrv'' \<mapsto> Master [''Employees''],
                             ''Employees'' \<mapsto> Care]
          \<rparr> ''file srv acl''"

definition "ChairSecurityRequirements = [ConfidentialChairData, PrintingACL, PrintingSink, InternalSubnet, FilesSrvACL]"

lemma "\<forall>m \<in> set ChairSecurityRequirements. implc_sinvar m ChairNetwork_empty" by eval

value "implc_get_offending_flows ChairSecurityRequirements ChairNetwork_empty"
value "generate_valid_topology ChairSecurityRequirements ChairNetwork_empty"

value "List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty)"

definition "ChairNetwork = generate_valid_topology ChairSecurityRequirements
      \<lparr>nodesL = nodesL ChairNetwork_empty, edgesL = List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty) \<rparr>"

value "ChairNetwork"

ML\<open>
visualize_graph @{context} @{term "ChairSecurityRequirements"} @{term "ChairNetwork"};
\<close>

definition "ChairNetwork_stateful_IFS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_IFS_no_violations ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_IFS_no_violations ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_IFS"
lemma "set (flows_stateL ChairNetwork_stateful_IFS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_IFS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_IFS)) - set (flows_stateL ChairNetwork_stateful_IFS)"
(*only problems: printers!!!*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_IFS"
lemma "set (filter_IFS_no_violations ChairNetwork [ConfidentialChairData]) = set (edgesL ChairNetwork)" by eval

definition "ChairNetwork_stateful_ACS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_ACS"
lemma "set (flows_stateL ChairNetwork_stateful_ACS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_ACS))"
  by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)"

(*flows that are already allowed in both directions are not marked as stateful*)
value "((set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)) - set (backlinks (flows_fixL ChairNetwork_stateful_ACS))"

(*the new backflows*)
value "set (edgesL (stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS)) - (set (edgesL ChairNetwork))"

(*the resulting ACS graph*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS"

value "generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"
value "generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements"
lemma "set (flows_fixL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) =
       set (flows_fixL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval
lemma "set (flows_stateL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) =
       set (flows_stateL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval

definition "ChairNetwork_stateful = generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"

ML_val\<open>
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful"})] "";
\<close>

(*these requirements impose no restrictoins on the stateful flows*)
definition "ChairNetwork_stateful_v2 = generate_valid_stateful_policy_IFSACS ChairNetwork
    [ConfidentialChairData, PrintingACL,  InternalSubnet, FilesSrvACL]"
ML_val\<open>
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful_v2"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]",
     @{term "flows_stateL ChairNetwork_stateful_v2"})] "";
\<close>

(*The sink requirements imposes the restriction that the printer cannot answer*)
definition "ChairNetwork_stateful_v3 = generate_valid_stateful_policy_IFSACS ChairNetwork [PrintingSink]"
ML_val\<open>
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful_v3"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful_v3"})] "";
\<close>

subsection\<open>An example of bad side-effects in access control policies\<close>

  definition ACL_not_with::"(string SecurityInvariant)" where
    "ACL_not_with \<equiv> new_configured_list_SecurityInvariant SINVAR_ACLnotCommunicateWith_impl.SINVAR_LIB_ACLnotCommunicateWith \<lparr>
        node_properties = [''A'' \<mapsto> {''C''},
                           ''B'' \<mapsto> {},
                           ''C'' \<mapsto> {}]
        \<rparr> ''example: a must not reach C''"

  definition simple_network :: "string list_graph" where
    "simple_network \<equiv> \<lparr> nodesL = [''A'', ''B'', ''C''],
                      edgesL = [(''B'', ''A''), (''B'', ''C'')] \<rparr>"

  lemma "wf_list_graph ChairNetwork_empty" by eval
  lemma "\<forall>m \<in> set [ACL_not_with]. implc_sinvar m simple_network" by eval

  lemma "implc_get_offending_flows [ACL_not_with] simple_network = []" by eval
  lemma "implc_get_offending_flows [ACL_not_with]
    \<lparr> nodesL = [''A'', ''B'', ''C''], edgesL = [(''B'', ''A''), (''B'', ''C''), (''A'', ''B'')] \<rparr> =
      [[(''B'', ''C'')], [(''A'', ''B'')]]" by eval
  lemma "implc_get_offending_flows [ACL_not_with]
    \<lparr> nodesL = [''A'', ''B'', ''C''], edgesL = [(''B'', ''A''), (''B'', ''C''), (''C'', ''B'')] \<rparr> =
      []" by eval

value "generate_valid_stateful_policy_IFSACS simple_network [ACL_not_with]"
value "generate_valid_stateful_policy_IFSACS_2 simple_network [ACL_not_with]"

subsection\<open>performance test\<close>
(*6 minutes , about 1.8k edges in graph, most of the times, no requirements apply,
  simply added some nodes, edges to the chair network. topology is valid*)
(*value "generate_valid_stateful_policy_IFSACS biggraph ChairSecurityRequirements"*)

end


section\<open>Relativization of the cumulative hierarchy\<close>
theory Univ_Relative
  imports
    "ZF-Constructible.Rank"
    "ZF.Univ"
    Discipline_Cardinal

begin

declare arity_ordinal_fm[arity]

context M_trivial
begin
declare powerset_abs[simp]

lemma family_union_closed: "\<lbrakk>strong_replacement(M, \<lambda>x y. y = f(x)); M(A); \<forall>x\<in>A. M(f(x))\<rbrakk>
      \<Longrightarrow> M(\<Union>x\<in>A. f(x))"
  using RepFun_closed ..

lemma family_union_closed': "\<lbrakk>strong_replacement(M, \<lambda>x y. x\<in>A \<and> y = f(x)); M(A); \<forall>x\<in>A. M(f(x))\<rbrakk>
      \<Longrightarrow> M(\<Union>x\<in>A. f(x))"
  using RepFun_closed2
  by simp

end \<comment> \<open>\<^locale>\<open>M_trivial\<close>\<close>

definition
  HVfrom :: "[i,i,i] \<Rightarrow> i" where
  "HVfrom(A,x,f) \<equiv> A \<union> (\<Union>y\<in>x. Powapply(f,y))"

relativize functional "HVfrom" "HVfrom_rel"
relationalize "HVfrom_rel" "is_HVfrom"
synthesize "is_HVfrom" from_definition assuming "nonempty"
arity_theorem intermediate for "is_HVfrom_fm"

lemma arity_is_HVfrom_fm:
  "A \<in> nat \<Longrightarrow>
    x \<in> nat \<Longrightarrow>
    f \<in> nat \<Longrightarrow>
    d \<in> nat \<Longrightarrow>
    arity(is_HVfrom_fm(A, x, f, d)) = succ(A) \<union> succ(d) \<union> (succ(x) \<union> succ(f))"
  using arity_is_HVfrom_fm' arity_is_Powapply_fm
  by(simp,subst arity_Replace_fm[of "is_Powapply_fm(succ(succ(succ(succ(f)))), 0, 1)" "succ(succ(x))" 1])
    (simp_all, auto simp add:arity pred_Un_distrib)

notation HVfrom_rel (\<open>HVfrom\<^bsup>_\<^esup>'(_,_,_')\<close>)

locale M_HVfrom = M_eclose +
  assumes
    Powapply_replacement:
    "M(f) \<Longrightarrow> strong_replacement(M,\<lambda>y z. z = Powapply\<^bsup>M\<^esup>(f,y))"
begin

is_iff_rel for "HVfrom"
proof -
  assume assms:"M(A)" "M(x)" "M(f)" "M(res)"
  then
  have "is_Replace(M,x,\<lambda>y z. z = Powapply\<^bsup>M\<^esup>(f,y),r) \<longleftrightarrow> r = {z . y\<in>x, z = Powapply\<^bsup>M\<^esup>(f,y)}"
    if "M(r)" for r
    using that Powapply_rel_closed
      Replace_abs[of x r "\<lambda>y z. z = Powapply\<^bsup>M\<^esup>(f,y)"] transM[of _ x]
    by simp
  moreover
  have "is_Replace(M,x,is_Powapply(M,f),r) \<longleftrightarrow>
        is_Replace(M,x,\<lambda>y z. z = Powapply\<^bsup>M\<^esup>(f,y),r)" if "M(r)" for r
    using assms that is_Powapply_iff is_Replace_cong
    by simp
  ultimately
  have "is_Replace(M,x,is_Powapply(M,f),r) \<longleftrightarrow> r = {z . y\<in>x, z = Powapply\<^bsup>M\<^esup>(f,y)}"
    if "M(r)" for r
    using that assms
    by simp
  moreover
  have "M({z . y \<in> x, z = Powapply\<^bsup>M\<^esup>(f,y)})"
    using assms strong_replacement_closed[OF Powapply_replacement]
      Powapply_rel_closed transM[of _ x]
    by simp
  moreover from assms
    \<comment> \<open>intermediate step for body of Replace\<close>
  have "{z . y \<in> x, z = Powapply\<^bsup>M\<^esup>(f,y)} = {y . w \<in> x, M(y) \<and> M(w) \<and> y = Powapply\<^bsup>M\<^esup>(f,w)}"
    by (auto dest:transM)
  ultimately
  show ?thesis
    using assms
    unfolding is_HVfrom_def HVfrom_rel_def
    by (auto dest:transM)
qed

rel_closed for "HVfrom"
proof -
  assume assms:"M(A)" "M(x)" "M(f)"
  have "M({z . y \<in> x, z = Powapply\<^bsup>M\<^esup>(f,y)})"
    using assms strong_replacement_closed[OF Powapply_replacement]
      Powapply_rel_closed transM[of _ x]
    by simp
  then
  have "M(A \<union> \<Union>({z . y\<in>x, z = Powapply\<^bsup>M\<^esup>(f,y)}))"
    using assms
    by simp
  moreover from assms
    \<comment> \<open>intermediate step for body of Replace\<close>
  have "{z . y \<in> x, z = Powapply\<^bsup>M\<^esup>(f,y)} = {y . w \<in> x, M(y) \<and> M(w) \<and> y = Powapply\<^bsup>M\<^esup>(f,w)}"
    by (auto dest:transM)
  ultimately
  show ?thesis
    using assms
    unfolding HVfrom_rel_def
    by simp
qed

end \<comment> \<open>\<^locale>\<open>M_HVfrom\<close>\<close>

definition
  Vfrom_rel :: "[i\<Rightarrow>o,i,i] \<Rightarrow> i" (\<open>Vfrom\<^bsup>_\<^esup>'(_,_')\<close>) where
  "Vfrom\<^bsup>M\<^esup>(A,i) = transrec(i, HVfrom_rel(M,A))"

definition
  is_Vfrom :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_Vfrom(M,A,i,z) \<equiv> is_transrec(M,is_HVfrom(M,A),i,z)"

definition
  Hrank :: "[i,i] \<Rightarrow> i" where
  "Hrank(x,f) \<equiv> (\<Union>y\<in>x. succ(f`y))"

definition
  rrank :: "i \<Rightarrow> i" where
  "rrank(a) \<equiv> Memrel(eclose({a}))^+"

relativize functional "Hrank" "Hrank_rel"
relationalize "Hrank_rel" "is_Hrank"
synthesize "is_Hrank" from_definition assuming "nonempty"

lemma arity_is_Hrank_fm : "x \<in> nat \<Longrightarrow>
    f \<in> nat \<Longrightarrow>
    d \<in> nat \<Longrightarrow>
    arity(is_Hrank_fm(x, f, d)) =
    succ(d) \<union> succ(x) \<union> succ(f)"
  unfolding is_Hrank_fm_def
  using  arity_fun_apply_fm arity_big_union_fm
    arity_fun_apply_fm arity_succ_fm arity_And arity_Exists
    arity_Replace_fm[of
      "(\<cdot>\<exists>\<cdot>\<cdot>succ(0) is 2\<cdot> \<and> \<cdot> succ(succ(succ(succ(f))))`1 is 0\<cdot>\<cdot>\<cdot>)"
      "succ(x)" 0 "4+\<^sub>\<omega>f"]
  by(simp_all add:Un_assoc pred_Un,simp add:ord_simp_union)

locale M_Vfrom = M_HVfrom +
  assumes
    trepl_HVfrom : "\<lbrakk> M(A);M(i) \<rbrakk> \<Longrightarrow> transrec_replacement(M,is_HVfrom(M,A),i)"
    and
    Hrank_replacement : "M(f) \<Longrightarrow> strong_replacement(M,\<lambda>x y . y = succ(f`x))"
    and
    is_Hrank_replacement : "M(x) \<Longrightarrow> wfrec_replacement(M,is_Hrank(M),rrank(x))"
    and
    HVfrom_replacement : "\<lbrakk> M(i) ; M(A) \<rbrakk> \<Longrightarrow>
                          transrec_replacement(M,is_HVfrom(M,A),i)"

begin

lemma Vfrom_rel_iff :
  assumes "M(A)" "M(i)" "M(z)" "Ord(i)"
  shows "is_Vfrom(M,A,i,z) \<longleftrightarrow> z = Vfrom\<^bsup>M\<^esup>(A,i)"
proof -
  have "relation2(M, is_HVfrom(M, A), HVfrom_rel(M, A))"
    using assms is_HVfrom_iff
    unfolding relation2_def
    by simp
  then
  show ?thesis
    using assms HVfrom_rel_closed trepl_HVfrom
      transrec_abs[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)" z]
    unfolding is_Vfrom_def Vfrom_rel_def
    by simp
qed

lemma relation2_HVfrom: "M(A) \<Longrightarrow> relation2(M,is_HVfrom(M,A),HVfrom_rel(M,A))"
  using is_HVfrom_iff
  unfolding relation2_def
  by auto

lemma HVfrom_closed :
  "M(A) \<Longrightarrow> \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(HVfrom_rel(M,A,x,g))"
  using HVfrom_rel_closed by simp

lemma Vfrom_rel_closed:
  assumes "M(A)" "M(i)" "Ord(i)"
  shows "M(transrec(i, HVfrom_rel(M, A)))"
  using is_HVfrom_iff HVfrom_closed HVfrom_replacement assms trepl_HVfrom relation2_HVfrom
    transrec_closed[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)"]
  by simp

lemma transrec_HVfrom:
  assumes "M(A)"
  shows "Ord(i) \<Longrightarrow> M(i) \<Longrightarrow> {x\<in>Vfrom(A,i). M(x)} = transrec(i,HVfrom_rel(M,A))"
proof (induct rule:trans_induct)
  have eq:"(\<Union>x\<in>i. {x \<in> Pow(transrec(x, HVfrom_rel(M, A))) . M(x)}) =  \<Union>{y . x \<in> i, y = Pow\<^bsup>M\<^esup>(transrec(x, HVfrom_rel(M, A)))}"
    if "Ord(i)" "M(i)" for i
    using assms Pow_rel_char[OF Vfrom_rel_closed[OF \<open>M(A)\<close> transM[of _ i]]] Ord_in_Ord' that
    by auto
  case (step i)
  then
  have 0: "M(Pow\<^bsup>M\<^esup>(transrec(x, HVfrom_rel(M, A))))" if "x\<in>i" for x
    using assms that transM[of _ i] Ord_in_Ord
      transrec_closed[of "is_HVfrom(M,A)" _ "HVfrom_rel(M,A)"] trepl_HVfrom relation2_HVfrom
    by auto
  have "Vfrom(A,i) = A \<union> (\<Union>y\<in>i. Pow((\<lambda>x\<in>i. Vfrom(A, x)) ` y))"
    using def_transrec[OF Vfrom_def, of A i] by simp
  then
  have "Vfrom(A,i) = A \<union> (\<Union>y\<in>i. Pow(Vfrom(A, y)))"
    by simp
  then
  have "{x\<in>Vfrom(A,i). M(x)} = {x\<in>A. M(x)} \<union> (\<Union>y\<in>i. {x\<in>Pow(Vfrom(A, y)). M(x)})"
    by auto
  with \<open>M(A)\<close>
  have "{x\<in>Vfrom(A,i). M(x)} = A \<union> (\<Union>y\<in>i. {x\<in>Pow(Vfrom(A, y)). M(x)})"
    by (auto intro:transM)
  also
  have "... = A \<union> (\<Union>y\<in>i. {x\<in>Pow({z\<in>Vfrom(A,y). M(z)}). M(x)})"
  proof -
    have "{x\<in>Pow(Vfrom(A, y)). M(x)} = {x\<in>Pow({z\<in>Vfrom(A,y). M(z)}). M(x)}"
      if "y\<in>i" for y by (auto intro:transM)
    then
    show ?thesis by simp
  qed
  also from step
  have " ... = A \<union> (\<Union>y\<in>i. {x\<in>Pow(transrec(y, HVfrom_rel(M, A))). M(x)})"
    using transM[of _ i]
    by auto
  also
  have " ... = transrec(i, HVfrom_rel(M, A))"
    using 0 step assms transM[of _ i] eq
      def_transrec[of "\<lambda>y. transrec(y, HVfrom_rel(M, A))" "HVfrom_rel(M, A)" i]
    unfolding Powapply_rel_def HVfrom_rel_def
    by auto
  finally
  show ?case .
qed

lemma Vfrom_abs: "\<lbrakk> M(A); M(i); M(V); Ord(i) \<rbrakk> \<Longrightarrow> is_Vfrom(M,A,i,V) \<longleftrightarrow> V = {x\<in>Vfrom(A,i). M(x)}"
  unfolding is_Vfrom_def
  using is_HVfrom_iff
    transrec_abs[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)"] trepl_HVfrom relation2_HVfrom
    transrec_HVfrom
  by simp

lemma Vfrom_closed: "\<lbrakk> M(A); M(i); Ord(i) \<rbrakk> \<Longrightarrow> M({x\<in>Vfrom(A,i). M(x)})"
  unfolding is_Vfrom_def
  using is_HVfrom_iff HVfrom_closed HVfrom_replacement
    transrec_closed[of "is_HVfrom(M,A)" i "HVfrom_rel(M,A)"] trepl_HVfrom relation2_HVfrom
    transrec_HVfrom
  by simp

end \<comment> \<open>\<^locale>\<open>M_Vfrom\<close>\<close>

subsection\<open>Formula synthesis\<close>

context M_Vfrom
begin

rel_closed for "Hrank"
  unfolding Hrank_rel_def
  using Hrank_replacement
  by simp

is_iff_rel for "Hrank"
proof -
  assume "M(f)" "M(x)" "M(res)"
  moreover from this
  have "{a . y \<in> x, M(a) \<and> M(y) \<and> a = succ(f ` y)} = {a . y \<in> x,  a = succ(f ` y)}"
    using transM[of _ x]
    by auto
  ultimately
  show ?thesis
    unfolding is_Hrank_def Hrank_rel_def
    using Replace_abs transM[of _ x] Hrank_replacement
    by auto
qed

lemma relation2_Hrank :
  "relation2(M,is_Hrank(M),Hrank)"
  unfolding  relation2_def
proof(clarify)
  fix x f res
  assume "M(x)" "M(f)" "M(res)"
  moreover from this
  have "{a . y \<in> x, M(a) \<and> M(y) \<and> a = succ(f ` y)} = {a . y \<in> x,  a = succ(f ` y)}"
    using transM[of _ x]
    by auto
  ultimately
  show "is_Hrank(M, x, f, res) \<longleftrightarrow> res = Hrank(x, f)"
    unfolding  Hrank_def relation2_def
    using is_Hrank_iff[unfolded Hrank_rel_def]
    by auto
qed

lemma Hrank_closed :
  "\<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(Hrank(x,g))"
proof(clarify)
  fix x g
  assume "M(x)" "M(g)"
  then
  show "M(Hrank(x,g))"
    using RepFun_closed[OF Hrank_replacement] transM[of _ x]
    unfolding Hrank_def
    by auto
qed

end \<comment>\<open>\<^locale>\<open>M_basic\<close>\<close>

context M_eclose
begin

lemma wf_rrank : "M(x) \<Longrightarrow> wf(rrank(x))"
  unfolding rrank_def using wf_trancl[OF wf_Memrel] .

lemma trans_rrank : "M(x) \<Longrightarrow> trans(rrank(x))"
  unfolding rrank_def using trans_trancl .

lemma relation_rrank : "M(x) \<Longrightarrow> relation(rrank(x))"
  unfolding rrank_def using relation_trancl .

lemma rrank_in_M : "M(x) \<Longrightarrow> M(rrank(x))"
  unfolding rrank_def by simp

end \<comment> \<open>\<^locale>\<open>M_eclose\<close>\<close>

lemma Hrank_trancl:"Hrank(y, restrict(f,Memrel(eclose({x}))-``{y}))
                  = Hrank(y, restrict(f,(Memrel(eclose({x}))^+)-``{y}))"
  unfolding Hrank_def
  using restrict_trans_eq by simp

lemma rank_trancl: "rank(x) = wfrec(rrank(x), x, Hrank)"
proof -
  have "rank(x) =  wfrec(Memrel(eclose({x})), x, Hrank)"
    (is "_ = wfrec(?r,_,_)")
    unfolding rank_def transrec_def Hrank_def by simp
  also
  have " ... = wftrec(?r^+, x, \<lambda>y f. Hrank(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, \<lambda>y f. Hrank(y, restrict(f,(?r^+)-``{y})))"
    using Hrank_trancl by simp
  also
  have " ... =  wfrec(?r^+, x, Hrank)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis unfolding rrank_def .
qed

definition
  Vset' :: "[i] \<Rightarrow> i" where
  "Vset'(A) \<equiv> Vfrom(0,A)"

reldb_add relational "Vfrom" "is_Vfrom"
reldb_add functional "Vfrom" "Vfrom_rel"
relativize functional "Vset'" "Vset_rel"
relationalize "Vset_rel" "is_Vset"
reldb_rem relational "Vset"
reldb_rem functional "Vset_rel"
reldb_add relational "Vset" "is_Vset"
reldb_add functional "Vset" "Vset_rel"

schematic_goal sats_is_Vset_fm_auto:
  assumes
    "i\<in>nat" "v\<in>nat" "env\<in>list(A)" "0\<in>A"
    "i < length(env)" "v < length(env)"
  shows
    "is_Vset(##A,nth(i, env),nth(v, env)) \<longleftrightarrow> sats(A,?ivs_fm(i,v),env)"
  unfolding is_Vset_def is_Vfrom_def
  by (insert assms; (rule sep_rules is_HVfrom_iff_sats is_transrec_iff_sats | simp)+)

synthesize "is_Vset" from_schematic "sats_is_Vset_fm_auto"
arity_theorem for "is_Vset_fm"
context M_Vfrom
begin

lemma Vset_abs: "\<lbrakk> M(i); M(V); Ord(i) \<rbrakk> \<Longrightarrow> is_Vset(M,i,V) \<longleftrightarrow> V = {x\<in>Vset(i). M(x)}"
  using Vfrom_abs unfolding is_Vset_def by simp

lemma Vset_closed: "\<lbrakk> M(i); Ord(i) \<rbrakk> \<Longrightarrow> M({x\<in>Vset(i). M(x)})"
  using Vfrom_closed unfolding is_Vset_def by simp

lemma rank_closed: "M(a) \<Longrightarrow> M(rank(a))"
  unfolding rank_trancl
  using Hrank_closed is_Hrank_replacement relation2_Hrank
    wf_rrank relation_rrank trans_rrank rrank_in_M
    trans_wfrec_closed[of "rrank(a)" a "is_Hrank(M)"]
    transM[of _ a]
  by auto

lemma M_into_Vset:
  assumes "M(a)"
  shows "\<exists>i[M]. \<exists>V[M]. ordinal(M,i) \<and> is_Vset(M,i,V) \<and> a\<in>V"
proof -
  let ?i="succ(rank(a))"
  from assms
  have "a\<in>{x\<in>Vfrom(0,?i). M(x)}" (is "a\<in>?V")
    using Vset_Ord_rank_iff by simp
  moreover from assms
  have "M(?i)"
    using rank_closed by simp
  moreover
  note \<open>M(a)\<close>
  moreover from calculation
  have "M(?V)"
    using Vfrom_closed by simp
  moreover from calculation
  have "ordinal(M,?i) \<and> is_Vfrom(M, 0, ?i, ?V) \<and> a \<in> ?V"
    using Ord_rank Vfrom_abs by simp
  ultimately
  show ?thesis
    using nonempty empty_abs
    unfolding is_Vset_def
    by blast
qed

end \<comment> \<open>\<^locale>\<open>M_HVfrom\<close>\<close>

end


theory Ex_Call
imports Monad2
begin

  datatype err = STATIC_ERROR

  type_synonym state = "string \<Rightarrow> int"

  datatype cmd =
      Basic "state \<Rightarrow> state"
    | Call "string option" string
    | Cond "state\<Rightarrow>bool" cmd cmd
    | Seq cmd cmd   (infixr ";;" 45)
    | Return "(state \<Rightarrow> int) option"

  abbreviation "static_check \<equiv> fcheck STATIC_ERROR"

  context
    fixes \<pi> :: "string \<rightharpoonup> (bool \<times> cmd)"
  begin
    definition "execute \<equiv> REC (\<lambda>execute cmd.
      case cmd of
        Basic f \<Rightarrow> doM { s\<leftarrow>get; set (f s) }
      | Return f \<Rightarrow> doM { s\<leftarrow>get; raise (map_option (\<lambda>f. f s) f) }
      | Call x n \<Rightarrow> doM {
          (rt,c) \<leftarrow> lookup STATIC_ERROR \<pi> n;
          r \<leftarrow> handle (doM {execute c; fail STATIC_ERROR}) (return);

          static_check (rt \<longleftrightarrow> r\<noteq>None); (* Procedure must match its return spec *)

          case (x,r) of
            (None,_) \<Rightarrow> return ()                (* Ignore result, if any *)
          | (Some _, None) \<Rightarrow> fail STATIC_ERROR  (* Void method expected to return result *)
          | (Some x, Some r) \<Rightarrow> doM {            (* Assign result *)
              s\<leftarrow>get; set (s(x:=r))
            }

        }
      | Cond b c1 c2 \<Rightarrow> doM {
          s\<leftarrow>get;
          if b s then
            execute c1
          else
            execute c2

        }
      | Seq c1 c2 \<Rightarrow> doM {
          execute c1;
          execute c2
        }
    )"

  end

  lemmas execute_code[code] = REC_unfold[OF execute_def, discharge_monos]
    and execute_unfold = REC_unfold[OF execute_def, discharge_monos]
    and execute_partial_rule = REC_partial_rule[OF execute_def, discharge_monos]
    and execute_total_rule = REC_total_rule[OF execute_def, discharge_monos]
    and execute_lrmwp_partial = lrmwpe_REC_partial[OF execute_def, discharge_monos, consumes 1, case_names nonterm step]
    and execute_lrmwp_total = lrmwpe_REC_total[OF execute_def, discharge_monos, consumes 1, case_names wf step]
    and execute_sim_rule[sim_rules] = sim_REC[OF execute_def execute_def, discharge_monos]

  lemma execute_sim:
    assumes "\<pi> \<subseteq>\<^sub>m \<pi>'"
    shows "sim (execute \<pi> c) (execute \<pi>' c)"
    by (auto split: cmd.split intro!: sim_rules assms)

  context
    fixes \<pi> :: "string \<rightharpoonup> (bool \<times> cmd)"
  begin
    fun wf_cmd where
      "wf_cmd nonvoid (Basic _) \<longleftrightarrow> True"
    | "wf_cmd nonvoid (Call r n) \<longleftrightarrow> (case \<pi> n of None \<Rightarrow> False | Some (rv,_) \<Rightarrow> r\<noteq>None \<longrightarrow> rv)"
    | "wf_cmd nonvoid (Seq c1 c2) \<longleftrightarrow> wf_cmd nonvoid c1 \<and> wf_cmd nonvoid c2"
    | "wf_cmd nonvoid (Cond _ c1 c2) \<longleftrightarrow> wf_cmd nonvoid c1 \<and> wf_cmd nonvoid c2"
    | "wf_cmd nonvoid (Return r) \<longleftrightarrow> nonvoid = (r\<noteq>None)"

    fun must_return where
      "must_return (Basic _) \<longleftrightarrow> False"
    | "must_return (Call _ _) \<longleftrightarrow> False"
    | "must_return (Seq c1 c2) \<longleftrightarrow> must_return c1 \<or> must_return c2"
    | "must_return (Cond _ c1 c2) \<longleftrightarrow> must_return c1 \<and> must_return c2"
    | "must_return (Return _) \<longleftrightarrow> True"

    fun wf_proc where
      "wf_proc (nonvoid, cmd) \<longleftrightarrow> must_return cmd \<and> wf_cmd nonvoid cmd"

  context
    assumes wf: "\<forall>p\<in>ran \<pi>. wf_proc p"
  begin

    lemma procE:
      assumes "\<pi> n = Some (nv,cmd)"
      obtains "must_return cmd" "wf_cmd nv cmd"
      using assms wf by (auto simp: ran_def)

    lemma
      assumes "run (execute \<pi> c) s = r"
      assumes "wf_cmd nonvoid c"
      shows "mwp r True bot (\<lambda>r _. nonvoid \<longleftrightarrow> r\<noteq>None) (\<lambda>_ _. \<not>must_return c)"
      using assms
    proof (induction arbitrary: nonvoid rule: execute_lrmwp_partial (*lrmwpe_REC_partial[OF execute_def, discharge_monos, consumes 1]*))
      case (nonterm x s)
      then show ?case by auto
    next
      case (step f x s r)
      note "step.IH"[OF refl, THEN mwp_cons, intro!]

      from "step.hyps" "step.prems" show ?case
        by (auto
          simp: run_simps
          elim: procE
          split: cmd.splits option.splits if_splits)

    qed
  end

end

definition "Assign x f \<equiv> Basic (\<lambda>s. (s(x:=f s)))"

fun peek_state where
  "peek_state vars NTERM = (NTERM, None)"
| "peek_state vars (FAIL f) = (FAIL f, None)"
| "peek_state vars (EXC e s) = (EXC e s, Some (map s vars))"
| "peek_state vars (SUCC r s) = (SUCC r s, Some (map s vars))"

value "peek_state [''x'',''y''] (run (execute (map_of [
  (''main'', (True, Assign ''x'' (\<lambda>s. s ''x'' + 42);; Return (Some (\<lambda>_. 41))))
]) (Call (Some ''y'') ''main'')) (\<lambda>_. 0))"

end


(* Title:     HOL/MiniML/Maybe.thy

   Author:    Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

header "Universal error monad"

theory Maybe
imports Main
begin

definition
  option_bind :: "['a option, 'a => 'b option] => 'b option" where
  "option_bind m f = (case m of None => None | Some r => f r)"

syntax "_option_bind" :: "[pttrns,'a option,'b] => 'c" ("(_ := _;//_)" 0)
translations "P := E; F" == "CONST option_bind E (%P. F)"

-- "constructor laws for @{text option_bind}"
lemma option_bind_Some: "option_bind (Some s) f = (f s)"
  by (simp add: option_bind_def)

lemma option_bind_None: "option_bind None f = None"
  by (simp add: option_bind_def)

declare option_bind_Some [simp] option_bind_None [simp]

-- "expansion of @{text option_bind}"
lemma split_option_bind: "P(option_bind res f) =
          ((res = None --> P None) & (!s. res = Some s --> P(f s)))"
  unfolding option_bind_def
  by (rule option.split)

lemma option_bind_eq_None [simp]:
    "((option_bind m f) = None) = ((m=None) | (? p. m = Some p & f p = None))"
  by (simp split: split_option_bind)

lemma rotate_Some: "(y = Some x) = (Some x = y)"
  by (simp add: eq_sym_conv)

end


subsection\<open>More Instances of Separation\<close>

theory Separation_Instances
  imports
    Interface
begin

text\<open>The following instances are mostly the same repetitive task; and we just
copied and pasted, tweaking some lemmas if needed (for example, we might have
needed to use some closure results).\<close>

definition radd_body :: "[i,i,i] \<Rightarrow> o" where
  "radd_body(R,S) \<equiv> \<lambda>z. (\<exists>x y. z = \<langle>Inl(x), Inr(y)\<rangle>) \<or>
                  (\<exists>x' x. z = \<langle>Inl(x'), Inl(x)\<rangle> \<and> \<langle>x', x\<rangle> \<in> R) \<or>
                  (\<exists>y' y. z = \<langle>Inr(y'), Inr(y)\<rangle> \<and> \<langle>y', y\<rangle> \<in> S)"

relativize functional "radd_body" "radd_body_rel"
relationalize "radd_body_rel" "is_radd_body"

synthesize "is_radd_body" from_definition
arity_theorem for "is_radd_body_fm"

definition rmult_body :: "[i,i,i] \<Rightarrow> o" where
  "rmult_body(b,d) \<equiv> \<lambda>z. \<exists>x' y' x y. z = \<langle>\<langle>x', y'\<rangle>, x, y\<rangle> \<and> (\<langle>x', x\<rangle> \<in> b \<or>
                              x' = x \<and> \<langle>y', y\<rangle> \<in> d)"

relativize functional "rmult_body" "rmult_body_rel"
relationalize "rmult_body_rel" "is_rmult_body"

synthesize "is_rmult_body" from_definition
arity_theorem for "is_rmult_body_fm"

lemma (in M_replacement) separation_well_ord_iso:
  "(M)(f) \<Longrightarrow> (M)(r) \<Longrightarrow> (M)(A) \<Longrightarrow> separation
        (M, \<lambda>x. x \<in> A \<longrightarrow> (\<exists>y[M]. \<exists>p[M]. is_apply(M, f, x, y) \<and> pair(M, y, x, p) \<and> p \<in> r))"
  using separation_imp separation_in lam_replacement_identity lam_replacement_constant
    lam_replacement_apply[of f] lam_replacement_product
  by simp

definition is_obase_body :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_obase_body(N,A,r,x) \<equiv> x \<in> A \<longrightarrow>
                  \<not> (\<exists>y[N].
                         \<exists>g[N].
                            ordinal(N, y) \<and>
                            (\<exists>my[N].
                                \<exists>pxr[N].
                                   membership(N, y, my) \<and>
                                   pred_set(N, A, x, r, pxr) \<and>
                                   order_isomorphism(N, pxr, r, y, my, g)))"

synthesize "is_obase_body" from_definition
arity_theorem for "is_obase_body_fm"

definition is_obase_equals :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_obase_equals(N,A,r,a) \<equiv> \<exists>x[N].
                     \<exists>g[N].
                        \<exists>mx[N].
                           \<exists>par[N].
                              ordinal(N, x) \<and>
                              membership(N, x, mx) \<and>
                              pred_set(N, A, a, r, par) \<and> order_isomorphism(N, par, r, x, mx, g)"

synthesize "is_obase_equals" from_definition
arity_theorem for "is_obase_equals_fm"

synthesize "PiP_rel" from_definition assuming "nonempty"
arity_theorem for "PiP_rel_fm"

synthesize "injP_rel" from_definition assuming "nonempty"
arity_theorem for "injP_rel_fm"

synthesize "surjP_rel" from_definition assuming "nonempty"
arity_theorem for "surjP_rel_fm"

context M_ZF1_trans
begin

lemma radd_body_abs:
  assumes "(##M)(R)" "(##M)(S)" "(##M)(x)"
  shows "is_radd_body(##M,R,S,x) \<longleftrightarrow> radd_body(R,S,x)"
  using assms pair_in_M_iff Inl_in_M_iff Inr_in_M_iff
  unfolding radd_body_def is_radd_body_def
  by (auto)

lemma separation_radd_body:
 "(##M)(R) \<Longrightarrow> (##M)(S) \<Longrightarrow> separation
        (##M, \<lambda>z. (\<exists>x y. z = \<langle>Inl(x), Inr(y)\<rangle>) \<or>
                  (\<exists>x' x. z = \<langle>Inl(x'), Inl(x)\<rangle> \<and> \<langle>x', x\<rangle> \<in> R) \<or>
                  (\<exists>y' y. z = \<langle>Inr(y'), Inr(y)\<rangle> \<and> \<langle>y', y\<rangle> \<in> S))"
  using separation_in_ctm[where \<phi>="is_radd_body_fm(1,2,0)" and env="[R,S]"]
    is_radd_body_def arity_is_radd_body_fm ord_simp_union is_radd_body_fm_type radd_body_abs
  unfolding radd_body_def
  by simp

lemma rmult_body_abs:
  assumes "(##M)(b)" "(##M)(d)" "(##M)(x)"
  shows "is_rmult_body(##M,b,d,x) \<longleftrightarrow> rmult_body(b,d,x)"
  using assms pair_in_M_iff apply_closed
  unfolding rmult_body_def is_rmult_body_def
  by (auto)

lemma separation_rmult_body:
 "(##M)(b) \<Longrightarrow> (##M)(d) \<Longrightarrow> separation
        (##M, \<lambda>z. \<exists>x' y' x y. z = \<langle>\<langle>x', y'\<rangle>, x, y\<rangle> \<and> (\<langle>x', x\<rangle> \<in> b \<or> x' = x \<and> \<langle>y', y\<rangle> \<in> d))"
  using separation_in_ctm[where \<phi>="is_rmult_body_fm(1,2,0)" and env="[b,d]"]
    is_rmult_body_def arity_is_rmult_body_fm ord_simp_union is_rmult_body_fm_type rmult_body_abs
  unfolding rmult_body_def
  by simp

lemma separation_is_obase:
 "(##M)(f) \<Longrightarrow> (##M)(r) \<Longrightarrow> (##M)(A) \<Longrightarrow> separation
        (##M, \<lambda>x. x \<in> A \<longrightarrow>
                  \<not> (\<exists>y[##M].
                         \<exists>g[##M].
                            ordinal(##M, y) \<and>
                            (\<exists>my[##M].
                                \<exists>pxr[##M].
                                   membership(##M, y, my) \<and>
                                   pred_set(##M, A, x, r, pxr) \<and>
                                   order_isomorphism(##M, pxr, r, y, my, g))))"
  using separation_in_ctm[where \<phi>="is_obase_body_fm(1,2,0)" and env="[A,r]"]
    is_obase_body_def arity_is_obase_body_fm ord_simp_union is_obase_body_fm_type
  by simp

lemma separation_obase_equals:
 "(##M)(f) \<Longrightarrow> (##M)(r) \<Longrightarrow> (##M)(A) \<Longrightarrow> separation
        (##M, \<lambda>a. \<exists>x[##M].
                     \<exists>g[##M].
                        \<exists>mx[##M].
                           \<exists>par[##M].
                              ordinal(##M, x) \<and>
                              membership(##M, x, mx) \<and>
                              pred_set(##M, A, a, r, par) \<and> order_isomorphism(##M, par, r, x, mx, g))"
  using separation_in_ctm[where \<phi>="is_obase_equals_fm(1,2,0)" and env="[A,r]"]
    is_obase_equals_def arity_is_obase_equals_fm ord_simp_union is_obase_equals_fm_type
  by simp

lemma separation_PiP_rel:
 "(##M)(A) \<Longrightarrow> separation(##M, PiP_rel(##M,A))"
  using separation_in_ctm[where env="[A]" and \<phi>="PiP_rel_fm(1,0)"]
    nonempty PiP_rel_iff_sats[symmetric] arity_PiP_rel_fm PiP_rel_fm_type
  by(simp_all add: ord_simp_union)

lemma separation_injP_rel:
 "(##M)(A) \<Longrightarrow> separation(##M, injP_rel(##M,A))"
  using separation_in_ctm[where env="[A]" and \<phi>="injP_rel_fm(1,0)"]
    nonempty injP_rel_iff_sats[symmetric] arity_injP_rel_fm injP_rel_fm_type
  by(simp_all add: ord_simp_union)

lemma separation_surjP_rel:
 "(##M)(A) \<Longrightarrow> (##M)(B) \<Longrightarrow> separation(##M, surjP_rel(##M,A,B))"
  using separation_in_ctm[where env="[A,B]" and \<phi>="surjP_rel_fm(1,2,0)"]
    nonempty surjP_rel_iff_sats[symmetric] arity_surjP_rel_fm surjP_rel_fm_type
  by(simp_all add: ord_simp_union)

lemma separation_is_function:
 "separation(##M, is_function(##M))"
  using separation_in_ctm[where env="[]" and \<phi>="function_fm(0)"] arity_function_fm
  by simp

end \<comment> \<open>\<^locale>\<open>M_ZF1_trans\<close>\<close>

(* Instances in M_replacement*)

definition fstsnd_in_sndsnd :: "[i] \<Rightarrow> o" where
  "fstsnd_in_sndsnd \<equiv> \<lambda>x. fst(snd(x)) \<in> snd(snd(x))"
relativize "fstsnd_in_sndsnd" "is_fstsnd_in_sndsnd"
synthesize "is_fstsnd_in_sndsnd" from_definition assuming "nonempty"
arity_theorem for "is_fstsnd_in_sndsnd_fm"

definition sndfst_eq_fstsnd :: "[i] \<Rightarrow> o" where
  "sndfst_eq_fstsnd \<equiv> \<lambda>x. snd(fst(x)) = fst(snd(x))"
relativize "sndfst_eq_fstsnd" "is_sndfst_eq_fstsnd"
synthesize "is_sndfst_eq_fstsnd" from_definition assuming "nonempty"
arity_theorem for "is_sndfst_eq_fstsnd_fm"

context M_ZF1_trans
begin

lemma fstsnd_in_sndsnd_abs:
  assumes "(##M)(x)"
  shows "is_fstsnd_in_sndsnd(##M,x) \<longleftrightarrow> fstsnd_in_sndsnd(x)"
  using assms pair_in_M_iff fst_abs snd_abs fst_snd_closed
  unfolding fstsnd_in_sndsnd_def is_fstsnd_in_sndsnd_def
  by auto

lemma separation_fstsnd_in_sndsnd:
 "separation(##M, \<lambda>x. fst(snd(x)) \<in> snd(snd(x)))"
  using separation_in_ctm[where env="[]" and \<phi>="is_fstsnd_in_sndsnd_fm(0)" and Q=fstsnd_in_sndsnd]
    nonempty fstsnd_in_sndsnd_abs arity_is_fstsnd_in_sndsnd_fm
  unfolding fstsnd_in_sndsnd_def
  by simp

lemma sndfst_eq_fstsnd_abs:
  assumes "(##M)(x)"
  shows "is_sndfst_eq_fstsnd(##M,x) \<longleftrightarrow> sndfst_eq_fstsnd(x)"
  using assms pair_in_M_iff fst_abs snd_abs fst_snd_closed
  unfolding sndfst_eq_fstsnd_def is_sndfst_eq_fstsnd_def
  by auto

lemma separation_sndfst_eq_fstsnd:
 "separation(##M, \<lambda>x. snd(fst(x)) = fst(snd(x)))"
  using separation_in_ctm[where env="[]" and \<phi>="is_sndfst_eq_fstsnd_fm(0)" and Q=sndfst_eq_fstsnd]
    nonempty sndfst_eq_fstsnd_abs arity_is_sndfst_eq_fstsnd_fm
  unfolding sndfst_eq_fstsnd_def
  by simp

end  \<comment> \<open>\<^locale>\<open>M_ZF1_trans\<close>\<close>

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: uexpr.thy                                                            *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 14 Feb 2017 *)

section \<open>Generic Expressions\<close>

theory uexpr
imports uvar ustate ustore ulens
keywords "declare_uvar" :: thy_decl
begin

default_sort type

subsection \<open>Expression Type\<close>

text \<open>
  Expressions are modelled by functions from states to HOL values. We make no
  assumptions about the state here, although operators may impose additional
  sort constraints on the state type such as membership to class @{class ust}.
  We note that if we \emph{did} require that the state types of expressions are
  always a member of class @{class ust}, there is actually the possibility of
  recording an alphabet i.e.~of axiomatic variables for the expression. This,
  however, turns out to require a notion of \emph{partial} lenses, because we
  would need to define monomorphic versions of the axiomatic variable lenses.
  Such is needed to formulate the unrestriction property of the state function.
  (Simon Foster is currently working on the integration of partial lenses.)
\<close>

typedef ('a, '\<sigma>(*::ust*)) expr = "UNIV::('\<sigma> \<Rightarrow> 'a) set"
apply (rule UNIV_witness)
done

notation Rep_expr ("\<lbrakk>_\<rbrakk>")

text \<open>
  The notation @{text "'a expr['\<sigma>]"} is introduced as a syntactic sugar for
  @{text "('a, '\<sigma>) expr"}. Moreover @{text "'a uexpr"} is synonymous for the
  type @{text "'a expr[ustate]"}.
\<close>

type_notation expr ("_ expr[_]" [1000, 0] 1000)

syntax "_uexpr" :: "type \<Rightarrow> type" ("_ uexpr" [1000] 1000)

translations (type) "'a uexpr" \<rightleftharpoons> (type) "'a expr[ustate]"

subsection \<open>Predicate Type\<close>

text \<open>Predicates are expressions instantiated with type @{type bool}.\<close>

syntax "_pred" :: "type \<Rightarrow> type" ("pred[_]")

translations (type) "pred['\<sigma>]" \<rightleftharpoons> (type) "bool expr['\<sigma>]"

syntax "_upred" :: "type" ("upred")

translations (type) "upred" \<rightleftharpoons> (type) "pred[ustate]"

subsection \<open>Lifted Constructors\<close>

setup_lifting type_definition_expr

lift_definition lit_expr :: "'a \<Rightarrow> 'a expr['\<sigma>]" ("\<guillemotleft>_\<guillemotright>")
is "\<lambda>c. (\<lambda>_. c)"
done

lift_definition var_expr :: "'a::injectable var \<Rightarrow> 'a uexpr"
is "\<lambda>v. (\<lambda>s. s\<star>v)"
done

lift_definition avar_expr :: "'a::injectable var \<Rightarrow> 'a expr['\<sigma>::ust]"
is "\<lambda>v. get\<^bsub>avar_ust\<^sub>L v\<^esub>"
done

lift_definition uop_expr ::
  "('a \<Rightarrow> 'b) \<Rightarrow> ('a expr['\<sigma>] \<Rightarrow> 'b expr['\<sigma>])"
is "\<lambda>f. \<lambda>e. (\<lambda>s. f (e s))"
done

lift_definition bop_expr ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a expr['\<sigma>] \<Rightarrow> 'b expr['\<sigma>] \<Rightarrow> 'c expr['\<sigma>])"
is "\<lambda>f. \<lambda>e\<^sub>1 e\<^sub>2. (\<lambda>s. f (e\<^sub>1 s) (e\<^sub>2 s))"
done

lift_definition trop_expr ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow>
    ('a expr['\<sigma>] \<Rightarrow> 'b expr['\<sigma>] \<Rightarrow> 'c expr['\<sigma>] \<Rightarrow> 'd expr['\<sigma>])"
is "\<lambda>f. \<lambda>e\<^sub>1 e\<^sub>2 e\<^sub>3. (\<lambda>s. f (e\<^sub>1 s) (e\<^sub>2 s) (e\<^sub>3 s))"
done

text \<open>
  The binding lifting functor can only deal with simple unary binders i.e.~of
  type @{typ "('a \<Rightarrow> 'b) \<Rightarrow> 'c"}. Fortunately, most Isabelle/HOL binders fall
  into that category, including various types of quantifiers. For instance, the
  functor @{const All}, being used in terms of the form @{term "\<forall>x. P x"}, has
  the type @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"}. Supporting potential other binders
  is an issue for future work.
\<close>

lift_definition binder_expr ::
  "(('a \<Rightarrow> 'b) \<Rightarrow> 'c) \<Rightarrow> (('a expr['\<sigma>] \<Rightarrow> 'b expr['\<sigma>]) \<Rightarrow> 'c expr['\<sigma>])"
is "\<lambda>bdr. \<lambda>f. (\<lambda>s. bdr (\<lambda>x. (f \<guillemotleft>x\<guillemotright> s)))"
done

text \<open>\todo{What about substitution?}\<close>

subsection \<open>Meta-logical Operators\<close>

definition taut :: "pred['\<sigma>] \<Rightarrow> bool" where
[transfer_unfold]: "taut e = (\<forall>s. \<lbrakk>e\<rbrakk> s)"

subsection \<open>Transfer Tactic\<close>

named_theorems expr_transfer "expr transfer theorems"

theorem expr_eq [expr_transfer]:
"e1 = e2 \<longleftrightarrow> (\<forall>s. \<lbrakk>e1\<rbrakk> s = \<lbrakk>e2\<rbrakk> s)"
apply (transfer')
apply (fold fun_eq_iff)
apply (rule refl)
done

declare lit_expr.rep_eq [expr_transfer]
declare var_expr.rep_eq [expr_transfer]
declare avar_expr.rep_eq [expr_transfer]
declare uop_expr.rep_eq [expr_transfer]
declare bop_expr.rep_eq [expr_transfer]
declare trop_expr.rep_eq [expr_transfer]
declare binder_expr.rep_eq [expr_transfer]

declare taut_def [expr_transfer]

method expr_transfer =
  (unfold expr_transfer)

method expr_simp =
  (expr_transfer, (* (ustate_transfer)?; *) simp?)

method expr_auto =
  (expr_transfer, (* (ustate_transfer)?; *) auto)

method expr_blast =
  (expr_transfer, (* (ustate_transfer)?; *) blast)

subsection \<open>Expression Parser\<close>

text \<open>
  We define a constant to tag terms to be processed by the parser. Note that
  this processing is done by a term-checker (rewrite step), and takes place
  after the term has already been parsed and type-checked by Isabelle/HOL.
  Hence typing information is readily available during the rewrite step and
  this allows us to correctly lift the various operators and free variables.
  (An solution using a syntax translations would need to look at the theory
  context to infer the types of literal constants and operators.)
\<close>

consts uparse :: "'a \<Rightarrow> 'a expr['\<sigma>]" ("'(_')\<^sub>u")

text \<open>The following tag protect inner terms from processing.\<close>

consts uprotect :: "'a expr['\<sigma>] \<Rightarrow> 'a" ("@'(_')")

text \<open>Configuration of the lifting parser and pretty-printer.\<close>

ML_file "uexpr.ML"

setup \<open>
  Context.theory_map (
    (Syntax_Phases.term_check 2 "ulift parser" Expr_Parser.uparse_tr))
\<close>

subsection \<open>Automatic Typing\<close>

text \<open>
  We lastly configure a convenience mechanism for automatic typing of free
  variables inside @{text "(_)\<^sub>u"} terms. Free variables without an explicit
  type constrain are thus automatically typed according to their `declared
  type' via the command @{command declare_uvar}. Or otherwise, if no type
  was declared for the variable name, any free type of a free variable is
  at least forced to be injectable. The mechanism is useful, for instance,
  to predetermine the types of auxiliary variables of a UTP theory. It also
  reduces the need for explicit typing e.g.~of terms like @{text "(x + 1)\<^sub>u"}.
\<close>

text \<open>
  We add an outer command to declare the type of lifted HOL variables. The
  command takes a variable name and a HOL type. For example, we may declare
  the type of HOL variable @{term ok} to be @{typ bool} using the following
  command invocation: @{text "declare_uvar ok \"bool\""}. As hinted above,
  this affects the way the parser performs its translation and lifting.
\<close>

ML \<open>
  Outer_Syntax.local_theory @{command_keyword "declare_uvar"} "declare uvar"
    (Parse.const_decl >>
      (fn (uvar, typ, _) => UVAR_Typing.mk_uvar_type_synonym uvar typ));
\<close>

text \<open>Automatic typing is achieved by the following syntax translation.\<close>

parse_translation \<open>
  [(@{const_syntax "uparse"}, UVAR_Typing.uvar_implicit_typing_tr)]
\<close>

subsection \<open>Expression Cartouche\<close>

text \<open>
  We additionally embed the expression parser into a cartouche. With this, we
  can use the syntax @{text "\<open>\<dots>\<close>"} synonymously for @{text "(\<dots>)\<^sub>u"}. There is
  a slight difference between these uses though, as with the cartouche we do
  not get unification of lifted variables beyond the inside of @{text "\<open>\<dots>\<close>"}.
  This is due to having to parse the content of the cartouche in isolation and
  not in the context of the entire HOL term. This perhaps makes the cartouche
  less attractive, although sometimes there may be benefit in taming the scope
  of unification.
\<close>

syntax "_expr_cartouche" :: "cartouche_position \<Rightarrow> 'a expr['\<sigma>]" ("_\<^sub>e")

parse_translation \<open>
  [(@{syntax_const "_expr_cartouche"}, Expr_Cartouche.uexpr_cartouche_tr)]
\<close>

declare [[show_types]]

text \<open>Observe the difference in the type of @{term f}.\<close>

term "taut (x = (1::nat) \<and> y = x + 1 \<longrightarrow> y = 2)\<^sub>u \<and> (f x)"
term "taut \<open>x = (1::nat) \<and> y = x + 1 \<longrightarrow> y = 2\<close>\<^sub>e \<and> (f x)"

declare [[show_types = false]]

theorem "taut \<open>x = 1 \<and> y = x + 1 \<longrightarrow> y = 2\<close>\<^sub>e"
apply (unfold expr_transfer)
apply (clarsimp)
done

theorem "taut \<open>ok \<and> x = 1 \<longrightarrow> ok' \<and> x' = 2\<close>\<^sub>e"
apply (expr_transfer)
(* Can we do something else transfer-wise here? *)
(* apply (ustate_transfer) *)
\<comment> \<open>TODO: Implement a conversion that carries out a renaming.\<close>
oops

subsection \<open>Parsing Tests\<close>

inject_type "fun"
inject_type set
inject_type list

text \<open>Automatic typing seems to work well in various scenarios.\<close>

declare [[show_types]]
declare [[show_sorts]]

term "(x)\<^sub>u"
term "(x::'a)\<^sub>u"
term "(x::nat)\<^sub>u"
(* term "(x::'a::zero)\<^sub>u" *)
term "(x::'a::{zero,injectable})\<^sub>u"
term "(x + 1)\<^sub>u"
term "(x = {})\<^sub>u"
term "(\<lambda>x. x + 1)\<^sub>u"
term "\<lambda>x. (x + 1)\<^sub>u"

(* declare [[show_types]] *)
(* declare [[show_sorts]] *)

declare_uvar ok :: "bool"
declare_uvar tr :: "'\<tau> list"
(* declare_ulens ok = "ok\<^sub>L" *)

term "(ok)\<^sub>u"
term "(tr)\<^sub>u"
term "(tr = [] \<and> x = 1)\<^sub>u"
term "(P \<and> ok \<longrightarrow> Q \<and> ok')\<^sub>u"

declare [[show_types=false]]
declare [[show_sorts=false]]

text \<open>Lambda expressions and binders are properly lifted too.\<close>

term "(x + 1)\<^sub>u"

term "(\<lambda>x::nat. x + 1 = 2)\<^sub>u"
term "\<lambda>x::nat. (x + 1 = 2)\<^sub>u"
term "(\<forall>x::nat. x + y = 1)\<^sub>u"

subsection \<open>Predicate Parser\<close>

text \<open>
  The expression parser exclusively deals with the lifting of HOL terms. We
  require further machinery to support the parsing of UTP predicates that may
  mix HOL and UTP operators. This is implemented at the level of syntax and
  translations rather than rewriting.

  There may in fact be an alternative solution that harnesses rewriting too,
  defining uninterpreted constants that act as tags for the rewriting engine
  to convert them into corresponding UTP operators. A downside then is that
  we lose information about state spaces, as the parsing of lift expressions
  only considers the underlying HOL types of the expression. Hence we cannot
  exploit unification of the state spaces in that setting easily.
\<close>

consts SkipR :: "pred['\<sigma>]" \<comment> \<open>Used for testing\<close>
consts SemiR :: "pred['\<sigma>\<^sub>1] \<Rightarrow> pred['\<sigma>\<^sub>2] \<Rightarrow> pred['\<sigma>\<^sub>3]"

nonterminal uterm

definition uterm :: "pred['\<sigma>] \<Rightarrow> pred['\<sigma>]" where
"uterm = id" \<comment> \<open>Used to tag a parsed predicate.\<close>

declare uterm_def [expr_transfer]

syntax "_uterm" :: "uterm \<Rightarrow> pred['\<sigma>]" ("`_`")
syntax "_ulift" :: "logic \<Rightarrow> uterm" ("_")
syntax "_uskip" :: "uterm" ("II")
syntax "_usemi" :: "uterm \<Rightarrow> uterm \<Rightarrow> uterm" (infixl ";" 100)
(* ...the grammar can be dynamically extended in sub-theories. *)

translations "_uterm p" \<rightleftharpoons> "(CONST uterm) p"
translations "_ulift t" \<rightharpoonup> "(CONST uparse) t"
translations "_uskip" \<rightleftharpoons> "(CONST SkipR)"
translations "_usemi p q" \<rightleftharpoons> "(CONST SemiR) p q"

term "`x' = x + (1::nat); y = x; @(P); II`"

subsection \<open>Proof Experiments\<close>

text \<open>We can prove equivalence laws with expression and state transfer.\<close>

theorem "(\<forall>x. y < x + 1)\<^sub>u = (y = (0::nat))\<^sub>u"
apply (expr_transfer)
\<comment> \<open>TODO: Let @{text ustate_transfer} retain the original variables names.\<close>
(* apply (ustate_transfer) *)
apply (auto)
done

theorem "(x + (1::nat))\<^sub>u = (1 + x)\<^sub>u"
apply (expr_transfer)
apply (simp)
done
end