theory SINVAR_Sink
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant Sink (IFS)\<close>

datatype node_config = Sink | SinkPool | Unassigned

definition default_node_properties :: "node_config"
  where  "default_node_properties = Unassigned"

fun allowed_sink_flow :: "node_config \<Rightarrow> node_config \<Rightarrow> bool" where
  "allowed_sink_flow Sink _ = False" |
  "allowed_sink_flow SinkPool SinkPool = True" |
  "allowed_sink_flow SinkPool Sink = True" |
  "allowed_sink_flow SinkPool _ = False" |
  "allowed_sink_flow Unassigned _ = True"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. e1 \<noteq> e2 \<longrightarrow> allowed_sink_flow (nP e1) (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation = True"

subsubsection \<open>Preliminaries\<close>

subsubsection\<open>ENF\<close>
  lemma Sink_ENFnr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl sinvar allowed_sink_flow"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_def)
  lemma Unassigned_to_All: "\<forall> e2. allowed_sink_flow Unassigned e2"
    by (rule allI, case_tac e2, simp_all)
  lemma Unassigned_default_candidate: "\<forall> e1 e2. \<not> allowed_sink_flow e1 e2 \<longrightarrow> \<not> allowed_sink_flow e1 Unassigned"
    apply(rule allI)+
    apply(case_tac "e2")
      apply simp_all
     apply(case_tac "e1")
       apply simp_all
    apply(case_tac "e1")
      apply simp_all
    done

  definition Sink_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "Sink_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 \<noteq> e2 \<and> \<not> allowed_sink_flow (nP e1) (nP e2)} })"
  lemma Sink_offending_set:
  "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Sink_offending_set"
    apply(simp only: fun_eq_iff ENFnr_offending_set[OF Sink_ENFnr] Sink_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation Sink: SecurityInvariant_IFS
where default_node_properties = default_node_properties
and sinvar = sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = Sink_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule SecurityInvariant_withOffendingFlows.ENFnr_snds_weakrefl_instance[OF Sink_ENFnr Unassigned_default_candidate Unassigned_to_All])
     apply(simp_all)[2]

   apply(erule default_uniqueness_by_counterexample_IFS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
    apply(case_tac otherbot, simp_all)
    apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := SinkPool, vertex_2 := Unassigned)" in exI, simp)
    apply(rule_tac x="vertex_2" in exI, simp)
    apply(rule_tac x="{(vertex_1, vertex_2)}" in exI, simp)
   apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := SinkPool, vertex_2 := Unassigned)" in exI, simp)
   apply(rule_tac x="vertex_2" in exI, simp)
   apply(rule_tac x="{(vertex_1, vertex_2)}" in exI, simp)

  apply(fact Sink_offending_set)
  done

  lemma TopoS_Sink: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar receiver_violation default_node_properties

end


(*  Title:      HOL/HOLCF/IOA/ex/TrivEx2.thy
    Author:     Olaf Müller
*)

section \<open>Trivial Abstraction Example with fairness\<close>

theory TrivEx2
imports IOA.Abstraction
begin

datatype action = INC

definition
  C_asig :: "action signature" where
  "C_asig = ({},{INC},{})"
definition
  C_trans :: "(action, nat)transition set" where
  "C_trans =
   {tr. let s = fst(tr);
            t = snd(snd(tr))
        in case fst(snd(tr))
        of
        INC       => t = Suc(s)}"
definition
  C_ioa :: "(action, nat)ioa" where
  "C_ioa = (C_asig, {0}, C_trans,{},{})"
definition
  C_live_ioa :: "(action, nat)live_ioa" where
  "C_live_ioa = (C_ioa, WF C_ioa {INC})"

definition
  A_asig :: "action signature" where
  "A_asig = ({},{INC},{})"
definition
  A_trans :: "(action, bool)transition set" where
  "A_trans =
   {tr. let s = fst(tr);
            t = snd(snd(tr))
        in case fst(snd(tr))
        of
        INC       => t = True}"
definition
  A_ioa :: "(action, bool)ioa" where
  "A_ioa = (A_asig, {False}, A_trans,{},{})"
definition
  A_live_ioa :: "(action, bool)live_ioa" where
  "A_live_ioa = (A_ioa, WF A_ioa {INC})"

definition
  h_abs :: "nat => bool" where
  "h_abs n = (n~=0)"

axiomatization where
  MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (\<diamond>\<box>\<langle>%(b,a,c). b\<rangle>)"

lemma h_abs_is_abstraction:
"is_abstraction h_abs C_ioa A_ioa"
apply (unfold is_abstraction_def)
apply (rule conjI)
txt \<open>start states\<close>
apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
txt \<open>step case\<close>
apply (rule allI)+
apply (rule imp_conj_lemma)
apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
apply (induct_tac "a")
apply (simp (no_asm) add: h_abs_def)
done

lemma Enabled_implication:
    "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
  apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
    C_trans_def trans_of_def)
  apply auto
  done

lemma h_abs_is_liveabstraction:
"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
apply (unfold is_live_abstraction_def)
apply auto
txt \<open>is_abstraction\<close>
apply (rule h_abs_is_abstraction)
txt \<open>temp_weakening\<close>
apply abstraction
apply (erule Enabled_implication)
done

lemma TrivEx2_abstraction:
  "validLIOA C_live_ioa (\<diamond>\<box>\<langle>%(n,a,m). n~=0\<rangle>)"
apply (unfold C_live_ioa_def)
apply (rule AbsRuleT2)
apply (rule h_abs_is_liveabstraction)
apply (rule MC_result)
apply abstraction
apply (simp add: h_abs_def)
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_62
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun last :: "Nat list => Nat" where
"last (nil2) = Z"
| "last (cons2 y (nil2)) = y"
| "last (cons2 y (cons2 x2 x3)) = last (cons2 x2 x3)"

theorem property0 :
  "((case xs of
         nil2 => True
         | cons2 y z => False) ==>
      ((last (cons2 x xs)) = (last xs)))"nitpick
  oops

end


section\<open>Simple Firewall Semantics\<close>
theory SimpleFw_Semantics
imports SimpleFw_Syntax
        IP_Addresses.IP_Address
        IP_Addresses.Prefix_Match
begin

  fun simple_match_ip :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word \<Rightarrow> bool" where
    "simple_match_ip (base, len) p_ip \<longleftrightarrow> p_ip \<in> ipset_from_cidr base len"

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval_simple_match_ip_set:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval ip) = {d. simple_match_ip ip d}"
    proof -
      { fix s and d :: "'a::len word \<times> nat"
        from wordinterval_to_set_ipcidr_tuple_to_wordinterval have
          "s \<in> wordinterval_to_set (ipcidr_tuple_to_wordinterval d) \<longleftrightarrow> simple_match_ip d s"
        by(cases d) auto
      } thus ?thesis by blast
    qed

  \<comment> \<open>by the way, the words do not wrap around\<close>
  lemma "{(253::8 word) .. 8} = {}" by simp

  fun simple_match_port :: "(16 word \<times> 16 word) \<Rightarrow> 16 word \<Rightarrow> bool" where
    "simple_match_port (s,e) p_p \<longleftrightarrow> p_p \<in> {s..e}"

  fun simple_matches :: "'i::len simple_match \<Rightarrow> ('i, 'a) simple_packet_scheme \<Rightarrow> bool" where
    "simple_matches m p \<longleftrightarrow>
      (match_iface (iiface m) (p_iiface p)) \<and>
      (match_iface (oiface m) (p_oiface p)) \<and>
      (simple_match_ip (src m) (p_src p)) \<and>
      (simple_match_ip (dst m) (p_dst p)) \<and>
      (match_proto (proto m) (p_proto p)) \<and>
      (simple_match_port (sports m) (p_sport p)) \<and>
      (simple_match_port (dports m) (p_dport p))"

  text\<open>The semantics of a simple firewall: just iterate over the rules sequentially\<close>
  fun simple_fw :: "'i::len simple_rule list \<Rightarrow> ('i, 'a) simple_packet_scheme \<Rightarrow> state" where
    "simple_fw [] _ = Undecided" |
    "simple_fw ((SimpleRule m Accept)#rs) p = (if simple_matches m p then Decision FinalAllow else simple_fw rs p)" |
    "simple_fw ((SimpleRule m Drop)#rs) p = (if simple_matches m p then Decision FinalDeny else simple_fw rs p)"

  fun simple_fw_alt where
    "simple_fw_alt [] _ = Undecided" |
    "simple_fw_alt (r#rs) p = (if simple_matches (match_sel r) p then
    	(case action_sel r of Accept \<Rightarrow> Decision FinalAllow | Drop \<Rightarrow> Decision FinalDeny) else simple_fw_alt rs p)"

  lemma simple_fw_alt: "simple_fw r p = simple_fw_alt r p" by(induction rule: simple_fw.induct) simp_all

  definition simple_match_any :: "'i::len simple_match" where
    "simple_match_any \<equiv> \<lparr>iiface=ifaceAny, oiface=ifaceAny, src=(0,0), dst=(0,0), proto=ProtoAny, sports=(0,65535), dports=(0,65535) \<rparr>"
  lemma simple_match_any: "simple_matches simple_match_any p"
    proof -
      have "(65535::16 word) = max_word" by(simp add: max_word_def)
      thus ?thesis by(simp add: simple_match_any_def ipset_from_cidr_0 match_ifaceAny)
    qed

  text\<open>we specify only one empty port range\<close>
  definition simple_match_none :: "'i::len simple_match" where
    "simple_match_none \<equiv>
      \<lparr>iiface=ifaceAny, oiface=ifaceAny, src=(1,0), dst=(0,0),
       proto=ProtoAny, sports=(1,0), dports=(0,65535) \<rparr>"
  lemma simple_match_none: "\<not> simple_matches simple_match_none p"
    proof -
      show ?thesis by(simp add: simple_match_none_def)
    qed

  fun empty_match :: "'i::len simple_match \<Rightarrow> bool" where
    "empty_match \<lparr>iiface=_, oiface=_, src=_, dst=_, proto=_,
                  sports=(sps1, sps2), dports=(dps1, dps2) \<rparr> \<longleftrightarrow> (sps1 > sps2) \<or> (dps1 > dps2)"

  lemma empty_match: "empty_match m \<longleftrightarrow> (\<forall>(p::('i::len, 'a) simple_packet_scheme). \<not> simple_matches m p)"
    proof
      assume "empty_match m"
      thus "\<forall>p. \<not> simple_matches m p" by(cases m) fastforce
    next
      assume assm: "\<forall>(p::('i::len, 'a) simple_packet_scheme). \<not> simple_matches m p"
      obtain iif oif sip dip protocol sps1 sps2 dps1 dps2 where m:
        "m = \<lparr>iiface = iif, oiface = oif, src = sip, dst = dip, proto = protocol, sports = (sps1, sps2), dports = (dps1, dps2)\<rparr>"
          by(cases m) force

      show "empty_match m"
        proof(simp add: m)
          let ?x="\<lambda>p. dps1 \<le> p_dport p \<longrightarrow> p_sport p \<le> sps2 \<longrightarrow> sps1 \<le> p_sport p \<longrightarrow>
              match_proto protocol (p_proto p) \<longrightarrow> simple_match_ip dip (p_dst p) \<longrightarrow> simple_match_ip sip (p_src p) \<longrightarrow>
              match_iface oif (p_oiface p) \<longrightarrow> match_iface iif (p_iiface p) \<longrightarrow> \<not> p_dport p \<le> dps2"
          from assm have nomatch: "\<forall>(p::('i::len, 'a) simple_packet_scheme). ?x p" by(simp add: m)
          { fix ips::"'i::len word \<times> nat"
            have "a \<in> ipset_from_cidr a n" for a::"'i::len word" and n
              using ipset_from_cidr_lowest by auto
            hence "simple_match_ip ips (fst ips)" by(cases ips) simp
          } note ips=this
          have proto: "match_proto protocol (case protocol of ProtoAny \<Rightarrow> TCP | Proto p \<Rightarrow> p)"
            by(simp split: protocol.split)
          { fix ifce
            have " match_iface ifce (iface_sel ifce)"
            by(cases ifce) (simp add: match_iface_refl)
          } note ifaces=this
          { fix p::"('i, 'a) simple_packet_scheme"
            from nomatch have "?x p" by blast
          } note pkt1=this
          obtain p::"('i, 'a) simple_packet_scheme" where [simp]:
			  "p_iiface p = iface_sel iif"
			  "p_oiface p = iface_sel oif"
			  "p_src p = fst sip"
			  "p_dst p = fst dip"
			  "p_proto p = (case protocol of ProtoAny \<Rightarrow> TCP | Proto p \<Rightarrow> p)"
			  "p_sport p = sps1"
			  "p_dport p = dps1"
			  by (meson simple_packet.select_convs)
          note pkt=pkt1[of p, simplified]
          from pkt ips proto ifaces have " sps1 \<le> sps2 \<longrightarrow> \<not> dps1 \<le> dps2" by blast
          thus "sps2 < sps1 \<or> dps2 < dps1" by fastforce
      qed
  qed

  lemma nomatch: "\<not> simple_matches m p \<Longrightarrow> simple_fw (SimpleRule m a # rs) p = simple_fw rs p"
    by(cases a, simp_all del: simple_matches.simps)

subsection\<open>Simple Ports\<close>
  fun simpl_ports_conjunct :: "(16 word \<times> 16 word) \<Rightarrow> (16 word \<times> 16 word) \<Rightarrow> (16 word \<times> 16 word)" where
    "simpl_ports_conjunct (p1s, p1e) (p2s, p2e) = (max p1s p2s, min p1e p2e)"

  lemma "{(p1s:: 16 word) .. p1e} \<inter> {p2s .. p2e} = {max p1s p2s .. min p1e p2e}" by(simp)

  lemma simple_match_port_code[code] :"simple_match_port (s,e) p_p = (s \<le> p_p \<and> p_p \<le> e)" by simp

  lemma simple_match_port_UNIV: "{p. simple_match_port (s,e) p} = UNIV \<longleftrightarrow> (s = 0 \<and> e = max_word)"
    apply(simp)
    apply(rule)
     apply(case_tac "s = 0")
      using antisym_conv apply blast
     using word_le_0_iff apply blast
    using word_zero_le by blast

subsection\<open>Simple IPs\<close>
  lemma simple_match_ip_conjunct:
    fixes ip1 :: "'i::len word \<times> nat"
    shows "simple_match_ip ip1 p_ip \<and> simple_match_ip ip2 p_ip \<longleftrightarrow>
            (case ipcidr_conjunct ip1 ip2 of None \<Rightarrow> False | Some ipx \<Rightarrow> simple_match_ip ipx p_ip)"
  proof -
  {
    fix b1 m1 b2 m2
    have "simple_match_ip (b1, m1) p_ip \<and> simple_match_ip (b2, m2) p_ip \<longleftrightarrow>
          p_ip \<in> ipset_from_cidr b1 m1 \<inter> ipset_from_cidr b2 m2"
    by simp
    also have "\<dots> \<longleftrightarrow> p_ip \<in> (case ipcidr_conjunct (b1, m1) (b2, m2) of None \<Rightarrow> {} | Some (bx, mx) \<Rightarrow> ipset_from_cidr bx mx)"
      using ipcidr_conjunct_correct by blast
    also have "\<dots> \<longleftrightarrow> (case ipcidr_conjunct (b1, m1) (b2, m2) of None \<Rightarrow> False | Some ipx \<Rightarrow> simple_match_ip ipx p_ip)"
      by(simp split: option.split)
    finally have "simple_match_ip (b1, m1) p_ip \<and> simple_match_ip (b2, m2) p_ip \<longleftrightarrow>
         (case ipcidr_conjunct (b1, m1) (b2, m2) of None \<Rightarrow> False | Some ipx \<Rightarrow> simple_match_ip ipx p_ip)" .
   } thus ?thesis by(cases ip1, cases ip2, simp)
  qed

  declare simple_matches.simps[simp del]

subsection\<open>Merging Simple Matches\<close>
  text\<open>@{typ "'i::len simple_match"} \<open>\<and>\<close> @{typ "'i::len simple_match"}\<close>

  fun simple_match_and :: "'i::len simple_match \<Rightarrow> 'i simple_match \<Rightarrow> 'i simple_match option" where
    "simple_match_and \<lparr>iiface=iif1, oiface=oif1, src=sip1, dst=dip1, proto=p1, sports=sps1, dports=dps1 \<rparr>
                      \<lparr>iiface=iif2, oiface=oif2, src=sip2, dst=dip2, proto=p2, sports=sps2, dports=dps2 \<rparr> =
      (case ipcidr_conjunct sip1 sip2 of None \<Rightarrow> None | Some sip \<Rightarrow>
      (case ipcidr_conjunct dip1 dip2 of None \<Rightarrow> None | Some dip \<Rightarrow>
      (case iface_conjunct iif1 iif2 of None \<Rightarrow> None | Some iif \<Rightarrow>
      (case iface_conjunct oif1 oif2 of None \<Rightarrow> None | Some oif \<Rightarrow>
      (case simple_proto_conjunct p1 p2 of None \<Rightarrow> None | Some p \<Rightarrow>
      Some \<lparr>iiface=iif, oiface=oif, src=sip, dst=dip, proto=p,
            sports=simpl_ports_conjunct sps1 sps2, dports=simpl_ports_conjunct dps1 dps2 \<rparr>)))))"

  lemma simple_match_and_correct: "simple_matches m1 p \<and> simple_matches m2 p \<longleftrightarrow>
    (case simple_match_and m1 m2 of None \<Rightarrow> False | Some m \<Rightarrow> simple_matches m p)"
    proof -
      obtain iif1 oif1 sip1 dip1 p1 sps1 dps1 where m1:
        "m1 = \<lparr>iiface=iif1, oiface=oif1, src=sip1, dst=dip1, proto=p1, sports=sps1, dports=dps1 \<rparr>" by(cases m1, blast)
      obtain iif2 oif2 sip2 dip2 p2 sps2 dps2 where m2:
        "m2 = \<lparr>iiface=iif2, oiface=oif2, src=sip2, dst=dip2, proto=p2, sports=sps2, dports=dps2 \<rparr>" by(cases m2, blast)

      have sip_None: "ipcidr_conjunct sip1 sip2 = None \<Longrightarrow> \<not> simple_match_ip sip1 (p_src p) \<or> \<not> simple_match_ip sip2 (p_src p)"
        using simple_match_ip_conjunct[of sip1 "p_src p" sip2] by simp
      have dip_None: "ipcidr_conjunct dip1 dip2 = None \<Longrightarrow> \<not> simple_match_ip dip1 (p_dst p) \<or> \<not> simple_match_ip dip2 (p_dst p)"
        using simple_match_ip_conjunct[of dip1 "p_dst p" dip2] by simp
      have sip_Some: "\<And>ip. ipcidr_conjunct sip1 sip2 = Some ip \<Longrightarrow>
        simple_match_ip ip (p_src p) \<longleftrightarrow> simple_match_ip sip1 (p_src p) \<and> simple_match_ip sip2 (p_src p)"
        using simple_match_ip_conjunct[of sip1 "p_src p" sip2] by simp
      have dip_Some: "\<And>ip. ipcidr_conjunct dip1 dip2 = Some ip \<Longrightarrow>
        simple_match_ip ip (p_dst p) \<longleftrightarrow> simple_match_ip dip1 (p_dst p) \<and> simple_match_ip dip2 (p_dst p)"
        using simple_match_ip_conjunct[of dip1 "p_dst p" dip2] by simp

      have iiface_None: "iface_conjunct iif1 iif2 = None \<Longrightarrow> \<not> match_iface iif1 (p_iiface p) \<or> \<not> match_iface iif2 (p_iiface p)"
        using iface_conjunct[of iif1 "(p_iiface p)" iif2] by simp
      have oiface_None: "iface_conjunct oif1 oif2 = None \<Longrightarrow> \<not> match_iface oif1 (p_oiface p) \<or> \<not> match_iface oif2 (p_oiface p)"
        using iface_conjunct[of oif1 "(p_oiface p)" oif2] by simp
      have iiface_Some: "\<And>iface. iface_conjunct iif1 iif2 = Some iface \<Longrightarrow>
        match_iface iface (p_iiface p) \<longleftrightarrow> match_iface iif1 (p_iiface p) \<and> match_iface iif2 (p_iiface p)"
        using iface_conjunct[of iif1 "(p_iiface p)" iif2] by simp
      have oiface_Some: "\<And>iface. iface_conjunct oif1 oif2 = Some iface \<Longrightarrow>
        match_iface iface (p_oiface p) \<longleftrightarrow> match_iface oif1 (p_oiface p) \<and> match_iface oif2 (p_oiface p)"
        using iface_conjunct[of oif1 "(p_oiface p)" oif2] by simp

      have proto_None: "simple_proto_conjunct p1 p2 = None \<Longrightarrow> \<not> match_proto p1 (p_proto p) \<or> \<not> match_proto p2 (p_proto p)"
        using simple_proto_conjunct_correct[of p1 "(p_proto p)" p2] by simp
      have proto_Some: "\<And>proto. simple_proto_conjunct p1 p2 = Some proto \<Longrightarrow>
        match_proto proto (p_proto p) \<longleftrightarrow> match_proto p1 (p_proto p) \<and> match_proto p2 (p_proto p)"
        using simple_proto_conjunct_correct[of p1 "(p_proto p)" p2] by simp

      have case_Some: "\<And>m. Some m = simple_match_and m1 m2 \<Longrightarrow>
       (simple_matches m1 p \<and> simple_matches m2 p) \<longleftrightarrow> simple_matches m p"
       apply(simp add: m1 m2 simple_matches.simps split: option.split_asm)
       using simple_ports_conjunct_correct by(blast dest: sip_Some dip_Some iiface_Some oiface_Some proto_Some)
      have case_None: "simple_match_and m1 m2 = None \<Longrightarrow> \<not> (simple_matches m1 p \<and> simple_matches m2 p)"
       apply(simp add: m1 m2 simple_matches.simps split: option.split_asm)
           apply(blast dest: sip_None dip_None iiface_None oiface_None proto_None)+
       done
      from case_Some case_None show ?thesis by(cases "simple_match_and m1 m2") simp_all
   qed

  lemma simple_match_and_SomeD: "simple_match_and m1 m2 = Some m \<Longrightarrow>
    simple_matches m p \<longleftrightarrow> (simple_matches m1 p \<and> simple_matches m2 p)"
    by(simp add: simple_match_and_correct)
  lemma simple_match_and_NoneD: "simple_match_and m1 m2 = None \<Longrightarrow>
    \<not>(simple_matches m1 p \<and> simple_matches m2 p)"
    by(simp add: simple_match_and_correct)
  lemma simple_matches_andD: "simple_matches m1 p \<Longrightarrow> simple_matches m2 p \<Longrightarrow>
    \<exists>m. simple_match_and m1 m2 = Some m \<and> simple_matches m p"
    by (meson option.exhaust_sel simple_match_and_NoneD simple_match_and_SomeD)

subsection\<open>Further Properties of a Simple Firewall\<close>
  fun has_default_policy :: "'i::len simple_rule list \<Rightarrow> bool" where
    "has_default_policy [] = False" |
    "has_default_policy [(SimpleRule m _)] = (m = simple_match_any)" |
    "has_default_policy (_#rs) = has_default_policy rs"

  lemma has_default_policy: "has_default_policy rs \<Longrightarrow>
    simple_fw rs p = Decision FinalAllow \<or> simple_fw rs p = Decision FinalDeny"
    proof(induction rs rule: has_default_policy.induct)
    case 1 thus ?case by (simp)
    next
    case (2 m a) thus ?case by(cases a) (simp_all add: simple_match_any)
    next
    case (3 r1 r2 rs)
      from 3 obtain a m where "r1 = SimpleRule m a" by (cases r1) simp
      with 3 show ?case by (cases a) simp_all
    qed

  lemma has_default_policy_fst: "has_default_policy rs \<Longrightarrow> has_default_policy (r#rs)"
   apply(cases r, rename_tac m a, simp)
   apply(cases rs)
    by(simp_all)

  text\<open>We can stop after a default rule (a rule which matches anything) is observed.\<close>
  fun cut_off_after_match_any :: "'i::len simple_rule list \<Rightarrow> 'i simple_rule list" where
    "cut_off_after_match_any [] = []" |
    "cut_off_after_match_any (SimpleRule m a # rs) =
      (if m = simple_match_any then [SimpleRule m a] else SimpleRule m a # cut_off_after_match_any rs)"

  lemma cut_off_after_match_any: "simple_fw (cut_off_after_match_any rs) p = simple_fw rs p"
    apply(induction rs p rule: simple_fw.induct)
      by(simp add: simple_match_any)+

  lemma simple_fw_not_matches_removeAll: "\<not> simple_matches m p \<Longrightarrow>
    simple_fw (removeAll (SimpleRule m a) rs) p = simple_fw rs p"
    apply(induction rs p rule: simple_fw.induct)
      apply(simp)
     apply(simp_all)
     apply blast+
    done

subsection\<open>Reality check: Validity of Simple Matches\<close>
  text\<open>While it is possible to construct a \<open>simple_fw\<close> expression that only matches a source
  or destination port, such a match is not meaningful, as the presence of the port information is
  dependent on the protocol. Thus, a match for a port should always include the match for a protocol.
  Additionally, prefixes should be zero on bits beyond the prefix length.
  \<close>

  definition "valid_prefix_fw m = valid_prefix (uncurry PrefixMatch m)"

  lemma ipcidr_conjunct_valid:
    "\<lbrakk>valid_prefix_fw p1; valid_prefix_fw p2; ipcidr_conjunct p1 p2 = Some p\<rbrakk> \<Longrightarrow> valid_prefix_fw p"
    unfolding valid_prefix_fw_def
    by(cases p; cases p1; cases p2) (simp add: ipcidr_conjunct.simps split: if_splits)

  definition simple_match_valid :: "('i::len, 'a) simple_match_scheme \<Rightarrow> bool" where
    "simple_match_valid m \<equiv>
    ({p. simple_match_port (sports m) p} \<noteq> UNIV \<or> {p. simple_match_port (dports m) p} \<noteq> UNIV \<longrightarrow>
        proto m \<in> Proto `{TCP, UDP, L4_Protocol.SCTP}) \<and>
    valid_prefix_fw (src m) \<and> valid_prefix_fw (dst m)"

  lemma simple_match_valid_alt[code_unfold]: "simple_match_valid = (\<lambda> m.
    (let c = (\<lambda>(s,e). (s \<noteq> 0 \<or> e \<noteq> max_word)) in (
    if c (sports m) \<or> c (dports m) then proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP else True)) \<and>
  valid_prefix_fw (src m) \<and> valid_prefix_fw (dst m))"
  proof -
    have simple_match_valid_alt_hlp1: "{p. simple_match_port x p} \<noteq> UNIV \<longleftrightarrow> (case x of (s,e) \<Rightarrow> s \<noteq> 0 \<or> e \<noteq> max_word)"
      for x using simple_match_port_UNIV by auto
    have simple_match_valid_alt_hlp2: "{p. simple_match_port x p} \<noteq> {} \<longleftrightarrow> (case x of (s,e) \<Rightarrow> s \<le> e)" for x by auto
    show ?thesis
      unfolding fun_eq_iff
      unfolding simple_match_valid_def Let_def
      unfolding simple_match_valid_alt_hlp1 simple_match_valid_alt_hlp2
      apply(clarify, rename_tac m, case_tac "sports m"; case_tac "dports m"; case_tac "proto m")
       by auto
  qed

  text\<open>Example:\<close>
  context
  begin
    private definition "example_simple_match1 \<equiv>
      \<lparr>iiface = Iface ''+'', oiface = Iface ''+'', src = (0::32 word, 0), dst = (0, 0),
       proto = Proto TCP, sports = (0, 1024), dports = (0, 1024)\<rparr>"

    lemma "simple_fw [SimpleRule example_simple_match1 Drop]
      \<lparr>p_iiface = '''', p_oiface = '''',  p_src = (1::32 word), p_dst = 2, p_proto = TCP, p_sport = 8,
       p_dport = 9, p_tcp_flags = {}, p_payload = ''''\<rparr> =
        Decision FinalDeny" by eval

    private definition "example_simple_match2 \<equiv> example_simple_match1\<lparr> proto := ProtoAny \<rparr>"
    text\<open>Thus, \<open>example_simple_match1\<close> is valid, but if we set its protocol match to any, it isn't anymore\<close>
    private lemma "simple_match_valid example_simple_match1" by eval
    private lemma "\<not> simple_match_valid example_simple_match2" by eval
  end

  lemma simple_match_and_valid:
    fixes m1 :: "'i::len simple_match"
    assumes mv: "simple_match_valid m1" "simple_match_valid m2"
    assumes mj: "simple_match_and m1 m2 = Some m"
    shows "simple_match_valid m"
  proof -
    have simpl_ports_conjunct_not_UNIV:
    "Collect (simple_match_port x) \<noteq> UNIV \<Longrightarrow>
      x = simpl_ports_conjunct p1 p2 \<Longrightarrow>
      Collect (simple_match_port p1) \<noteq> UNIV \<or> Collect (simple_match_port p2) \<noteq> UNIV"
    for x p1 p2 by (metis Collect_cong mem_Collect_eq simple_ports_conjunct_correct)

    (* prefix validity. That's simple. *)
    have "valid_prefix_fw (src m1)" "valid_prefix_fw (src m2)" "valid_prefix_fw (dst m1)" "valid_prefix_fw (dst m2)"
      using mv unfolding simple_match_valid_alt by simp_all
    moreover have "ipcidr_conjunct (src m1) (src m2) = Some (src m)"
                  "ipcidr_conjunct (dst m1) (dst m2) = Some (dst m)"
      using mj by(cases m1; cases m2; cases m; simp split: option.splits)+
    ultimately have pv: "valid_prefix_fw (src m)" "valid_prefix_fw (dst m)"
      using ipcidr_conjunct_valid by blast+

    (* now for the source ports\<dots> *)
    define nmu where "nmu ps \<longleftrightarrow> {p. simple_match_port ps p} \<noteq> UNIV" for ps
    have "simpl_ports_conjunct (sports m1) (sports m2) = (sports m)" (is "?ph1 sports")
      using mj by(cases m1; cases m2; cases m; simp split: option.splits)
    hence sp: "nmu (sports m) \<longrightarrow> nmu (sports m1) \<or> nmu (sports m2)"
      (is "?ph2 sports")
      unfolding nmu_def using simpl_ports_conjunct_not_UNIV by metis

    (* dst ports: mutatis mutandem *)
    have "?ph1 dports" using mj by(cases m1; cases m2; cases m; simp split: option.splits)
    hence dp: "?ph2 dports" unfolding nmu_def using simpl_ports_conjunct_not_UNIV by metis

    (* And an argument for the protocol. *)
    define php where "php mr \<longleftrightarrow> proto mr \<in> Proto ` {TCP, UDP, L4_Protocol.SCTP}"
      for mr :: "'i simple_match"
    have pcj: "simple_proto_conjunct (proto m1) (proto m2) = Some (proto m)"
      using mj by(cases m1; cases m2; cases m; simp split: option.splits)
    hence p: "php m1 \<Longrightarrow> php m"
             "php m2 \<Longrightarrow> php m"
      using conjunctProtoD conjunctProtoD2 pcj unfolding php_def by auto

    (* Since I'm trying to trick the simplifier with these defs, I need these as explicit statements: *)
    have "\<And>mx. simple_match_valid mx \<Longrightarrow> nmu (sports mx) \<or> nmu (dports mx) \<Longrightarrow> php mx"
      unfolding nmu_def php_def simple_match_valid_def by blast
    hence mps: "nmu (sports m1) \<Longrightarrow> php m1" "nmu (dports m1) \<Longrightarrow> php m1"
               "nmu (sports m2) \<Longrightarrow> php m2" "nmu (dports m2) \<Longrightarrow> php m2" using mv by blast+

    have pa: "nmu (sports m) \<or> nmu (dports m) \<longrightarrow> php m"
    (*  apply(intro impI)
      apply(elim disjE)
      apply(drule sp[THEN mp])
      apply(elim disjE)
      apply(drule mps)
      apply(elim p; fail) *)
      using sp dp mps p by fast

    show ?thesis
      unfolding simple_match_valid_def
      using pv pa[unfolded nmu_def php_def] by blast
  qed

  definition "simple_fw_valid \<equiv> list_all (simple_match_valid \<circ> match_sel)"

text\<open>The simple firewall does not care about tcp flags, payload, or any other packet extensions.\<close>
lemma simple_matches_extended_packet:
      "simple_matches m
        \<lparr>p_iiface = iifce,
         oiface = oifce,
         p_src = s, dst = d,
         p_proto = prot,
         p_sport = sport, p_dport = dport,
         tcp_flags = tcp_flags, p_payload = payload1\<rparr>
        \<longleftrightarrow>
       simple_matches m
        \<lparr>p_iiface = iifce,
         oiface = oifce,
         p_src = s, p_dst = d,
         p_proto = prot,
         p_sport = sport, p_dport = dport,
         p_tcp_flags = tcp_flags2, p_payload = payload2, \<dots> = aux\<rparr>
        "
  by(simp add: simple_matches.simps)
end


theory AxiomaticCategoryTheory  imports Main
begin declare [[smt_solver = cvc4,smt_oracle]]

typedecl i  (*Type for individuals*)
consts fExistence:: "i\<Rightarrow>bool" ("E") (*Existence/definedness predicate in free logic*)

abbreviation fNot ("\<^bold>\<not>") (*Free negation*)
 where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
abbreviation fImplies (infixr "\<^bold>\<rightarrow>" 13) (*Free implication*)
 where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<phi> \<longrightarrow> \<psi>"
abbreviation fIdentity (infixr "\<^bold>=" 13) (*Free identity*)
 where "l \<^bold>= r \<equiv> l = r"
abbreviation fForall ("\<^bold>\<forall>") (*Free universal quantification guarded by @{text "E"}*)
 where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
abbreviation fForallBinder (binder "\<^bold>\<forall>" [8] 9) (*Binder notation*)
 where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"

(* Further free logic connectives can now be defined as usual.*)
abbreviation fOr (infixr "\<^bold>\<or>" 11)
 where "\<phi> \<^bold>\<or> \<psi> \<equiv> (\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<psi>"
abbreviation fAnd (infixr "\<^bold>\<and>" 12)
 where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
abbreviation fImplied (infixr "\<^bold>\<leftarrow>" 13)
 where "\<phi> \<^bold>\<leftarrow> \<psi> \<equiv> \<psi> \<^bold>\<rightarrow> \<phi>"
abbreviation fEquiv (infixr "\<^bold>\<leftrightarrow>" 15)
 where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<and> (\<psi> \<^bold>\<rightarrow> \<phi>)"
abbreviation fExists ("\<^bold>\<exists>")
 where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
abbreviation fExistsBinder (binder "\<^bold>\<exists>" [8]9)
 where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"

(* Preliminaries *)

consts
 domain:: "i\<Rightarrow>i" ("dom _" [108] 109)
 codomain:: "i\<Rightarrow>i" ("cod _" [110] 111)
 composition:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<cdot>" 110)

abbreviation KlEq (infixr "\<cong>" 56) (* Kleene equality *)
 where "x \<cong> y \<equiv> (E x \<^bold>\<or> E y) \<^bold>\<rightarrow> x \<^bold>= y"

abbreviation ExId (infixr "\<simeq>" 56) (* Existing identity *)
 where "x \<simeq> y \<equiv> E x \<^bold>\<and> E y \<^bold>\<and> x \<^bold>= y"

lemma "x \<cong> x \<^bold>\<and> (x \<cong> y \<^bold>\<rightarrow> y \<cong> x) \<^bold>\<and> ((x \<cong> y \<^bold>\<and> y \<cong> z) \<^bold>\<rightarrow> x \<cong> z)" by blast
lemma "x \<simeq> x" nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
lemma " (x \<simeq> y \<^bold>\<rightarrow> y \<simeq> x) \<^bold>\<and> ((x \<simeq> y \<^bold>\<and> y \<simeq> z) \<^bold>\<rightarrow> x \<simeq> z)" by blast
lemma "x \<simeq> y \<^bold>\<rightarrow> x \<cong> y" by simp
lemma "x \<simeq> y \<^bold>\<leftarrow> x \<cong> y" nitpick [user_axioms, show_all, format = 2, expect = genuine] oops

abbreviation I where "I i \<equiv> (\<^bold>\<forall>x. E(i\<cdot>x) \<^bold>\<rightarrow> i\<cdot>x \<cong> x) \<^bold>\<and> (\<^bold>\<forall>x. E(x\<cdot>i) \<^bold>\<rightarrow> x\<cdot>i \<cong> x)"

(* Axioms Set I *)

locale Axioms_Set_I =
assumes
 S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
 E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
 A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. I i \<^bold>\<and> i\<cdot>y \<cong> y" and
 D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. I j \<^bold>\<and> x\<cdot>j \<cong> x"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma E\<^sub>iImplied: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    by (metis A\<^sub>i C\<^sub>i S\<^sub>i)
  lemma UC\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. I i \<^bold>\<and> i\<cdot>y \<cong> y \<^bold>\<and> (\<^bold>\<forall>j.(I j \<^bold>\<and> j\<cdot>y \<cong> y) \<^bold>\<rightarrow> i \<cong> j)"
    by (smt A\<^sub>i C\<^sub>i S\<^sub>i)
  lemma UD\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. I j \<^bold>\<and> x\<cdot>j \<cong> x \<^bold>\<and> (\<^bold>\<forall>i.(I i \<^bold>\<and> x\<cdot>i \<cong> x) \<^bold>\<rightarrow> j \<cong> i)"
    by (smt A\<^sub>i D\<^sub>i S\<^sub>i)
 lemma "(\<exists>C D. (\<^bold>\<forall>y. I (C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. I (D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
   nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
 lemma "(\<exists>x. E x) \<^bold>\<and> (\<exists>C D. (\<^bold>\<forall>y. I (C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. I (D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
   nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

(* Axioms Set II *)

locale Axioms_Set_II =
assumes
 S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
 E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
 A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
 D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma E\<^sub>i\<^sub>iImplied: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    by (metis A\<^sub>i\<^sub>i C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)

context Axioms_Set_II
begin
  lemma S\<^sub>iFromII: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)"
    using S\<^sub>i\<^sub>i by blast
  lemma E\<^sub>iFromII: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    using E\<^sub>i\<^sub>i by blast
  lemma A\<^sub>iFromII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i by blast
  lemma C\<^sub>iFromII: "\<^bold>\<forall>y.\<^bold>\<exists>i. I i \<^bold>\<and> i\<cdot>y \<cong> y"
    by (metis C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
  lemma D\<^sub>iFromII: "\<^bold>\<forall>x.\<^bold>\<exists>j. I j \<^bold>\<and> x\<cdot>j \<cong> x"
    by (metis D\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
end

(* Axioms Set III *)

locale Axioms_Set_III =
assumes
 S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
 E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
 A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
 D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
begin
  lemma True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma E\<^sub>i\<^sub>i\<^sub>iImplied: "E(x\<cdot>y) \<^bold>\<rightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))"
    by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
end

context Axioms_Set_III
begin
  lemma S\<^sub>i\<^sub>iFromIII: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>i\<^sub>i by blast
  lemma E\<^sub>i\<^sub>iFromIII: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"
    by (metis A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
  lemma A\<^sub>i\<^sub>iFromIII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i\<^sub>i by blast
  lemma C\<^sub>i\<^sub>iFromIII: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)"
    using C\<^sub>i\<^sub>i\<^sub>i by auto
  lemma D\<^sub>i\<^sub>iFromIII: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
    using D\<^sub>i\<^sub>i\<^sub>i by auto
end

context Axioms_Set_II
begin
  lemma S\<^sub>i\<^sub>i\<^sub>iFromII: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>i by blast
  lemma E\<^sub>i\<^sub>i\<^sub>iFromII: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> (E(cod y)))"
    by (metis C\<^sub>i\<^sub>i D\<^sub>i\<^sub>i E\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
  lemma A\<^sub>i\<^sub>i\<^sub>iFromII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i by blast
  lemma C\<^sub>i\<^sub>i\<^sub>iFromII: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)"
    using C\<^sub>i\<^sub>i by auto
  lemma D\<^sub>i\<^sub>i\<^sub>iFromII: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
    using D\<^sub>i\<^sub>i by auto
end

(* Axioms Set IV *)

locale Axioms_Set_IV =
assumes
 S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
 E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
 A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" and
 D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True  (* Nitpick finds a model *)
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_IV
begin
  lemma S\<^sub>i\<^sub>i\<^sub>iFromIV: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>v by blast
  lemma E\<^sub>i\<^sub>i\<^sub>iFromIV: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> (E(cod y)))"
    using E\<^sub>i\<^sub>v by blast
  lemma A\<^sub>i\<^sub>i\<^sub>iFromIV: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>v by blast
  lemma C\<^sub>i\<^sub>i\<^sub>iFromIV: "E y \<^bold>\<rightarrow> (I(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)"
    by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
  lemma D\<^sub>i\<^sub>i\<^sub>iFromIV: "E x \<^bold>\<rightarrow> (I(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
    by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
end

context Axioms_Set_III
begin
  lemma S\<^sub>i\<^sub>vFromIII: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S\<^sub>i\<^sub>i\<^sub>i by blast
  lemma E\<^sub>i\<^sub>vFromIII: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))"
    by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
  lemma A\<^sub>i\<^sub>vFromIII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A\<^sub>i\<^sub>i\<^sub>i by blast
  lemma C\<^sub>i\<^sub>vFromIII: "(cod y)\<cdot>y \<cong> y"
    using C\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
  lemma D\<^sub>i\<^sub>vFromIII: "x\<cdot>(dom x) \<cong> x"
    using D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
end

(* Axioms Set V *)

locale Axioms_Set_V =
assumes
 S1: "E(dom x) \<^bold>\<rightarrow> E x" and
 S2: "E(cod y) \<^bold>\<rightarrow> E y" and
 S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
 S5: "x\<cdot>(dom x) \<cong> x" and
 S6: "(cod y)\<cdot>y \<cong> y"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_V
begin
  lemma S\<^sub>i\<^sub>vFromV: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"
    using S1 S2 S3 by blast
  lemma E\<^sub>i\<^sub>vFromV: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))"  using S3 by metis
  lemma A\<^sub>i\<^sub>vFromV: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"  using S4 by blast
  lemma C\<^sub>i\<^sub>vFromV: "(cod y)\<cdot>y \<cong> y"  using S6 by blast
  lemma D\<^sub>i\<^sub>vFromV: "x\<cdot>(dom x) \<cong> x"  using S5 by blast
end

context Axioms_Set_IV
begin
  lemma S1FromIV:  "E(dom x) \<^bold>\<rightarrow> E x"  using S\<^sub>i\<^sub>v by blast
  lemma S2FromIV:  "E(cod y) \<^bold>\<rightarrow> E y"  using S\<^sub>i\<^sub>v by blast
  lemma S3FromIV:  "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" using E\<^sub>i\<^sub>v by metis
  lemma S4FromIV:  "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"  using A\<^sub>i\<^sub>v by blast
  lemma S5FromIV:  "x\<cdot>(dom x) \<cong> x"  using D\<^sub>i\<^sub>v by blast
  lemma S6FromIV:  "(cod y)\<cdot>y \<cong> y"  using C\<^sub>i\<^sub>v by blast
end

(* Axioms Set FS-I *)

consts
   source:: "i\<Rightarrow>i" ("\<box>_" [108] 109)
   target:: "i\<Rightarrow>i" ("_\<box>" [110] 111)
   compositionF:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<^bold>\<cdot>" 110)

locale Axioms_Set_FS_I =
assumes
  A1: "E(x\<^bold>\<cdot>y) \<^bold>\<leftrightarrow> (x\<box> \<cong> \<box>y)" and
 A2a: "((\<box>x)\<box>) \<cong> \<box>x" and
 A2b: "\<box>(x\<box>) \<cong> \<box>x" and
 A3a: "(\<box>x)\<^bold>\<cdot>x \<cong> x" and
 A3b: "x\<^bold>\<cdot>(x\<box>) \<cong> x" and
 A4a: "\<box>(x\<^bold>\<cdot>y) \<cong> \<box>(x\<^bold>\<cdot>(\<box>y))" and
 A4b: "(x\<^bold>\<cdot>y)\<box> \<cong> ((x\<box>)\<^bold>\<cdot>y)\<box>" and
  A5: "x\<^bold>\<cdot>(y\<^bold>\<cdot>z) \<cong> (x\<^bold>\<cdot>y)\<^bold>\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = none] oops
  lemma InconsistencyAutomatic: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False"
    by (metis A1 A2a A3a)
  lemma InconsistencyInteractive: assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
    proof -
      (* Let @{text "a"} be an undefined object *)
     obtain a where 1: "\<^bold>\<not>(E a)" using assms by auto
      (* We instantiate axiom @{text "A3a"} with @{text "a"}. *)
     have 2: "(\<box>a)\<^bold>\<cdot>a \<cong> a" using A3a by blast
      (* By unfolding the definition of @{text "\<cong>"} we get from 1 that @{text "(\<box>a)\<^bold>\<cdot>a"} is
           not defined. This is
           easy to see, since if @{text "(\<box>a)\<^bold>\<cdot>a"} were defined, we also had that  @{text "a"} is
           defined, which is not the case by assumption. *)
     have 3: "\<^bold>\<not>(E((\<box>a)\<^bold>\<cdot>a))" using 1 2 by metis
      (* We instantiate axiom @{text "A1"} with @{text "\<box>a"} and @{text "a"}. *)
     have 4: "E((\<box>a)\<^bold>\<cdot>a) \<^bold>\<leftrightarrow> (\<box>a)\<box> \<cong> \<box>a" using A1 by blast
      (* We instantiate axiom @{text "A2a"} with @{text "a"}. *)
     have 5: "(\<box>a)\<box> \<cong> \<box>a" using A2a by blast
      (* From 4 and 5 we obtain @{text "\<^bold>(E((\<box>a)\<^bold>\<cdot>a))"} by propositional logic. *)
     have 6: "E((\<box>a)\<^bold>\<cdot>a)" using 4 5 by blast
      (* We have @{text "\<^bold>\<not>(E((\<box>a)\<^bold>\<cdot>a))"} and @{text "E((\<box>a)\<^bold>\<cdot>a)"}, hence Falsity. *)
     then show ?thesis using 6 3 by blast
    qed
end

(* Axioms Set FS-II *)

locale Axioms_Set_FS_II =
assumes
  A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
 A2a: "cod(dom x) \<cong> dom x " and
 A2b: "dom(cod y) \<cong> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
 A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = none] oops
  lemma InconsistencyAutomaticVII: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False"
    by (metis A1 A2a A3a)
  lemma "\<forall>x. E x"
    using InconsistencyAutomaticVII by auto
  lemma InconsistencyInteractiveVII:
    assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
    proof -
      (* Let @{text "a"} be an undefined object *)
     obtain a where 1: "\<^bold>\<not>(E a)" using NEx by auto
      (* We instantiate axiom @{text "A3a"} with @{text "a"}. *)
     have 2: "a\<cdot>(dom a) \<cong> a" using A3a by blast
      (* By unfolding the definition of @{text "\<cong>"} we get from 1 that
          @{text "a\<cdot>(dom a)"} is not defined. This is
          easy to see, since if @{text "a\<cdot>(dom a)"} were defined, we also had that @{text "a"} is
          defined, which is not the case by assumption.*)
     have 3: "\<^bold>\<not>(E(a\<cdot>(dom a)))" using 1 2 by metis
      (* We instantiate axiom @{text "A1"} with @{text "a"} and @{text "dom a"}. *)
     have 4: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> cod(dom a)" using A1 by blast
      (* We instantiate axiom @{text "A2a"} with @{text "a"}. *)
     have 5: "cod(dom a) \<cong> dom a" using A2a by blast
      (* We use 5 (and symmetry and transitivity of @{text "\<cong>"}) to rewrite the
           right-hand of the equivalence 4 into @{text "dom a \<cong> dom a"}. *)
     have 6: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> dom a" using 4 5 by auto
      (* By reflexivity of @{text "\<cong>"} we get that @{text "a\<cdot>(dom a)"} must be defined. *)
     have 7: "E(a\<cdot>(dom a))" using 6 by blast
      (* We have shown in 7 that @{text "a\<cdot>(dom a)"} is defined, and in 3
           that it is undefined. Contradiction. *)
     then show ?thesis using 7 3 by blast
   qed
end

(* Axioms Set VI *)

locale Axioms_Set_VI =
assumes
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A2a: "cod(dom x) \<cong> dom x" and
 A2b: "dom(cod y) \<cong> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
 A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma A4aRedundant: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)"
    using A1' A2a A3a A5 by metis
  lemma A4bRedundant: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))"
    using A1' A2b A3b A5 by smt
  lemma A2aRedundant: "cod(dom x) \<cong> dom x"
    using A1' A3a A3b A4a A4b by smt
  lemma A2bRedundant: "dom(cod y) \<cong> cod y"
    using A1' A3a A3b A4a A4b by smt
end

context Axioms_Set_VI
begin
  lemma S1FromVI: "E(dom x) \<^bold>\<rightarrow> E x"
    by (metis A1' A2a A3a)
  lemma S2FromVI: "E(cod y) \<^bold>\<rightarrow> E y"
    using A1' A2b A3b by metis
  lemma S3FromVI: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI: "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI: "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

context Axioms_Set_V
begin
  lemma A1'FromV: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    using S3 by blast
  lemma A2aFromV: "cod(dom x) \<cong> dom x"
    by (metis S1 S2 S3 S5)
  lemma A2bFromV: "dom(cod y) \<cong> cod y"
    using S1 S2 S3 S6 by metis
  lemma A3aFromV: "x\<cdot>(dom x) \<cong> x"
    using S5 by blast
  lemma A3bFromV: "(cod y)\<cdot>y \<cong> y"
    using S6 by blast
  lemma A4aFromV: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)"
    by (metis S1 S3 S4 S5 S6)
  lemma A4bFromV: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))"
    by (metis S2 S3 S4 S5 S6)
  lemma  A5FromV: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using S4 by blast
end

(* Axioms Set VI reduced a*)

locale Axioms_Set_VI_reduced_a =
assumes
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
 A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_VI_reduced_a
begin
  lemma S1FromVI: "E(dom x) \<^bold>\<rightarrow> E x"
    using A1' A3a A4a by smt
  lemma S2FromVI: "E(cod y) \<^bold>\<rightarrow> E y"
    by (smt A1' A3b A4b)
  lemma S3FromVI: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI: "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI: "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

(* Axioms Set VI reduced b *)

locale Axioms_Set_VI_reduced_b =
assumes
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A2a: "cod(dom x) \<cong> dom x" and
 A2b: "dom(cod y) \<cong> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_VI_reduced_b
begin
  lemma S1FromVI_new': "E(dom x) \<^bold>\<rightarrow> E x"
    by (metis A1' A2a A3a)
  lemma S2FromVI_new': "E(cod y) \<^bold>\<rightarrow> E y"
    using A1' A2b A3b by smt
  lemma S3FromVI_new': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI_new': "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI_new': "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI_new': "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

(* Axioms Set VI reduced c*)

locale Axioms_Set_VI_reduced_c =
assumes
 S1\<^sub>v: "E(dom x) \<^bold>\<rightarrow> E x" and
 S2\<^sub>v: "E(cod y) \<^bold>\<rightarrow> E y" and
 A1': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
 A3a: "x\<cdot>(dom x) \<cong> x" and
 A3b: "(cod y)\<cdot>y \<cong> y" and
  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_VI_reduced_c
begin
  lemma S1FromVI_new'': "E(dom x) \<^bold>\<rightarrow> E x"
    using S1\<^sub>v by blast
  lemma S2FromVI_new'': "E(cod y) \<^bold>\<rightarrow> E y"
    using S2\<^sub>v by blast
  lemma S3FromVI_new'': "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    by (metis A1')
  lemma S4FromVI_new'': "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    using A5 by blast
  lemma S5FromVI_new'': "x\<cdot>(dom x) \<cong> x"
    using A3a by blast
  lemma S6FromVI_new'': "(cod y)\<cdot>y \<cong> y"
    using A3b by blast
end

(* Axioms Set FS-III *)

locale Axioms_Set_FS_III =
  assumes
  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
 B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " and
 B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" and
 B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" and
 B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" and
 B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_FS_III
begin
  lemma S1: "E(dom x) \<^bold>\<rightarrow> E x"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S2: "E(cod y) \<^bold>\<rightarrow> E y"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S5: "x\<cdot>(dom x) \<cong> x"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
  lemma S6: "(cod y)\<cdot>y \<cong> y"
    nitpick [user_axioms, show_all, format = 2, expect = genuine] oops
end

(* Axioms Set FS-IV *)

locale Axioms_Set_FS_IV =
assumes
 B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
 B0b: "E(dom x) \<^bold>\<rightarrow> E x" and
 B0c: "E(cod x) \<^bold>\<rightarrow> E x" and
  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
 B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " and
 B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" and
 B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" and
 B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" and
 B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
 B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
begin
  lemma True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
  lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True
    nitpick [satisfy, user_axioms, show_all, format = 2, expect = genuine] oops
end

context Axioms_Set_FS_IV
begin
  lemma S1FromVIII: "E(dom x) \<^bold>\<rightarrow> E x"  using B0b by blast
  lemma S2FromVIII: "E(cod y) \<^bold>\<rightarrow> E y"  using B0c by blast
  lemma S3FromVIII: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis B0a B0b B0c B1 B3a)
  lemma S4FromVIII: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" by (meson B0a B5)
  lemma S5FromVIII: "x\<cdot>(dom x) \<cong> x" using B0a B3a by blast
  lemma S6FromVIII: "(cod y)\<cdot>y \<cong> y" using B0a B3b by blast
end

context Axioms_Set_V
begin
  lemma B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S1 S2 S3 by blast
  lemma B0b: "E(dom x) \<^bold>\<rightarrow> E x" using S1 by blast
  lemma B0c: "E(cod x) \<^bold>\<rightarrow> E x" using S2 by blast
  lemma  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" by (metis S3 S5)
  lemma B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " by (metis S3 S5)
  lemma B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" by (metis S3 S6)
  lemma B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" using S5 by auto
  lemma B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" using S6 by blast
  lemma B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis S1 S3 S4 S5)
  lemma B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis S2 S3 S4 S6)
  lemma  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
end

context Axioms_Set_FS_IV
begin
  lemma B2aRedundant: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " by (metis B0a B1 B3a)
  lemma B2bRedundant: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" by (metis B0a B1 B3b)
  lemma B4aRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis B0a B0b B1 B3a B5)
  lemma B4bRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis B0a B0c B1 B3b B5)
end

end


theory Adjustable_References
  imports Main "HOL-Library.Mapping" "HOL-Library.RBT_Mapping"
    "HOL-Library.Code_Target_Numeral"
begin

text \<open>
This is an Isabelle/HOL formalization of ``Adjustable References'', ITP 2013 by Viktor Vafeiadis.
See also \<^url>\<open>https://people.mpi-sws.org/~viktor/arefs/\<close>.
\<close>

datatype ('r, 't) aref = Aref (aref_of: "'r \<Rightarrow> 't") (val_of: 'r)

locale Is_Aref =
  fixes f :: "'r \<Rightarrow> 'a \<Rightarrow> 'b"
  fixes upd :: "'r \<Rightarrow> 'a \<Rightarrow> 'r * 'b"
  assumes "\<forall> x a. f (fst (upd x a)) = f x"
      and "\<forall> x a. snd (upd x a) = f x a"
begin

definition aref_val where
  "aref_val x = Aref f x"

definition aref_get :: "('r, 'a \<Rightarrow> 'b) aref \<Rightarrow> 'a \<Rightarrow> 'b" where
  "aref_get r = f (val_of r)"

lemma get_val:
  "aref_get (aref_val x) = f x"
  unfolding aref_get_def aref_val_def by simp

definition
  "aref_getu = (let a = upd in aref_get)"

lemma aref_getu:
  "aref_getu = aref_get"
  unfolding aref_getu_def Let_def ..

end

text \<open>This axiomatization is necessary for termination proofs\<close>
lemma aref_getu_cong[fundef_cong]:
  "Is_Aref.aref_getu f1 g1 r1 x1 = Is_Aref.aref_getu f1 g2 r2 x2" if
  "\<And> M. g1 M x2 = g2 M x2" "r1 = r2" "x1 = x2"
  sorry

fun fib where
  "fib 0 = (1 :: int)" |
  "fib (Suc 0) = 1" |
  "fib (Suc (Suc n)) = fib (n + 1) + fib n"

definition
  "mem_upd M x \<equiv>
  case Mapping.lookup M x of
    Some v \<Rightarrow> (M, v)
  | None \<Rightarrow> let v = fib x in (Mapping.update x v M, v)
"

definition
  "f M x \<equiv> case Mapping.lookup M x of
    Some v \<Rightarrow> v
  | None \<Rightarrow> fib x
"

code_printing
  constant Is_Aref.aref_val \<rightharpoonup> (SML) "(fn f => fn v => ref v) _ _"

code_printing
  constant Is_Aref.aref_get \<rightharpoonup> (SML) "(fn f => fn r => f (!r)) _ _"

code_printing
  constant Is_Aref.aref_getu \<rightharpoonup> (SML)
    "(fn f => fn u => fn r => fn x => let val (v, fv) = u (!r) x in r := v; fv end) _ _ _"

interpretation Is_Aref f mem_upd
  apply standard
  subgoal
    unfolding f_def mem_upd_def
    apply auto
    apply (intro ext)
    apply (auto split: option.split simp: Let_def)
    subgoal
      by (metis domI domIff lookup_update')
    subgoal
      by (metis lookup_update' option.distinct(1) option.sel)
    subgoal
      by (metis lookup_update_neq option.inject option.simps(3))
    done
  subgoal
    unfolding f_def mem_upd_def
    by (auto split: option.split simp: Let_def)
  done

lemma
  "aref_get (aref_val Mapping.empty) n = fib n"
  unfolding get_val f_def by (auto simp: lookup_empty)

definition
  "fib_memo1 r n = aref_getu r n"

lemma fib_fib_memo:
  "fib n = fib_memo1 (aref_val Mapping.empty) n"
  unfolding get_val f_def fib_memo1_def aref_getu by (auto simp: lookup_empty)

lemma
  "aref_get (aref_val m) n = fib n"
  unfolding get_val f_def oops

definition
  "test n = sum_list (map fib (replicate n 37))"

lemma test_code[code]:
  "test n = (let r = aref_val Mapping.empty in sum_list (map (fib_memo1 r) (replicate n 37)))"
  unfolding test_def fib_fib_memo Let_def ..

code_printing
  constant Is_Aref.aref_val \<rightharpoonup> (SML) "(fn f => fn v => Unsynchronized.ref v) _ _"

code_printing
  constant Is_Aref.aref_get \<rightharpoonup> (SML) "(fn f => fn r => f (!r)) _ _"

code_printing
  constant Is_Aref.aref_getu \<rightharpoonup> (SML)
    "(fn f => fn u => fn r => fn x => let val (v, fv) = u (!r) x in r := v; fv end) _ _ _"

text \<open>This example shows that memoization is actually working.\<close>
(*
code_reflect Test functions test fib nat_of_integer

ML_val \<open>Test.test (Test.nat_of_integer 100000)\<close>
ML_val \<open>Test.fib (Test.nat_of_integer 37)\<close>
*)

paragraph \<open>Experiments for recursive memoization.\<close>

definition
  "fib' = (let r = aref_val Mapping.empty in fib_memo1 r)"

lemma fib'_fib:
  "fib' n = fib n"
  unfolding fib'_def fib_fib_memo Let_def ..

lemma fib_unroll:
  "fib n = (if n = 0 \<or> n = 1 then 1 else fib (n - 1) + fib (n - 2))"
  apply (cases n)
   apply (simp; fail)
  subgoal for m
    by (cases m) auto
  done

lemma fib_code[code]:
  "fib n = (let f = fib' in if n = 0 \<or> n = 1 then 1 else f (n - 1) + f (n - 2))"
  unfolding fib'_fib Let_def by (rule fib_unroll)

export_code fib in SML
export_code fib' checking SML

text \<open>This memoizes nothing.\<close>
(*
code_reflect Test functions fib' nat_of_integer

ML_val \<open>Test.fiba (Test.nat_of_integer 40)\<close>
*)

(* definition "fib2 r n = (if n = 0 \<or> n = 1 then 1 else fib_memo1 r (n - 1) + fib_memo1 r (n - 2))"*)
(*
definition
  "fib2 r n = (if n = 0 \<or> n = 1 then fib_memo1 r n else fib_memo1 r (n - 1) + fib_memo1 r (n - 2))"

lemma fib2_fib:
  "fib2 (aref_val Mapping.empty) n = fib n"
  unfolding fib2_def fib_fib_memo[symmetric] by (simp add: fib_unroll)

definition
  "fib_iter2 n = (let r = aref_val Mapping.empty; _ = map (fib2 r) [0..<n] in fib2 r n)"

lemma fib_iter2_correct:
  "fib_iter2 n = fib n"
  unfolding fib_iter2_def Let_def by (subst fib2_fib; rule HOL.refl)

export_code fib_iter2 in SML
code_reflect Test functions fib_iter2 nat_of_integer
text \<open>Does not memoize\<close>
ML_val \<open>Test.fib_iter2 (Test.nat_of_integer 38)\<close>
*)

context
  fixes r ::  "((nat, int) mapping, nat \<Rightarrow> int) aref"
begin

function fib1 and mem_upd' where
"fib1 n =
  (if n = 0 \<or> n = 1 then 1 else Is_Aref.aref_getu f mem_upd' r (n - 1) + Is_Aref.aref_getu f mem_upd' r (n - 2))"
| "mem_upd' M x = (
  case Mapping.lookup M x of
    Some v \<Rightarrow> (M, v)
  | None \<Rightarrow> let v = fib1 x in (Mapping.update x v M, v))"
     apply auto
  subgoal for P x
    apply (cases x)
     apply auto
    done
  done

lemma wf_term:
  "wf {(x, y). case (x, y) of
    (Inl (n :: nat), Inl m) \<Rightarrow> False
  | (Inl n, Inr (_, m :: nat)) \<Rightarrow> n \<le> m
  | (Inr (_, n), Inl m) \<Rightarrow> n < m
  | (Inr (_, n), Inr (_, m)) \<Rightarrow> False
  }"
proof (rule wfI_min, goal_cases)
  case (1 x Q)
  let ?l = "Inf {n. Inl n \<in> Q}"
  let ?r = "Inf {n. \<exists> M. Inr (M, n) \<in> Q}"
  from \<open>x \<in> Q\<close> consider
    (r)    "{n. Inl n \<in> Q} = {}" "{n. \<exists> M. Inr (M, n) \<in> Q} \<noteq> {}"
    | (l)    "{n. Inl n \<in> Q} \<noteq> {}" "{n. \<exists> M. Inr (M, n) \<in> Q} = {}"
    | (both) "{n. Inl n \<in> Q} \<noteq> {}" "{n. \<exists> M. Inr (M, n) \<in> Q} \<noteq> {}"
    by (cases x) auto
  then show ?case
  proof cases
    case r
    then obtain n2 M where *:
      "Inr (M, n2) \<in> Q"
      by auto
    then obtain M' where "Inr (M'::'a, ?r) \<in> Q"
      by (smt Inf_nat_def LeastI_ex mem_Collect_eq)
    with * \<open>_ = {}\<close> show ?thesis
      by (intro bexI[where x = "Inr (M'::'a, ?r)"]) (auto split: sum.split_asm)
  next
    case l
    then obtain n1 where *:
      "Inl n1 \<in> Q"
      by auto
    with \<open>_ = {}\<close> show ?thesis
      by (intro bexI[where x = "Inl ?l"]) (auto elim: LeastI simp: Inf_nat_def split: sum.split_asm)
  next
    case both
    then obtain n1 n2 M where *:
      "Inl n1 \<in> Q" "Inr (M, n2) \<in> Q"
      by auto
    from this(2) obtain M' where M: "Inr (M'::'a, ?r) \<in> Q"
      by (smt Inf_nat_def LeastI_ex mem_Collect_eq)
    let ?z = "if ?r < ?l then Inr (M'::'a, ?r) else Inl ?l"
    from * M show ?thesis
      apply -
      apply (rule bexI[where x = ?z])
      subgoal
        apply (auto split: sum.split_asm)
        subgoal for m
          by (subgoal_tac "?l \<le> m"; fastforce intro: cInf_lower)
        subgoal for M m
          by (subgoal_tac "?r \<le> m"; fastforce intro: cInf_lower)
        done
      by (auto elim: LeastI simp: Inf_nat_def)
  qed
qed

termination
  by (standard, rule wf_term, auto)

context
  assumes "r = aref_val Mapping.empty"
begin

lemma
  fib1: "fib1 n = fib n" and mem_upd': "mem_upd' M x = mem_upd M x"
proof (induction rule: fib1_mem_upd'.induct)
  case prems: (1 n)
  show ?case
    apply (auto simp del: mem_upd'.simps simp add: Let_def)
    apply (cases n)
     apply simp
    subgoal for m
      apply (cases m)
       apply simp
      using prems apply (simp add: aref_getu_cong[of mem_upd', OF _ HOL.refl HOL.refl])
      unfolding fib_memo1_def[symmetric] \<open>r = _\<close> fib_fib_memo ..
    done
next
  case (2 M x)
  then show ?case
    by (auto simp: Let_def mem_upd_def split: if_split_asm option.split)
qed

end

end

definition
  "fib_iter n \<equiv> let _ = map fib [2..<n] in fib n"

definition
  "fib_iter1 n = (let r = aref_val Mapping.empty; _ = map (fib1 r) [2..<n] in fib1 r n)"

lemma fib_iter1_correct:
  "fib_iter1 n = fib n"
  unfolding fib_iter1_def Let_def by (subst fib1; rule HOL.refl)

export_code fib fib_iter in SML
export_code fib checking SML

code_reflect Test functions fib_iter1 fib_iter fib nat_of_integer

text \<open>Also doesn't memoize anything\<close>
ML_val \<open>Test.fib (Test.nat_of_integer 30)\<close>
ML_val \<open>Test.fib_iter (Test.nat_of_integer 30)\<close>

text \<open>This memoizes\<close>
ML_val \<open>Test.fib_iter1 (Test.nat_of_integer 2000)\<close>

end


(*  Title:      HOL/Library/Code_Target_Nat.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Implementation of natural numbers by target-language integers\<close>

theory Code_Target_Nat
imports Code_Abstract_Nat
begin

subsection \<open>Implementation for @{typ nat}\<close>

context
includes natural.lifting integer.lifting
begin

lift_definition Nat :: "integer \<Rightarrow> nat"
  is nat
  .

lemma [code_post]:
  "Nat 0 = 0"
  "Nat 1 = 1"
  "Nat (numeral k) = numeral k"
  by (transfer, simp)+

lemma [code_abbrev]:
  "integer_of_nat = of_nat"
  by transfer rule

lemma [code_unfold]:
  "Int.nat (int_of_integer k) = nat_of_integer k"
  by transfer rule

lemma [code abstype]:
  "Code_Target_Nat.Nat (integer_of_nat n) = n"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (nat_of_integer k) = max 0 k"
  by transfer auto

lemma [code_abbrev]:
  "nat_of_integer (numeral k) = nat_of_num k"
  by transfer (simp add: nat_of_num_numeral)

lemma [code abstract]:
  "integer_of_nat (nat_of_num n) = integer_of_num n"
  by transfer (simp add: nat_of_num_numeral)

lemma [code abstract]:
  "integer_of_nat 0 = 0"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat 1 = 1"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (m + n) = of_nat m + of_nat n"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (m - n) = max 0 (of_nat m - of_nat n)"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (m * n) = of_nat m * of_nat n"
  by transfer (simp add: of_nat_mult)

lemma [code abstract]:
  "integer_of_nat (m div n) = of_nat m div of_nat n"
  by transfer (simp add: zdiv_int)

lemma [code abstract]:
  "integer_of_nat (m mod n) = of_nat m mod of_nat n"
  by transfer (simp add: zmod_int)

lemma [code]:
  "Divides.divmod_nat m n = (m div n, m mod n)"
  by (fact divmod_nat_div_mod)

lemma [code]:
  "divmod m n = map_prod nat_of_integer nat_of_integer (divmod m n)"
  by (simp only: prod_eq_iff divmod_def map_prod_def case_prod_beta fst_conv snd_conv)
    (transfer, simp_all only: nat_div_distrib nat_mod_distrib
        zero_le_numeral nat_numeral)

lemma [code]:
  "HOL.equal m n = HOL.equal (of_nat m :: integer) (of_nat n)"
  by transfer (simp add: equal)

lemma [code]:
  "m \<le> n \<longleftrightarrow> (of_nat m :: integer) \<le> of_nat n"
  by simp

lemma [code]:
  "m < n \<longleftrightarrow> (of_nat m :: integer) < of_nat n"
  by simp

lemma num_of_nat_code [code]:
  "num_of_nat = num_of_integer \<circ> of_nat"
  by transfer (simp add: fun_eq_iff)

end

lemma (in semiring_1) of_nat_code_if:
  "of_nat n = (if n = 0 then 0
     else let
       (m, q) = Divides.divmod_nat n 2;
       m' = 2 * of_nat m
     in if q = 0 then m' else m' + 1)"
proof -
  from div_mult_mod_eq have *: "of_nat n = of_nat (n div 2 * 2 + n mod 2)" by simp
  show ?thesis
    by (simp add: Let_def divmod_nat_div_mod of_nat_add [symmetric])
      (simp add: * mult.commute of_nat_mult add.commute)
qed

declare of_nat_code_if [code]

definition int_of_nat :: "nat \<Rightarrow> int" where
  [code_abbrev]: "int_of_nat = of_nat"

lemma [code]:
  "int_of_nat n = int_of_integer (of_nat n)"
  by (simp add: int_of_nat_def)

lemma [code abstract]:
  "integer_of_nat (nat k) = max 0 (integer_of_int k)"
  including integer.lifting by transfer auto

lemma term_of_nat_code [code]:
  \<comment> \<open>Use @{term Code_Numeral.nat_of_integer} in term reconstruction
        instead of @{term Code_Target_Nat.Nat} such that reconstructed
        terms can be fed back to the code generator\<close>
  "term_of_class.term_of n =
   Code_Evaluation.App
     (Code_Evaluation.Const (STR ''Code_Numeral.nat_of_integer'')
        (typerep.Typerep (STR ''fun'')
           [typerep.Typerep (STR ''Code_Numeral.integer'') [],
         typerep.Typerep (STR ''Nat.nat'') []]))
     (term_of_class.term_of (integer_of_nat n))"
  by (simp add: term_of_anything)

lemma nat_of_integer_code_post [code_post]:
  "nat_of_integer 0 = 0"
  "nat_of_integer 1 = 1"
  "nat_of_integer (numeral k) = numeral k"
  including integer.lifting by (transfer, simp)+

code_identifier
  code_module Code_Target_Nat \<rightharpoonup>
    (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


section \<open> Frames \<close>

theory utp_frames
  imports utp_rel_laws
begin

subsection \<open> Operators \<close>

text \<open> The frame operator restricts the relation P to only operate on variables in the frame a \<close>

definition frame :: "'s scene \<Rightarrow> 's hrel \<Rightarrow> 's hrel" where
 [pred]: "frame a P = (\<lambda> (s, s'). s \<approx>\<^sub>S s' on - a \<and> P (s, s'))"

text \<open> The frame extension operator take a lens @{term a}, and a relation @{term P}. It constructs
  a relation such that all variables outside of @{term a} are unchanged, and the valuations for
  @{term a} are drawn from @{term P}. Intuitively, this can be seen as extending the alphabet
  of @{term P}. \<close>

definition frame_ext :: "('s\<^sub>1 \<Longrightarrow> ('s\<^sub>2 :: scene_space)) \<Rightarrow> 's\<^sub>1 hrel \<Rightarrow> 's\<^sub>2 hrel" where
  "frame_ext a P = frame \<lbrace>a\<rbrace>\<^sub>F (P \<up> (a \<times> a))"

abbreviation modifies :: "'s hrel \<Rightarrow> 's scene \<Rightarrow> bool" where
"modifies P a \<equiv> P is frame a"

abbreviation not_modifies :: "'s hrel \<Rightarrow> 's scene \<Rightarrow> bool" where
"not_modifies P a \<equiv> P is frame (-a)"

text \<open> Variable restriction - assign arbitrary values to a scene, effectively forbidding the
  relation from using its value\<close>

definition rrestr :: "'s scene \<Rightarrow> 's hrel \<Rightarrow> 's hrel" where
[pred]: "rrestr A P = (\<lambda> (s, s'). (\<exists> s\<^sub>0 s\<^sub>0'. P (s \<oplus>\<^sub>S s\<^sub>0 on A, s' \<oplus>\<^sub>S s\<^sub>0' on A)) \<and> s' \<approx>\<^sub>S s on A)"

abbreviation not_uses :: "'s hrel \<Rightarrow> 's scene \<Rightarrow> bool" where
"not_uses P a \<equiv> P is rrestr a"

syntax
  "_frame" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]")
  "_frame_ext" :: "svid \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sub>\<up>")
  \<comment> \<open> Modifies Predicate \<close>
  "_modifies"     :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infix "mods" 30)
  \<comment> \<open> Not Modifies Predicate \<close>
  "_not_modifies" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infix "nmods" 30)
  \<comment> \<open> Not Uses Predicate \<close>
  "_not_uses"     :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infix "nuses" 30)

translations
  "_frame a P" == "CONST frame a P"
  "\<lbrace>A\<rbrace>:[P]" <= "_frame \<lbrakk>\<lbrace>A\<rbrace>\<^sub>F\<rbrakk>\<^sub>F P"
  "_frame_ext a P" == "CONST frame_ext a P"
  "_modifies P a" == "CONST modifies P a"
  "P mods \<lbrace>A\<rbrace>" <= "_modifies P \<lbrakk>\<lbrace>A\<rbrace>\<^sub>F\<rbrakk>\<^sub>F"
  "_not_modifies P a" == "CONST not_modifies P a"
  "P nmods \<lbrace>A\<rbrace>" <= "_not_modifies P \<lbrakk>\<lbrace>A\<rbrace>\<^sub>F\<rbrakk>\<^sub>F"
  "_not_uses P a" == "CONST not_uses P a"
  "P nuses \<lbrace>A\<rbrace>" <= "_not_uses P \<lbrakk>\<lbrace>A\<rbrace>\<^sub>F\<rbrakk>\<^sub>F"

lemma nmods_iff [pred]: "P nmods A \<longleftrightarrow> (\<forall> s s'. P (s, s') \<longrightarrow> s \<approx>\<^sub>S s' on A)"
  by (pred_auto add: Healthy_def)

lemma nuses_iff [pred]:
  assumes "idem_scene A"
  shows "P nuses A \<longleftrightarrow> (\<forall> s s' s\<^sub>0. P (s, s') \<longrightarrow> (s \<approx>\<^sub>S s' on A \<and> P (s \<oplus>\<^sub>S s\<^sub>0 on A, s' \<oplus>\<^sub>S s\<^sub>0 on A)))"
  apply (pred_auto assms: assms add: Healthy_def)
  apply (metis scene_override_idem scene_override_overshadow_right)
  apply (metis scene_override_overshadow_left scene_override_overshadow_right)
  apply (metis scene_override_idem scene_override_overshadow_left)
  apply blast
  apply (metis scene_override_idem scene_override_overshadow_right)
  done

lemma nuses_converse_commute: "\<lbrakk> idem_scene A; P nuses A; Q nuses (- A) \<rbrakk> \<Longrightarrow> P ;; Q = Q ;; P"
  apply (pred_auto)
  apply (smt (verit) scene_override_commute scene_override_idem scene_override_overshadow_left)
  apply (metis scene_equiv_def scene_equiv_sym scene_override_commute)
  done

lemma subst_indep_commute: "\<lbrakk> idem_scene A; A \<sharp>\<^sub>s \<sigma>; -A \<sharp>\<^sub>s \<rho> \<rbrakk> \<Longrightarrow> \<sigma> \<circ>\<^sub>s \<rho> = \<rho> \<circ>\<^sub>s \<sigma>"
  by (expr_auto, metis scene_override_commute scene_override_idem)

lemma nuses_assigns: "\<lbrakk> idem_scene A; A \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>a nuses A"
  by (simp add: nuses_iff expr_defs, auto, simp_all add: assigns_rel_def)
     (metis scene_equiv_def scene_equiv_sym scene_override_idem)

subsection \<open> Frame laws \<close>

named_theorems frame

lemma frame_all [frame]: "\<Sigma>:[P] = P"
  by (pred_auto)

lemma frame_none [frame]: "\<emptyset>:[P] = (P \<and> II)"
  by (pred_auto add: scene_override_commute)

term unrest

translations
  "\<lbrace>A\<rbrace> \<sharp> P" <= "_unrest \<lbrakk>\<lbrace>A\<rbrace>\<^sub>F\<rbrakk>\<^sub>F P"

lemma skip_uses_nothing: "idem_scene A \<Longrightarrow> II nuses A"
  by (pred_simp)

lemma "basis_lens y \<Longrightarrow> \<lbrace>y\<^sup><, y\<^sup>>\<rbrace> \<sharp> P \<Longrightarrow> P nuses \<lbrace>y\<rbrace>"
  apply (pred_auto)
  oops

lemma frame_commute:
  assumes "\<lbrace>y\<^sup><, y\<^sup>>\<rbrace> \<sharp> P"
  shows "$x:[P] ;; $y:[Q] = $y:[Q] ;; $x:[P]"
  oops

lemma frame_commute:
  assumes "($y\<^sup><) \<sharp> P" "($y\<^sup>>) \<sharp> P""($x\<^sup><) \<sharp> Q" "($x\<^sup>>) \<sharp> Q" "x \<bowtie> y"
  shows "$x:[P] ;; $y:[Q] = $y:[Q] ;; $x:[P]"
  oops
  (*apply (insert assms)
  apply (pred_auto)
   apply (rename_tac s s' s\<^sub>0)
   apply (subgoal_tac "(s \<oplus>\<^sub>L s' on y) \<oplus>\<^sub>L s\<^sub>0 on x = s\<^sub>0 \<oplus>\<^sub>L s' on y")
    apply (metis lens_indep_get lens_indep_sym lens_override_def)
   apply (simp add: lens_indep.lens_put_comm lens_override_def)
  apply (rename_tac s s' s\<^sub>0)
  apply (subgoal_tac "put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> s (get\<^bsub>x\<^esub> (put\<^bsub>x\<^esub> s\<^sub>0 (get\<^bsub>x\<^esub> s')))) (get\<^bsub>y\<^esub> (put\<^bsub>y\<^esub> s (get\<^bsub>y\<^esub> s\<^sub>0)))
                      = put\<^bsub>x\<^esub> s\<^sub>0 (get\<^bsub>x\<^esub> s')")
   apply (metis lens_indep_get lens_indep_sym)
  apply (metis lens_indep.lens_put_comm)
  done*)

lemma frame_miracle [simp]:
  "x:[false] = false"
  by (pred_auto)

lemma frame_skip [simp]:
  "idem_scene x \<Longrightarrow> x:[II] = II"
  by (pred_auto)

lemma frame_assign_in [frame]:
  "\<lbrakk> vwb_lens a; x \<subseteq>\<^sub>L a \<rbrakk> \<Longrightarrow> $a:[x := v] = x := v"
  apply pred_auto
  by (simp add: lens_override_def scene_override_commute)

lemma frame_conj_true [frame]:
  "\<lbrakk>-{x\<^sup><, x\<^sup>>} \<sharp> P; vwb_lens x \<rbrakk> \<Longrightarrow> (P \<and> $x:[true]) = $x:[P]"
  by (pred_auto)

(*lemma frame_is_assign [frame]:
  "vwb_lens x \<Longrightarrow> x:[$x\<acute> =\<^sub>u \<lceil>v\<rceil>\<^sub><] = x := v"
  by (pred_auto)
  *)
lemma frame_seq [frame]:
  assumes "vwb_lens x" "-{x\<^sup>>,x\<^sup><} \<sharp> P" "-{x\<^sup><,x\<^sup>>} \<sharp> Q"
  shows "$x:[P ;; Q] = $x:[P] ;; $x:[Q]"
  unfolding frame_def apply (pred_auto)
  oops

lemma frame_assign_commute_unrest:
  assumes "vwb_lens x" "x \<bowtie> a" "$a \<sharp> v" "$x\<^sup>< \<sharp> P" "$x\<^sup>> \<sharp> P"
  shows "x := v ;; $a:[P] = $a:[P] ;; x := v"
  using assms apply (pred_auto)
  oops

lemma frame_to_antiframe [frame]:
  "\<lbrakk> x \<bowtie>\<^sub>S y; x \<squnion>\<^sub>S y = \<top>\<^sub>S \<rbrakk> \<Longrightarrow> x:[P] = (-y):[P]"
  apply pred_auto
  by (metis scene_indep_compat scene_indep_override scene_override_commute scene_override_id scene_override_union)+

(*
lemma rel_frext_miracle [frame]:
  "a:[false]\<^sup>+ = false"
  by (metis false_pred_def frame_miracle trancl_empty)

lemma rel_frext_skip [frame]:
  "idem_scene a \<Longrightarrow> a:[II]\<^sup>+ = II"
  by (metis frame_skip rtrancl_empty rtrancl_trancl_absorb)

lemma rel_frext_seq [frame]:
  "idem_scene a \<Longrightarrow> a:[P ;; Q]\<^sup>+ = (a:[P]\<^sup>+ ;; a:[Q]\<^sup>+)"
  apply (pred_auto)
  oops (* gets nitpicked *)
*)

(*
lemma rel_frext_assigns [frame]:
  "vwb_lens a \<Longrightarrow> a:[\<langle>\<sigma>\<rangle>\<^sub>a]\<^sup>+ = \<langle>\<sigma> \<oplus>\<^sub>s a\<rangle>\<^sub>a"
  by (pred_auto)

lemma rel_frext_rcond [frame]:
  "a:[P \<triangleleft> b \<triangleright>\<^sub>r Q]\<^sup>+ = (a:[P]\<^sup>+ \<triangleleft> b \<oplus>\<^sub>p a \<triangleright>\<^sub>r a:[Q]\<^sup>+)"
  by (pred_auto)

lemma rel_frext_commute:
  "x \<bowtie> y \<Longrightarrow> x:[P]\<^sup>+ ;; y:[Q]\<^sup>+ = y:[Q]\<^sup>+ ;; x:[P]\<^sup>+"
  apply (pred_auto)
   apply (rename_tac a c b)
   apply (subgoal_tac "\<And>b a. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b a) = get\<^bsub>y\<^esub> b")
    apply (metis (no_types, hide_lams) lens_indep_comm lens_indep_get)
   apply (simp add: lens_indep.lens_put_irr2)
  apply (subgoal_tac "\<And>b c. get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> b c) = get\<^bsub>x\<^esub> b")
   apply (subgoal_tac "\<And>b a. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b a) = get\<^bsub>y\<^esub> b")
    apply (metis (mono_tags, lifting) lens_indep_comm)
   apply (simp_all add: lens_indep.lens_put_irr2)
  done

lemma antiframe_disj [frame]: "(x:\<lbrakk>P\<rbrakk> \<or> x:\<lbrakk>Q\<rbrakk>) = x:\<lbrakk>P \<or> Q\<rbrakk>"
  by (pred_auto)

lemma antiframe_seq [frame]:
  "\<lbrakk> vwb_lens x; $x\<acute> \<sharp> P; $x \<sharp> Q \<rbrakk>  \<Longrightarrow> (x:\<lbrakk>P\<rbrakk> ;; x:\<lbrakk>Q\<rbrakk>) = x:\<lbrakk>P ;; Q\<rbrakk>"
  apply (pred_auto)
   apply (metis vwb_lens_wb wb_lens_def weak_lens.put_get)
  apply (metis vwb_lens_wb wb_lens.put_twice wb_lens_def weak_lens.put_get)
  done

lemma antiframe_copy_assign:
  "vwb_lens x \<Longrightarrow> (x := \<guillemotleft>v\<guillemotright> ;; x:\<lbrakk>P\<rbrakk> ;; x := \<guillemotleft>v\<guillemotright>) = (x := \<guillemotleft>v\<guillemotright> ;; x:\<lbrakk>P\<rbrakk>)"
  by pred_auto

lemma nameset_skip: "vwb_lens x \<Longrightarrow> (\<^bold>n\<^bold>s x \<bullet> II) = II\<^bsub>x\<^esub>"
  by (pred_auto, meson vwb_lens_wb wb_lens.get_put)

lemma nameset_skip_ra: "vwb_lens x \<Longrightarrow> (\<^bold>n\<^bold>s x \<bullet> II\<^bsub>x\<^esub>) = II\<^bsub>x\<^esub>"
  by (pred_auto)

declare sublens_def [lens_defs]
*)
subsection \<open> Modification laws \<close>
lemma "(rrestr x P) nmods x"
  oops

end


(*  Title:      ZF/ex/CoUnit.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Trivial codatatype definitions, one of which goes wrong!\<close>

theory CoUnit imports Main begin

text \<open>
  See discussion in: L C Paulson.  A Concrete Final Coalgebra Theorem
  for ZF Set Theory.  Report 334, Cambridge University Computer
  Laboratory.  1994.

  \bigskip

  This degenerate definition does not work well because the one
  constructor's definition is trivial!  The same thing occurs with
  Aczel's Special Final Coalgebra Theorem.
\<close>

consts
  counit :: i
codatatype
  "counit" = Con ("x \<in> counit")

inductive_cases ConE: "Con(x) \<in> counit"
  \<comment> \<open>USELESS because folding on @{term "Con(xa) == xa"} fails.\<close>

lemma Con_iff: "Con(x) = Con(y) \<longleftrightarrow> x = y"
  \<comment> \<open>Proving freeness results.\<close>
  by (auto elim!: counit.free_elims)

lemma counit_eq_univ: "counit = quniv(0)"
  \<comment> \<open>Should be a singleton, not everything!\<close>
  apply (rule counit.dom_subset [THEN equalityI])
  apply (rule subsetI)
  apply (erule counit.coinduct)
   apply (rule subset_refl)
  apply (unfold counit.con_defs)
  apply fast
  done

text \<open>
  \medskip A similar example, but the constructor is non-degenerate
  and it works!  The resulting set is a singleton.
\<close>

consts
  counit2 :: i
codatatype
  "counit2" = Con2 ("x \<in> counit2", "y \<in> counit2")

inductive_cases Con2E: "Con2(x, y) \<in> counit2"

lemma Con2_iff: "Con2(x, y) = Con2(x', y') \<longleftrightarrow> x = x' & y = y'"
  \<comment> \<open>Proving freeness results.\<close>
  by (fast elim!: counit2.free_elims)

lemma Con2_bnd_mono: "bnd_mono(univ(0), %x. Con2(x, x))"
  apply (unfold counit2.con_defs)
  apply (rule bnd_monoI)
   apply (assumption | rule subset_refl QPair_subset_univ QPair_mono)+
  done

lemma lfp_Con2_in_counit2: "lfp(univ(0), %x. Con2(x,x)) \<in> counit2"
  apply (rule singletonI [THEN counit2.coinduct])
  apply (rule qunivI [THEN singleton_subsetI])
  apply (rule subset_trans [OF lfp_subset empty_subsetI [THEN univ_mono]])
  apply (fast intro!: Con2_bnd_mono [THEN lfp_unfold])
  done

lemma counit2_Int_Vset_subset [rule_format]:
  "Ord(i) ==> \<forall>x y. x \<in> counit2 \<longrightarrow> y \<in> counit2 \<longrightarrow> x \<inter> Vset(i) \<subseteq> y"
  \<comment> \<open>Lemma for proving finality.\<close>
  apply (erule trans_induct)
  apply (tactic "safe_tac (put_claset subset_cs @{context})")
  apply (erule counit2.cases)
  apply (erule counit2.cases)
  apply (unfold counit2.con_defs)
  apply (tactic \<open>fast_tac (put_claset subset_cs @{context}
    addSIs [@{thm QPair_Int_Vset_subset_UN} RS @{thm subset_trans}, @{thm QPair_mono}]
    addSEs [@{thm Ord_in_Ord}, @{thm Pair_inject}]) 1\<close>)
  done

lemma counit2_implies_equal: "[| x \<in> counit2;  y \<in> counit2 |] ==> x = y"
  apply (rule equalityI)
  apply (assumption | rule conjI counit2_Int_Vset_subset [THEN Int_Vset_subset])+
  done

lemma counit2_eq_univ: "counit2 = {lfp(univ(0), %x. Con2(x,x))}"
  apply (rule equalityI)
   apply (rule_tac [2] lfp_Con2_in_counit2 [THEN singleton_subsetI])
  apply (rule subsetI)
  apply (drule lfp_Con2_in_counit2 [THEN counit2_implies_equal])
  apply (erule subst)
  apply (rule singletonI)
  done

end