theory PF_Tables
imports
  PF_Primitives
  "HOL-Library.Simps_Case_Conv"
begin

definition decision :: "table_entry \<Rightarrow> bool" where
"decision te = (\<not>is_Negated te)"

instantiation address :: linorder
begin
fun less_eq_address :: "address \<Rightarrow> address \<Rightarrow> bool" where
"less_eq_address (IPv4 a) (IPv4 b) = (a \<le> b)"
|"less_eq_address (IPv4 a) (IPv6 b) = True"
|"less_eq_address (IPv6 a) (IPv4 b) = False"
|"less_eq_address (IPv6 a) (IPv6 b) = (a \<le> b)"

case_of_simps less_eq_address_cases: less_eq_address.simps

fun less_address :: "address \<Rightarrow> address \<Rightarrow> bool" where
"less_address (IPv4 a) (IPv4 b) = (a < b)"
|"less_address (IPv4 a) (IPv6 b) = True"
|"less_address (IPv6 a) (IPv4 b) = False"
|"less_address (IPv6 a) (IPv6 b) = (a < b)"

case_of_simps less_address_cases: less_address.simps
thm less_address_cases

instance by standard (auto simp add: less_eq_address_cases less_address_cases split: address.splits)
end

instantiation table_entry :: linorder
begin
(* depends on correct order of prefix_match *)
fun less_eq_table_entry :: "table_entry \<Rightarrow> table_entry \<Rightarrow> bool" where
"less_eq_table_entry (TableEntry a) (TableEntry b) = (a \<le> b)"
|"less_eq_table_entry (TableEntry a) (TableEntryNegated b) = True"
|"less_eq_table_entry (TableEntryNegated a) (TableEntry b) = False"
|"less_eq_table_entry (TableEntryNegated a) (TableEntryNegated b) = (a \<le> b)"

case_of_simps less_eq_table_entry_cases: less_eq_table_entry.simps

fun less_table_entry :: "table_entry \<Rightarrow> table_entry \<Rightarrow> bool" where
"less_table_entry (TableEntry a) (TableEntry b) = (a < b)"
|"less_table_entry (TableEntry a) (TableEntryNegated b) = True"
|"less_table_entry (TableEntryNegated a) (TableEntry b) = False"
|"less_table_entry (TableEntryNegated a) (TableEntryNegated b) = (a < b)"

case_of_simps less_table_entry_cases: less_table_entry.simps
thm less_table_entry_cases

instance by standard (auto simp add: less_eq_table_entry_cases less_table_entry_cases split: table_entry.splits)
end

(* IPv4 *)

definition match_table_v4_inner :: "table \<Rightarrow> 32 word \<Rightarrow> bool" where
"match_table_v4_inner table addr =
 (case (find (\<lambda> t . prefix_match_semantics (ip4 (ta t)) addr) table) of
 (Some t) \<Rightarrow> decision t |None \<Rightarrow> False)"

definition match_table_v4 :: "table \<Rightarrow> 32 word \<Rightarrow> bool" where
"match_table_v4 table addr = match_table_v4_inner (sort [t \<leftarrow> table. isIPv4 (ta t)]) addr"

abbreviation foldf_v4 :: "table_entry \<Rightarrow> 32 word set \<Rightarrow> 32 word set" where
"foldf_v4 t a \<equiv> (case t of (TableEntry te) \<Rightarrow> a \<union> prefix_to_wordset (ip4 te) | (TableEntryNegated te) \<Rightarrow> a - prefix_to_wordset  (ip4 te))"

definition table_to_set_v4 :: "table \<Rightarrow> 32 word set" where
"table_to_set_v4 table = foldr foldf_v4 table {}"

definition match_table_v4'_inner :: "table \<Rightarrow> 32 word \<Rightarrow> bool" where
"match_table_v4'_inner table address \<longleftrightarrow> address \<in> table_to_set_v4 table"

definition match_table_v4' :: "table \<Rightarrow> 32 word \<Rightarrow> bool" where
"match_table_v4' table address = match_table_v4'_inner (sort [t \<leftarrow> table. isIPv4 (ta t)]) address"

abbreviation foldf_wi_v4 :: "table_entry \<Rightarrow> 32 wordinterval \<Rightarrow> 32 wordinterval" where
"foldf_wi_v4 t a \<equiv> (case t of (TableEntry te) \<Rightarrow> wordinterval_union a (prefix_to_wordinterval (ip4 te))
 | (TableEntryNegated te) \<Rightarrow> wordinterval_setminus a (prefix_to_wordinterval (ip4 te)))"

definition table_to_wordinterval_v4_inner :: "table \<Rightarrow> 32 wordinterval" where
"table_to_wordinterval_v4_inner table = foldr foldf_wi_v4 table Empty_WordInterval"

definition table_to_wordinterval_v4 :: "table \<Rightarrow> 32 wordinterval" where
"table_to_wordinterval_v4 table = table_to_wordinterval_v4_inner (sort [t \<leftarrow> table. isIPv4 (ta t)])"

lemma table_to_wordinterval_v4: "wordinterval_to_set (table_to_wordinterval_v4_inner table) = table_to_set_v4 table"
  unfolding table_to_set_v4_def table_to_wordinterval_v4_inner_def
  by (induction table ) (auto split:table_entry.splits)

lemma match_table_v4': "match_table_v4' table addr = wordinterval_element addr (table_to_wordinterval_v4 table)"
  unfolding match_table_v4'_def table_to_wordinterval_v4_def match_table_v4'_inner_def using table_to_wordinterval_v4 by auto

lemma find_Some_decision_addr_in_set_v4:
  assumes "\<And>t. t \<in> set table \<Longrightarrow> isIPv4 (ta t)" "valid_table table"
  assumes "find (\<lambda>x. prefix_match_semantics (ip4 (ta x)) address) table = Some te"
  shows "decision te = (address \<in> table_to_set_v4 table)"
  using assms proof(induction table)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  have vp: "valid_prefix (ip4 (ta x))" using Cons(2) Cons(3) unfolding valid_table_def
        by (auto simp add: address.case_eq_if)
  show ?case
  proof(cases "prefix_match_semantics (ip4 (ta x)) address")
    case True
    then have *:"find (\<lambda>x. prefix_match_semantics (ip4 (ta x)) address) (x # xs) = Some x" by auto
    have **:"address \<in> prefix_to_wordset (ip4 (ta x))" using vp True prefix_match_semantics_wordset unfolding valid_table_def by auto
    then show ?thesis
    proof(cases x)
      case (TableEntry x1)
      then show ?thesis unfolding table_to_set_v4_def decision_def using Cons * ** by auto
    next
      case (TableEntryNegated x2)
      then show ?thesis unfolding table_to_set_v4_def decision_def using Cons * ** by auto
    qed
  next
    case False
    then have *: "find (\<lambda>x. prefix_match_semantics (ip4 (ta x)) address) xs = Some te" using Cons by auto
    have vt: "valid_table xs" using Cons(3) by (simp add:valid_table_def)
      then show ?thesis
      proof(cases x)
        case (TableEntry x1)
        then have "decision te = (address \<in> table_to_set_v4 xs)" using * vt Cons by auto
        then show ?thesis unfolding table_to_set_v4_def using False vp prefix_match_semantics_wordset TableEntry by auto
      next
        case (TableEntryNegated x2)
        then have "decision te = (address \<in> table_to_set_v4 xs)" using * vt Cons by auto
        then show ?thesis unfolding table_to_set_v4_def using False vp prefix_match_semantics_wordset TableEntryNegated by auto
      qed
  qed
qed

lemma find_None_addr_not_in_set_v4:
  assumes "\<And>t. t \<in> set table \<Longrightarrow> isIPv4 (ta t)" "valid_table table"
  assumes "find (\<lambda>x. prefix_match_semantics (ip4 (ta x)) address) table = None"
  shows "address \<notin> table_to_set_v4 table"
  using assms
proof(induction table)
  case Nil
  then show ?case unfolding table_to_set_v4_def by simp
next
  case (Cons a table)
  then have *:"\<not>prefix_match_semantics (ip4 (ta a)) address" by auto
  moreover have "prefix_match_semantics (ip4 (ta a)) address = (address \<in> prefix_to_wordset (ip4 (ta a)))"
    using prefix_match_semantics_wordset Cons unfolding valid_table_def by (auto simp add: address.case_eq_if)
  ultimately show ?case using Cons unfolding valid_table_def
    by (simp add: table_entry.case_eq_if table_to_set_v4_def)
qed

lemma match_table_v4_inner:
  assumes "valid_table table" "\<And>t. t \<in> set table \<Longrightarrow> isIPv4 (ta t)"
  shows "match_table_v4_inner table address = match_table_v4'_inner table address"
  using assms
proof(cases "find (\<lambda>t. prefix_match_semantics (ip4 (ta t)) address) table")
  case None
  then show ?thesis unfolding match_table_v4_inner_def match_table_v4'_inner_def using find_None_addr_not_in_set_v4 assms by simp
next
  case (Some a)
  then show ?thesis unfolding match_table_v4_inner_def match_table_v4'_inner_def using find_Some_decision_addr_in_set_v4 assms by simp
qed

lemma match_table_v4:
  assumes "valid_table table"
  shows "match_table_v4 table address = match_table_v4' table address"
  using assms
proof(-)
  have "\<And>t. t \<in> set (sort [t\<leftarrow>table . isIPv4 (ta t)]) \<Longrightarrow> isIPv4 (ta t)" by auto
  moreover have "valid_table (sort [t\<leftarrow>table . isIPv4 (ta t)])" using assms by (simp add: valid_table_def)
  ultimately show ?thesis unfolding match_table_v4_def match_table_v4'_def using match_table_v4_inner
    by blast
qed

lemma match_table_v4_wordinterval:
  assumes "valid_table table"
  shows "match_table_v4 table address = wordinterval_element address (table_to_wordinterval_v4 table)"
  using assms match_table_v4 match_table_v4' by simp

(* IPv6 *) (* largely copied from above *)

definition match_table_v6_inner :: "table \<Rightarrow> 128 word \<Rightarrow> bool" where
"match_table_v6_inner table addr =
 (case (find (\<lambda> t . prefix_match_semantics (ip6 (ta t)) addr) table) of
 (Some t) \<Rightarrow> decision t |None \<Rightarrow> False)"

definition match_table_v6 :: "table \<Rightarrow> 128 word \<Rightarrow> bool" where
"match_table_v6 table addr = match_table_v6_inner (sort [t \<leftarrow> table. isIPv6 (ta t)]) addr"

abbreviation foldf_v6 :: "table_entry \<Rightarrow> 128 word set \<Rightarrow> 128 word set" where
"foldf_v6 t a \<equiv> (case t of (TableEntry te) \<Rightarrow> a \<union> prefix_to_wordset (ip6 te) | (TableEntryNegated te) \<Rightarrow> a - prefix_to_wordset  (ip6 te))"

definition table_to_set_v6 :: "table \<Rightarrow> 128 word set" where
"table_to_set_v6 table = foldr foldf_v6 table {}"

definition match_table_v6'_inner :: "table \<Rightarrow> 128 word \<Rightarrow> bool" where
"match_table_v6'_inner table address \<longleftrightarrow> address \<in> table_to_set_v6 table"

definition match_table_v6' :: "table \<Rightarrow> 128 word \<Rightarrow> bool" where
"match_table_v6' table address = match_table_v6'_inner (sort [t \<leftarrow> table. isIPv6 (ta t)]) address"

abbreviation foldf_wi_v6 :: "table_entry \<Rightarrow> 128 wordinterval \<Rightarrow> 128 wordinterval" where
"foldf_wi_v6 t a \<equiv> (case t of (TableEntry te) \<Rightarrow> wordinterval_union a (prefix_to_wordinterval (ip6 te))
 | (TableEntryNegated te) \<Rightarrow> wordinterval_setminus a (prefix_to_wordinterval (ip6 te)))"

definition table_to_wordinterval_v6_inner :: "table \<Rightarrow> 128 wordinterval" where
"table_to_wordinterval_v6_inner table = foldr foldf_wi_v6 table Empty_WordInterval"

definition table_to_wordinterval_v6 :: "table \<Rightarrow> 128 wordinterval" where
"table_to_wordinterval_v6 table = table_to_wordinterval_v6_inner (sort [t \<leftarrow> table. isIPv6 (ta t)])"

lemma table_to_wordinterval_v6: "wordinterval_to_set (table_to_wordinterval_v6_inner table) = table_to_set_v6 table"
  unfolding table_to_set_v6_def table_to_wordinterval_v6_inner_def
  by (induction table ) (auto split:table_entry.splits)

lemma match_table_v6': "match_table_v6' table addr = wordinterval_element addr (table_to_wordinterval_v6 table)"
  unfolding match_table_v6'_def table_to_wordinterval_v6_def match_table_v6'_inner_def using table_to_wordinterval_v6 by auto

lemma find_Some_decision_addr_in_set_v6:
  assumes "\<And>t. t \<in> set table \<Longrightarrow> isIPv6 (ta t)" "valid_table table"
  assumes "find (\<lambda>x. prefix_match_semantics (ip6 (ta x)) address) table = Some te"
  shows "decision te = (address \<in> table_to_set_v6 table)"
  using assms proof(induction table)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  have vp: "valid_prefix (ip6 (ta x))" using Cons(2) Cons(3) unfolding valid_table_def
    by (metis address.collapse(2) address.simps(6) list.set_intros(1))
  show ?case
  proof(cases "prefix_match_semantics (ip6 (ta x)) address")
    case True
    then have *:"find (\<lambda>x. prefix_match_semantics (ip6 (ta x)) address) (x # xs) = Some x" by auto
    have **:"address \<in> prefix_to_wordset (ip6 (ta x))" using vp True prefix_match_semantics_wordset unfolding valid_table_def by auto
    then show ?thesis
    proof(cases x)
      case (TableEntry x1)
      then show ?thesis unfolding table_to_set_v6_def decision_def using Cons * ** by auto
    next
      case (TableEntryNegated x2)
      then show ?thesis unfolding table_to_set_v6_def decision_def using Cons * ** by auto
    qed
  next
    case False
    then have *: "find (\<lambda>x. prefix_match_semantics (ip6 (ta x)) address) xs = Some te" using Cons by auto
    have vt: "valid_table xs" using Cons(3) by (simp add:valid_table_def)
      then show ?thesis
      proof(cases x)
        case (TableEntry x1)
        then have "decision te = (address \<in> table_to_set_v6 xs)" using * vt Cons by auto
        then show ?thesis unfolding table_to_set_v6_def using False vp prefix_match_semantics_wordset TableEntry by auto
      next
        case (TableEntryNegated x2)
        then have "decision te = (address \<in> table_to_set_v6 xs)" using * vt Cons by auto
        then show ?thesis unfolding table_to_set_v6_def using False vp prefix_match_semantics_wordset TableEntryNegated by auto
      qed
  qed
qed

lemma find_None_addr_not_in_set_v6:
  assumes "\<And>t. t \<in> set table \<Longrightarrow> isIPv6 (ta t)" "valid_table table"
  assumes "find (\<lambda>x. prefix_match_semantics (ip6 (ta x)) address) table = None"
  shows "address \<notin> table_to_set_v6 table"
  using assms
proof(induction table)
  case Nil
  then show ?case unfolding table_to_set_v6_def by simp
next
  case (Cons a table)
  then have *:"\<not>prefix_match_semantics (ip6 (ta a)) address" by auto
  moreover have "prefix_match_semantics (ip6 (ta a)) address = (address \<in> prefix_to_wordset (ip6 (ta a)))"
    using prefix_match_semantics_wordset Cons unfolding valid_table_def
    by (metis address.case_eq_if address.distinct_disc(1) list.set_intros(1))
  ultimately show ?case using Cons unfolding valid_table_def
    by (simp add: table_entry.case_eq_if table_to_set_v6_def)
qed

lemma match_table_v6_inner:
  assumes "valid_table table" "\<And>t. t \<in> set table \<Longrightarrow> isIPv6 (ta t)"
  shows "match_table_v6_inner table address = match_table_v6'_inner table address"
  using assms
proof(cases "find (\<lambda>t. prefix_match_semantics (ip6 (ta t)) address) table")
  case None
  then show ?thesis unfolding match_table_v6_inner_def match_table_v6'_inner_def using find_None_addr_not_in_set_v6 assms by simp
next
  case (Some a)
  then show ?thesis unfolding match_table_v6_inner_def match_table_v6'_inner_def using find_Some_decision_addr_in_set_v6 assms by simp
qed

lemma match_table_v6:
  assumes "valid_table table"
  shows "match_table_v6 table address = match_table_v6' table address"
  using assms
proof(-)
  have "\<And>t. t \<in> set (sort [t\<leftarrow>table . isIPv6 (ta t)]) \<Longrightarrow> isIPv6 (ta t)" by auto
  moreover have "valid_table (sort [t\<leftarrow>table . isIPv6 (ta t)])" using assms by (simp add: valid_table_def)
  ultimately show ?thesis unfolding match_table_v6_def match_table_v6'_def using match_table_v6_inner
    by blast
qed

lemma match_table_v6_wordinterval:
  assumes "valid_table table"
  shows "match_table_v6 table address = wordinterval_element address (table_to_wordinterval_v6 table)"
  using assms match_table_v6 match_table_v6' by simp
end


theory prop_13
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster drop *)
  theorem x0 :
    "(drop (S n) (Cons2 x xs)) = (drop n xs)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory first_incompleteness_par
  imports embedding
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>First Incompleteness Theorem (paraconsistent scenario)\<close>

(* Here we reconstruct the proofs of Gödel's first theorem (file "first_incompleteness_class.thy")
but this time employing the paraconsistent logic (R)mbC (featuring a paraconsistent negation). *)

abbreviation neg :: "wo\<Rightarrow>wo" ("\<^bold>\<not>_" [54] 55) where "\<^bold>\<not>\<phi> \<equiv> \<^bold>\<not>\<^sup>p\<phi>" (* negation is paraconsistent *)
abbreviation circ :: "wo\<Rightarrow>wo" ("\<^bold>\<circ>_" [54] 55) where "\<^bold>\<circ>\<phi> \<equiv> \<^bold>\<circ>\<^sup>m\<^sup>b\<^sup>c\<phi>" (* logic is (R)mbC *)

(* We employ the model finder Nitpick to verify that the problem is not trivial: *)
lemma "\<forall>P.  [\<^bold>\<turnstile> P] \<or>  [\<^bold>\<turnstile> \<^bold>\<not>P]" nitpick[card w=2] oops (* countermodel found *)
lemma "\<exists>P. \<sim>[\<^bold>\<turnstile> P] \<and> \<sim>[\<^bold>\<turnstile> \<^bold>\<not>P]" nitpick[card w=1] oops (* countermodel found *)

(* If F is consistent, then F \<turnstile>/ G\<^sub>(\<^sub>F\<^sub>) *)
lemma non_provable: fixes G
                    assumes "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"          (* G's fixed-point *)
                    and     "[\<^bold>\<turnstile> \<^bold>\<circ>\<^bold>\<box>G]"           (* \<^bold>\<circ>-consistency of \<^bold>\<box>G *)
                    shows   "\<sim>[\<^bold>\<turnstile> G]"
proof
  assume Gprov: "[\<^bold>\<turnstile> G]"                       (* assume G were provable *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>G]" by simp                           (* by necessitation *)
  hence negGprov: "[\<^bold>\<turnstile> \<^bold>\<not>G]"                   (* by contraposition and \<dots>*)
    using assms(1) assms(2) by blast (*\<dots>using G's fixed-point with \<^bold>\<circ>\<^bold>\<box>G *)
  from Gprov negGprov have "[\<^bold>\<turnstile> \<^bold>\<bottom>]" using assms(2)       (* using \<^bold>\<circ>\<^bold>\<box>G \<dots>*)
                        by presburger      (*\<dots> the solver can derive \<^bold>\<bottom> *)
  thus False by simp
qed

(* If F is \<^bold>*-consistent, then F \<turnstile>/ \<^bold>\<not>G\<^sub>(\<^sub>F\<^sub>) *)
lemma non_refutable_v1: fixes G
                        assumes "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"       (* G's fixed-point *)
                        and     "\<forall>\<phi>. \<sim>[\<^bold>\<turnstile> \<^bold>\<not>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>]"    (* \<^bold>*-consistency *)
                        and     "[\<^bold>\<turnstile> \<^bold>\<circ>G]"           (* \<^bold>\<circ>-consistency of G *)
                        shows   "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>G]"
proof
  assume negGprov: "[\<^bold>\<turnstile> \<^bold>\<not>G]"                   (* assume G were refutable *)
  hence provGprov: "[\<^bold>\<turnstile> \<^bold>\<box>G]"                   (* by contraposition and \<dots>*)
    using assms(1) assms(3) by blast    (*\<dots>using G's fixed-point with \<^bold>\<circ>G *)
  have Gcons: "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>G \<^bold>\<and> \<^bold>\<box>G]" using assms(2) by (rule allE) (*G is *-con.*)
  from negGprov provGprov have "[\<^bold>\<turnstile> \<^bold>\<not>G \<^bold>\<and> \<^bold>\<box>G]" by simp       (* by \<^bold>\<and>-intr.*)
  hence "[\<^bold>\<turnstile> \<^bold>\<bottom>]" using Gcons by simp         (* using \<^bold>*-consistency of G *)
  thus False by simp
qed

(* If F is S-consistent, then F \<turnstile>/ \<^bold>\<not>G\<^sub>(\<^sub>F\<^sub>) *)
lemma non_refutable_v2: fixes G
                        assumes "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"       (* G's fixed-point *)
                        and     "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi>]\<longrightarrow>[\<^bold>\<turnstile> \<phi>]"  (* S-consistency *)
                        and     "[\<^bold>\<turnstile> \<^bold>\<circ>G]"           (* \<^bold>\<circ>-consistency of G*)
                        shows   "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>G]"
proof
  assume negGprov: "[\<^bold>\<turnstile> \<^bold>\<not>G]"                  (* assume G were refutable *)
  hence provGprov: "[\<^bold>\<turnstile> \<^bold>\<box>G]"                  (* by contraposition and \<dots>*)
    using assms(1) assms(3) by blast   (*\<dots>using G's fixed-point with \<^bold>\<circ>G *)
  have  "[\<^bold>\<turnstile> \<^bold>\<box>G] \<longrightarrow> [\<^bold>\<turnstile> G]" using assms(2) by (rule allE)  (* G is S-con.*)
  hence Gprov: "[\<^bold>\<turnstile> G]" using provGprov by (rule mp)  (* by modus ponens *)
  from Gprov negGprov have "[\<^bold>\<turnstile> \<^bold>\<bottom>]" using assms(3)         (* using \<^bold>\<circ>G \<dots>*)
                        by simp             (*\<dots> by LFI definition of \<^bold>\<bottom> *)
  thus False by simp
qed

section \<open>Experiments with other variants\<close>

abbreviation "P_consistency_a     \<equiv>  \<sim>[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom>]"
abbreviation "P_consistency_b_par \<equiv>  [\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]"
abbreviation "circ_consistency    \<equiv>  \<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<circ>\<phi>]"

(* If F is P-consistent-a, then F \<turnstile>/ \<^bold>\<not>G\<^sub>F *)
lemma non_refutable_v3: fixes G
                        assumes "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"
                        and     P_consistency_a
                        and     "[\<^bold>\<turnstile> \<^bold>\<circ>G]"
                      shows   "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>G]" using assms by meson

(* If F is P-consistent-b, then F \<turnstile>/ \<^bold>\<not>G\<^sub>F *)
lemma non_refutable_v4: fixes G
                        assumes "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"
                        and     P_consistency_b_par
                        and     "[\<^bold>\<turnstile> \<^bold>\<circ>G]"
                      shows   "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>G]"
  (* sledgehammer[prover=remote_leo3,verbose](assms) (*Leo-III reports a proof*)*)
   oops (* TODO: prove or refute*)

(* If F is \<^bold>\<circ>-consistent, then F \<turnstile>/ \<^bold>\<not>G\<^sub>F *)
lemma non_refutable_v5: fixes G
                        assumes "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"
                        and     circ_consistency
                        and     "[\<^bold>\<turnstile> \<^bold>\<circ>G]"
                        shows   "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>G]"
  nitpick oops (* countermodel found *)

end


theory Map_of_Tree
  imports Main Algebras
begin

section \<open>Map Representation of a Tree\<close>

text \<open>This section presents a representation of tree using the mapping from path to value,
    of type \<^typ>\<open>'key list \<Rightarrow> 'val\<close>.
  It implements the hierarchical algebra and supports for permission algebra.

  Basic operations include `push_map` and `pull_map` which put a sub-tree onto certain location
    and fetch a sub-tree at certain location respectively.

  In this representation, the indexes near the root locate at the left side of the list, e.g.,
  \<open>[a,b,c] \<^enum>\<^sub>m D\<close> characterizes tree \<open>Root \<rightarrow> a \<rightarrow> b \<rightarrow> c \<rightarrow> D\<close>.
\<close>

(* subsection \<open>Preliminary\<close>

primrec subtract_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where \<open>subtract_prefix l' (h#l) =
      (case l' of h' # l'' \<Rightarrow> if h = h' then subtract_prefix l'' l else undefined
                | [] \<Rightarrow> undefined)\<close>
  | \<open>subtract_prefix l [] = l\<close>

lemma subtract_prefix[simp]:
  \<open>subtract_prefix (ha#la) (hb#lb) = (if ha = hb then subtract_prefix la lb else undefined)\<close>
  \<open>subtract_prefix l [] = l\<close>
  by simp_all

declare subtract_prefix.simps[simp del]

lemma subtract_prefix_app[simp]:
  \<open>subtract_prefix (xs @ zs) xs = zs\<close>
  by (induct xs; simp)

lemma prefix_subtract_prefix[simp]:
  \<open> prefix xs ys
\<Longrightarrow> xs @ (subtract_prefix ys xs) = ys \<close>
  unfolding prefix_def by clarsimp

"HOL-Library.Sublist" *)

subsection \<open>Push a map to a location\<close>

definition push_map :: \<open>'a list \<Rightarrow> ('a list \<Rightarrow> 'b) \<Rightarrow> ('a list \<Rightarrow> 'b::one)\<close> (infixr "\<^enum>\<^sub>m" 75)
  where \<open>push_map idx f = (\<lambda>x. if take (length idx) x = idx then f (drop (length idx) x) else 1 )\<close>

lemma push_map_unit[simp]:
  \<open>push_map ia (1(ib := x)) = 1(ia@ib := x)\<close>
  unfolding push_map_def
  by (simp add: fun_eq_iff, metis append_eq_conv_conj)

lemma push_map_push_map:
  \<open>push_map ia (push_map ib f) = push_map (ia@ib) f\<close>
  unfolding push_map_def fun_eq_iff
  by (smt (verit, ccfv_threshold) add.commute append_eq_append_conv append_eq_conv_conj drop_drop length_append take_add take_drop)

lemma push_map_distrib_mult:
  \<open>push_map idx f * push_map idx g = push_map idx (f * g)\<close>
  for f :: \<open>'a list \<Rightarrow> 'b::monoid_mult\<close>
  unfolding push_map_def fun_eq_iff times_fun_def by simp

lemma push_map_distrib_map_add:
  \<open>push_map idx (f ++ g) = push_map idx f ++ push_map idx g\<close>
  unfolding push_map_def fun_eq_iff map_add_def by simp

lemma push_map_sep_disj[simp]:
  \<open>push_map idx a ## push_map idx b \<longleftrightarrow> a ## b\<close>
  for a :: \<open>'k list \<Rightarrow> 'v::sep_magma_1\<close>
  unfolding sep_disj_fun_def push_map_def apply simp
  by (metis append_eq_conv_conj)

lemma push_map_distrib_sep_mult:
  \<open> f ## g
\<Longrightarrow> push_map idx f * push_map idx g = push_map idx (f * g)\<close>
  for f :: \<open>'a list \<Rightarrow> 'b::sep_monoid\<close>
  unfolding push_map_def fun_eq_iff times_fun_def by simp

lemma push_map_eq_1[simp]:
  \<open>push_map idx f = 1 \<longleftrightarrow> f = 1\<close>
  unfolding push_map_def fun_eq_iff by simp (metis append_eq_conv_conj)

lemma push_map_1[simp]:
  \<open>push_map idx 1 = 1\<close>
  unfolding push_map_def fun_eq_iff by simp

lemma push_map_mult_nil[simp]:
  \<open>push_map [] f = f\<close>
  unfolding push_map_def fun_eq_iff by simp

lemma share_push_map:
  \<open>share n (push_map idx f) = push_map idx (share n f)\<close>
  for f :: \<open>'a list \<Rightarrow> 'b :: share_one\<close>
  unfolding push_map_def fun_eq_iff share_fun_def by simp

lemma (in homo_one) push_map_homo:
  \<open>\<phi> o (push_map idx f) = push_map idx (\<phi> o f)\<close>
  unfolding push_map_def fun_eq_iff by simp

lemma push_map_to_share:
  \<open>push_map idx (to_share o f) = to_share o (push_map idx f)\<close>
  unfolding push_map_def fun_eq_iff by simp

lemma push_map_dom_eq[simp]:
  \<open>dom (push_map idx f) = dom (push_map idx g) \<longleftrightarrow> dom f = dom g\<close>
  unfolding dom_def fun_eq_iff push_map_def set_eq_iff apply simp
  by (metis (full_types) append_eq_conv_conj)

subsection \<open>Pull a map at a location\<close>

definition pull_map :: \<open>'a list \<Rightarrow> ('a list \<Rightarrow> 'b) \<Rightarrow> ('a list \<Rightarrow> 'b)\<close>
  where \<open>pull_map idx f = (\<lambda>x. f (idx@x))\<close>

lemma pull_map_unit[simp]:
  \<open>pull_map ia (1((ia@ib) := x)) = 1(ib := x)\<close>
  unfolding pull_map_def by (simp add: fun_eq_iff)

lemma pull_push_map[simp]:
  \<open>pull_map idx (push_map idx f) = f\<close>
  unfolding pull_map_def push_map_def fun_eq_iff by simp

lemma push_pull_map:
  \<open>push_map idx (pull_map idx f) \<subseteq>\<^sub>m f\<close>
  unfolding pull_map_def push_map_def map_le_def dom_def
  by simp (metis append_take_drop_id)

lemma pull_map_1[simp]:
  \<open>pull_map idx 1 = 1\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_0[simp]:
  \<open>pull_map idx 0 = 0\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_nil[simp]:
  \<open>pull_map [] f = f\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_pull_map[simp]:
  \<open>pull_map a (pull_map b f) = pull_map (b@a) f\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_cons:
  \<open>pull_map a (pull_map [b] f) = pull_map (b#a) f\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_funcomp:
  \<open>\<phi> 1 = 1 \<Longrightarrow> \<phi> o (pull_map idx f) = pull_map idx (\<phi> o f)\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_homo_mult:
  \<open>pull_map idx (f * g) = pull_map idx f * pull_map idx g\<close>
  unfolding pull_map_def fun_eq_iff
  by (simp add: times_fun)

lemma pull_map_to_share:
  \<open>pull_map idx (to_share o f) = to_share o (pull_map idx f)\<close>
  unfolding pull_map_def fun_eq_iff by simp

lemma pull_map_share:
  \<open>pull_map idx (share n f) = share n (pull_map idx f)\<close>
  unfolding pull_map_def fun_eq_iff share_fun_def by simp

lemma pull_map_sep_disj[simp]:
  \<open>f ## g \<Longrightarrow> pull_map idx f ## pull_map idx g\<close>
  unfolding pull_map_def sep_disj_fun_def by simp

subsection \<open>Helpers\<close>

subsubsection \<open>For Trees of Numeric Path\<close>

definition nnode :: \<open>(nat list \<Rightarrow> 'b) list \<Rightarrow> nat list \<Rightarrow> 'b::one\<close>
  \<comment> \<open>A tree node of children L\<close>
  where \<open>nnode L = (\<lambda>idx. case idx of i#idx' \<Rightarrow> (if i < length L then (L!i) idx' else 1) | _ \<Rightarrow> 1)\<close>

lemma share_nnode:
  \<open>share n (nnode L) = nnode (map (share n) L)\<close>
  for L :: \<open>(nat list \<Rightarrow> 'a::share_one) list\<close>
  unfolding nnode_def fun_eq_iff by (simp add: share_fun_def split: list.split)

lemma pull_map_node:
  \<open>pull_map (i#idx) (nnode L) = (if i < length L then pull_map idx (L!i) else 1)\<close>
  unfolding nnode_def pull_map_def fun_eq_iff by simp

(*
TODO

subsubsection \<open>Extract & Contract from higher-order function\<close>

definition contract_map :: \<open>('k \<Rightarrow> 'k list \<Rightarrow> ('v::one)) \<Rightarrow> 'k list \<Rightarrow> 'v\<close>
  where \<open>contract_map f = (\<lambda>ks. case ks of [] \<Rightarrow> 1 | h#r \<Rightarrow> f h r)\<close>

definition extract_map :: \<open>('k list \<Rightarrow> ('v::one)) \<Rightarrow> 'k \<Rightarrow> 'k list \<Rightarrow> 'v\<close>
  where \<open>extract_map f = (\<lambda>h r. f (h#r))\<close>

lemma
  \<open>extract_map (contract_map f) = f\<close>
  unfolding extract_map_def contract_map_def fun_eq_iff
  by (clarsimp)

lemma
  \<open>extract_map f h = pull_map [h] f\<close>
  unfolding pull_map_def extract_map_def fun_eq_iff
  by (clarsimp; case_tac x; clarsimp)
*)

end