(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section \<open>\isaheader{Tries without invariants}\<close>
theory Trie2 imports
  Trie_Impl
begin

(*<*)

subsection \<open>Abstract type definition\<close>

typedef ('key, 'val) trie =
  "{t :: ('key, 'val) Trie.trie. invar_trie t}"
  morphisms impl_of Trie
proof
  show "empty_trie \<in> ?trie" by(simp)
qed

lemma invar_trie_impl_of [simp, intro]: "invar_trie (impl_of t)"
using impl_of[of t] by simp

lemma Trie_impl_of [code abstype]: "Trie (impl_of t) = t"
by(rule impl_of_inverse)

subsection \<open>Primitive operations\<close>

definition empty :: "('key, 'val) trie"
where "empty = Trie (empty_trie)"

definition update :: "'key list \<Rightarrow> 'val \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where "update ks v t = Trie (update_trie ks v (impl_of t))"

definition delete :: "'key list \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where "delete ks t = Trie (delete_trie ks (impl_of t))"

definition lookup :: "('key, 'val) trie \<Rightarrow> 'key list \<Rightarrow> 'val option"
where "lookup t = lookup_trie (impl_of t)"

definition isEmpty :: "('key, 'val) trie \<Rightarrow> bool"
where "isEmpty t = is_empty_trie (impl_of t)"

definition iteratei :: "('key, 'val) trie \<Rightarrow> ('key list \<times> 'val, '\<sigma>) set_iterator"
where "iteratei t = set_iterator_image trie_reverse_key (Trie_Impl.iteratei (impl_of t))"

lemma iteratei_code[code] :
  "iteratei t c f = Trie_Impl.iteratei (impl_of t) c (\<lambda>(ks, v). f (rev ks, v))"
unfolding iteratei_def set_iterator_image_alt_def
apply (subgoal_tac "(\<lambda>x. f (trie_reverse_key x)) = (\<lambda>(ks, v). f (rev ks, v))")
apply (auto simp add: trie_reverse_key_def)
done

lemma impl_of_empty [code abstract]: "impl_of empty = empty_trie"
by(simp add: empty_def Trie_inverse)

lemma impl_of_update [code abstract]: "impl_of (update ks v t) = update_trie ks v (impl_of t)"
by(simp add: update_def Trie_inverse invar_trie_update)

lemma impl_of_delete [code abstract]: "impl_of (delete ks t) = delete_trie ks (impl_of t)"
by(simp add: delete_def Trie_inverse invar_trie_delete)

subsection \<open>Correctness of primitive operations\<close>

lemma lookup_empty [simp]: "lookup empty = Map.empty"
by(simp add: lookup_def empty_def Trie_inverse)

lemma lookup_update [simp]: "lookup (update ks v t) = (lookup t)(ks \<mapsto> v)"
by(simp add: lookup_def update_def Trie_inverse invar_trie_update lookup_update')

lemma lookup_delete [simp]: "lookup (delete ks t) = (lookup t)(ks := None)"
by(simp add: lookup_def delete_def Trie_inverse invar_trie_delete lookup_delete')

lemma isEmpty_lookup: "isEmpty t \<longleftrightarrow> lookup t = Map.empty"
by(simp add: isEmpty_def lookup_def is_empty_lookup_empty)

lemma finite_dom_lookup: "finite (dom (lookup t))"
by(simp add: lookup_def finite_dom_lookup)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
proof -
  note it_base = Trie_Impl.trie_iteratei_correct [of "impl_of m"]
  show ?thesis
    unfolding iteratei_def lookup_def
    apply (rule set_iterator_image_correct [OF it_base])
    apply (simp_all add: set_eq_iff image_iff inj_on_def)
  done
qed

subsection \<open>Type classes\<close>

instantiation trie :: (equal, equal) equal begin

definition "equal_class.equal (t :: ('a, 'b) trie) t' = (impl_of t = impl_of t')"

instance
proof
qed(simp add: equal_trie_def impl_of_inject)
end

hide_const (open) empty lookup update delete iteratei isEmpty

end


(* VDM to Isabelle Translation @2022-02-27T12:43:43.849662Z
   Copyright 2021, Leo Freitas, leo.freitas@newcastle.ac.uk

in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 11:7
files = [./src/test/resources/Examples/Gateway/gateway.vdmsl]
*)
theory gateway_PO
imports gateway
begin

\<comment>\<open>VDM source: String = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 11:7\<close>
theorem String_TOTAL_PO1:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (s :: VDMChar VDMSeq)  . ((((inv_VDMSeq' (inv_VDMChar) s))) \<longrightarrow> isTest ((inv_String s)) (inv_bool))))"
	by simp

\<comment>\<open>VDM source: String = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 10:3\<close>
theorem String_INV_SATISFIABILITY_PO2:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (s :: VDMChar VDMSeq)  . ((((inv_VDMSeq' (inv_VDMChar) s))) \<longrightarrow> (s \<noteq> []))))"

	by force

\<comment>\<open>VDM source: Message = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 14:7\<close>
theorem Message_TOTAL_PO3:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (m :: String)  . ((((inv_String m))) \<longrightarrow> isTest ((inv_Message m)) (inv_bool))))"

	oops

\<comment>\<open>VDM source: Message = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 13:3\<close>
theorem Message_INV_SATISFIABILITY_PO4:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (m :: String)  . ((((inv_String m))) \<longrightarrow> ((len m) \<le> (100::VDMNat1)))))"

	oops

	(*
	\<comment>\<open>VDM proof obligation `Gateway_measure_Gateway` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: Gateway; measure_Gateway = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 58:12\<close>
theorem Gateway_measure_Gateway_TOTAL_PO5:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ms :: Message VDMSeq)   (cat :: Category)  . ((((inv_VDMSeq' (inv_String) ms)))  \<and>  (((inv_Category cat))) \<longrightarrow> isTest ((measure_Gateway ms   cat)) (inv_VDMNat))))"

	oops

	*)

	(*
	\<comment>\<open>VDM proof obligation `Gateway_rest_p` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: Gateway; rest_p = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 50:3\<close>
theorem Gateway_rest_p_RECURSIVE_PO6:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ms :: Message VDMSeq)   (cat :: Category)  . ((((inv_VDMSeq' (inv_String) ms)))  \<and>  (((inv_Category cat))) \<longrightarrow> ((\<not> (ms = [])) \<longrightarrow> ((measure_Gateway ms   cat) > (measure_Gateway (tl ms)   cat))))))"

	oops

	*)

\<comment>\<open>VDM source: Gateway; rest_p = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 54:34\<close>
theorem Gateway_rest_p_NON_EMPTY_SEQ_PO7:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ms :: Message VDMSeq)   (cat :: Category)  . ((((inv_VDMSeq' (inv_String) ms)))  \<and>  (((inv_Category cat))) \<longrightarrow> ((\<not> (ms = [])) \<longrightarrow> (ms \<noteq> [])))))"
	by meson

\<comment>\<open>VDM source: Gateway = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 56:30\<close>
theorem Gateway_NON_EMPTY_SEQ_PO8:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ms :: Message VDMSeq)   (cat :: Category)  . ((((inv_VDMSeq' (inv_String) ms)))  \<and>  (((inv_Category cat))) \<longrightarrow> ((\<not> (ms = [])) \<longrightarrow> (
		let
(rest_p::Ports) = (Gateway (tl ms)   cat)
		in
			(if (inv_Ports rest_p) then
			(ms \<noteq> [])
		 else
			undefined
		)
		)))))"
	  apply (simp del: Gateway.simps, safe)
  unfolding inv_Ports_defs list_all_def
	apply (simp del: Gateway.simps, safe)
  apply (simp del: Gateway.simps split:if_splits)
	oops

\<comment>\<open>VDM source: FlattenMessages = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 77:3\<close>
theorem FlattenMessages_SUB_TYPE_PO9:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ms :: Message VDMSeq)  . ((((inv_VDMSeq' (inv_String) ms))) \<longrightarrow> (((len (conc ms)) \<le> (100::VDMNat1)) \<longrightarrow> ((inv_Message (conc ms)) \<and> ((inv_String (conc ms)) \<and> isTest ((conc ms)) (inv_VDMSeq' (inv_VDMChar))))))))"
	nitpick
	oops

\<comment>\<open>VDM source: FlattenMessages' = ?\<close>
\<comment>\<open>in 'gateway' (./src/test/resources/Examples/Gateway/gateway.vdmsl) at line 82:3\<close>
theorem FlattenMessages'_SUB_TYPE_PO10:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ms :: Message VDMSeq)  . ((((inv_VDMSeq' (inv_String) ms))) \<longrightarrow> (((ms \<noteq> []) \<and> ((len (conc ms)) \<le> (100::VDMNat1))) \<longrightarrow> ((inv_Message (conc ms)) \<and> ((inv_String (conc ms)) \<and> isTest ((conc ms)) (inv_VDMSeq' (inv_VDMChar))))))))"
		unfolding inv_Message_defs list_all_def len_def conc_def by simp

\<comment>\<open>Processing VDM exports as Isabelle hidden declarations\<close>

\<comment> \<open>@LF 5 sledgehammered; 1 simplified expansion; 1 counter exampled; 2 ignored about measures; 1 induction + involved over recursion\<close>

end


theory TopoS_Stateful_Policy_impl
imports TopoS_Composition_Theory_impl TopoS_Stateful_Policy_Algorithm
begin

section{*Stateful Policy -- List Implementaion*}

record 'v stateful_list_policy =
    hostsL :: "'v list"
    flows_fixL :: "('v \<times>'v) list"
    flows_stateL :: "('v \<times>'v) list"

definition stateful_list_policy_to_list_graph :: "'v stateful_list_policy \<Rightarrow> 'v list_graph" where
  "stateful_list_policy_to_list_graph \<T> = \<lparr> nodesL = hostsL \<T>, edgesL = (flows_fixL \<T>) @ [e \<leftarrow> flows_stateL \<T>. e \<notin> set (flows_fixL \<T>)] @ [e \<leftarrow> backlinks (flows_stateL \<T>). e \<notin> set (flows_fixL \<T>)] \<rparr>"

lemma stateful_list_policy_to_list_graph_complies:
  "list_graph_to_graph (stateful_list_policy_to_list_graph \<lparr> hostsL = V, flows_fixL = E\<^sub>f, flows_stateL = E\<^sub>\<sigma> \<rparr>) =
    stateful_policy_to_network_graph \<lparr> hosts = set V, flows_fix = set E\<^sub>f, flows_state = set E\<^sub>\<sigma> \<rparr>"
    by(simp add: stateful_list_policy_to_list_graph_def stateful_policy_to_network_graph_def all_flows_def list_graph_to_graph_def backlinks_correct, blast)

lemma valid_list_graph_stateful_list_policy_to_list_graph:
    "valid_list_graph G \<Longrightarrow> distinct E \<Longrightarrow> set E \<subseteq> set (edgesL G) \<Longrightarrow> valid_list_graph (stateful_list_policy_to_list_graph \<lparr>hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = E\<rparr>)"
  apply(simp add: valid_list_graph_def stateful_list_policy_to_list_graph_def)
  apply(rule conjI)
   apply(simp add: backlinks_distinct)
  apply(rule conjI)
   apply(simp add: backlinks_set)
   apply(blast)
  apply(rule conjI)
   apply(simp add: backlinks_set)
   apply(blast)
  apply(simp add: valid_list_graph_axioms_def)
   apply(rule conjI)
   apply(simp add: backlinks_set)
   apply(force)
  apply(simp add: backlinks_set)
  apply(clarsimp)
  apply(erule disjE)
   apply(auto)[1]
  apply(erule disjE)
   apply(auto)[1]
  by force

subsection{*Algorithms*}

   fun filter_IFS_no_violations_accu :: "'v list_graph \<Rightarrow> 'v SecurityInvariant list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list" where
      "filter_IFS_no_violations_accu G M accu [] = accu" |
      "filter_IFS_no_violations_accu G M accu (e#Es) = (if
        all_security_requirements_fulfilled (TopoS_Composition_Theory_impl.get_IFS M) (stateful_list_policy_to_list_graph \<lparr> hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = (e#accu) \<rparr>)
        then filter_IFS_no_violations_accu G M (e#accu) Es
        else filter_IFS_no_violations_accu G M accu Es)"
    definition filter_IFS_no_violations :: "'v list_graph \<Rightarrow> 'v SecurityInvariant list \<Rightarrow> ('v \<times> 'v) list" where
      "filter_IFS_no_violations G M = filter_IFS_no_violations_accu G M [] (edgesL G)"

   lemma filter_IFS_no_violations_accu_distinct: "\<lbrakk> distinct (Es@accu) \<rbrakk> \<Longrightarrow> distinct (filter_IFS_no_violations_accu G M accu Es)"
    apply(induction Es arbitrary: accu)
     by(simp_all)

   lemma filter_IFS_no_violations_accu_complies:
    "\<lbrakk>\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
      valid_list_graph G; set Es \<subseteq> set (edgesL G); set accu \<subseteq> set (edgesL G); distinct (Es@accu) \<rbrakk> \<Longrightarrow>
      filter_IFS_no_violations_accu G (get_impl M) accu Es = TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations_accu (list_graph_to_graph G) (get_spec M) accu Es"
      proof(induction Es arbitrary: accu)
      case Nil
        thus ?case by(simp add: get_impl_def get_spec_def)
      next
      case (Cons e Es)
        -- "@{thm Cons.IH[OF Cons.prems(1) Cons.prems(2)]}"
        let ?caseDistinction = "all_security_requirements_fulfilled (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (stateful_list_policy_to_list_graph \<lparr> hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = (e#accu) \<rparr>)"

        from get_IFS_get_ACS_select_simps(2)[OF Cons.prems(1)] have get_impl_zip_simp: "(get_impl (zip (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M)))) = TopoS_Composition_Theory_impl.get_IFS (get_impl M)" by simp

        from get_IFS_get_ACS_select_simps(3)[OF Cons.prems(1)] have get_spec_zip_simp: "(get_spec (zip (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M)))) = TopoS_Composition_Theory.get_IFS (get_spec M)" by simp

        from Cons.prems(3) Cons.prems(4) have "set (e # accu) \<subseteq> set (edgesL G)" by simp
        from Cons.prems(4) have "set (accu) \<subseteq> set (edgesL G)" by simp
        from Cons.prems(5) have "distinct (e # accu)" by simp
        from Cons.prems(3) have "set Es \<subseteq> set (edgesL G)" by simp
        from Cons.prems(5) have "distinct (Es @ accu)" by simp
        from Cons.prems(5) have "distinct (Es @ (e # accu))" by simp

        from Cons.prems(2) have validLG: "valid_list_graph (stateful_list_policy_to_list_graph \<lparr>hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = e # accu\<rparr>)"
          apply(rule valid_list_graph_stateful_list_policy_to_list_graph)
           apply(fact `distinct (e # accu)`)
          apply(fact `set (e # accu) \<subseteq> set (edgesL G)`)
          done

        from get_IFS_get_ACS_select_simps(1)[OF Cons.prems(1)]
        have "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))). SecurityInvariant_complies_formal_def m_impl m_spec" .
        from all_security_requirements_fulfilled_complies[OF this] have all_security_requirements_fulfilled_eq_rule:
        "\<And>G. valid_list_graph G \<Longrightarrow>
            TopoS_Composition_Theory_impl.all_security_requirements_fulfilled (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) G =
            TopoS_Composition_Theory.all_security_requirements_fulfilled (TopoS_Composition_Theory.get_IFS (get_spec M)) (list_graph_to_graph G)"
            by(simp add: get_impl_zip_simp get_spec_zip_simp)

        have case_impl_spec: "?caseDistinction <-> TopoS_Composition_Theory.all_security_requirements_fulfilled (TopoS_Composition_Theory.get_IFS (get_spec M)) (stateful_policy_to_network_graph \<lparr> hosts = set (nodesL G), flows_fix = set (edgesL G), flows_state = set (e#accu) \<rparr>)"
          apply(subst all_security_requirements_fulfilled_eq_rule[OF validLG])
          by(simp add: stateful_list_policy_to_list_graph_complies)

        show ?case
          proof(case_tac ?caseDistinction)
          assume cTrue: ?caseDistinction

          from cTrue have g1: "TopoS_Stateful_Policy_impl.filter_IFS_no_violations_accu G (get_impl M) accu (e # Es) = TopoS_Stateful_Policy_impl.filter_IFS_no_violations_accu G (get_impl M) (e # accu) Es" by simp

          from cTrue[simplified case_impl_spec] have g2: "TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations_accu (list_graph_to_graph G) (get_spec M) accu (e # Es) =
            TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations_accu (list_graph_to_graph G) (get_spec M) (e#accu)Es"
            by(simp add: list_graph_to_graph_def)

          show ?case
            apply(simp only: g1 g2)
            using Cons.IH[OF Cons.prems(1) Cons.prems(2) `set Es \<subseteq> set (edgesL G)` `set (e # accu) \<subseteq> set (edgesL G)` `distinct (Es @ (e # accu))`] by simp
        next
          assume cFalse: "\<not> ?caseDistinction"

          from cFalse have g1: "TopoS_Stateful_Policy_impl.filter_IFS_no_violations_accu G (get_impl M) accu (e # Es) = TopoS_Stateful_Policy_impl.filter_IFS_no_violations_accu G (get_impl M) accu Es" by simp

          from cFalse[simplified case_impl_spec] have g2: "TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations_accu (list_graph_to_graph G) (get_spec M) accu (e # Es) =
            TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations_accu (list_graph_to_graph G) (get_spec M) accu Es"
            by(simp add: list_graph_to_graph_def)

          show ?case
            apply(simp only: g1 g2)
            using Cons.IH[OF Cons.prems(1) Cons.prems(2) `set Es \<subseteq> set (edgesL G)` `set accu \<subseteq> set (edgesL G)` `distinct (Es @ accu)`] by simp
          qed
       qed

   lemma filter_IFS_no_violations_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec; valid_list_graph G \<rbrakk> \<Longrightarrow>
       filter_IFS_no_violations G (get_impl M) = TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations (list_graph_to_graph G) (get_spec M) (edgesL G)"
    apply(unfold filter_IFS_no_violations_def TopoS_Stateful_Policy_Algorithm.filter_IFS_no_violations_def)
    apply(rule filter_IFS_no_violations_accu_complies)
        apply(simp_all)
    apply(simp add: valid_list_graph_def)
    done

    fun filter_compliant_stateful_ACS_accu :: "'v list_graph \<Rightarrow> 'v SecurityInvariant list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list" where
      "filter_compliant_stateful_ACS_accu G M accu [] = accu" |
      "filter_compliant_stateful_ACS_accu G M accu (e#Es) = (if
        e \<notin> set (backlinks (edgesL G)) \<and> (\<forall>F \<in> set (implc_get_offending_flows (get_ACS M) (stateful_list_policy_to_list_graph \<lparr> hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = (e#accu) \<rparr>)). set F \<subseteq> set (backlinks (e#accu)))
        then filter_compliant_stateful_ACS_accu G M (e#accu) Es
        else filter_compliant_stateful_ACS_accu G M accu Es)"
    definition filter_compliant_stateful_ACS :: "'v list_graph \<Rightarrow> 'v SecurityInvariant list \<Rightarrow> ('v \<times> 'v) list" where
      "filter_compliant_stateful_ACS G M = filter_compliant_stateful_ACS_accu G M [] (edgesL G)"

   lemma filter_compliant_stateful_ACS_accu_complies:
    "\<lbrakk>\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
      valid_list_graph G; set Es \<subseteq> set (edgesL G); set accu \<subseteq> set (edgesL G); distinct (Es@accu) \<rbrakk> \<Longrightarrow>
      filter_compliant_stateful_ACS_accu G (get_impl M) accu Es = TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_accu (list_graph_to_graph G) (get_spec M) accu Es"
      proof(induction Es arbitrary: accu)
      case Nil
        thus ?case by(simp add: get_impl_def get_spec_def)
      next
      case (Cons e Es)
        -- "@{thm Cons.IH[OF Cons.prems(1) Cons.prems(2)]}"
        let ?caseDistinction = "e \<notin> set (backlinks (edgesL G)) \<and> (\<forall>F \<in> set (implc_get_offending_flows (get_ACS (get_impl M)) (stateful_list_policy_to_list_graph \<lparr> hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = (e#accu) \<rparr>)). set F \<subseteq> set (backlinks (e#accu)))"

        have backlinks_simp: "(e \<notin> set (backlinks (edgesL G))) <-> (e \<notin> backflows (set (edgesL G)))"
          by(simp add: backlinks_correct)

        have "\<And> G X. (\<forall>F\<in>set (implc_get_offending_flows (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) G). set F \<subseteq> X) =
              (\<forall>F\<in>set ` set (implc_get_offending_flows (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) G). F \<subseteq> X)" by blast
        also have "\<And> G X. valid_list_graph G \<Longrightarrow> (\<forall>F\<in>set ` set (implc_get_offending_flows (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) G). F \<subseteq> X) =
          (\<forall>F\<in>get_offending_flows (TopoS_Composition_Theory.get_ACS (get_spec M)) (list_graph_to_graph G). F \<subseteq> X)"
            using implc_get_offending_flows_complies[OF get_IFS_get_ACS_select_simps(4)[OF Cons.prems(1)], simplified get_IFS_get_ACS_select_simps[OF Cons.prems(1)]] by simp
        finally have implc_get_offending_flows_simp_rule: "\<And>G X. valid_list_graph G \<Longrightarrow>
          (\<forall>F\<in>set (implc_get_offending_flows (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) G). set F \<subseteq> X) = (\<forall>F\<in>get_offending_flows (TopoS_Composition_Theory.get_ACS (get_spec M)) (list_graph_to_graph G). F \<subseteq> X)" .

        from Cons.prems(3) Cons.prems(4) have "set (e # accu) \<subseteq> set (edgesL G)" by simp
        from Cons.prems(4) have "set (accu) \<subseteq> set (edgesL G)" by simp
        from Cons.prems(5) have "distinct (e # accu)" by simp
        from Cons.prems(3) have "set Es \<subseteq> set (edgesL G)" by simp
        from Cons.prems(5) have "distinct (Es @ accu)" by simp
        from Cons.prems(5) have "distinct (Es @ (e # accu))" by simp
        from Cons.prems(2) have validLG: "valid_list_graph (stateful_list_policy_to_list_graph \<lparr>hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = e # accu\<rparr>)"
          apply(rule valid_list_graph_stateful_list_policy_to_list_graph)
           apply(fact `distinct (e # accu)`)
          apply(fact `set (e # accu) \<subseteq> set (edgesL G)`)
          done

        have "set (backlinks (e # accu)) = backflows (insert e (set accu))"
          by(simp add: backlinks_set backflows_def)

        -- "@{thm implc_get_offending_flows_simp_rule[OF validLG]}"
        have case_impl_spec: "?caseDistinction <-> (
          e \<notin> backflows (set (edgesL G)) \<and> (\<forall>F \<in> get_offending_flows (TopoS_Composition_Theory.get_ACS (get_spec M)) (stateful_policy_to_network_graph \<lparr> hosts = set (nodesL G), flows_fix = set (edgesL G), flows_state = set (e#accu) \<rparr>). F \<subseteq> (backflows (set (e#accu)))))"
          apply(simp add: backlinks_simp)
          apply(simp add: implc_get_offending_flows_simp_rule[OF validLG])
          apply(simp add: stateful_list_policy_to_list_graph_complies)
          by(simp add: `set (backlinks (e # accu)) = backflows (insert e (set accu))`)

        show ?case
          proof(case_tac ?caseDistinction)
          assume cTrue: ?caseDistinction

          from cTrue have g1: "TopoS_Stateful_Policy_impl.filter_compliant_stateful_ACS_accu G (get_impl M) accu (e # Es) =  TopoS_Stateful_Policy_impl.filter_compliant_stateful_ACS_accu G (get_impl M) (e#accu) Es" by simp

          from cTrue[simplified case_impl_spec] have g2: "TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_accu (list_graph_to_graph G) (get_spec M) accu (e # Es) =
            TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_accu (list_graph_to_graph G) (get_spec M) (e#accu) Es"
            by(simp add: list_graph_to_graph_def)

          show ?case
            apply(simp only: g1 g2)
            using Cons.IH[OF Cons.prems(1) Cons.prems(2) `set Es \<subseteq> set (edgesL G)` `set (e # accu) \<subseteq> set (edgesL G)` `distinct (Es @ (e # accu))`] by simp
        next
          assume cFalse: "\<not> (?caseDistinction)"

          from cFalse have g1: "TopoS_Stateful_Policy_impl.filter_compliant_stateful_ACS_accu G (get_impl M) accu (e # Es)  = TopoS_Stateful_Policy_impl.filter_compliant_stateful_ACS_accu G (get_impl M) accu Es" by force

          from cFalse[simplified case_impl_spec] have g2: "TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_accu (list_graph_to_graph G) (get_spec M) accu (e # Es) =
            TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_accu (list_graph_to_graph G) (get_spec M) accu Es"
            apply(simp add: list_graph_to_graph_def) by fast

          show ?case
            apply(simp only: g1 g2)
            using Cons.IH[OF Cons.prems(1) Cons.prems(2) `set Es \<subseteq> set (edgesL G)` `set accu \<subseteq> set (edgesL G)` `distinct (Es @ accu)`] by simp
          qed
       qed

   lemma filter_compliant_stateful_ACS_cont_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec; valid_list_graph G; set Es \<subseteq> set (edgesL G); distinct Es \<rbrakk> \<Longrightarrow>
       filter_compliant_stateful_ACS_accu G (get_impl M) [] Es = TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS (list_graph_to_graph G) (get_spec M) Es"
    apply(unfold filter_compliant_stateful_ACS_def TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_def)
    apply(rule filter_compliant_stateful_ACS_accu_complies)
        apply(simp_all)
    done

   lemma filter_compliant_stateful_ACS_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec; valid_list_graph G \<rbrakk> \<Longrightarrow>
       filter_compliant_stateful_ACS G (get_impl M) = TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS (list_graph_to_graph G) (get_spec M) (edgesL G)"
    apply(unfold filter_compliant_stateful_ACS_def TopoS_Stateful_Policy_Algorithm.filter_compliant_stateful_ACS_def)
    apply(rule filter_compliant_stateful_ACS_accu_complies)
        apply(simp_all)
    apply(simp add: valid_list_graph_def)
    done

(*TODO: show valid_stateful_policy and distinctness and valid_list_graph, ...*)

   definition generate_valid_stateful_policy_IFSACS :: "'v list_graph \<Rightarrow> 'v SecurityInvariant list \<Rightarrow> 'v stateful_list_policy" where
    "generate_valid_stateful_policy_IFSACS G M = (let filterIFS = filter_IFS_no_violations G M in
        (let filterACS = filter_compliant_stateful_ACS_accu G M [] filterIFS in \<lparr> hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = filterACS \<rparr>))"

  fun inefficient_list_intersect :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "inefficient_list_intersect [] bs = []" |
    "inefficient_list_intersect (a#as) bs = (if a \<in> set bs then a#(inefficient_list_intersect as bs) else inefficient_list_intersect as bs)"
  lemma inefficient_list_intersect_correct: "set (inefficient_list_intersect a b) = (set a) \<inter> (set b)"
    apply(induction a)
     by(simp_all)

  definition generate_valid_stateful_policy_IFSACS_2 :: "'v list_graph \<Rightarrow> 'v SecurityInvariant list \<Rightarrow>  'v stateful_list_policy" where
    "generate_valid_stateful_policy_IFSACS_2 G M =
    \<lparr> hostsL = nodesL G, flows_fixL = edgesL G, flows_stateL = inefficient_list_intersect (filter_IFS_no_violations G M) (filter_compliant_stateful_ACS G M) \<rparr>"

   lemma generate_valid_stateful_policy_IFSACS_2_complies: "\<lbrakk>\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
          valid_list_graph G;
          valid_reqs (get_spec M);
          TopoS_Composition_Theory.all_security_requirements_fulfilled (get_spec M) (list_graph_to_graph G);
          \<T> = (generate_valid_stateful_policy_IFSACS_2 G (get_impl M))\<rbrakk> \<Longrightarrow>
   stateful_policy_compliance \<lparr>hosts = set (hostsL \<T>), flows_fix = set (flows_fixL \<T>), flows_state = set (flows_stateL \<T>) \<rparr> (list_graph_to_graph G) (get_spec M)"
    apply(rule_tac edgesList="edgesL G" in generate_valid_stateful_policy_IFSACS_2_stateful_policy_compliance)
        apply(simp)
       apply (metis valid_list_graph_def valid_list_graph_iff_valid_graph)
      apply(simp)
     apply(simp add: list_graph_to_graph_def)
    apply(simp add: TopoS_Stateful_Policy_Algorithm.generate_valid_stateful_policy_IFSACS_2_def TopoS_Stateful_Policy_impl.generate_valid_stateful_policy_IFSACS_2_def)
    apply(simp add: list_graph_to_graph_def inefficient_list_intersect_correct)
    apply(thin_tac "\<T> = ?x")
    apply(frule(1) filter_compliant_stateful_ACS_complies)
    apply(frule(1) filter_IFS_no_violations_complies)
    apply(thin_tac "?a")
    apply(thin_tac "?a")
    apply(thin_tac "?a")
    apply(thin_tac "?a")
    apply(simp)
    by (metis list_graph_to_graph_def)

end


theory Functions_gn_n3
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"Ax1\", \"Ax2\", \"Ax3\", \"Ax4\", \"Ax5\", \"Ax6\", \"Ax7\",
     \"Ax8\", \"Ax9\", \"Ax10\", \"Ax11\", \"Ax12\", \"Ax13\", \"Ax14\",
     \"Ax15\"]"

typedecl ('a1) Seq

consts
X_all :: "(nat => 'S partial) => ('S => bool) => bool" ("all''/'(_,/ _')" [3,3] 999)
X_concat :: "(nat => 'S partial) * (nat => 'S partial) => nat => 'S partial"
X_empty :: "(nat => 'S partial) => bool" ("empty''/'(_')" [3] 999)
X_even :: "nat => bool" ("even''/'(_')" [3] 999)
X_filter :: "(nat => 'S partial) => ('S => bool) => nat => 'S partial"
X_finite :: "(nat => 'S partial) => bool" ("finite''/'(_')" [3] 999)
X_h :: "(nat => 'S partial) => 'S partial" ("h/'(_')" [3] 999)
X_head :: "(nat => 'S partial) => 'S partial" ("head/'(_')" [3] 999)
X_length :: "(nat => 'S partial) => nat partial" ("length''/'(_')" [3] 999)
X_minX2 :: "(nat => bool) => nat partial" ("min''''/'(_')" [3] 999)
X_start :: "(nat => 'S partial) => nat partial" ("start/'(_')" [3] 999)
nf :: "(nat => 'S partial) => nat => 'S partial"
t :: "(nat => 'S partial) => nat => 'S partial"
tail :: "(nat => 'S partial) => nat => 'S partial"
X__o__X :: "('b => 'c partial) * ('a => 'b partial) => 'a => 'c partial"
X_map :: "('S => 'S partial) => (nat => 'S partial) => nat => 'S partial"

axioms
Ax1 [rule_format] :
"ALL Q.
 min''(Q) =
 (if Q 0 then makePartial 0 else min''(% m. Q (m + 1)))"

Ax2 [rule_format] : "ALL Q. defOp (min''(Q)) = (EX m. Q m)"

Ax3 [rule_format] : "ALL s. X_start(s) = min''(% m. defOp (s m))"

Ax4 [rule_format] : "ALL s. head(s) = s 0"

Ax5 [rule_format] : "ALL s. tail s = (% x. s (x + 1))"

Ax6 [rule_format] : "ALL s. head(nf s) = h(s)"

Ax7 [rule_format] : "ALL s. tail (nf s) = nf (t s)"

Ax8 [rule_format] :
"ALL P.
 ALL s.
 head(X_filter s P) =
 resOp (head(s), bool2partial (lift2bool P (head(s))))"

Ax9 [rule_format] :
"ALL P. ALL s. tail (X_filter s P) = X_filter (tail s) P"

Ax10 [rule_format] :
 "ALL s.
  h(s) =
   restrictOp (s (makeTotal (X_start s))) (defOp (X_start s))"

Ax10_monadic [rule_format] :
"ALL s.
 h(s) =
  ((lift2partial s) (X_start s))"

Ax11 [rule_format] :
"ALL s.
 t s =
 (% k. restrictOp (s (k + 1 + makeTotal (X_start s))) (defOp (X_start s)))"

Ax11_monadic [rule_format] :
"ALL s.
 t s =
 (% k. (lift2partial s) ((mapPartial ((op +) (k + 1))) (X_start s)))"

Ax12 [rule_format] :
"ALL s. finite'(s) = (EX X_n. ALL m. m > X_n --> ~ defOp (s m))"

Ax13 [rule_format] : "ALL s. empty'(s) = (ALL m. ~ defOp (s m))"

Ax14 [rule_format] :
"ALL s.
 ALL s2.
 head(X_concat (s, s2)) =
 (if ~ empty'(s) then head(s) else head(s2))"

Ax15 [rule_format] :
"ALL s.
 ALL s2.
 tail (X_concat (s, s2)) =
 (if ~ empty'(s) then X_concat (tail s, s2) else tail s2)"

Ax16 [rule_format] :
"ALL f.
 ALL s.
 X_head(X_map f s) = (restrictOp (f (makeTotal (X_head s))) (defOp (X_head s)))"

Ax16_monadic [rule_format] :
"ALL f.
 ALL s.
 X_head(X_map f s) =(lift2partial f) (X_head s)"

Ax17 [rule_format] :
"ALL f. ALL s. tail (X_map f s) = X_map f (tail s)"

o_def [rule_format] :
"ALL f.
 ALL g.
 X__o__X (g, f) =
 (% x. restrictOp (g (makeTotal (f x))) (defOp (f x)))"

o_def_monadic [rule_format] :
"ALL f.
 ALL g.
 X__o__X (g,f) =
 (%x. lift2partial g (f x))"

theorem coinduct: "[|R u v ==> (head(u)=head(v) & (R (tail u) (tail v)));  R u v|] ==> u=v"
apply (rule ext)
apply (induct_tac x)
sorry

theorem restrict1 : "restrictOp (restrictOp a (defOp b)) c = restrictOp (restrictOp a c) (defOp (restrictOp b c))"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_trivial_rule[simp]: "b ==> restrictOp u b = u"
apply (simp add: restrictOp_def)
done

theorem restrict_trivial [simp]: "restrictOp u True = u"
apply (simp)
done

theorem restrict_assoc[simp] : "restrictOp a (defOp (restrictOp b c)) = restrictOp (restrictOp a (defOp b)) c"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def noneOp_def defOp.simps)
sorry

theorem restrict_out[simp] : "restrictOp (u b) b = restrictOp (u True) b"
apply (case_tac "b")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem mkpartial_cancel [simp]: "makeTotal(makePartial x) = x"
apply (simp add: makeTotal_def makePartial_def)
done

theorem mkpartial_cancel2 [simp]: "defOp(x) ==> makePartial(makeTotal x) = x"
apply (simp add: makeTotal_def makePartial_def)
apply (case_tac x)
apply (simp)
apply (simp)
done

theorem mkpartial_cancel3 [simp] : "((makePartial x) = (makePartial y)) = (x = y)"
apply (simp add: makePartial_def)
done

theorem defOp_trivial [simp]: "defOp(makePartial x) = True"
apply (simp add: makePartial_def makeTotal_def)
done

(* Some more stuff about removing extraneous restrictions *)

theorem total_restrict2 [simp]:
"(c ==> b) ==> restrictOp (u (makeTotal  (restrictOp a b))) c =
	   restrictOp (u (makeTotal a)) c"
apply (simp add: makeTotal_def restrictOp_def defOp.simps undefinedOp_def)
done

theorem def_restrict [simp]:
"defOp (restrictOp a b) = (defOp a & b)"
apply (simp add:  restrictOp_def defOp.simps undefinedOp_def split: split_if)
done

theorem total_restrict [simp]:
"restrictOp (u (makeTotal  (restrictOp a b))) (defOp (restrictOp a b)) =
	   restrictOp (u (makeTotal a)) (defOp a & b)"
apply simp
done

lemma restrictOp_cong [cong]:
  "b = b' ==> (b' ==> a = a') ==> restrictOp a b = restrictOp a' b'"
  apply (simp add: restrictOp_def defOp.simps undefinedOp_def)
done

lemma double_defop: "defOp(head(X_filter (X_filter a P) P)) = defOp(head(X_filter a P))"
apply (simp add: Ax8 resOp_def bool2partial_def)
apply (auto)
done

theorem defop_filter2: "((defOp (head(a))) & (P (makeTotal (head(a))))) = defOp(head(X_filter a P))"
apply (simp add: Ax8 bool2partial_def resOp_def lift2bool_def)
done

lemma double_filter_head[simp]: "head(X_filter (X_filter a P) P) = head(X_filter a P)"
(*apply (case_tac "defOp(a 0) & P(makeTotal (a 0))")*)
apply (simp add: Ax8 resOp_def bool2partial_def lift2bool_def)
apply (simp add: defop_filter2 cong: conj_cong)
done

theorem filter_double : "ALL P. ALL s. X_filter s P=X_filter (X_filter s P) P"
apply (auto)
apply (rule_tac R="(%x y. EX a. (x=X_filter a P) & y=(X_filter (X_filter a P) P))" in coinduct)
apply (auto)
apply (rule_tac x="tail a" in exI)
apply (simp add: Ax9)
done

lemma defophead1: "defOp (X_head (X_map f s)) = (defOp (f(makeTotal (X_head s))) & defOp (X_head s))"
apply (simp add: Ax16)
done

lemma defophead2: "defOp (X_head s) ==> head (X_map f s) = f(makeTotal (X_head s))"
apply (simp add: Ax16)
done

lemma test: "((restrictOp a c) = (restrictOp b c)) = (c --> (a = b))"
apply (simp add: restrictOp_def)
done

lemma res_overlap[simp]: "restrictOp (restrictOp a b) c = restrictOp a (b & c)"
apply (simp add: restrictOp_def)
done

theorem Ax4_1v1 :
"ALL f.
 ALL g.
 ALL s.
 head(X_map (X__o__X (f, g)) s) = head(((X_map f) o (X_map g)) s)"
apply (auto simp add: o_def Ax16)
done

theorem Ax4_1_monadic :
"ALL f.
 ALL g.
 ALL s.
 head(X_map (X__o__X (f, g)) s) = head(((X_map f) o (X_map g)) s)"
apply (auto)
apply (simp only: o_def_monadic Ax16_monadic)
apply (simp)
done

theorem Ax4_1v2:
"ALL f.
 ALL g.
 ALL s.
 head(X_map (X__o__X (f, g)) s) = head(((X_map f) o (X_map g)) s)"
apply (auto)
apply (simp add: Ax16 o_def)
apply (case_tac "defOp (head(s))")
apply (simp)
apply (simp)
apply (simp add: restrictOp_def)
done

theorem Ax4_1v3:
"ALL f.
 ALL g.
 ALL s.
 head(X_map (X__o__X (f, g)) s) = head(((X_map f) o (X_map g)) s)"
apply (auto)
apply (simp only: Ax16 o_def)
apply (subst def_restrict)
apply (subst restrictOp_cong)
apply (simp)
apply (subst restrict_assoc)
apply (simp)
done

theorem Ax4_1 :
"ALL f.
 ALL g.
 X_map (X__o__X (f, g)) = (X_map f) o (X_map g)"
apply (auto)
apply (rule ext)
apply (simp only: o_def comp_def)
oops

lemma asd: "(defOp (X_start (nf s))) = defOp (X_start s)"
apply (subst Ax3)
apply (subst Ax3)
apply (subst Ax2)
apply (subst Ax2)
sorry

lemma asd2: "(EX m. defOp (nf s m)) = (EX m. defOp (s m))"
sorry

lemma asd2: "h(X_filter (nf s) P) = h(X_filter s P)"
apply (rule_tac R="(%x y. EX a. (x=nf a) & (y=nf a))" in coinduct)
apply (simp add: Ax10)
apply (simp only: Ax3)
apply (simp only: Ax2)
apply (subst asd2)

theorem filter_nfcom: "ALL P. ALL s. nf (X_filter (nf s) P) = nf (X_filter s P)"
apply (auto)
apply (rule_tac R="(%x y. EX a. (x=nf (X_filter (nf s) P)) & (y=nf (X_filter s P)))" in coinduct)
apply (simp add: Ax6)
apply clarify
apply (rule conjI)
apply (auto)
apply (simp add: Ax6 Ax8 resOp_def bool2partial_def lift2bool_def Ax10 cong: conj_cong)
apply (subst Ax10)
apply (auto)
apply (simp add: bisim2)
apply (rule_tac x="s" in exI)
apply (auto)
done

lemma asd: "h(X_filter s P)=min'' (% m. (defOp (s m) & P (makeTotal (s m))))"
apply (subst Ax10)
apply (simp add: Ax3)
apply (subst Ax1)

lemma asd: "P (makeTotal (head(nf s))) ==> head(nf (X_filter s P)) = head(X_filter (nf s) P)"
apply (simp only: Ax6)
apply (simp only: bool2partial_def lift2bool_def resOp_def)
apply clarsimp
apply (simp only: Ax6)
apply (auto)
apply (subst Ax10)
apply (simp)
apply (simp only: Ax6)

apply (simp add: Ax6 Ax8)

end


(*  Title:      Sequents/Modal0.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory Modal0
imports LK0
begin

ML_file "modal.ML"

consts
  box           :: "o\<Rightarrow>o"       ("[]_" [50] 50)
  dia           :: "o\<Rightarrow>o"       ("<>_" [50] 50)
  Lstar         :: "two_seqi"
  Rstar         :: "two_seqi"

syntax
  "_Lstar"      :: "two_seqe"   ("(_)|L>(_)" [6,6] 5)
  "_Rstar"      :: "two_seqe"   ("(_)|R>(_)" [6,6] 5)

ML \<open>
  fun star_tr c [s1, s2] = Const(c, dummyT) $ seq_tr s1 $ seq_tr s2;
  fun star_tr' c [s1, s2] = Const(c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
\<close>

parse_translation \<open>
 [(@{syntax_const "_Lstar"}, K (star_tr @{const_syntax Lstar})),
  (@{syntax_const "_Rstar"}, K (star_tr @{const_syntax Rstar}))]
\<close>

print_translation \<open>
 [(@{const_syntax Lstar}, K (star_tr' @{syntax_const "_Lstar"})),
  (@{const_syntax Rstar}, K (star_tr' @{syntax_const "_Rstar"}))]
\<close>

definition strimp :: "[o,o]\<Rightarrow>o"   (infixr "--<" 25)
  where "P --< Q == [](P \<longrightarrow> Q)"

definition streqv :: "[o,o]\<Rightarrow>o"   (infixr ">-<" 25)
  where "P >-< Q == (P --< Q) \<and> (Q --< P)"

lemmas rewrite_rls = strimp_def streqv_def

lemma iffR: "\<lbrakk>$H,P \<turnstile> $E,Q,$F;  $H,Q \<turnstile> $E,P,$F\<rbrakk> \<Longrightarrow> $H \<turnstile> $E, P \<longleftrightarrow> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL: "\<lbrakk>$H,$G \<turnstile> $E,P,Q;  $H,Q,P,$G \<turnstile> $E \<rbrakk> \<Longrightarrow> $H, P \<longleftrightarrow> Q, $G \<turnstile> $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemmas safe_rls = basic conjL conjR disjL disjR impL impR notL notR iffL iffR
  and unsafe_rls = allR exL
  and bound_rls = allL exR

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Shift_Right_Hoare_Pos_Typed
  imports VHDL_Hoare_Typed Bits_Int_Aux
begin

datatype sig = IN | OUT

definition shiftr :: "nat \<Rightarrow> sig conc_stmt" where
  "shiftr n \<equiv> process {IN} : Bassign_trans OUT (Bshiftr (Bsig IN) n) 1"

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bassign_trans OUT (Bshiftr (Bsig IN) n) 1)"
  shows "\<exists>len>0. \<Gamma> IN = Lty Uns len \<and> \<Gamma> OUT = Lty Uns len \<or> \<Gamma> IN = Lty Sig len \<and> \<Gamma> OUT = Lty Sig len"
  apply (rule seq_wt_cases(4)[OF assms])
  by (metis bexp_wt_cases_shiftr bexp_wt_cases_slice(2))

locale unsigned_shift_right =
  fixes \<Gamma> :: "sig tyenv"
  fixes len :: nat
  fixes amount :: nat
  assumes "0 < len"
  assumes "\<Gamma> IN = Lty Uns len \<and> \<Gamma> OUT = Lty Uns len"
begin

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans OUT (Bshiftr (Bsig IN) n) 1)"
  by (rule seq_wt.intros(4))
     (metis (full_types) bexp_wt.intros(23) bexp_wt.intros(3) unsigned_shift_right_axioms
     unsigned_shift_right_def)

abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

definition inv :: "sig assn2" where
  "inv tw \<equiv> (lof_wline tw OUT (fst tw) = take len (replicate amount False @ lof_wline tw IN (fst tw - 1)))"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> (disjnt {IN} (event_of tw) \<longrightarrow> (\<forall>i > fst tw. lof_wline tw OUT i = lof_wline tw OUT (fst tw)))"

lemma inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Bshiftr (Bsig IN) amount)"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  have bexpIN: "bexp_wt \<Gamma> (Bsig IN) (Lty Uns len)"
    using unsigned_shift_right_axioms unfolding unsigned_shift_right_def by (metis bexp_wt.intros(3))+
  obtain bsIN where evalIN: "eval_world_raw (fst tw) (snd tw) (Bsig IN) = Lv Uns bsIN" and" length bsIN = len "
      using eval_world_raw_lv[OF bexpIN `wityping \<Gamma> (snd tw)`] by blast
  have "lof_wline tw' OUT (fst tw + 1) = lval_of v"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  also have "... = take len (replicate amount False   @ lof_wline tw IN (fst tw))"
    using evalIN `length bsIN = len` unfolding v_def eval_world_raw.simps eval_arith.simps Let_def by auto
  finally show ?thesis
    unfolding inv_def tw'_def worldline_upd2_def worldline_upd_def  by auto
qed

lemma inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv2 (fst tw' + 1, snd tw')"
  unfolding inv2_def tw'_def worldline_upd2_def worldline_upd_def by auto

lemma conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {IN} (event_of tw)"
    by auto
  have "lof_wline tw OUT (fst tw + 1) = lof_wline tw OUT (fst tw)"
    using `inv2 tw` `disjnt {IN} (event_of tw)` unfolding inv2_def by auto
  also have "... = take len (replicate amount False @ lval_of (wline_of tw IN (get_time tw - 1)))"
    using `inv tw` unfolding inv_def by auto
  also have "... = take len (replicate amount False @ lval_of (wline_of tw IN (get_time tw)))"
    using `disjnt {IN} (event_of tw)`  unfolding event_of_alt_def   by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "inv (fst tw + 1, snd tw)"
    unfolding inv_def by auto
qed

lemma conc_hoare2:
  "\<And>tw. inv2 tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> inv2 (fst tw + 1, snd tw)"
  unfolding inv2_def by auto

lemma conc_stmt_wf:
  "conc_stmt_wf (shiftr amount)"
  unfolding shiftr_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc:
  "nonneg_delay_conc (shiftr amount)"
  unfolding shiftr_def by auto

lemma nonneg_delay_conc':
  "nonneg_delay_conc ( process {IN} : Bassign_trans OUT (Bshiftr (Bsig IN) amount) 1)"
  using nonneg_delay_conc unfolding shiftr_def by auto

lemma conc_wt:
  "conc_wt \<Gamma> (shiftr amount)"
  unfolding shiftr_def  by (meson conc_wt.intros(1) well_typed)

lemma conc_wt':
  "conc_wt \<Gamma> ( process {IN} : Bassign_trans OUT (Bshiftr (Bsig IN) amount) 1)"
  using conc_wt unfolding shiftr_def by auto

lemma conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace> shiftr amount \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> (shiftr amount) (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                              inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf, rule nonneg_delay_conc, rule conc_wt, simp)
  unfolding shiftr_def wp3_conc_single'[OF conc_wt' nonneg_delay_conc'] wp3_fun.simps
  using inv_next_time inv2_next_time conc_hoare conc_hoare2 by presburger

lemma nonneg_delay_add:
  " nonneg_delay (Bassign_trans OUT (Bshiftr (Bsig IN) amount) 1)"
  using nonneg_delay_conc' by auto

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) (shiftr amount) (\<lambda>tw. inv tw \<and> inv2 tw)"
  unfolding shiftr_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay_add], simp)
  unfolding wp3_fun.simps using inv_next_time inv2_next_time by blast

lemma correctness:
  assumes "sim_fin2 w (i + 1) (shiftr amount) tw'" and "wityping \<Gamma> w"
  shows "lof_wline tw' OUT (i + 1) = take len (replicate amount False @ lof_wline tw' IN (i))"
  using grand_correctness[OF assms conc_stmt_wf conc_wt nonneg_delay_conc conc_sim2' init_sat_nand_inv_comb]
  unfolding shiftr_def inv_def  by (metis (no_types, lifting) add_diff_cancel_right' assms(1)
  sim_fin2.cases world_maxtime_lt_fst_tres)

end

end


theory Float_Tests_Poly_Reduced
imports Main
        IEEE_Floating_Point.IEEE
        IEEE_Floating_Point.IEEE_Properties
begin

(* SPECIAL INPUTS *)
(*from the IEEE 754-2019 standard*)

lemma rem_fin_inf: "is_finite x \<Longrightarrow> float_rem x \<infinity> = x"
  oops

lemma sqrt_mzero: "float_sqrt minus_zero = minus_zero"
  oops

lemma compare_cases:
  "flt x y \<or> feq x y \<or> fgt x y \<longleftrightarrow>
    \<not>(is_nan x \<or> is_nan y)"
  oops

lemma compare_unique1: "\<not> (flt x y \<and> feq x y)"
  oops

lemma compare_unique2: "\<not> (flt x y \<and> fgt x y)"
  oops

lemma compare_unique3: "\<not> (flt x y \<and> (is_nan x \<or> is_nan y))"
  oops

lemma compare_unique4: "\<not> (feq x y \<and> fgt x y)"
  oops

lemma compare_unique5: "\<not> (feq x y \<and> (is_nan x \<or> is_nan y))"
  oops

lemma compare_unique6: "\<not> (fgt x y \<and> (is_nan x \<or> is_nan y))"
  oops

lemma zero_eq_mzero: "0 \<doteq> minus_zero"
  oops

lemma float_id: "\<not> is_nan x \<Longrightarrow> x \<doteq> x"
  oops

lemma fadd_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fadd rm x y)"
  oops

lemma fadd_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fadd rm y x)"
  oops

lemma fsub_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fsub rm x y)"
  oops

lemma fsub_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fsub rm y x)"
  oops

lemma fmul_inf1:
  "\<not> is_nan x \<Longrightarrow> \<not> is_zero x \<Longrightarrow>
    is_infinity y \<Longrightarrow> is_infinity (fmul rm x y)"
  oops

lemma fmul_inf2:
  "\<not> is_nan x \<Longrightarrow> \<not> is_zero x \<Longrightarrow>
    is_infinity y \<Longrightarrow> is_infinity (fmul rm y x)"
  oops

lemma fdiv_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_zero (fdiv rm x y)"
  oops

lemma fdiv_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fdiv rm y x)"
  oops

lemma fsqrt_inf: "fsqrt rm plus_infinity = plus_infinity"
  oops

lemma abs_nan: "is_nan x \<Longrightarrow> is_nan \<bar>x\<bar>"
  oops

lemma neg_nan: "is_nan x \<Longrightarrow> is_nan (uminus x)"
  oops

lemma fadd_nan1: "is_nan x \<Longrightarrow> is_nan (fadd rm x y)"
  oops

lemma fadd_nan2: "is_nan y \<Longrightarrow> is_nan (fadd rm x y)"
  oops

lemma fsub_nan1: "is_nan x \<Longrightarrow> is_nan (fsub rm x y)"
  oops

lemma fsub_nan2: "is_nan y \<Longrightarrow> is_nan (fsub rm x y)"
  oops

lemma fmul_nan1: "is_nan x \<Longrightarrow> is_nan (fmul rm x y)"
  oops

lemma fmul_nan2: "is_nan y \<Longrightarrow> is_nan (fmul rm x y)"
  oops

lemma fdiv_nan1: "is_nan x \<Longrightarrow> is_nan (fdiv rm x y)"
  oops

lemma fdiv_nan2: "is_nan y \<Longrightarrow> is_nan (fdiv rm x y)"
  oops

lemma fma_nan1: "is_nan x \<Longrightarrow> is_nan (fmul_add rm x y z)"
  oops

lemma fma_nan2: "is_nan y \<Longrightarrow> is_nan (fmul_add rm x y z)"
  oops

lemma fma_nan3: "is_nan z \<Longrightarrow> is_nan (fmul_add rm x y z)"
  oops

lemma frem_nan1: "is_nan x \<Longrightarrow> is_nan (frem rm x y)"
  oops

lemma frem_nan2: "is_nan y \<Longrightarrow> is_nan (frem rm x y)"
  oops

lemma fsqrt_nan: "is_nan x \<Longrightarrow> is_nan (fsqrt rm x)"
  oops

lemma fintrnd_nan: "is_nan x \<Longrightarrow> is_nan (fintrnd rm x)"
  oops

lemma zero_plus_zero: "fadd rm 0 0 = 0"
  oops

lemma mzero_plus_mzero: "fadd rm minus_zero minus_zero = minus_zero"
  oops

lemma fmul_inf_zero1:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul rm x y)"
  oops

lemma fmul_inf_zero2:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul rm y x)"
  oops

lemma fma_inf_zero1:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul_add rm x y z)"
  oops

lemma fma_inf_zero2:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul_add rm y x z)"
  oops

lemma inf_plus_minf1: "is_nan (fadd rm plus_infinity minus_infinity)"
  oops

lemma inf_plus_minf2: "is_nan (fadd rm minus_infinity plus_infinity)"
  oops

lemma inf_minus_inf1: "is_nan (fsub rm plus_infinity plus_infinity)"
  oops

lemma inf_minus_inf2: "is_nan (fsub rm minus_infinity minus_infinity)"
  oops

lemma zero_div_zero:
  "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> is_nan (fdiv rm x y)"
  oops

lemma inf_div_inf:
  "is_infinity x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fdiv rm x y)"
  oops

lemma frem_inf: "is_infinity x \<Longrightarrow> is_nan (frem rm x y)"
  oops

lemma frem_zero: "is_zero y \<Longrightarrow> is_nan (frem rm x y)"
  oops

lemma fsqrt_neg: "x < 0 \<Longrightarrow> is_nan (fsqrt rm x)"
  oops

lemma div_zero:
  "\<not> is_nan x \<Longrightarrow> is_zero y \<Longrightarrow>
    \<not> is_zero x \<Longrightarrow> is_infinity (x div y)"
  oops

(* ROUNDING *)
(*from "Handbook of Floating-Point Arithmetic" by J-M Muller*)

lemma leq_round:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    x \<le> y \<Longrightarrow>
      round rm (valof x) \<le> round rm (valof y)"
  oops

lemma round_id: "is_finite x \<Longrightarrow> feq (round rm (valof x)) x"
  oops

lemma round_sym_nearest_even:
  "round To_nearest (-x) = - (round To_nearest x)"
  oops

lemma round_sym_nearest_away:
  "round To_nearest_away (-x) = - (round To_nearest_away x)"
  oops

lemma round_sym_zero:
  "round float_To_zero (-x) = - (round float_To_zero x)"
  oops

lemma round_sym_updown:
  "round To_pinfinity (-x) = - (round To_ninfinity x)"
  oops

lemma round_add_eq_sub:
  "\<not> is_nan x \<Longrightarrow> \<not> is_nan y \<Longrightarrow>
    feq (fadd To_pinfinity x y) (- (fsub To_ninfinity (-x) y))"
  oops

lemma round_mul_eq:
  "\<not> is_nan x \<Longrightarrow> \<not> is_nan y \<Longrightarrow>
    feq (fmul To_ninfinity x y) (- (fmul To_pinfinity (-x) y))"
  oops

lemma round_zero: "ROUNDFLOAT 0 = 0"
  oops

lemma sterbenz:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    (valof y)/2 \<le> valof x \<and> valof x \<le> 2*(valof y) \<Longrightarrow>
      valof x - valof y = valof (fsub rm x y)"
  oops

lemma hauser:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_denormal (x+y) \<Longrightarrow> valof (x+y) = valof x + valof y"
  oops

(* VARIOUS *)

lemma triple_zero: "is_zero (Abs_float (s, 0 , 0))"
  oops

lemma some_nan_neq: "\<not> some_nan \<doteq> x"
  oops

lemma float_mul_comm_eq:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow> x * y = y * x"
  oops

lemma less_greater_equal:
  "fle x y \<Longrightarrow> fge x y \<Longrightarrow> feq x y"
  oops

end