theory Regular_Relation_Abstract_Impl
  imports Pair_Automaton
    GTT_Transitive_Closure
    RR2_Infinite_Q_infinity
    Horn_Fset
begin

abbreviation TA_of_lists where
  "TA_of_lists \<Delta> \<Delta>\<^sub>E \<equiv> TA (fset_of_list \<Delta>) (fset_of_list \<Delta>\<^sub>E)"

section \<open>Computing the epsilon transitions for the composition of GTT's\<close>

definition \<Delta>\<^sub>\<epsilon>_rules :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) horn set" where
  "\<Delta>\<^sub>\<epsilon>_rules A B =
    {zip ps qs \<rightarrow>\<^sub>h (p, q) |f ps p qs q. f ps \<rightarrow> p |\<in>| rules A \<and> f qs \<rightarrow> q |\<in>| rules B \<and> length ps = length qs} \<union>
    {[(p, q)] \<rightarrow>\<^sub>h (p', q) |p p' q. (p, p') |\<in>| eps A} \<union>
    {[(p, q)] \<rightarrow>\<^sub>h (p, q') |p q q'. (q, q') |\<in>| eps B}"

locale \<Delta>\<^sub>\<epsilon>_horn =
  fixes A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin

sublocale horn "\<Delta>\<^sub>\<epsilon>_rules A B" .

lemma \<Delta>\<^sub>\<epsilon>_infer0:
  "infer0 = {(p, q) |f p q. f [] \<rightarrow> p |\<in>| rules A \<and> f [] \<rightarrow> q |\<in>| rules B}"
  unfolding horn.infer0_def \<Delta>\<^sub>\<epsilon>_rules_def
  using zip_Nil[of "[]"]
  by auto (metis length_greater_0_conv zip_eq_Nil_iff)+

lemma \<Delta>\<^sub>\<epsilon>_infer1:
  "infer1 pq X = {(p, q) |f ps p qs q. f ps \<rightarrow> p |\<in>| rules A \<and> f qs \<rightarrow> q |\<in>| rules B \<and> length ps = length qs \<and>
    (fst pq, snd pq) \<in> set (zip ps qs) \<and> set (zip ps qs) \<subseteq> insert pq X} \<union>
    {(p', snd pq) |p p'. (p, p') |\<in>| eps A \<and> p = fst pq} \<union>
    {(fst pq, q') |q q'. (q, q') |\<in>| eps B \<and> q = snd pq}"
  unfolding \<Delta>\<^sub>\<epsilon>_rules_def horn_infer1_union
  apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
    by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma \<Delta>\<^sub>\<epsilon>_sound:
  "\<Delta>\<^sub>\<epsilon>_set A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (\<Delta>\<^sub>\<epsilon>_set_cong f ps p qs q) show ?case
      apply (intro infer[of "zip ps qs" "(p, q)"])
      subgoal using \<Delta>\<^sub>\<epsilon>_set_cong(1-3) by (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
      subgoal using \<Delta>\<^sub>\<epsilon>_set_cong(3,5) by (auto simp: zip_nth_conv)
      done
  next
    case (\<Delta>\<^sub>\<epsilon>_set_eps1 p p' q) then show ?case
      by (intro infer[of "[(p, q)]" "(p', q)"]) (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
  next
    case (\<Delta>\<^sub>\<epsilon>_set_eps2 q q' p) then show ?case
      by (intro infer[of "[(p, q)]" "(p, q')"]) (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using \<Delta>\<^sub>\<epsilon>_set_cong[of _ "map fst as" "fst a" A "map snd as" "snd a" B]
        \<Delta>\<^sub>\<epsilon>_set_eps1[of _ "fst a" A "snd a" B] \<Delta>\<^sub>\<epsilon>_set_eps2[of _ "snd a" B "fst a" A]
      by (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
  qed
qed

end

section \<open>Computing the epsilon transitions for the transitive closure of GTT's\<close>

definition \<Delta>_trancl_rules :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) horn set" where
  "\<Delta>_trancl_rules A B =
    \<Delta>\<^sub>\<epsilon>_rules A B \<union> {[(p, q), (q, r)] \<rightarrow>\<^sub>h (p, r) |p q r. True}"

locale \<Delta>_trancl_horn =
  fixes A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin

sublocale horn "\<Delta>_trancl_rules A B" .

lemma \<Delta>_trancl_infer0:
  "infer0 = horn.infer0 (\<Delta>\<^sub>\<epsilon>_rules A B)"
  by (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def \<Delta>_trancl_rules_def horn.infer0_def)

lemma \<Delta>_trancl_infer1:
  "infer1 pq X = horn.infer1 (\<Delta>\<^sub>\<epsilon>_rules A B) pq X \<union>
   {(r, snd pq) |r p'. (r, p') \<in> X \<and> p' = fst pq} \<union>
   {(fst pq, r) |q' r. (q', r) \<in> (insert pq X) \<and> q' = snd pq}"
  unfolding \<Delta>_trancl_rules_def horn_infer1_union Un_assoc
  apply (intro arg_cong2[of _ _ _ _ "(\<union>)"] HOL.refl)
  by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma \<Delta>_trancl_sound:
  "\<Delta>_trancl_set A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (\<Delta>_set_cong f ps p qs q) show ?case
      apply (intro infer[of "zip ps qs" "(p, q)"])
      subgoal using \<Delta>_set_cong(1-3) by (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
      subgoal using \<Delta>_set_cong(3,5) by (auto simp: zip_nth_conv)
      done
  next
    case (\<Delta>_set_eps1 p p' q) then show ?case
      by (intro infer[of "[(p, q)]" "(p', q)"]) (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
  next
    case (\<Delta>_set_eps2 q q' p) then show ?case
      by (intro infer[of "[(p, q)]" "(p, q')"]) (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
  next
    case (\<Delta>_set_trans p q r) then show ?case
      by (intro infer[of "[(p,q), (q,r)]" "(p, r)"]) (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using \<Delta>_set_cong[of _ "map fst as" "fst a" A "map snd as" "snd a" B]
        \<Delta>_set_eps1[of _ "fst a" A "snd a" B] \<Delta>_set_eps2[of _ "snd a" B "fst a" A]
        \<Delta>_set_trans[of "fst a" "snd (hd as)" A B "snd a"]
      by (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
  qed
qed

end

section \<open>Computing the epsilon transitions for the transitive closure of pair automata\<close>

definition \<Delta>_Atr_rules :: "('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) horn set" where
  "\<Delta>_Atr_rules Q A B =
    {[] \<rightarrow>\<^sub>h (p, q) | p q. (p , q) |\<in>| Q} \<union>
    {[(p, q),(r, v)] \<rightarrow>\<^sub>h (p, v) |p q r v. (q, r) |\<in>| \<Delta>\<^sub>\<epsilon> B A}"

locale \<Delta>_Atr_horn =
  fixes Q :: "('q \<times> 'q) fset" and A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin

sublocale horn "\<Delta>_Atr_rules Q A B" .

lemma \<Delta>_Atr_infer0: "infer0 = fset Q"
  by (auto simp: horn.infer0_def \<Delta>_Atr_rules_def fmember_iff_member_fset)

lemma \<Delta>_Atr_infer1:
  "infer1 pq X = {(p, snd pq) | p q. (p, q) \<in> X \<and> (q, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A} \<union>
   {(fst pq, v) | q r v. (snd pq, r) |\<in>| \<Delta>\<^sub>\<epsilon> B A \<and> (r, v) \<in> X} \<union>
   {(fst pq, snd pq) | q . (snd pq, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A}"
  unfolding \<Delta>_Atr_rules_def horn_infer1_union
  by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma \<Delta>_Atr_sound:
  "\<Delta>_Atrans_set Q A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (base p q)
    then show ?case
      by (intro infer[of "[]" "(p, q)"]) (auto simp: \<Delta>_Atr_rules_def)
  next
    case (step p q r v)
    then show ?case
      by (intro infer[of "[(p, q), (r, v)]" "(p, v)"]) (auto simp: \<Delta>_Atr_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using base[of "fst a" "snd a" Q A B]
      using \<Delta>_Atrans_set.step[of "fst a" _ Q A B "snd a"]
      by (auto simp: \<Delta>_Atr_rules_def) blast
  qed
qed

end

section \<open>Computing the Q infinity set for the infinity predicate automaton\<close>

definition Q_inf_rules :: "('q, 'f option \<times> 'g option) ta \<Rightarrow> ('q \<times> 'q) horn set" where
  "Q_inf_rules A =
    {[] \<rightarrow>\<^sub>h (ps ! i, p) |f ps p i. (None, Some f) ps \<rightarrow> p |\<in>| rules A \<and> i < length ps} \<union>
    {[(p, q)] \<rightarrow>\<^sub>h (p, r) |p q r. (q, r) |\<in>| eps A} \<union>
    {[(p, q), (q, r)] \<rightarrow>\<^sub>h (p, r) |p q r. True}"

locale Q_horn =
  fixes A :: "('q, 'f option \<times> 'g option) ta"
begin

sublocale horn "Q_inf_rules A" .

lemma Q_infer0:
  "infer0 = {(ps ! i, p) |f ps p i. (None, Some f) ps \<rightarrow> p |\<in>| rules A \<and> i < length ps}"
  unfolding horn.infer0_def Q_inf_rules_def by auto

lemma Q_infer1:
  "infer1 pq X = {(fst pq, r) | q r. (q, r) |\<in>| eps A \<and> q = snd pq} \<union>
    {(r, snd pq) |r p'. (r, p') \<in> X \<and> p' = fst pq} \<union>
    {(fst pq, r) |q' r. (q', r) \<in> (insert pq X) \<and> q' = snd pq}"
  unfolding Q_inf_rules_def horn_infer1_union
  by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+

lemma Q_sound:
  "Q_inf A = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using lr unfolding x
  proof (induct)
    case (trans p q r)
    then show ?case
      by (intro infer[of "[(p,q), (q,r)]" "(p, r)"])
        (auto simp: Q_inf_rules_def)
  next
    case (rule f qs q i)
    then show ?case
      by (intro infer[of "[]" "(qs ! i, q)"])
        (auto simp: Q_inf_rules_def)
  next
    case (eps p q r)
    then show ?case
      by (intro infer[of "[(p, q)]" "(p, r)"])
        (auto simp: Q_inf_rules_def)
  qed
next
  case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
  show ?case using rl unfolding x
  proof (induct)
    case (infer as a) then show ?case
      using Q_inf.eps[of "fst a" _ A "snd a"]
      using Q_inf.trans[of "fst a" "snd (hd as)" A "snd a"]
      by (auto simp: Q_inf_rules_def intro: Q_inf.rule)
  qed
qed

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_list
imports Infra_nat
begin

(*****************************************************
               Small lemmas for List
 *****************************************************)

(*** list of the empty set ***)

primrec
  Emptyset_list :: "nat => 'a set list"    ("{}::_" [1000] 1000 )
where
  "{}::0 = []"
 |"{}::(Suc n) = {} # {}::n"

lemma not_emptyset_EX: "A ~= {} = (EX a. a:A)"
by (auto)

lemma one_list_decompo:
   "([a] = s @ t) = ((s =[] & t = [a]) | (s = [a] & t = []))"
by (induct_tac s, auto)

lemma list_nil_or_unnil: "ALL t. (t = []) | (EX a s. t = a # s)"
apply (intro allI)
by (induct_tac t, auto)

lemma list_last_nil_or_unnil: "ALL t. (t = []) | (EX s a. t =s @ [a])"
apply (intro allI)
by (induct_tac t, auto)

(*** unnil ***)

lemma unnil_ex_ALL: "ALL s. s ~= [] --> (EX a. a : set s)"
apply (rule allI)
apply (induct_tac s)
apply (auto)
done

lemma unnil_ex: "s ~= [] ==> (EX a. a : set s)"
by (simp add: unnil_ex_ALL)

(*** nil ***)

lemma emptyset_to_nil: "({} = set t) = (t = [])"
by (auto)

lemma nil_to_emptyset: "(X = set []) = (X = {})"
by (auto)

(****** butlast ******)

lemma notin_butlast_decompo:
  "e ~: set (butlast (s @ t))
      = ((e ~: set s & e ~: set (butlast t)) | (e ~: set (butlast s) & t = []))"
apply (induct_tac s)
by (auto)

lemma in_butlast_decompo:
  "e : set (butlast (s @ t))
      = ((e : set s | e : set (butlast t)) & (e : set (butlast s) | t ~= []))"
apply (induct_tac s)
by (auto)

lemma butlast_subseteq : "set (butlast s) <= set s"
apply (induct_tac s)
by (auto)

(*** length s = 1 ***)

lemma list_length_one: "(length s = Suc 0) = (EX a. s =[a])"
apply (induct_tac s)
by (auto)

(****** list app app ******)

(*** lm ***)

lemma list_app_app_only_if:
  "ALL s1 s2 t1 t2. (s1 @ s2 = t1 @ t2)
       --> ((EX u. s1 = t1 @ u & t2 = u @ s2) |
            (EX u. t1 = s1 @ u & s2 = u @ t2)   )"
apply (rule allI)
apply (induct_tac s1)
apply (intro allI impI)
apply (rule disjI2)
apply (rule_tac x="t1" in exI)
apply (simp)

 (* step *)

apply (intro allI impI)
apply (insert list_nil_or_unnil)
apply (rotate_tac -1)
apply (drule_tac x="t1" in spec)
apply (erule disjE)

  (* t1 = [] *)
 apply (simp)

  (* t1 ~= [] *)
 apply (elim exE)
 apply (simp)
done

(*** list app app ***)

lemma list_app_app:
  "(s1 @ s2 = t1 @ t2) =
      ((EX u. s1 = t1 @ u & t2 = u @ s2) |
       (EX u. t1 = s1 @ u & s2 = u @ t2))"
apply (rule iffI)
apply (simp add: list_app_app_only_if)
apply (auto)
done

(*** list app [a] ***)

lemma list_app_decompo_one:
  "(s @ t = [a]) = ((s = [a] & t = []) | (s = [] & t = [a]))"
apply (induct_tac s)
by (auto)

(*** map ***)

lemma divide_map_fst_ALL:
  "ALL ss s2 s1. map fst (ss::('a * 'b) list) = s1 @ s2
       --> (EX (ss1::('a * 'b) list) (ss2::('a * 'b) list).
            ss = ss1 @ ss2 & map fst ss1 = s1 & map fst ss2 = s2)"
apply (rule allI)
apply (rule allI)
apply (induct_tac s2)
apply (simp_all)

apply (intro allI impI)
apply (drule_tac x="s1 @ [a]" in spec)
apply (simp)
apply (elim conjE exE)
apply (insert list_last_nil_or_unnil)
apply (drule_tac x="ss1" in spec)
apply (erule disjE)
apply (simp)
apply (elim conjE exE)
apply (simp)
apply (rule_tac x="s" in exI, simp)
done

lemma divide_map_fst:
  "map fst (ss::('a * 'b) list) = s1 @ s2
       ==> (EX (ss1::('a * 'b) list) (ss2::('a * 'b) list).
            ss = ss1 @ ss2 & map fst ss1 = s1 & map fst ss2 = s2)"
by (simp add: divide_map_fst_ALL)

(*** zip ***)

lemma map_fst_zip_eq_lm:
  "ALL t. length s <= length t --> map fst (zip s t) = s"
apply (induct_tac s)
apply (simp_all)
apply (intro allI impI)
apply (insert list_nil_or_unnil)
apply (rotate_tac -1)
apply (drule_tac x="t" in spec)
by (auto)

lemma map_fst_zip_eq:
  "length s <= length t ==> map fst (zip s t) = s"
by (simp add: map_fst_zip_eq_lm)

lemma fst_set_zip_eq_lm:
  "ALL t. length s <= length t --> fst ` set (zip s t) = set s"
apply (induct_tac s)
apply (simp_all)
apply (intro allI impI)
apply (insert list_nil_or_unnil)
apply (rotate_tac -1)
apply (drule_tac x="t" in spec)
apply (erule disjE, simp)
apply (elim conjE exE, simp)
done

lemma fst_set_zip_eq:
  "length s <= length t ==> fst ` set (zip s t) = set s"
by (simp add: fst_set_zip_eq_lm)

lemma zip_map_fst_snd: "zip (map fst s) (map snd s) = s"
apply (induct_tac s)
by (auto)

lemma set_nth: "(a : set s) = (EX i. i < length s & a = s!i)"
apply (induct_tac s)
apply (simp_all)
apply (rule iffI)

(* => *)
 apply (force)

(* <= *)
 apply (elim conjE exE)
 apply (drule sym)
 apply (simp)
 apply (insert nat_zero_or_Suc)
 apply (drule_tac x="i" in spec)
 apply (erule disjE, simp)
 apply (elim exE, simp)
done

lemma nth_pair_zip_in_ALL:
      "ALL s t i. (length s = length t & i < length t)
       --> (s!i,t!i) : set (zip s t)"
apply (rule allI)
apply (induct_tac s)
apply (auto)
apply (insert list_nil_or_unnil)
apply (rotate_tac -1)
apply (drule_tac x="t" in spec)
apply (erule disjE, simp)
apply (elim conjE exE, simp)

apply (insert nat_zero_or_Suc)
apply (drule_tac x="i" in spec)
apply (erule disjE, simp)
apply (elim conjE exE, simp)
done

lemma nth_pair_zip_in:
      "[| length s = length t ; i < length t |]
       ==> (s!i,t!i) : set (zip s t)"
by (simp add: nth_pair_zip_in_ALL)

(*** emptyset list ***)

lemma length_Emptyset_list[simp]: "length({}::n) = n"
apply (induct_tac n)
by (simp_all)

(* =================================================== *
 |             addition for CSP-Prover 5               |
 * =================================================== *)

(* --------------------------------------------------- *
             convenient lemmas for proofs
 * --------------------------------------------------- *)

(* -----------
      list
 * ----------- *)

lemma not_nil: "(s ~= []) = (EX a t. s=a#t)"
apply (induct_tac s)
apply (auto)
done

lemma tl_nil: "(tl s = []) = (s=[] | (EX a. s=[a]))"
apply (induct_tac s)
by (auto)

lemma tl_not_nil: "(tl s ~= []) = (EX a1 a2 t. s=a1#a2#t)"
apply (induct_tac s)
apply (auto simp add: tl_nil)
done

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{State Space Exploration} *}
theory Exploration
imports Main "../../ICF/Collections"
begin
text_raw {*\label{thy:Exploration}*}

text {*
  In this theory, a workset algorithm for state-space exploration is defined.
  It explores the set of states that are reachable by a given relation,
   starting at a given set of initial states.

  The specification makes use of the data refinement framework for
  while-algorithms (cf. Section~\ref{thy:DatRef}), and is thus suited for
  being refined to an executable algorithm, using the Isabelle Collections Framework
  to provide the necessary data structures.
  *}

subsection "Generic Search Algorithm"

  -- "The algorithm contains a set of discovered states and a workset"
type_synonym '\<Sigma> sse_state = "'\<Sigma> set \<times> '\<Sigma> set"

  -- "Loop body"
inductive_set
  sse_step :: "('\<Sigma>\<times>'\<Sigma>) set \<Rightarrow> ('\<Sigma> sse_state \<times> '\<Sigma> sse_state) set"
  for R where
  "\<lbrakk> \<sigma>\<in>W;
     \<Sigma>' = \<Sigma> \<union> (R``{\<sigma>});
     W' = (W-{\<sigma>}) \<union> ((R``{\<sigma>}) - \<Sigma>)
   \<rbrakk> \<Longrightarrow> ((\<Sigma>,W),(\<Sigma>',W'))\<in>sse_step R"

  -- "Loop condition"
definition sse_cond :: "'\<Sigma> sse_state set" where
  "sse_cond = {(\<Sigma>,W). W\<noteq>{}}"

  -- "Initial state"
definition sse_initial :: "'\<Sigma> set \<Rightarrow> '\<Sigma> sse_state" where
  "sse_initial \<Sigma>i == (\<Sigma>i,\<Sigma>i)"

  -- {*Invariants:
  \begin{itemize}
    \item The workset contains only states that are already
      discovered.
    \item All discovered states are target states
    \item If there is a target state that is not discovered yet,
          then there is an element in the workset from that this
          target state is reachable without using discovered
          states as intermediate states. This supports the intuition
          of the workset as a frontier between the sets of discovered
          and undiscovered states.

  \end{itemize}*}
definition sse_invar :: "'\<Sigma> set \<Rightarrow> ('\<Sigma>\<times>'\<Sigma>) set \<Rightarrow> '\<Sigma> sse_state set" where
  "sse_invar \<Sigma>i R = {(\<Sigma>,W).
    W\<subseteq>\<Sigma> \<and>
    (\<Sigma> \<subseteq> R\<^sup>*``\<Sigma>i) \<and>
    (\<forall>\<sigma>\<in>(R\<^sup>*``\<Sigma>i)-\<Sigma>. \<exists>\<sigma>h\<in>W. (\<sigma>h,\<sigma>)\<in>(R - (UNIV \<times> \<Sigma>))\<^sup>*)
  }"

definition "sse_algo \<Sigma>i R ==
  \<lparr> wa_cond=sse_cond,
    wa_step=sse_step R,
    wa_initial = {sse_initial \<Sigma>i},
    wa_invar = sse_invar \<Sigma>i R \<rparr>"

definition "sse_term_rel \<Sigma>i R ==
  { (\<sigma>',\<sigma>). \<sigma>\<in>sse_invar \<Sigma>i R \<and> (\<sigma>,\<sigma>')\<in>sse_step R }"

  -- "Termination: Either a new state is discovered, or the workset shrinks"
theorem sse_term:
  assumes finite[simp, intro!]: "finite (R\<^sup>*``\<Sigma>i)"
  shows "wf (sse_term_rel \<Sigma>i R)"
proof -
  have "wf (({(\<Sigma>',\<Sigma>). \<Sigma> \<subset> \<Sigma>' \<and> \<Sigma>' \<subseteq> (R\<^sup>*``\<Sigma>i)}) <*lex*> finite_psubset)"
    by (auto intro: wf_bounded_supset)
  moreover have "sse_term_rel \<Sigma>i R \<subseteq> \<dots>" (is "_ \<subseteq> ?R")
  proof
    fix S
    assume A: "S\<in>sse_term_rel \<Sigma>i R"
    obtain \<Sigma> W \<Sigma>' W' \<sigma> where
      [simp]: "S=((\<Sigma>',W'),(\<Sigma>,W))" and
      S: "(\<Sigma>,W) \<in> sse_invar \<Sigma>i R"
         "\<sigma>\<in>W"
         "\<Sigma>' = \<Sigma> \<union> R``{\<sigma>}"
         "W' = (W-{\<sigma>}) \<union> (R``{\<sigma>} - \<Sigma>)"
    proof -
      obtain \<Sigma> W \<Sigma>' W' where SF[simp]: "S=((\<Sigma>',W'),(\<Sigma>,W))" by (cases S) force
      from A have R: "(\<Sigma>,W) \<in> sse_invar \<Sigma>i R" "((\<Sigma>,W),(\<Sigma>',W'))\<in>sse_step R"
        by (auto simp add: sse_term_rel_def)
      from sse_step.cases[OF R(2)] obtain \<sigma> where S:
        "\<sigma>\<in>W"
        "\<Sigma>' = \<Sigma> \<union> R``{\<sigma>}"
        "W' = (W-{\<sigma>}) \<union> (R``{\<sigma>} - \<Sigma>)"
        by metis
      thus ?thesis
        by (rule_tac that[OF SF R(1) S])
    qed

    from S(1) have
      [simp, intro!]: "finite \<Sigma>" "finite W" and
      WSS: "W\<subseteq>\<Sigma>" and
      SSS: "\<Sigma>\<subseteq>R\<^sup>*``\<Sigma>i"
      by (auto simp add: sse_invar_def intro: finite_subset)

    show "S\<in>?R" proof (cases "R``{\<sigma>} \<subseteq> \<Sigma>")
      case True with S have "\<Sigma>'=\<Sigma>" "W' \<subset> W" by auto
      thus ?thesis by (simp)
    next
      case False
      with S have "\<Sigma>' \<supset> \<Sigma>" by auto
      moreover from S(2) WSS SSS have "\<sigma>\<in>R\<^sup>*``\<Sigma>i" by auto
      hence "R``{\<sigma>} \<subseteq> R\<^sup>*``\<Sigma>i"
        by (auto intro: rtrancl_into_rtrancl)
      with S(3) SSS have "\<Sigma>' \<subseteq> R\<^sup>*``\<Sigma>i" by auto
      ultimately show ?thesis by simp
    qed
  qed
  ultimately show ?thesis by (auto intro: wf_subset)
qed

lemma sse_invar_initial: "(sse_initial \<Sigma>i) \<in> sse_invar \<Sigma>i R"
  by (unfold sse_invar_def sse_initial_def)
     (auto elim: rtrancl_last_touch)

  -- "Correctness theorem: If the loop terminates, the discovered states are
       exactly the reachable states"
theorem sse_invar_final:
  "\<forall>S. S\<in>wa_invar (sse_algo \<Sigma>i R) \<and> S\<notin>wa_cond (sse_algo \<Sigma>i R)
    \<longrightarrow> fst S = R\<^sup>*``\<Sigma>i"
  by (intro allI, case_tac S)
     (auto simp add: sse_invar_def sse_cond_def sse_algo_def)

lemma sse_invar_step: "\<lbrakk>S\<in>sse_invar \<Sigma>i R; (S,S')\<in>sse_step R\<rbrakk>
  \<Longrightarrow> S'\<in>sse_invar \<Sigma>i R"
  -- "Split the goal by the invariant:"
  apply (cases S, cases S')
  apply clarsimp
  apply (erule sse_step.cases)
  apply clarsimp
  apply (subst sse_invar_def)
  apply (simp add: Let_def split_conv)
  apply (intro conjI)
  -- "Solve the easy parts automatically"
  apply (auto simp add: sse_invar_def) [3]
  apply (force simp add: sse_invar_def
               dest: rtrancl_into_rtrancl) [1]
  -- "Tackle the complex part (last part of the invariant) in Isar"
proof (intro ballI)
  fix \<sigma> W \<Sigma> \<sigma>'
  assume A:
    "(\<Sigma>,W)\<in>sse_invar \<Sigma>i R"
    "\<sigma>\<in>W"
    "\<sigma>'\<in>R\<^sup>* `` \<Sigma>i - (\<Sigma> \<union> R `` {\<sigma>})"
    -- "Using the invariant of the original state, we obtain
        a state in the original workset and a path not touching
        the originally discovered states"
  from A(3) have "\<sigma>' \<in> R\<^sup>* `` \<Sigma>i - \<Sigma>" by auto
  with A(1) obtain \<sigma>h where IP:
    "\<sigma>h\<in>W"
    "(\<sigma>h,\<sigma>')\<in>(R - (UNIV \<times> \<Sigma>))\<^sup>*"
  and SS:
    "W\<subseteq>\<Sigma>"
    "\<Sigma>\<subseteq>R\<^sup>* `` \<Sigma>i"
    by (unfold sse_invar_def) force

  -- {* We now make a case distinction, whether the obtained path contains
      states from @{term "post \<sigma>"} or not: *}
  from IP(2) show "\<exists>\<sigma>h\<in>W - {\<sigma>} \<union> (R `` {\<sigma>} - \<Sigma>).
                     (\<sigma>h, \<sigma>') \<in> (R - UNIV \<times> (\<Sigma> \<union> R `` {\<sigma>}))\<^sup>*"
  proof (cases rule: rtrancl_last_visit[where S="R `` {\<sigma>}"])
    case no_visit
    -- {* In the case that the obtained path contains no states from
          @{term "post \<sigma>"}, we can take it. *}
    hence G1: "(\<sigma>h,\<sigma>')\<in>(R- (UNIV \<times> (\<Sigma>\<union>R `` {\<sigma>})))\<^sup>*"
      by (simp add: set_diff_diff_left Sigma_Un_distrib2)
    moreover have "\<sigma>h \<noteq> \<sigma>"
      -- {* We may exclude the case that our obtained path started at
            @{text \<sigma>}, as all successors of @{text \<sigma>} are
            in @{term "R `` {\<sigma>}"} *}
    proof
      assume [simp]: "\<sigma>h=\<sigma>"
      from A SS have "\<sigma>\<noteq>\<sigma>'" by auto
      with G1 show False
        by (auto simp add: elim: converse_rtranclE)
    qed
    ultimately show ?thesis using IP(1) by auto
  next
    case (last_visit_point \<sigma>t)
    -- {* If the obtained path contains a state from @{text "R `` {\<sigma>}"},
          we simply pick the last one: *}
    hence "(\<sigma>t,\<sigma>')\<in>(R- (UNIV \<times> (\<Sigma>\<union>R `` {\<sigma>})))\<^sup>*"
      by (simp add: set_diff_diff_left Sigma_Un_distrib2)
    moreover from last_visit_point(2) have "\<sigma>t\<notin>\<Sigma>"
      by (auto elim: trancl.cases)
    ultimately show ?thesis using last_visit_point(1) by auto
  qed
qed

-- "The sse-algorithm is a well-defined while-algorithm"
theorem sse_while_algo: "finite (R\<^sup>*``\<Sigma>i) \<Longrightarrow> while_algo (sse_algo \<Sigma>i R)"
  apply unfold_locales
  apply (auto simp add: sse_algo_def intro: sse_invar_step sse_invar_initial)
  apply (drule sse_term)
  apply (erule_tac wf_subset)
  apply (unfold sse_term_rel_def)
  apply auto
  done

subsection "Depth First Search"
text_raw {*\label{sec:sse:dfs}*}
text {*
  In this section, the generic state space exploration algorithm is refined
  to a DFS-algorithm, that uses a stack to implement the workset.
*}

type_synonym '\<Sigma> dfs_state = "'\<Sigma> set \<times> '\<Sigma> list"

definition dfs_\<alpha> :: "'\<Sigma> dfs_state \<Rightarrow> '\<Sigma> sse_state"
  where "dfs_\<alpha> S == let (\<Sigma>,W)=S in (\<Sigma>,set W)"

definition dfs_invar_add :: "'\<Sigma> dfs_state set"
  where "dfs_invar_add == {(\<Sigma>,W). distinct W}"

definition "dfs_invar \<Sigma>i R == dfs_invar_add \<inter> { s. dfs_\<alpha> s \<in> sse_invar \<Sigma>i R }"

inductive_set dfs_initial :: "'\<Sigma> set \<Rightarrow> '\<Sigma> dfs_state set" for \<Sigma>i
  where "\<lbrakk> distinct W; set W = \<Sigma>i\<rbrakk> \<Longrightarrow> (\<Sigma>i,W)\<in>dfs_initial \<Sigma>i"

inductive_set dfs_step :: "('\<Sigma>\<times>'\<Sigma>) set \<Rightarrow> ('\<Sigma> dfs_state \<times>'\<Sigma> dfs_state) set"
  for R where
  "\<lbrakk> W=\<sigma>#Wtl;
     distinct Wn;
     set Wn = R``{\<sigma>} - \<Sigma>;
     W' = Wn@Wtl;
     \<Sigma>' = R``{\<sigma>} \<union> \<Sigma>
  \<rbrakk> \<Longrightarrow> ((\<Sigma>,W),(\<Sigma>',W'))\<in>dfs_step R"

definition dfs_cond :: "'\<Sigma> dfs_state set"
  where "dfs_cond == { (\<Sigma>,W). W\<noteq>[]}"

definition "dfs_algo \<Sigma>i R == \<lparr>
  wa_cond = dfs_cond,
  wa_step = dfs_step R,
  wa_initial = dfs_initial \<Sigma>i,
  wa_invar = dfs_invar \<Sigma>i R \<rparr>"

  -- "The DFS-algorithm refines the state-space exploration algorithm"
theorem dfs_pref_sse:
  "wa_precise_refine (dfs_algo \<Sigma>i R) (sse_algo \<Sigma>i R) dfs_\<alpha>"
  apply (unfold_locales)
  apply (auto simp add: dfs_algo_def sse_algo_def dfs_cond_def sse_cond_def
                        dfs_\<alpha>_def)
  apply (erule dfs_step.cases)
  apply (rule_tac \<sigma>=\<sigma> in sse_step.intros)
  apply (auto simp add: dfs_invar_def sse_invar_def dfs_invar_add_def
                        sse_initial_def dfs_\<alpha>_def
              elim: dfs_initial.cases)
  done

  -- "The DFS-algorithm is a well-defined while-algorithm"

  have [simp]: "wa_invar (sse_algo \<Sigma>i R) = sse_invar \<Sigma>i R"
    by (simp add: sse_algo_def)

  show ?thesis
    apply (rule wa_intro)
    apply (simp add: sse_while_algo)

    apply (simp add: dfs_invar_def dfs_algo_def)

    apply (auto simp add: dfs_invar_add_def dfs_algo_def dfs_\<alpha>_def
                          dfs_cond_def sse_invar_def
                elim!: dfs_step.cases) [1]

    apply (auto simp add: dfs_invar_add_def dfs_algo_def
                elim: dfs_initial.cases) [1]
    done
qed

  -- "The result of the DFS-algorithm is correct"
theorems dfs_invar_final =
  wa_precise_refine.transfer_correctness[OF dfs_pref_sse sse_invar_final]

end


theory Lib_Numbers_toString
imports Main
begin

section\<open>Printing Numbers\<close>

(*http://stackoverflow.com/questions/23864965/string-of-nat-in-isabelle*)
fun string_of_nat :: "nat \<Rightarrow> string" where
  "string_of_nat n = (if n < 10 then [char_of_nat (48 + n)] else
     string_of_nat (n div 10) @ [char_of_nat (48 + (n mod 10))])"
definition string_of_int :: "int \<Rightarrow> string" where
  "string_of_int i = (if i < 0 then ''-'' @ string_of_nat (nat (- i)) else
     string_of_nat (nat i))"

lemma "string_of_nat 123456 = ''123456''" by eval

declare string_of_nat.simps[simp del]

end


theory Cardinality1
  imports Main
begin

lemma "\<exists>x . x \<in> A \<Longrightarrow> card A > 0"
proof -

lemma "card A = 0 \<Longrightarrow> A = {}"
proof -
  assume "card A = 0"
  {
    assume "A \<noteq> {}"
    hence "\<exists>x . x \<in> A"  sorry


subsection \<open>Executable Version to Compute Representative Polynomials\<close>

theory Roots_of_Algebraic_Poly_Impl
imports
  Roots_of_Algebraic_Poly
  Polynomials.MPoly_Type_Class_FMap
begin

text \<open>We need to specialize our code to real and complex polynomials,
  since @{const algebraic} and @{const min_int_poly} are
  not executable in their parametric versions.\<close>

definition initial_root_problem_real :: "real poly \<Rightarrow> _" where
  [simp]: "initial_root_problem_real p = initial_root_problem p"

definition initial_root_problem_complex :: "complex poly \<Rightarrow> _" where
  [simp]: "initial_root_problem_complex p = initial_root_problem p"

lemmas initial_root_problem_code =
  initial_root_problem_real_def[unfolded initial_root_problem_def]
  initial_root_problem_complex_def[unfolded initial_root_problem_def]

declare initial_root_problem_code[code]

lemma initial_root_problem_code_unfold[code_unfold]:
  "initial_root_problem = initial_root_problem_complex"
  "initial_root_problem = initial_root_problem_real"
  by (intro ext, simp)+

definition representative_poly_real :: "real poly \<Rightarrow> _" where
  [simp]: "representative_poly_real p = representative_poly p"

definition representative_poly_complex :: "complex poly \<Rightarrow> _" where
  [simp]: "representative_poly_complex p = representative_poly p"

lemmas representative_poly_code =
  representative_poly_real_def[unfolded representative_poly_def]
  representative_poly_complex_def[unfolded representative_poly_def]

declare representative_poly_code[code]

lemma representative_poly_code_unfold[code_unfold]:
  "representative_poly = representative_poly_complex"
  "representative_poly = representative_poly_real"
  by (intro ext, simp)+

end


(* I borrow the implementation by
    [Title:      Sequents/LK0.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1993  University of Cambridge]

But make a modification to adapt to our application.
*)

header {* Classical First-Order Sequent Calculus *}

theory DLK0
imports DSequents
begin

class "term"
default_sort "term"

consts

  Trueprop :: "two_seqi"

syntax
 "_Trueprop" :: "two_seqe" ("((_)/ |- (_))" [6,6] 5)

parse_translation {* [(@{syntax_const "_Trueprop"}, K (two_seq_tr @{const_syntax Trueprop}))] *}
print_translation {* [(@{const_syntax Trueprop}, K (two_seq_tr' @{syntax_const "_Trueprop"}))] *}

axiomatization where

  (*Structural rules: contraction, thinning, exchange [Soren Heilmann] *)

  contRS: "$H |- $E, $S, $S, $F ==> $H |- $E, $S, $F" and
  contLS: "$H, $S, $S, $G |- $E ==> $H, $S, $G |- $E" and

  thinRS: "$H |- $E, $F ==> $H |- $E, $S, $F" and
  thinLS: "$H, $G |- $E ==> $H, $S, $G |- $E" and

  exchRS: "$H |- $E, $R, $S, $F ==> $H |- $E, $S, $R, $F" and
  exchLS: "$H, $R, $S, $G |- $E ==> $H, $S, $R, $G |- $E" and

  cut:   "[| $H |- $E, P;  $H, P |- $E |] ==> $H |- $E"

axiomatization where
 (*Propositional rules*)

  basic: "$H, P, $G |- $E, P, $F" and

  conjR: "[| $H|- $E, P, $F;  $H|- $E, Q, $F |] ==> $H|- $E, P [&] Q, $F"and
  conjL: "$H, P, Q, $G |- $E ==> $H, P [&] Q, $G |- $E"and

  disjR: "$H |- $E, P, Q, $F ==> $H |- $E, P [|] Q, $F"and
  disjL: "[| $H, P, $G |- $E;  $H, Q, $G |- $E |] ==> $H, P [|] Q, $G |- $E"and

  impR:  "$H, P |- $E, Q, $F ==> $H |- $E, P [-->] Q, $F"and
  impL:  "[| $H,$G |- $E,P;  $H, Q, $G |- $E |] ==> $H, P [-->] Q, $G |- $E"and

  notR:  "$H, P |- $E, $F ==> $H |- $E, [~] P, $F"and
  notL:  "$H, $G |- $E, P ==> $H, [~] P, $G |- $E"and

  FalseL: "$H, WFalse, $G |- $E"and

  True_def: "WTrue == WFalse [-->] WFalse"and
  iff_def:  "P [<->] Q == (P [-->] Q) [&] (Q [-->] P)"

axiomatization where
  (*Quantifiers*)

  allR:  "(!!x.$H |- $E, P(x), $F) ==> $H |- $E, WALL x P(x), $F"and
  allL:  "$H, P(x), $G, WALL x P(x) |- $E ==> $H, WALL x P(x), $G |- $E"and

  exR:   "$H |- $E, P(x), $F, WEX x P(x) ==> $H |- $E, WEX  x P(x), $F"and
  exL:   "(!!x.$H, P(x), $G |- $E) ==> $H, WEX x P(x), $G |- $E"

axiomatization where
 (*Equality*)

  refl:  "$H |- $E, a [=] a, $F"and
  subst: "\<And>G H E. $H(a), $G(a) |- $E(a) ==> $H(b), a [=] b, $G(b) |- $E(b)"

  (* Reflection *)
axiomatization where
  eq_reflection:  "|- x [=] y ==> (x==y)"and
  iff_reflection: "|- P [<->] Q ==> (P==Q)"

(** Structural Rules on formulas **)

(*contraction*)

lemma contR: "$H |- $E, P, P, $F ==> $H |- $E, P, $F"
  by (rule contRS)

lemma contL: "$H, P, P, $G |- $E ==> $H, P, $G |- $E"
  by (rule contLS)

(*thinning*)

lemma thinR: "$H |- $E, $F ==> $H |- $E, P, $F"
  by (rule thinRS)

lemma thinL: "$H, $G |- $E ==> $H, P, $G |- $E"
  by (rule thinLS)

(*exchange*)

lemma exchR: "$H |- $E, Q, P, $F ==> $H |- $E, P, Q, $F"
  by (rule exchRS)

lemma exchL: "$H, Q, P, $G |- $E ==> $H, P, Q, $G |- $E"
  by (rule exchLS)

ML {*
(*Cut and thin, replacing the right-side formula*)
fun cutR_tac ctxt s i =
  res_inst_tac ctxt [(("P", 0), s) ] @{thm cut} i  THEN  rtac @{thm thinR} i

(*Cut and thin, replacing the left-side formula*)
fun cutL_tac ctxt s i =
  res_inst_tac ctxt [(("P", 0), s)] @{thm cut} i  THEN  rtac @{thm thinL} (i+1)
*}

(** If-and-only-if rules **)
lemma iffR:
    "[| $H,P |- $E,Q,$F;  $H,Q |- $E,P,$F |] ==> $H |- $E, P [<->] Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL:
    "[| $H,$G |- $E,P,Q;  $H,Q,P,$G |- $E |] ==> $H, P [<->] Q, $G |- $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemma iff_refl: "$H |- $E, (P [<->] P), $F"
  apply (rule iffR basic)+
  done

lemma TrueR: "$H |- $E, WTrue, $F"
  apply (unfold True_def)
  apply (rule impR)
  apply (rule basic)
  done

(*(*Descriptions*)
lemma the_equality:
  assumes p1: "$H |- $E, P(a), $F"
    and p2: "!!x. $H, P(x) |- $E, x=a, $F"
  shows "$H |- $E, (THE x. P(x)) = a, $F"
  apply (rule cut)
   apply (rule_tac [2] p2)
  apply (rule The, rule thinR, rule exchRS, rule p1)
  apply (rule thinR, rule exchRS, rule p2)
  done
*)

(** Weakened quantifier rules.  Incomplete, they let the search terminate.**)

lemma allL_thin: "$H, P(x), $G |- $E ==> $H, WALL x P(x), $G |- $E"
  apply (rule allL)
  apply (erule thinL)
  done

lemma exR_thin: "$H |- $E, P(x), $F ==> $H |- $E, WEX x P(x), $F"
  apply (rule exR)
  apply (erule thinR)
  done

(*The rules of LK*)

lemmas [safe] =
  iffR iffL
  notR notL
  impR impL
  disjR disjL
  conjR conjL
  FalseL TrueR
  refl basic
ML {* val prop_pack = Cla.get_pack @{context} *}

lemmas [safe] = exL allR
lemmas [unsafe] = the_equality exR_thin allL_thin
ML {* val LK_pack = Cla.get_pack @{context} *}

ML {*
  val LK_dup_pack =
    Cla.put_pack prop_pack @{context}
    |> fold_rev Cla.add_safe @{thms allR exL}
    |> fold_rev Cla.add_unsafe @{thms allL exR the_equality}
    |> Cla.get_pack;
*}

method_setup fast_prop =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack prop_pack ctxt))) *}

method_setup fast_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack LK_dup_pack ctxt))) *}

method_setup best_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.best_tac (Cla.put_pack LK_dup_pack ctxt))) *}

method_setup lem = {*
  Attrib.thm >> (fn th => fn _ =>
    SIMPLE_METHOD' (fn i =>
      rtac (@{thm thinR} RS @{thm cut}) i THEN
      REPEAT (rtac @{thm thinL} i) THEN
      rtac th i))
*}

lemma mp_R:
  assumes major: "$H |- $E, $F, P [-->] Q"
    and minor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule thinRS [THEN cut], rule major)
  apply step
  apply (rule thinR, rule minor)
  done

lemma mp_L:
  assumes major: "$H, $G |- $E, P [-->] Q"
    and minor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule thinL [THEN cut], rule major)
  apply step
  apply (rule thinL, rule minor)
  done

(** Two rules to generate left- and right- rules from implications **)

lemma R_of_imp:
  assumes major: "|- P [-->] Q"
    and minor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule mp_R)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

lemma L_of_imp:
  assumes major: "|- P [-->] Q"
    and minor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule mp_L)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

(*Can be used to create implications in a subgoal*)
lemma backwards_impR:
  assumes prem: "$H, $G |- $E, $F, P [-->] Q"
  shows "$H, P, $G |- $E, Q, $F"
  apply (rule mp_L)
   apply (rule_tac [2] basic)
  apply (rule thinR, rule prem)
  done

lemma conjunct1: "|-P [&] Q ==> |-P"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma conjunct2: "|-P [&] Q ==> |-Q"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma spec: "|- (WALL x P(x)) ==> |- P(x)"
  apply (erule thinR [THEN cut])
  apply fast
  done

(** Equality **)

lemma sym: "|- a [=] b [-->] b [=] a"
  by (safe add!: subst)

lemma trans: "|- a [=] b [-->] b [=] c [-->] a [=] c"
  by (safe add!: subst)

(* Symmetry of equality in hypotheses *)
lemmas symL =  sym [THEN L_of_imp]

(* Symmetry of equality in hypotheses *)
lemmas symR =sym [THEN R_of_imp]

lemma transR: "[| $H|- $E, $F, a [=] b;  $H|- $E, $F, b [=] c |] ==> $H|- $E, a [=] c, $F"
  by (rule trans [THEN R_of_imp, THEN mp_R])

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma def_imp_iff: "(A == B) ==> |- A [<->] B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A == B) ==> |- A [=] B"
  apply (unfold)
  apply (rule refl)
  done

(*New added axioms for formulas of our syntax*)
(*Arith*)
axiomatization where
Trans: "formT (f::fform) ==> |- f" and
Trans1: "(formT (f1::fform) ==> formT (f::fform)) ==> f1 |- f" and
Trans2: "(formT (f1::fform) & formT (f2::fform) ==> formT (f::fform)) ==> f1, f2 |- f" and
Trans3: "(formT (f1::fform) & formT (f2::fform) & formT (f3::fform) ==> formT (f::fform)) ==> f1, f2, f3 |- f" and
Trans4: "(formT (f1::fform) & formT (f2::fform) & formT (f3::fform) & formT (f4::fform) ==> formT (f::fform)) ==> f1, f2, f3, f4 |- f"

axiomatization where
TransR: "|- f ==> formT (f::fform)" and
TransR1: "f1 |- f ==> (formT (f1::fform) --> formT (f::fform))" and
TransR2: "f1, f2 |- f ==> (formT (f1::fform) & formT (f2::fform) --> formT (f::fform))" and
TransR3: "f1, f2, f3 |- f ==> (formT (f1::fform) & formT (f2::fform) & formT (f3::fform) --> formT (f::fform))"
end


theory ProofSearchPredicates
imports Own
begin

subsection \<open>Predicates that guide the proof search\<close>
text \<open>These are based on type classes which the IPM uses to guide its proof search for certain steps.\<close>

named_theorems log_prog_rule "Rules that can be used for logic programming reasoning in Iris"

subsubsection \<open>Splitting\<close>
definition can_be_split :: "('a::ucamera) upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool" where
  "can_be_split PQ P Q \<equiv> PQ \<stileturn>\<turnstile> P \<^emph> Q"
named_theorems split_rule

lemma can_be_split_refl: "can_be_split (P\<^emph>Q) P Q"
  unfolding can_be_split_def by (simp add: upred_entails_eq_eq)

lemma can_be_split_baseL: "can_be_split P P upred_emp"
  unfolding can_be_split_def by (simp add: upred_entails_eq_eq upred_true_sep)

lemma can_be_split_baseR: "can_be_split P upred_emp P"
  unfolding can_be_split_def by (simp add: upred_entails_eq_eq upred_true_sep upred_sep_comm)

lemma can_be_split_rev: "can_be_split P Q R \<Longrightarrow> can_be_split P R Q"
  unfolding can_be_split_def upred_entail_eq_def by (simp add: upred_sep_comm)

lemma can_be_split_mono [split_rule]:
  "\<lbrakk>can_be_split P P1 P2; can_be_split Q Q1 Q2\<rbrakk> \<Longrightarrow> can_be_split (P\<^emph>Q) (P1\<^emph>Q1) (P2\<^emph>Q2)"
  by (smt (verit, del_insts) can_be_split_def upred_entail_eq_def upred_sep_assoc_eq
    upred_sep_comm2_eq upred_sep_mono)

lemma can_be_splitI: "P \<stileturn>\<turnstile> Q \<^emph> R \<Longrightarrow> can_be_split P Q R" unfolding can_be_split_def .

lemma can_be_splitE: "can_be_split P Q R \<Longrightarrow> P \<stileturn>\<turnstile> Q \<^emph> R" unfolding can_be_split_def .

lemma can_be_split_R_R: "can_be_split P P1 P2 \<Longrightarrow> can_be_split (Q\<^emph>P) P1 (Q\<^emph>P2)"
  by (metis can_be_split_mono can_be_split_refl upred_sep_comm upred_true_sep)

lemma can_be_split_sepL: "can_be_split P Q R \<Longrightarrow> can_be_split (P\<^emph>S) (Q\<^emph>S) R"
  by (simp add: can_be_split_def upred_entail_eq_def upred_frame upred_sep_comm2_eq)

lemma can_be_split_sepR: "can_be_split P Q R \<Longrightarrow> can_be_split (P\<^emph>S) Q (R\<^emph>S)"
  by (simp add: can_be_split_def upred_entail_eq_def upred_frame upred_sep_assoc_eq)

lemma split_trans: "\<lbrakk>can_be_split P P1 P2; P1 \<turnstile> Q; Q\<^emph>P2 \<turnstile> R\<rbrakk> \<Longrightarrow> P \<turnstile> R"
  unfolding can_be_split_def by (meson upred_entail_eqL upred_entails_trans upred_frame)

lemma split_trans_rule: "\<lbrakk>Q\<turnstile>Q'; can_be_split P P1 P2; P1 \<turnstile> Q; Q'\<^emph>P2 \<turnstile> R\<rbrakk> \<Longrightarrow> P \<turnstile> R"
  unfolding can_be_split_def by (meson upred_entail_eqL upred_entails_trans upred_frame)

lemma split_frame: "\<lbrakk>can_be_split P P1 P2; can_be_split Q Q1 Q2; P1\<turnstile>Q1; P2\<turnstile>Q2\<rbrakk> \<Longrightarrow> P\<turnstile>Q"
  by (meson can_be_split_def split_trans upred_entail_eqR upred_entails_refl upred_entails_trans upred_sep_mono)

lemma can_be_split_disj [split_rule]: "\<lbrakk>can_be_split P P' Q; can_be_split R R' Q\<rbrakk> \<Longrightarrow> can_be_split (P\<or>\<^sub>uR) (P'\<or>\<^sub>uR') Q"
  unfolding can_be_split_def upred_entail_eq_def by transfer blast

lemma can_be_split_later [split_rule]: "can_be_split P Q R \<Longrightarrow> can_be_split (\<triangleright>P) (\<triangleright>Q) (\<triangleright>R)"
  unfolding can_be_split_def by (smt (verit, ccfv_threshold) upred_later_sep upred_later_mono
  diff_le_self ne_sprop_weaken ofe_refl upred_entail_eq_simp upred_later.rep_eq valid_raw_non_expansive)

lemma can_be_split_except_zero [split_rule]: "can_be_split P Q R \<Longrightarrow> can_be_split (\<diamondop>P) (\<diamondop>Q) (\<diamondop>R)"
  unfolding can_be_split_def using except_zero_sep except_zero_mono
  by (smt (verit, ccfv_threshold) upred_entail_eq_def upred_entails_trans)

lemma framing': "\<lbrakk>can_be_split S T Q; T \<turnstile> P\<rbrakk> \<Longrightarrow> S\<turnstile>P\<^emph>Q"
  unfolding can_be_split_def upred_entail_eq_def
  using upred_entails_trans upred_frame by blast

lemma framing'': "can_be_split P Q R \<Longrightarrow> S\<^emph>Q\<turnstile>T \<Longrightarrow> S\<^emph>P\<turnstile>T\<^emph>R"
  by (metis can_be_split_sepL framing' upred_sep_comm)

lemma split_last_frame: "can_be_split P Q R \<Longrightarrow> P \<turnstile> R"
  unfolding can_be_split_def upred_entail_eq_def
  using upred_entails_trans upred_weakeningR by blast

subsubsection \<open>Framing\<close>
definition frame :: "('a::ucamera) upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool" where
  "frame P Q R \<equiv> Q\<^emph>R \<turnstile> P"
named_theorems frame_rule

lemma frameI: "Q\<^emph>R \<turnstile> P \<Longrightarrow> frame P Q R" unfolding frame_def .
lemma frameE: "frame P Q R \<Longrightarrow> Q\<^emph>R \<turnstile> P" unfolding frame_def .

text \<open>Central lemma of framing.\<close>
lemma framing: "\<lbrakk>frame P Q R; S \<turnstile> Q\<rbrakk> \<Longrightarrow> S\<^emph>R\<turnstile>P"
  by (simp add: frame_def upred_entails_substE upred_sep_comm)

lemma framing_emp: "\<lbrakk>frame P Q R; upred_emp \<turnstile> Q\<rbrakk> \<Longrightarrow> R\<turnstile>P"
  using frameE upred_emp_left upred_entails_trans by blast

lemma upred_wand_goal: "\<lbrakk>frame T Q S; P \<turnstile> Q \<^emph> R\<rbrakk> \<Longrightarrow> P \<^emph> (R-\<^emph>S) \<turnstile> T"
  unfolding frame_def
  by (smt (verit, ccfv_SIG) upred_entails_wand_holdsR upred_sep_comm upred_sep_comm2_eq upred_wandI
    upred_wand_apply upred_wand_holds2E upred_wand_holdsI)

lemma frame_rule_apply: "\<lbrakk>T \<turnstile> R;frame P Q R; S \<turnstile> Q\<^emph>T\<rbrakk> \<Longrightarrow> S \<turnstile> P"
  unfolding frame_def using upred_entails_substI upred_entails_trans by blast

lemma frame_refl [frame_rule,log_prog_rule]: "frame (P\<^emph>Q) P Q"
  unfolding frame_def by simp

lemma frame_baseR [frame_rule,log_prog_rule]: "frame P upred_emp P"
  unfolding frame_def by (rule upred_weakeningR)

lemma frame_baseL: "frame P P upred_emp"
  unfolding frame_def by (rule upred_weakeningL)

lemma can_be_split_frame: "can_be_split P Q R \<Longrightarrow> frame P Q R"
  unfolding can_be_split_def upred_entail_eq_def frame_def by simp

lemma frame_rev: "frame P Q R \<Longrightarrow> frame P R Q"
  unfolding frame_def by (simp add: upred_sep_comm)

lemma frame_mono: "\<lbrakk>frame P1 Q1 R1; frame P2 Q2 R2\<rbrakk> \<Longrightarrow> frame (P1\<^emph>P2) (Q1\<^emph>Q2) (R1\<^emph>R2)"
proof-
assume "frame P1 Q1 R1" "frame P2 Q2 R2"
from upred_sep_mono[OF this[unfolded frame_def]] show "frame (P1\<^emph>P2) (Q1\<^emph>Q2) (R1\<^emph>R2)"
  by (simp add: upred_sep_comm2_eq frame_def upred_sep_assoc_eq)
qed

lemma frame_sepL [frame_rule,log_prog_rule]: "frame P Q R \<Longrightarrow> frame (P\<^emph>S) (Q\<^emph>S) R"
  by (simp add: frame_def upred_frame upred_sep_comm2_eq)

lemma frame_sepL' [frame_rule,log_prog_rule]: "frame S Q R \<Longrightarrow> frame (P\<^emph>S) (P\<^emph>Q) R"
  by (simp add: frame_def upred_entails_substI upred_sep_assoc_rev)

lemma frame_sepR: "frame P Q R \<Longrightarrow> frame (P\<^emph>S) Q (R\<^emph>S)"
  by (simp add: frame_def upred_frame upred_sep_assoc_eq)

lemma frame_disj [frame_rule,log_prog_rule]: "\<lbrakk>frame P P' Q; frame R R' Q\<rbrakk> \<Longrightarrow> frame (P\<or>\<^sub>uR) (P'\<or>\<^sub>uR') Q"
  unfolding frame_def by transfer metis

lemma frame_existsR [frame_rule, log_prog_rule]: "(\<And>x. frame (P x) Q (R x)) \<Longrightarrow> frame (\<exists>\<^sub>u x. P x) Q (\<exists>\<^sub>u x. R x)"
  unfolding frame_def apply transfer' by blast

lemma frame_existsR' [frame_rule, log_prog_rule]: "(\<And>x. frame P  Q (R x)) \<Longrightarrow> frame P Q (\<exists>\<^sub>u x. R x)"
  unfolding frame_def apply transfer' by blast

lemma frame_exists2 [frame_rule,log_prog_rule]: "frame (P x) Q R \<Longrightarrow> frame (\<exists>\<^sub>u x. P x) Q R"
unfolding frame_def apply transfer' by blast

lemma frame_exists [frame_rule,log_prog_rule]: "(\<And>x. frame (P x) (Q x) R) \<Longrightarrow> frame (\<exists>\<^sub>u x. P x) (\<exists>\<^sub>u x. Q x) R"
  unfolding frame_def by transfer' blast

lemma frame_exists': "frame (P x) (\<exists>\<^sub>u x. Q x) R \<Longrightarrow> frame (\<exists>\<^sub>u x. P x) (\<exists>\<^sub>u x. Q x) R"
unfolding frame_def apply transfer' by blast

lemma frame_later [frame_rule,log_prog_rule]: "frame P Q R \<Longrightarrow> frame (\<triangleright>P) (\<triangleright>Q) R"
  unfolding frame_def by (rule upred_later_mono_extL) assumption

method frame_solver = (rule frame_rule)+

subsubsection \<open> Persistent predicates \<close>
definition persistent :: "('a::ucamera) upred_f \<Rightarrow> bool" where "persistent P \<equiv> P \<turnstile> \<box>P"
lemma persistentI: "persistent P \<Longrightarrow> P \<turnstile> \<box>P"
  unfolding persistent_def .

lemma persistent_holds_sep:
  "\<lbrakk>persistent P; persistent Q\<rbrakk> \<Longrightarrow> upred_holds (P\<^emph>Q) \<longleftrightarrow> upred_holds P \<and> upred_holds Q"
  unfolding persistent_def upred_holds.rep_eq upred_entails.rep_eq upred_persis.rep_eq upred_sep.rep_eq
  by (smt (verit, ccfv_threshold) camera_comm camera_core_id le_cases3 n_incl_def ofe_refl upred_def_def upred_def_rep)

lemma persistent_holds_sep':
  "\<lbrakk>persistent P; persistent Q\<rbrakk> \<Longrightarrow> (P\<^emph>Q) \<stileturn>\<turnstile> P \<and>\<^sub>u Q"
  by (rule upred_entail_eqI) (metis (no_types, lifting) camera_core_id ofe_refl persistent_def
    upred_conj.rep_eq upred_entailsE upred_entails_conj_sep upred_persis.rep_eq upred_sep.rep_eq)

named_theorems pers_rule
method pers_solver = (rule pers_rule)+

lemma persistent_persis [pers_rule,log_prog_rule]: "persistent (\<box>P)"
  by (auto simp: persistent_def upred_persis.rep_eq upred_entails.rep_eq camera_core_idem)

lemma persistent_pure [pers_rule,log_prog_rule]: "persistent (\<upharpoonleft>P)"
  by (auto simp: persistent_def upred_persis.rep_eq upred_entails.rep_eq upred_pure.rep_eq)

lemma persistent_valid [pers_rule,log_prog_rule]: "persistent (\<V>(a))"
  by (auto simp: persistent_def upred_persis.rep_eq upred_entails.rep_eq upred_valid.rep_eq)

lemma persistent_core_own [pers_rule,log_prog_rule]: "persistent (Own(a::'a::{core_id,ucamera}))"
  by (auto simp: persistent_def upred_persis.rep_eq upred_entails.rep_eq upred_own.rep_eq core_id)

lemma persistent_core_upred_own2 [pers_rule,log_prog_rule]: "pcore_id_pred (a::'a::ucamera) \<Longrightarrow> persistent (Own a)"
  unfolding persistent_def upred_persis.rep_eq upred_entails.rep_eq upred_own.rep_eq core_id_pred
  using camera_core_mono_n by fastforce

context fixes get_cmra :: "gname \<Rightarrow> 'a::ucamera \<Rightarrow> 'b::total_camera option"
  and put_cmra :: "gname \<Rightarrow> 'b \<Rightarrow> 'a"
  assumes inG: "inG get_cmra put_cmra"
begin
lemma persistent_core_own2 [pers_rule,log_prog_rule]:
  "pcore_id_pred a \<Longrightarrow> persistent (own put_cmra \<gamma> a)"
  unfolding inG.own_def[OF inG]
  using pcore_id_put[OF inG] persistent_core_upred_own2 by auto
end

lemma persistent_eq [pers_rule,log_prog_rule]: "persistent (a=\<^sub>ub)"
  unfolding persistent_def by transfer simp

lemma persistent_later [pers_rule,log_prog_rule]: "persistent P \<Longrightarrow> persistent (\<triangleright> P)"
  unfolding persistent_def
  by (rule upred_entails_trans[OF upred_later_mono[of P "\<box>P"] upred_entail_eqR[OF upred_persis_later]])

lemma persistent_conj [pers_rule,log_prog_rule]: "\<lbrakk>persistent P; persistent Q\<rbrakk> \<Longrightarrow> persistent (P \<and>\<^sub>u Q)"
  by (auto simp: persistent_def upred_conj.rep_eq upred_entails.rep_eq upred_persis.rep_eq)

lemma persistent_disj [pers_rule,log_prog_rule]: "\<lbrakk>persistent P; persistent Q\<rbrakk> \<Longrightarrow> persistent (P \<or>\<^sub>u Q)"
  by (auto simp: persistent_def upred_disj.rep_eq upred_entails.rep_eq upred_persis.rep_eq)

lemma persistent_exists [pers_rule,log_prog_rule]: "(\<And>x. persistent (P x)) \<Longrightarrow> persistent (\<exists>\<^sub>u x. P x)"
  by (auto simp: upred_exists.rep_eq persistent_def upred_persis.rep_eq upred_entails.rep_eq)

lemma persistent_forall [pers_rule,log_prog_rule]: "(\<And>x. persistent (P x)) \<Longrightarrow> persistent (\<forall>\<^sub>u x. P x)"
  by (auto simp: upred_forall.rep_eq persistent_def upred_persis.rep_eq upred_entails.rep_eq)

lemma persistent_sep [pers_rule,log_prog_rule]: "\<lbrakk>persistent P; persistent Q\<rbrakk> \<Longrightarrow> persistent (P \<^emph> Q)"
by (simp add: persistent_def upred_sep.rep_eq upred_entails.rep_eq upred_persis.rep_eq)
  (metis camera_comm camera_core_id camera_valid_op dual_order.refl n_incl_def ofe_refl
    upred_def_def upred_def_rep)

lemma persistent_except_zero [pers_rule,log_prog_rule]: "persistent P \<Longrightarrow> persistent (\<diamondop>P)"
  unfolding except_zero_def
  apply (pers_solver, assumption)
  by pers_solver

lemma persistent_dupl: "persistent P \<Longrightarrow> P\<^emph>P \<stileturn>\<turnstile> P"
  unfolding persistent_def upred_entail_eq_def
  by transfer (metis camera_core_id n_incl_def ofe_refl order_refl)

lemma persistent_dupl': "persistent P \<Longrightarrow> can_be_split P P P"
  unfolding can_be_split_def using persistent_dupl upred_entail_eq_symm by blast
lemmas persistent_dupl_frame = can_be_split_frame[OF persistent_dupl']

lemma persistent_dupl_split: "persistent P \<Longrightarrow> can_be_split (Q\<^emph>P) (Q\<^emph>P) P"
  unfolding can_be_split_def using persistent_dupl upred_entail_eq_def upred_entails_substE
  upred_sep_assoc upred_weakeningL by blast
lemmas persistent_dupl_frame2 = can_be_split_frame[OF persistent_dupl_split]

lemma persistent_dupl_split': "\<lbrakk>persistent P; can_be_split Q R S\<rbrakk> \<Longrightarrow> can_be_split (Q\<^emph>P) (R\<^emph>P) (S\<^emph>P)"
  unfolding can_be_split_def using can_be_split_def can_be_split_mono persistent_dupl' by blast

lemma persistent_dupl_frame3: "\<lbrakk>persistent P; frame Q R S\<rbrakk> \<Longrightarrow> frame (Q\<^emph>P) (R\<^emph>P) (S\<^emph>P)"
  unfolding frame_def using frameE frameI frame_mono persistent_dupl_frame by blast

lemma "persistent P \<Longrightarrow> ofe_eq P (P \<^emph> P)"
  unfolding persistent_def apply transfer
  by (metis camera_core_id n_incl_def ofe_refl order_refl)

lemma persistent_split: "\<lbrakk>persistent Q; Q\<^emph>R1\<turnstile>R2; P\<^emph>Q\<turnstile>T\<rbrakk> \<Longrightarrow> P\<^emph>Q\<^emph>R1\<turnstile>T\<^emph>R2"
proof -
  assume assms: "persistent Q" "Q\<^emph>R1 \<turnstile> R2" "P\<^emph>Q\<turnstile>T"
  from upred_sep_mono[OF this(3,2)] have "P\<^emph>Q\<^emph>Q\<^emph>R1 \<turnstile> T\<^emph>R2"
    using upred_entails_trans upred_sep_assoc_rev by blast
  moreover from persistent_dupl[OF assms(1)] have "P\<^emph>Q\<^emph>R1 \<turnstile> P\<^emph>Q\<^emph>Q\<^emph>R1"
    using upred_entail_eqR upred_entails_substE upred_frame upred_sep_assoc by blast
  ultimately show ?thesis using upred_entails_trans by blast
qed

lemma persistent_trans: "\<lbrakk>persistent P; Q\<^emph>P\<turnstile>R \<Longrightarrow> R\<turnstile>T \<Longrightarrow> Q\<^emph>P\<turnstile>T\<rbrakk> \<Longrightarrow> (Q\<^emph>P\<turnstile>R \<Longrightarrow> R\<^emph>P\<turnstile>T \<Longrightarrow> Q\<^emph>P\<turnstile>T)"
  by (metis persistent_dupl upred_entail_eqR upred_entails_substE upred_sep_assoc_eq upred_sep_comm)

lemma persistent_keep: "\<lbrakk>persistent Q; P\<turnstile>Q\<rbrakk> \<Longrightarrow> P\<turnstile>P\<^emph>Q"
  unfolding persistent_def by transfer (metis camera_comm camera_core_id ofe_refl)

lemma persistent_persisI: "\<lbrakk>persistent P; P\<turnstile>Q\<rbrakk> \<Longrightarrow> P \<turnstile>\<box>Q"
  using persistent_def upred_entails_trans upred_persis_mono by blast

lemma upred_persis_frame: "\<lbrakk>persistent P; P\<^emph>Q\<turnstile>R\<rbrakk> \<Longrightarrow> P\<^emph>\<box>Q\<turnstile>\<box>R"
  by (meson persistent_persis persistent_persisI persistent_sep upred_entails_substE upred_persisE)

lemma persistent_sep_conj: "\<lbrakk>persistent P; persistent Q\<rbrakk> \<Longrightarrow> P \<and>\<^sub>u Q \<turnstile> P \<^emph> Q"
  unfolding persistent_def by transfer (metis camera_core_id ofe_refl)

lemma persistent_loebI: "\<lbrakk>persistent P; P\<^emph>(\<box>\<triangleright>Q)\<turnstile>Q\<rbrakk> \<Longrightarrow> P\<turnstile>Q"
  apply (rule upred_entails_trans[OF _ loeb_persis])
  apply (rule upred_entails_trans[OF persistentI])
  by (auto intro!: upred_persis_mono upred_entails_trans[OF upred_entails_refl upred_implI]
    upred_entails_trans[OF persistent_sep_conj], pers_solver)

lemma loebI: "\<box>\<triangleright>Q\<turnstile>Q \<Longrightarrow> upred_holds Q"
  apply (subst upred_holds_entails)
  apply (rule persistent_loebI, pers_solver)
  apply (subst upred_sep_comm)
  by (auto simp: upred_true_sep)

subsubsection \<open>Except zero predicates\<close>
definition is_except_zero :: "'a::ucamera upred_f \<Rightarrow> bool" where "is_except_zero P \<equiv> \<diamondop>P \<turnstile> P"
named_theorems iez_rule
method iez_solver = (rule iez_rule)+

lemma is_except_zero_except_zero [iez_rule,log_prog_rule]: "is_except_zero (\<diamondop>P)"
  unfolding is_except_zero_def by (rule except_zero_idem)

lemma is_except_zero_later [iez_rule,log_prog_rule]: "is_except_zero (\<triangleright>P)"
  unfolding is_except_zero_def except_zero_def by transfer blast

subsubsection \<open>Timeless predicates\<close>
definition timeless :: "'a::ucamera upred_f \<Rightarrow> bool" where "timeless P \<equiv> (\<triangleright>P) \<turnstile> \<diamondop>P"

named_theorems timeless_rule
method timeless_solver = (rule timeless_rule)+

lemma own_timeless': "dcamera_val x \<Longrightarrow> timeless (Own x)"
  apply (auto simp: timeless_def dcamera_val_def discrete_val_def except_zero_def; transfer)
  apply (auto simp: n_incl_def)
  apply (metis (mono_tags, lifting) Rep_sprop bot_nat_0.extremum camera_valid_op diff_le_self mem_Collect_eq n_valid_ne)
  by (metis camera_extend diff_le_self ne_sprop_weaken ofe_eq_limit ofe_sym valid_raw_non_expansive)

lemma own_timeless [timeless_rule,log_prog_rule]: "timeless (Own (x::'a::ducamera))"
  by (auto simp: upred_own.rep_eq upred_entails.rep_eq upred_later.rep_eq except_zero_def
    upred_disj.rep_eq upred_pure.rep_eq n_incl_def d_equiv timeless_def)

lemma timeless_pure [timeless_rule,log_prog_rule]: "timeless (\<upharpoonleft>(b))"
  unfolding timeless_def except_zero_def by transfer simp

lemma timeless_conj [timeless_rule,log_prog_rule]: "\<lbrakk>timeless P; timeless Q\<rbrakk> \<Longrightarrow> timeless (P\<and>\<^sub>uQ)"
  unfolding timeless_def except_zero_def by transfer blast

lemma timeless_disj [timeless_rule]: "\<lbrakk>timeless P; timeless Q\<rbrakk> \<Longrightarrow> timeless (P\<or>\<^sub>uQ)"
  unfolding timeless_def except_zero_def by transfer blast

lemma timeless_impl [timeless_rule,log_prog_rule]: "timeless Q \<Longrightarrow> timeless (P\<longrightarrow>\<^sub>uQ)"
  unfolding timeless_def except_zero_def apply transfer
  by (metis (mono_tags, lifting) Rep_sprop diff_le_mono diff_le_self diff_self_eq_0 mem_Collect_eq n_incl_refl)

lemma timeless_sep [timeless_rule,log_prog_rule]: "\<lbrakk>timeless P; timeless Q\<rbrakk> \<Longrightarrow> timeless (P\<^emph>Q)"
  unfolding timeless_def
  apply (rule upred_entails_trans[OF upred_entail_eqL[OF upred_later_sep]])
  apply (rule upred_entails_trans[OF _ upred_entail_eqR[OF except_zero_sep]])
  by (auto intro: upred_sep_mono)

lemma timeless_wand [timeless_rule,log_prog_rule]: "timeless Q \<Longrightarrow> timeless (P-\<^emph>Q)"
  unfolding timeless_def except_zero_def apply transfer
  by (smt (verit, ccfv_threshold) Rep_sprop diff_diff_cancel diff_is_0_eq diff_right_commute
    mem_Collect_eq n_incl_refl nat_le_linear)

lemma timeless_forall [timeless_rule,log_prog_rule]: "(\<And>x. timeless (P x)) \<Longrightarrow> timeless (\<forall>\<^sub>u x. P x)"
  unfolding timeless_def except_zero_def by transfer' blast

lemma timeless_exists [timeless_rule,log_prog_rule]: "(\<And>x. timeless (P x)) \<Longrightarrow> timeless (\<exists>\<^sub>u x. P x)"
  unfolding timeless_def except_zero_def by transfer' blast

lemma timeless_persis [timeless_rule,log_prog_rule]: "timeless P \<Longrightarrow> timeless (\<box>P)"
  unfolding timeless_def except_zero_def apply transfer using camera_core_n_valid by blast

subsubsection \<open>Modality elimination\<close>
definition elim_modal :: "'a::ucamera upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool"
  where "elim_modal P P' Q Q' \<equiv> P \<^emph> (P'-\<^emph>Q') \<turnstile> Q"

lemma elim_modal_timeless: "\<lbrakk>P \<turnstile> \<diamondop>P'; is_except_zero Q\<rbrakk> \<Longrightarrow> elim_modal P P' Q Q"
  unfolding is_except_zero_def elim_modal_def
  by (metis except_zero_mono_ext upred_entails_refl upred_entails_trans upred_frame upred_sep_comm upred_wandE)

lemma elim_modal_timeless': "\<lbrakk>timeless P; is_except_zero Q\<rbrakk> \<Longrightarrow> elim_modal (\<triangleright>P) P Q Q"
  by (unfold timeless_def;rule elim_modal_timeless;assumption+)

lemma elim_later_timelessL: "timeless P \<Longrightarrow> elim_modal (\<triangleright>P) P (\<triangleright>Q) (\<triangleright>Q)"
  by (rule elim_modal_timeless', assumption, iez_solver)

lemma elim_modal_entails: "\<lbrakk>elim_modal P P' Q Q'; P' \<turnstile> Q'\<rbrakk> \<Longrightarrow> P \<turnstile> Q"
proof -
  assume assms: "elim_modal P P' Q Q'" "P' \<turnstile> Q'"
  from upred_wand_holdsI[OF assms(2)] have "P' -\<^emph> Q'" .
  show ?thesis apply (rule add_holds[OF \<open>P'-\<^emph>Q'\<close>])
  by (rule assms(1)[unfolded elim_modal_def])
qed

lemma elim_modal_entails': "\<lbrakk>elim_modal P P' Q Q'; R \<^emph> P' \<turnstile> Q'\<rbrakk> \<Longrightarrow> R \<^emph> P \<turnstile> Q"
  by (metis elim_modal_def upred_entails_substE upred_sep_comm upred_wandI)

subsubsection \<open>Plain predicates\<close>
definition plain :: "'a::ucamera upred_f \<Rightarrow> bool" where "plain P \<equiv> P\<turnstile>\<^item>P"

named_theorems plain_rule
method plain_solver = (rule plain_rule)+

lemma plain_persistent [log_prog_rule]: "plain P \<Longrightarrow> persistent P"
  unfolding plain_def persistent_def apply transfer using n_incl_\<epsilon> by blast

lemma bupd_plain_sound: "\<lbrakk>plain P; \<Rrightarrow>\<^sub>b P\<rbrakk> \<Longrightarrow> P"
  unfolding plain_def by transfer (metis \<epsilon>_right_id n_incl_\<epsilon> verit_comp_simplify1(2))

lemma bupd_plain: "plain P \<Longrightarrow> \<Rrightarrow>\<^sub>b P \<turnstile> P"
  unfolding plain_def by transfer (metis \<epsilon>_right_id n_incl_\<epsilon> order_refl)

lemma plain_pure [plain_rule,log_prog_rule]: "plain (\<upharpoonleft>P)" unfolding plain_def by transfer blast
lemma plain_conj [plain_rule,log_prog_rule]: "\<lbrakk>plain P; plain Q\<rbrakk> \<Longrightarrow> plain (P\<and>\<^sub>uQ)" unfolding plain_def by transfer fast
lemma plain_disj [plain_rule,log_prog_rule]: "\<lbrakk>plain P; plain Q\<rbrakk> \<Longrightarrow> plain (P\<or>\<^sub>uQ)" unfolding plain_def by transfer fast
lemma plain_forall [plain_rule,log_prog_rule]: "(\<And>x. plain (P x)) \<Longrightarrow> plain (\<forall>\<^sub>u x. P x)"
  unfolding plain_def by transfer blast
lemma plain_exists [plain_rule,log_prog_rule]: "(\<And>x. plain (P x)) \<Longrightarrow> plain (\<exists>\<^sub>u x. P x)"
  unfolding plain_def by transfer blast
lemma plain_impl [plain_rule,log_prog_rule]: "\<lbrakk>plain P; plain Q\<rbrakk> \<Longrightarrow> plain (P\<longrightarrow>\<^sub>uQ)"
  unfolding plain_def apply transfer
  by (smt (verit, ccfv_threshold) Rep_sprop \<epsilon>_right_id incl_def mem_Collect_eq n_incl_\<epsilon> order_refl)
lemma plain_wand [plain_rule,log_prog_rule]: "\<lbrakk>plain P; plain Q\<rbrakk> \<Longrightarrow> plain (P-\<^emph>Q)"
  unfolding plain_def apply transfer
  by (metis (mono_tags, lifting) Rep_sprop \<epsilon>_left_id \<epsilon>_right_id mem_Collect_eq n_incl_op_extend order_refl)
lemma plain_sep [plain_rule,log_prog_rule]: "\<lbrakk>plain P; plain Q\<rbrakk> \<Longrightarrow> plain (P\<^emph>Q)"
  unfolding plain_def apply transfer
  by (metis \<epsilon>_left_id camera_comm n_incl_def ofe_refl order_refl)
lemma plain_plainly [plain_rule,log_prog_rule]: "plain (\<^item>P)" unfolding plain_def by transfer fast
lemma plain_eq [plain_rule,log_prog_rule]: "plain (a=\<^sub>ub)" unfolding plain_def by transfer blast
lemma plain_later [plain_rule,log_prog_rule]: "plain P \<Longrightarrow> plain (\<triangleright>P)"
  unfolding plain_def apply transfer using Rep_sprop diff_le_self by blast
lemma plain_except_zero [plain_rule,log_prog_rule]: "plain P \<Longrightarrow> plain (\<diamondop>P)" unfolding except_zero_def
  by (plain_solver, assumption)+  plain_solver

method pers_solver' = (pers_solver; rule plain_persistent; plain_solver)

lemma persistent_impl: "\<lbrakk>plain P; persistent Q\<rbrakk> \<Longrightarrow> persistent (P -\<^emph> Q)"
  unfolding plain_def persistent_def apply transfer
  by (metis (no_types, lifting) \<epsilon>_right_id camera_comm n_incl_op_extend ne_sprop_weaken ofe_eq_limit
    order_eq_refl valid_raw_non_expansive)
end


theory Semantics_Stateful
imports Semantics
begin

section\<open>Semantics Stateful\<close>

subsection\<open>Model 1 -- Curried Stateful Matcher\<close>

text\<open>Processing a packet with state can be modeled as follows:
  The state is @{term \<sigma>}.
  The primitive matcher @{term \<gamma>\<^sub>\<sigma>} is a curried function where the first argument is the state and
  it returns a stateless primitive matcher, i.e. @{term "\<gamma> = (\<gamma>\<^sub>\<sigma> \<sigma>)"}.
  With this stateless primitive matcher @{term \<gamma>}, the @{const iptables_bigstep} semantics are executed.
  As entry point, the iptables built-in chains @{term "''INPUT''"}, @{term "''OUTPUT''"}, and @{term "''FORWARD''"} with their
  default-policy (@{const Accept} or @{const Drop} are valid for iptables) are chosen.
  The semantics must yield a @{term "Decision X"}.
  Due to the default-policy, this is always the case if the ruleset is well-formed.
  When a decision is made, the state @{term \<sigma>} is updated.\<close>

inductive semantics_stateful ::
  "'a ruleset \<Rightarrow>
   ('\<sigma> \<Rightarrow> ('a, 'p) matcher) \<Rightarrow> (*matcher, first parameter is the state*)
   ('\<sigma> \<Rightarrow> final_decision \<Rightarrow> 'p \<Rightarrow> '\<sigma>) \<Rightarrow> (*state update function after firewall has decision for a packet*)
   '\<sigma> \<Rightarrow> (*Starting state. constant*)
   (string \<times> action) \<Rightarrow> (*The chain and default policy the firewall evaluates. For example ''FORWARD'', Drop*)
   'p list \<Rightarrow> (*packets to be processed*)
   ('p \<times> final_decision) list \<Rightarrow> (*packets which have been processed and their decision. ordered the same as the firewall processed them. oldest packet first*)
   '\<sigma> \<Rightarrow> (*final state*)
   bool" for \<Gamma> and \<gamma>\<^sub>\<sigma> and state_update and \<sigma>\<^sub>0 where
  --\<open>A list of packets @{term ps} waiting to be processed. Nothing has happened, start and final state are the same, the list of processed packets is empty.\<close>
  "semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps [] \<sigma>\<^sub>0" |

  --\<open>Processing one packet\<close>
  "semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed \<sigma>' \<Longrightarrow>
   \<Gamma>,(\<gamma>\<^sub>\<sigma> \<sigma>'),p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
    semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update \<sigma>' X p)"

lemma semantics_stateful_intro_process_one: "semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed_old \<sigma>_old \<Longrightarrow>
       \<Gamma>,\<gamma>\<^sub>\<sigma> \<sigma>_old,p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
       \<sigma>' = state_upate \<sigma>_old X p \<Longrightarrow>
       ps_processed = ps_processed_old@[(p, X)] \<Longrightarrow>
       semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful.intros)

lemma semantics_stateful_intro_start: "\<sigma>\<^sub>0 = \<sigma>' \<Longrightarrow> ps_processed = [] \<Longrightarrow>
       semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful.intros)

text\<open>Example below\<close>

subsection\<open>Model 2 -- Packets Tagged with State Information\<close>

text\<open>In this model, the matcher is completely stateless but packets are previously tagged with
      (static) stateful information.\<close>

inductive semantics_stateful_packet_tagging ::
   "'a ruleset \<Rightarrow>
    ('a, 'ptagged) matcher \<Rightarrow>
    ('\<sigma> \<Rightarrow> 'p \<Rightarrow> 'ptagged) \<Rightarrow> (*taggs the packet accordig to the current state before processing by firewall*)
    ('\<sigma> \<Rightarrow> final_decision \<Rightarrow> 'p \<Rightarrow> '\<sigma>) \<Rightarrow> (*state updater*)
    '\<sigma> \<Rightarrow> (*Starting state. constant*)
    (string \<times> action) \<Rightarrow>
    'p list \<Rightarrow> (*packets to be processed*)
    ('p \<times> final_decision) list \<Rightarrow> (*packets which have been processed*)
    '\<sigma> \<Rightarrow> (*final state*)
    bool" for \<Gamma> and \<gamma> and packet_tagger and state_update and \<sigma>\<^sub>0 where
  "semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps [] \<sigma>\<^sub>0" |

  "semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed \<sigma>' \<Longrightarrow>
   \<Gamma>,\<gamma>,(packet_tagger \<sigma>' p)\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
    semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update \<sigma>' X p)"

lemma semantics_stateful_packet_tagging_intro_start: "\<sigma>\<^sub>0 = \<sigma>' \<Longrightarrow> ps_processed = [] \<Longrightarrow>
       semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful_packet_tagging.intros)

lemma semantics_stateful_packet_tagging_intro_process_one:
      "semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed_old \<sigma>_old \<Longrightarrow>
       \<Gamma>,\<gamma>,(packet_tagger \<sigma>_old p)\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
       \<sigma>' = state_upate \<sigma>_old X p \<Longrightarrow>
       ps_processed = ps_processed_old@[(p, X)] \<Longrightarrow>
       semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful_packet_tagging.intros)

lemma semantics_bigstep_state_vs_tagged:
  assumes "\<forall>m::'m. stateful_matcher' \<sigma> m p = stateful_matcher_tagged' m (packet_tagger' \<sigma> p)"
  shows "\<Gamma>,stateful_matcher' \<sigma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> t \<longleftrightarrow>
         \<Gamma>,stateful_matcher_tagged',packet_tagger' \<sigma> p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> t"
proof -
  { fix m::"'m match_expr"
   from assms have
    "matches (stateful_matcher' \<sigma>) m p \<longleftrightarrow> matches stateful_matcher_tagged' m (packet_tagger' \<sigma> p)"
      by(induction m) (simp_all)
  } note matches_stateful_matcher_stateful_matcher_tagged=this

  show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
  proof
    assume ?lhs
    thus ?rhs
     proof(induction rs Undecided t rule: iptables_bigstep_induct)
     case (Seq _ _ _ t)
       thus ?case
         apply(cases t)
          apply (simp add: seq)
         apply(auto simp add: decision seq dest: decisionD)
         done
     qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
  next
    assume ?rhs
    thus ?lhs
     proof(induction rs Undecided t rule: iptables_bigstep_induct)
     case (Seq _ _ _ t)
       thus ?case
         apply(cases t)
          apply (simp add: seq)
         apply(auto  simp add: decision seq dest: decisionD)
         done
     qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
  qed
qed

text\<open>Both semantics are equal\<close>
theorem semantics_stateful_vs_tagged:
  assumes "\<forall>m \<sigma> p. stateful_matcher' \<sigma> m p = stateful_matcher_tagged' m (packet_tagger' \<sigma> p)"
  shows "semantics_stateful rs stateful_matcher' state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>' =
       semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>'"
  proof -
   from semantics_bigstep_state_vs_tagged[of stateful_matcher' _ _ stateful_matcher_tagged' packet_tagger'] assms
     have vs_tagged:
     "rs,stateful_matcher' \<sigma>',p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> t \<longleftrightarrow>
      rs,stateful_matcher_tagged',packet_tagger' \<sigma>' p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> t"
      for t p \<sigma>' built_in_chain default_policy by blast
   from assms have stateful_matcher_eq:
    "(\<lambda>a b. stateful_matcher_tagged' a (packet_tagger' \<sigma>' b)) = stateful_matcher' \<sigma>'" for \<sigma>' by presburger
  show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
    proof
      assume ?lhs thus ?rhs
        proof(induction rule: semantics_stateful.induct)
        case 1 thus ?case by(auto intro: semantics_stateful_packet_tagging_intro_start)[1]
        next
        case (2 built_in_chain default_policy p ps  ps_processed \<sigma>')
          from 2 have
            "semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' \<sigma>\<^sub>0 (built_in_chain, default_policy) (p # ps) ps_processed \<sigma>'"
            by blast
          with 2(2,3) show ?case
          apply -
          apply(rule semantics_stateful_packet_tagging_intro_process_one)
             apply(simp_all add: vs_tagged)
          done
       qed
    next
      assume ?rhs thus ?lhs
      proof(induction rule: semantics_stateful_packet_tagging.induct)
        case 1 thus ?case by(auto intro: semantics_stateful_intro_start)
        next
        case (2 built_in_chain default_policy p ps ps_processed \<sigma>') thus ?case
           apply -
           apply(rule semantics_stateful_intro_process_one)
              apply(simp_all add: stateful_matcher_eq vs_tagged)
           done
      qed
    qed
  qed

text\<open>Examples\<close>
context
begin
subsection\<open>Example: Conntrack with curried matcher\<close>
  text\<open>We illustrate stateful semantics with a simple example. We allow matching on the states New
  and Established. In addition, we introduce a primitive match to match on outgoing ssh packets (dst port = 22).
  The state is managed in a state table where accepted connections are remembered.\<close>

  text\<open>SomePacket with source and destination port or something we don't know about\<close>
  private datatype packet = SomePacket "nat \<times> nat" | OtherPacket

  private datatype primitive_matches = New | Established | IsSSH

  text\<open>In the state, we remember the packets which belong to an established connection.\<close>
  private datatype conntrack_state = State "packet set"

  text\<open>The stateful primitive matcher: It is given the current state table.
    If match on @{const Established}, the packet must be known in the state table.
    If match on @{const New}, the packet must not be in the state table.
    If match on @{const IsSSH}, the dst port of the packet must be 22.\<close>
  private fun stateful_matcher :: "conntrack_state \<Rightarrow> (primitive_matches, packet) matcher" where
    "stateful_matcher (State state_table) = (\<lambda>m p. m = Established \<and> p \<in> state_table \<or>
                                           m = New \<and> p \<notin> state_table \<or>
                                           m = IsSSH \<and> (\<exists>dst_port. p = SomePacket (22, dst_port)))"

  text\<open>Connections are always bi-directional.\<close>
  private fun reverse_direction :: "packet \<Rightarrow> packet" where
    "reverse_direction OtherPacket = OtherPacket" |
    "reverse_direction (SomePacket (src, dst)) = SomePacket (dst,src)"

  text\<open>If a packet is accepted, the state for its bi-directional connection is saved in the state table.\<close>
  private fun state_update' :: "conntrack_state \<Rightarrow> final_decision \<Rightarrow> packet \<Rightarrow> conntrack_state" where
    "state_update' (State state_table) FinalAllow p = State (state_table \<union> {p, reverse_direction p})" |
    "state_update' (State state_table) FinalDeny p = State state_table"

  text\<open>Allow everything that is established and allow new ssh connections.
    Drop everything else (default policy, see below)\<close>
  private definition "ruleset == [''INPUT'' \<mapsto> [Rule (Match Established) Accept, Rule (MatchAnd (Match IsSSH) (Match New)) Accept]]"

  text\<open>The @{const ruleset} does not allow @{const OtherPacket}\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop) []
    [(OtherPacket, FinalDeny)] (State {})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
       apply(rule semantics_stateful_intro_start)
        apply(simp_all)
     apply(rule seq_cons)
      apply(rule call_result)
        apply(simp_all)
      apply(rule seq_cons)
       apply(auto intro: iptables_bigstep.intros)
    done

  text\<open>The @{const ruleset} allows ssh packets, i.e. any packets with destination port 22 in the @{const New} rule.
        The state is updated such that everything which belongs to the connection will now be accepted.\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (22, 1024), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
       apply(rule semantics_stateful_intro_start)
        apply(simp_all)
     apply(rule seq_cons)
      apply(rule call_result)
        apply(simp_all)
      apply(rule seq_cons)
       apply(auto intro: iptables_bigstep.intros)
    done

  text\<open>If we continue with this state, answer packets are now allowed\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
      apply(rule semantics_stateful_intro_process_one)
         apply(simp_all)
        apply(rule semantics_stateful_intro_start)
         apply(simp_all)
      apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
        apply(auto intro: iptables_bigstep.intros)
    apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
      apply(auto intro: iptables_bigstep.intros)
    done

  text\<open>In contrast, without having previously established a state, answer packets are prohibited\<close>
  text\<open>If we continue with this state, answer packets are now allowed\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (1024, 22), FinalDeny), (SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
      apply(rule semantics_stateful_intro_process_one)
         apply(simp_all)
       apply(rule semantics_stateful_intro_process_one)
          apply(simp_all)
        apply(rule semantics_stateful_intro_start)
         apply(simp_all)
       apply(rule seq_cons, rule call_result, simp_all, rule seq_cons, auto intro: iptables_bigstep.intros)+
    done

subsection\<open>Example: Conntrack with packet tagging\<close>

  datatype packet_tag = TagNew | TagEstablished
  datatype packet_tagged = SomePacket_tagged "nat \<times> nat \<times> packet_tag" | OtherPacket_tagged packet_tag

  fun get_packet_tag :: "packet_tagged \<Rightarrow> packet_tag" where
    "get_packet_tag (SomePacket_tagged (_,_, tag)) = tag" |
    "get_packet_tag (OtherPacket_tagged tag) = tag"

  definition stateful_matcher_tagged :: "(primitive_matches, packet_tagged) matcher" where
    "stateful_matcher_tagged \<equiv> \<lambda>m p. m = Established \<and> (get_packet_tag p = TagEstablished) \<or>
                                           m = New \<and> (get_packet_tag p = TagNew) \<or>
                                           m = IsSSH \<and> (\<exists>dst_port tag. p = SomePacket_tagged (22, dst_port, tag))"

  fun calculate_packet_tag :: "conntrack_state \<Rightarrow> packet \<Rightarrow> packet_tag" where
    "calculate_packet_tag (State state_table) p = (if p \<in> state_table then TagEstablished else TagNew)"

  fun packet_tagger :: "conntrack_state \<Rightarrow> packet \<Rightarrow> packet_tagged" where
    "packet_tagger \<sigma> (SomePacket (s,d)) = (SomePacket_tagged (s,d, calculate_packet_tag \<sigma> (SomePacket (s,d))))" |
    "packet_tagger \<sigma> OtherPacket = (OtherPacket_tagged (calculate_packet_tag \<sigma> OtherPacket))"

  text\<open>If a packet is accepted, the state for its bi-directional connection is saved in the state table.\<close>
  fun state_update_tagged :: "conntrack_state \<Rightarrow> final_decision \<Rightarrow> packet \<Rightarrow> conntrack_state" where
    "state_update_tagged (State state_table) FinalAllow p = State (state_table \<union> {p, reverse_direction p})" |
    "state_update_tagged (State state_table) FinalDeny p = State state_table"

  text\<open>Both semantics are equal\<close>
  lemma "semantics_stateful rs stateful_matcher state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>' =
    semantics_stateful_packet_tagging rs stateful_matcher_tagged packet_tagger state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>'"
    apply(rule semantics_stateful_vs_tagged)
    apply(intro allI, rename_tac m \<sigma> p)
    apply(case_tac \<sigma>)
    apply(case_tac p)
     apply(simp_all add: stateful_matcher_tagged_def)
    apply force
    done
end

end