section {*nat\_seq*}
theory
  nat_seq

imports
  partial_functions

begin

function (domintros) nat_seq :: "
  nat
  \<Rightarrow> nat
  \<Rightarrow> nat list"
  where
    "nat_seq n m =
  (if n \<le> m then [n]@nat_seq (Suc n) m else [])"
   apply(rename_tac P x)(*strict*)
   apply(auto)
  done

lemma nat_seq_termination: "
  nat_seq_dom (x, y)"
  apply(rule_tac
      TERM_ARGS_TEST = "\<lambda>(n,m). True"
      and RECURSIVE_COND = "\<lambda>(n,m). n \<le> m"
      and MODIFY_ARGS_FOR_REC_CALL = "\<lambda>(n,m). (Suc n,m)"
      and MEASURE = "\<lambda>(n,m). Suc m - n"
      in partial_termination_wf)
      apply(auto)
   apply(rename_tac a b)(*strict*)
   apply(rule nat_seq.domintros)
   apply(blast)
  apply(rename_tac a b)(*strict*)
  apply(rule nat_seq.domintros)
  apply(auto)
  done

lemma nat_seqEmpty: "
  n>m
  \<Longrightarrow> nat_seq n m = []"
  apply(rule_tac
      t = "nat_seq n m"
      and s = " (if n \<le> m then [n] @ nat_seq (Suc n) m else [])"
      in ssubst)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(clarsimp)
  done

lemma nat_seq_Shift_length: "
  length (nat_seq n m) = length (nat_seq (n + k) (m + k))"
  apply(induct m arbitrary: n k)
   apply(rename_tac n k)(*strict*)
   apply(rule_tac
      t = "nat_seq n 0"
      and s = " (if n \<le> 0 then [n] @ nat_seq (Suc n) 0 else [])"
      in ssubst)
    apply(rename_tac n k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac n k)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      t = "nat_seq (Suc 0) 0"
      and s = " (if (Suc 0) \<le> 0 then [Suc 0] @ nat_seq (Suc (Suc 0)) 0 else [])"
      in ssubst)
    apply(rename_tac n k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac n k)(*strict*)
   apply(clarsimp)
   apply(rule conjI)
    apply(rename_tac n k)(*strict*)
    apply(clarsimp)
    apply(rename_tac k)(*strict*)
    apply(rule_tac
      t = "nat_seq k k"
      and s = " (if k \<le> k then [k] @ nat_seq (Suc k) k else [])"
      in ssubst)
     apply(rename_tac k)(*strict*)
     apply(rule nat_seq.psimps)
     apply(rule nat_seq_termination)
    apply(rename_tac k)(*strict*)
    apply(clarsimp)
    apply(rule_tac
      t = "nat_seq (Suc k) k"
      and s = " (if (Suc k) \<le> k then [Suc k] @ nat_seq (Suc (Suc k)) k else [])"
      in ssubst)
     apply(rename_tac k)(*strict*)
     apply(rule nat_seq.psimps)
     apply(rule nat_seq_termination)
    apply(rename_tac k)(*strict*)
    apply(clarsimp)
   apply(rename_tac n k)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      t = "nat_seq (n + k) k"
      and s = " (if (n + k) \<le> k then [n + k] @ nat_seq (Suc (n + k)) k else [])"
      in ssubst)
    apply(rename_tac n k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac n k)(*strict*)
   apply(clarsimp)
  apply(rename_tac m n k)(*strict*)
  apply(rule_tac
      t = "nat_seq n (Suc m)"
      and s = " (if n \<le> (Suc m) then [n] @ nat_seq (Suc n) (Suc m) else [])"
      in ssubst)
   apply(rename_tac m n k)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k)(*strict*)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac m n k)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      t = "length (nat_seq (Suc n) (Suc m))"
      and s = "length (nat_seq n m)"
      in ssubst)
    apply(rename_tac m n k)(*strict*)
    apply(rule_tac
      s = "length (nat_seq (n + (Suc 0)) (m + (Suc 0)))"
      and t = "length (nat_seq n m)"
      in ssubst)
     apply(rename_tac m n k)(*strict*)
     apply(blast)
    apply(rename_tac m n k)(*strict*)
    apply(force)
   apply(rename_tac m n k)(*strict*)
   apply(rule_tac
      t = "nat_seq (n + k) (Suc (m + k))"
      and s = " (if (n + k) \<le> (Suc(m + k)) then [n + k] @ nat_seq (Suc (n + k)) (Suc(m + k)) else [])"
      in ssubst)
    apply(rename_tac m n k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac m n k)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      t = "Suc (n + k)"
      and s = "n + (Suc k)"
      in ssubst)
    apply(rename_tac m n k)(*strict*)
    apply(arith)
   apply(rename_tac m n k)(*strict*)
   apply(rule_tac
      t = "Suc (m + k)"
      and s = "m + (Suc k)"
      in ssubst)
    apply(rename_tac m n k)(*strict*)
    apply(arith)
   apply(rename_tac m n k)(*strict*)
   apply(blast)
  apply(rename_tac m n k)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq (n + k) (Suc (m + k))"
      and s = " (if (n + k) \<le> (Suc(m + k)) then [n + k] @ nat_seq (Suc (n + k)) (Suc(m + k)) else [])"
      in ssubst)
   apply(rename_tac m n k)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k)(*strict*)
  apply(clarsimp)
  done

lemma nat_seq_length: "
  m \<ge> n
  \<Longrightarrow> length (nat_seq n m) = m - n + 1"
  apply(subgoal_tac "n \<le> m \<longrightarrow> length (nat_seq n m) = m - n + 1")
   apply(blast)
  apply(thin_tac "m \<ge> n")
  apply(induct m arbitrary: n)
   apply(rename_tac n)(*strict*)
   apply(auto)
   apply(rule_tac
      t = "nat_seq 0 0"
      and s = " (if 0 \<le> 0 then [0] @ nat_seq (Suc 0) 0 else [])"
      in ssubst)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(clarsimp)
   apply(rule_tac
      t = "nat_seq (Suc 0) 0"
      and s = " (if (Suc 0) \<le> 0 then [Suc 0] @ nat_seq (Suc (Suc 0)) 0 else [])"
      in ssubst)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(clarsimp)
  apply(rename_tac m n)(*strict*)
  apply(rule_tac
      t = "nat_seq n (Suc m)"
      and s = " (if n \<le> (Suc m) then [n] @ nat_seq (Suc n) (Suc m) else [])"
      in ssubst)
   apply(rename_tac m n)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "length (nat_seq (Suc n) (Suc m))"
      and s = "length (nat_seq n m)"
      in ssubst)
   apply(rename_tac m n)(*strict*)
   apply(rule_tac
      t = "Suc n"
      and s = "n + (Suc 0)"
      in ssubst)
    apply(rename_tac m n)(*strict*)
    apply(arith)
   apply(rename_tac m n)(*strict*)
   apply(rule_tac
      t = "Suc m"
      and s = "m + (Suc 0)"
      in ssubst)
    apply(rename_tac m n)(*strict*)
    apply(arith)
   apply(rename_tac m n)(*strict*)
   apply(rule sym)
   apply(rule nat_seq_Shift_length)
  apply(rename_tac m n)(*strict*)
  apply(case_tac "Suc m - n = 0")
   apply(rename_tac m n)(*strict*)
   apply(clarsimp)
   apply(rename_tac m)(*strict*)
   apply(rule_tac
      t = "nat_seq (Suc m) m"
      and s = " (if (Suc m) \<le> m then [Suc m] @ nat_seq (Suc (Suc m)) m else [])"
      in ssubst)
    apply(rename_tac m)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac m)(*strict*)
   apply(clarsimp)
  apply(rename_tac m n)(*strict*)
  apply(rule_tac
      t = "Suc m - n"
      and s = "Suc (m - n)"
      in ssubst)
   apply(rename_tac m n)(*strict*)
   apply(arith)
  apply(rename_tac m n)(*strict*)
  apply(force)
  done

lemma nat_seq_length_Suc0: "
  w = nat_seq (Suc 0) m
  \<Longrightarrow> m>0
  \<Longrightarrow> length w = m"
  apply(subgoal_tac "\<forall>m. length (nat_seq (Suc 0) (Suc m)) = Suc m")
   apply(case_tac m)
    apply(force)
   apply(rename_tac nat)(*strict*)
   apply(erule_tac
      x = "nat"
      in allE)
   apply(clarsimp)
  apply(thin_tac "w = nat_seq (Suc 0) m")
  apply(thin_tac "0 < m")
  apply(rule allI) +
  apply(rename_tac m)(*strict*)
  apply(induct_tac m)
   apply(rename_tac m)(*strict*)
   apply(rule_tac
      t = "nat_seq (Suc 0) (Suc 0)"
      and s = " (if (Suc 0) \<le> (Suc 0) then [Suc 0] @ nat_seq (Suc (Suc 0)) (Suc 0) else [])"
      in ssubst)
    apply(rename_tac m)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac m)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      t = "nat_seq (Suc (Suc 0)) (Suc 0)"
      and s = " (if (Suc (Suc 0)) \<le> (Suc 0) then [Suc (Suc 0)] @ nat_seq (Suc (Suc (Suc 0))) (Suc 0) else [])"
      in ssubst)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(clarsimp)
  apply(rename_tac m n)(*strict*)
  apply(rule_tac
      t = "nat_seq (Suc 0) (Suc (Suc n))"
      and s = " (if (Suc 0) \<le> (Suc (Suc n)) then [Suc 0] @ nat_seq (Suc (Suc 0)) (Suc (Suc n)) else [])"
      in ssubst)
   apply(rename_tac m n)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n)(*strict*)
  apply(clarsimp)
  apply(rename_tac n)(*strict*)
  apply(rule_tac
      s = "(Suc (Suc n)) - (Suc (Suc 0)) + 1"
      and t = "length (nat_seq (Suc (Suc 0)) (Suc (Suc n)))"
      in ssubst)
   apply(rename_tac n)(*strict*)
   apply(rule nat_seq_length)
   apply(blast)
  apply(rename_tac n)(*strict*)
  apply(arith)
  done

lemma nat_seq_Shift_nth: "
  i \<le> (m - n)
  \<Longrightarrow> n \<le> m
  \<Longrightarrow> nat_seq (n + k) (m + k) ! i = k + (nat_seq n m ! i)"
  apply(subgoal_tac "i \<le> m - n \<and> n \<le> m \<longrightarrow> nat_seq (n + k) (m + k) ! i = k + nat_seq n m ! i")
   apply(blast)
  apply(thin_tac "i \<le> m - n")
  apply(thin_tac "n \<le> m")
  apply(induct m arbitrary: n k i)
   apply(rename_tac n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq n 0"
      and s = " (if n \<le> 0 then [n] @ nat_seq (Suc n) 0 else [])"
      in ssubst)
    apply(rename_tac n k i)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac n k i)(*strict*)
   apply(clarsimp)
   apply(rename_tac k)(*strict*)
   apply(auto)
   apply(rule_tac
      t = "nat_seq (Suc 0) 0"
      and s = " (if (Suc 0) \<le> 0 then [Suc 0] @ nat_seq (Suc (Suc 0)) 0 else [])"
      in ssubst)
    apply(rename_tac k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac k)(*strict*)
   apply(rule_tac
      t = "nat_seq k k"
      and s = " (if k \<le> k then [k] @ nat_seq (Suc k) k else [])"
      in ssubst)
    apply(rename_tac k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac k)(*strict*)
   apply(clarsimp)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "nat_seq n (Suc m)"
      and s = " (if n \<le> (Suc m) then [n] @ nat_seq (Suc n) (Suc m) else [])"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq (n + k) (Suc (m + k))"
      and s = " (if (n + k) \<le> (Suc (m + k)) then [n + k] @ nat_seq (Suc (n + k)) (Suc (m + k)) else [])"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k i)(*strict*)
  apply(clarsimp)
  apply(case_tac i)
   apply(rename_tac m n k i)(*strict*)
   apply(auto)
  apply(rename_tac m n k nat)(*strict*)
  apply(rename_tac i)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "Suc (m + k)"
      and s = "m + (Suc k)"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "Suc (n + k)"
      and s = "n + (Suc k)"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "Suc m"
      and s = "m + (Suc 0)"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "Suc n"
      and s = "n + (Suc 0)"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(case_tac "i \<le> m - n \<and> n \<le> m")
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq (n + Suc k) (m + Suc k) ! i"
      and s = "(Suc k) + nat_seq n m ! i"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(blast)
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq (n + Suc 0) (m + Suc 0) ! i"
      and s = "(Suc 0) + nat_seq n m ! i"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(blast)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(clarsimp)
  apply(arith)
  done

lemma nat_seq_nth_ignore_tail: "
  i \<le> m - n
  \<Longrightarrow> n \<le> m
  \<Longrightarrow> nat_seq n m ! i = nat_seq n (m + k) ! i"
  apply(subgoal_tac "i \<le> m - n \<and> n \<le> m \<longrightarrow> nat_seq n m ! i = nat_seq n (m + k) ! i")
   apply(blast)
  apply(thin_tac "i \<le> m - n")
  apply(thin_tac "n \<le> m")
  apply(induct m arbitrary: n k i)
   apply(rename_tac n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq n 0"
      and s = " (if n \<le> 0 then [n] @ nat_seq (Suc n) 0 else [])"
      in ssubst)
    apply(rename_tac n k i)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac n k i)(*strict*)
   apply(clarsimp)
   apply(rename_tac k)(*strict*)
   apply(rule_tac
      t = "nat_seq 0 k"
      and s = " (if 0 \<le> k then [0] @ nat_seq (Suc 0) k else [])"
      in ssubst)
    apply(rename_tac k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac k)(*strict*)
   apply(clarsimp)
  apply(rename_tac m n k i)(*strict*)
  apply(rule impI)
  apply(rule_tac
      t = "nat_seq n (Suc m)"
      and s = " (if n \<le> (Suc m) then [n] @ nat_seq (Suc n) (Suc m) else [])"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq n (Suc (m + k))"
      and s = " (if n \<le> (Suc(m + k)) then [n] @ nat_seq (Suc n) (Suc(m + k)) else [])"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k i)(*strict*)
  apply(clarsimp)
  apply(case_tac i)
   apply(rename_tac m n k i)(*strict*)
   apply(clarsimp)
  apply(rename_tac m n k i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac m n k nat)(*strict*)
  apply(rename_tac i)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "Suc n"
      and s = "n + (Suc 0)"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(rule_tac
      t = "Suc m"
      and s = "m + (Suc 0)"
      in ssubst)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(case_tac "i \<le> m - n \<and> n \<le> m")
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq (n + Suc 0) (m + Suc 0) ! i"
      and s = "(Suc 0) + (nat_seq n m) ! i"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(rule nat_seq_Shift_nth)
     apply(rename_tac m n k i)(*strict*)
     apply(blast)
    apply(rename_tac m n k i)(*strict*)
    apply(clarsimp)
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq n m ! i"
      and s = "nat_seq n (m + k) ! i"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(blast)
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "Suc n"
      and s = "n + (Suc 0)"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(arith)
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "Suc (m + k)"
      and s = "m + k + (Suc 0)"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(arith)
   apply(rename_tac m n k i)(*strict*)
   apply(rule_tac
      t = "nat_seq (n + Suc 0) (m + k + Suc 0) ! i"
      and s = "(Suc 0) + (nat_seq n (m + k)) ! i"
      in ssubst)
    apply(rename_tac m n k i)(*strict*)
    apply(rule nat_seq_Shift_nth)
     apply(rename_tac m n k i)(*strict*)
     apply(arith)
    apply(rename_tac m n k i)(*strict*)
    apply(arith)
   apply(rename_tac m n k i)(*strict*)
   apply(arith)
  apply(rename_tac m n k i)(*strict*)
  apply(clarsimp)
  apply(arith)
  done

lemma nat_seq_nth_compute: "
  n \<le> m
  \<Longrightarrow> k \<le> m - n
  \<Longrightarrow> nat_seq n m ! k = n + k"
  apply(subgoal_tac "k \<le> m - n \<and> n \<le> m \<longrightarrow> nat_seq n m ! k = n + k")
   apply(blast)
  apply(thin_tac "k \<le> m - n")
  apply(thin_tac "n \<le> m")
  apply(induct m arbitrary: n k i)
   apply(rename_tac n k)(*strict*)
   apply(rule_tac
      t = "nat_seq n 0"
      and s = " (if n \<le> 0 then [n] @ nat_seq (Suc n) 0 else [])"
      in ssubst)
    apply(rename_tac n k)(*strict*)
    apply(rule nat_seq.psimps)
    apply(rule nat_seq_termination)
   apply(rename_tac n k)(*strict*)
   apply(clarsimp)
  apply(rename_tac m n k)(*strict*)
  apply(auto)
  apply(rule_tac
      t = "nat_seq n (Suc m)"
      and s = " (if n \<le> (Suc m) then [n] @ nat_seq (Suc n) (Suc m) else [])"
      in ssubst)
   apply(rename_tac m n k)(*strict*)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(rename_tac m n k)(*strict*)
  apply(clarsimp)
  apply(case_tac k)
   apply(rename_tac m n k)(*strict*)
   apply(auto)
  apply(rename_tac m n nat)(*strict*)
  apply(rule_tac
      t = "nat_seq (Suc n) (Suc m) ! nat"
      and s = "(Suc 0) + (nat_seq n m) ! nat "
      in ssubst)
   apply(rename_tac m n nat)(*strict*)
   apply(rule_tac
      t = "Suc n"
      and s = "n + (Suc 0)"
      in ssubst)
    apply(rename_tac m n nat)(*strict*)
    apply(arith)
   apply(rename_tac m n nat)(*strict*)
   apply(rule_tac
      t = "Suc m"
      and s = "m + (Suc 0)"
      in ssubst)
    apply(rename_tac m n nat)(*strict*)
    apply(arith)
   apply(rename_tac m n nat)(*strict*)
   apply(rule nat_seq_Shift_nth)
    apply(rename_tac m n nat)(*strict*)
    apply(arith)
   apply(rename_tac m n nat)(*strict*)
   apply(arith)
  apply(rename_tac m n nat)(*strict*)
  apply(rule_tac
      t = "nat_seq n m ! nat"
      and s = "n + nat"
      in ssubst)
   apply(rename_tac m n nat)(*strict*)
   apply(case_tac "n \<le> m \<and> nat \<le> m - n")
    apply(rename_tac m n nat)(*strict*)
    apply(blast)
   apply(rename_tac m n nat)(*strict*)
   apply(arith)
  apply(rename_tac m n nat)(*strict*)
  apply(arith)
  done

lemma natUptTo_n_n: "
  nat_seq n n = [n]"
  apply(rule_tac
      t = "nat_seq n n"
      and s = " (if n \<le> n then [n] @ nat_seq (Suc n) n else [])"
      in ssubst)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq (Suc n) n"
      and s = " (if (Suc n) \<le> n then [Suc n] @ nat_seq (Suc (Suc n)) n else [])"
      in ssubst)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(clarsimp)
  done

lemma natUptTo_n_Sucn: "
  nat_seq n (Suc n) = [n,Suc n]"
  apply(rule_tac
      t = "nat_seq n (Suc n)"
      and s = " (if n \<le> (Suc n) then [n] @ nat_seq (Suc n) (Suc n) else [])"
      in ssubst)
   apply(rule nat_seq.psimps)
   apply(rule nat_seq_termination)
  apply(clarsimp)
  apply(rule natUptTo_n_n)
  done

lemma nat_seq_length_prime: "
  length (nat_seq n m) = m + 1 - n"
  apply(case_tac "n \<le> m")
   apply(rule_tac
      t = "m + 1 - n"
      and s = "m - n + 1"
      in ssubst)
    apply(force)
   apply(rule nat_seq_length)
   apply(force)
  apply(clarsimp)
  apply(rule nat_seqEmpty)
  apply(force)
  done

lemma nat_seq_in_interval: "
  i  \<in> set (nat_seq n m)
  \<Longrightarrow> n \<le> i \<and> i \<le> m"
  apply(subgoal_tac "\<exists>k < length (nat_seq n m). (nat_seq n m) ! k = i")
   prefer 2
   apply(rule set_elem_nth)
   apply(force)
  apply(clarsimp)
  apply(rename_tac k)(*strict*)
  apply(subgoal_tac "length (nat_seq n m) = m + 1 - n")
   apply(rename_tac k)(*strict*)
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(rename_tac k)(*strict*)
  apply(clarsimp)
  apply(case_tac "n \<le> m")
   apply(rename_tac k)(*strict*)
   apply(rule_tac
      t = "nat_seq n m ! k"
      and s = "n + k"
      in ssubst)
    apply(rename_tac k)(*strict*)
    apply(rule nat_seq_nth_compute)
     apply(rename_tac k)(*strict*)
     apply(force)
    apply(rename_tac k)(*strict*)
    apply(force)
   apply(rename_tac k)(*strict*)
   apply(force)
  apply(rename_tac k)(*strict*)
  apply(clarsimp)
  done

lemma nat_seq_drop_last: "
  nat_seq n (Suc (n + ka)) = nat_seq n (n + ka) @ [Suc (n + ka)]"
  apply(rule listEqI)
   apply (metis Suc_eq_plus1 add_Suc_right diff_add_inverse length_Suc nat_seq_length_prime add.commute)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "length(nat_seq n (Suc (n + ka))) = (Suc (n+ka)) - n + Suc 0")
   apply(rename_tac i)(*strict*)
   prefer 2
   apply (metis One_nat_def Suc_diff_le Suc_eq_plus1 Suc_eq_plus1_left le_Suc_eq le_add1 nat_seq_length_prime add.commute)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "length(nat_seq n ((n + ka))) = ((n+ka)) - n + Suc 0")
   apply(rename_tac i)(*strict*)
   prefer 2
   apply (metis One_nat_def Suc_diff_le Suc_eq_plus1 Suc_eq_plus1_left le_add1 nat_seq_length_prime add.commute)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(case_tac "i=Suc ka")
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
   apply (metis add_Suc_right diff_add_inverse le_add1 le_refl nat_seq_nth_compute nth_append_length)
  apply(rename_tac i)(*strict*)
  apply(rule_tac
      t="(nat_seq n (n + ka) @ [Suc (n + ka)]) ! i"
      and s="(nat_seq n (n + ka)) ! i"
      in ssubst)
   apply(rename_tac i)(*strict*)
   apply (metis List.nth_append less_SucE add.commute)
  apply(rename_tac i)(*strict*)
  apply(subgoal_tac "i<Suc ka")
   apply(rename_tac i)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      s="n+i"
      in ssubst)
   apply(rename_tac i)(*strict*)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac i)(*strict*)
    apply(force)
   apply(rename_tac i)(*strict*)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(rule nat_seq_nth_compute)
   apply(rename_tac i)(*strict*)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(force)
  done

lemma nat_seq_drop_last_simp: "
  n\<le>m
  \<Longrightarrow> nat_seq n (Suc m) = nat_seq n m @ [Suc m]"
  apply (metis le_iff_add nat_seq_drop_last natUptTo_n_n)
  done

lemma nat_seq_drop_last_prime: "
  nat_seq (Suc 0) (Suc m) = nat_seq (Suc 0) m @ [Suc m]"
  apply (metis nat_seq_drop_last_simp less_Suc0 nat_seqEmpty natUptTo_n_n self_append_conv2 trivNat)
  done

lemma nat_seq_drop_first: "
  a = m
  \<Longrightarrow> b = m + n
  \<Longrightarrow> b = b'
  \<Longrightarrow> c = Suc m
  \<Longrightarrow> nat_seq a b = [m]@(nat_seq c b')"
  apply(subgoal_tac "length (nat_seq m (m + n)) = (m + n) + 1 - m")
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(subgoal_tac "length (nat_seq (Suc m) (m + n)) = (m + n) + 1 - (Suc m)")
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(clarsimp)
  apply(rule listEqI)
   apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq m (m + n) ! i"
      and s = "m + i"
      in ssubst)
   apply(rename_tac i)(*strict*)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac i)(*strict*)
    apply(force)
   apply(rename_tac i)(*strict*)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(case_tac i)
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(rule_tac
      t = "nat_seq (Suc m) (m + n) ! nat"
      and s = "(Suc m) + nat"
      in ssubst)
   apply(rename_tac nat)(*strict*)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac nat)(*strict*)
    apply(force)
   apply(rename_tac nat)(*strict*)
   apply(force)
  apply(rename_tac nat)(*strict*)
  apply(force)
  done

lemma nat_seq_split: "
  a = x
  \<Longrightarrow> a = a'
  \<Longrightarrow> b = x + y + z
  \<Longrightarrow> b = b'
  \<Longrightarrow> c = x + y
  \<Longrightarrow> c = c'
  \<Longrightarrow> nat_seq a b = nat_seq a' c @ (tl(nat_seq c' b'))"
  apply(clarsimp)
  apply(induct "y" arbitrary: z)
   apply(rename_tac z)(*strict*)
   apply(clarsimp)
   apply(subgoal_tac "length(nat_seq x (x + z)) = (x + z) + 1 - x")
    apply(rename_tac z)(*strict*)
    apply(clarsimp)
    apply(rule tl_nth_eq)
     apply(rename_tac z)(*strict*)
     apply(force)
    apply(rename_tac z)(*strict*)
    apply(rule_tac
      t = "nat_seq x (x + z) ! 0"
      and s = "x + 0"
      in ssubst)
     apply(rename_tac z)(*strict*)
     apply(rule nat_seq_nth_compute)
      apply(rename_tac z)(*strict*)
      apply(force)
     apply(rename_tac z)(*strict*)
     apply(clarsimp)
    apply(rename_tac z)(*strict*)
    apply(clarsimp)
    apply (metis natUptTo_n_n)
   apply(rename_tac z)(*strict*)
   apply (metis nat_seq_length_prime)
  apply(rename_tac y z)(*strict*)
  apply(clarsimp)
  apply(erule_tac
      x = "Suc z"
      in meta_allE)
  apply(clarsimp)
  apply(thin_tac "nat_seq x (Suc (x + y + z)) = nat_seq x (x + y) @ tl (nat_seq (x + y) (Suc (x + y + z)))")
  apply(rule_tac
      t = "nat_seq (x + y) (Suc (x + y + z))"
      and s = "[x + y]@(nat_seq (Suc (x + y)) (Suc (x + y + z)))"
      in ssubst)
   apply(rename_tac y z)(*strict*)
   apply(rule nat_seq_drop_first)
      apply(rename_tac y z)(*strict*)
      apply(force)
     apply(rename_tac y z)(*strict*)
     apply(force)
    apply(rename_tac y z)(*strict*)
    apply(force)
   apply(rename_tac y z)(*strict*)
   apply(force)
  apply(rename_tac y z)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq (Suc(x + y)) (Suc (x + y + z))"
      and s = "[Suc(x + y)]@(nat_seq (Suc(Suc (x + y))) (Suc (x + y + z)))"
      in ssubst)
   apply(rename_tac y z)(*strict*)
   apply(rule nat_seq_drop_first)
      apply(rename_tac y z)(*strict*)
      apply(force)
     apply(rename_tac y z)(*strict*)
     apply(force)
    apply(rename_tac y z)(*strict*)
    apply(force)
   apply(rename_tac y z)(*strict*)
   apply(force)
  apply(rename_tac y z)(*strict*)
  apply(clarsimp)
  apply(rename_tac y)(*strict*)
  apply(subgoal_tac "length(nat_seq x (x + y)) = (x + y) + 1 - x")
   apply(rename_tac y)(*strict*)
   prefer 2
   apply (metis nat_seq_length_prime)
  apply(rename_tac y)(*strict*)
  apply(subgoal_tac "length(nat_seq x (Suc(x + y))) = (Suc(x + y)) + 1 - x")
   apply(rename_tac y)(*strict*)
   prefer 2
   apply (metis nat_seq_length_prime)
  apply(rename_tac y)(*strict*)
  apply(rule listEqI)
   apply(rename_tac y)(*strict*)
   apply(clarsimp)
  apply(rename_tac y i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t = "nat_seq x (Suc (x + y)) ! i"
      and s = "x + i"
      in ssubst)
   apply(rename_tac y i)(*strict*)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac y i)(*strict*)
    apply(force)
   apply(rename_tac y i)(*strict*)
   apply(force)
  apply(rename_tac y i)(*strict*)
  apply(case_tac "i = Suc y")
   apply(rename_tac y i)(*strict*)
   apply(clarsimp)
   apply(rename_tac y)(*strict*)
   apply (metis nth_append_length)
  apply(rename_tac y i)(*strict*)
  apply (metis diff_add_inverse2 le_add2 less_Suc_eq_le less_antisym nat_seq_nth_compute add.commute nth_append_1)
  done

lemma nat_seq_interval: "
  x \<le> n
  \<Longrightarrow> n \<le> y
  \<Longrightarrow> n  \<in> set (nat_seq x y)"
  apply(rule_tac
      s = "(\<exists>i < length xs. xs ! i = x)" for xs x
      in ssubst)
   apply(rule in_set_conv_nth)
  apply(rule_tac
      t = "length (nat_seq x y)"
      and s = "y + 1 - x"
      in ssubst)
   apply(rule nat_seq_length_prime)
  apply(clarsimp)
  apply(rule_tac
      x = "n - x"
      in exI)
  apply(rule conjI)
   apply(force)
  apply(rule_tac
      t = "nat_seq x y ! (n - x)"
      and s = "x + (n - x)"
      in ssubst)
   apply(rule nat_seq_nth_compute)
    apply(force)
   apply(force)
  apply(force)
  done

lemma nat_seq_last: "
  m < n
  \<Longrightarrow> nat_seq (Suc m) (n - Suc 0) @ [n] = nat_seq (Suc m) n"
  apply(subgoal_tac "length (nat_seq (Suc m) (n - Suc 0)) = (n - Suc 0) + 1 - (Suc m)")
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(clarsimp)
  apply(subgoal_tac "length (nat_seq (Suc m) n) = n + 1 - (Suc m)")
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(rule listEqI)
   apply(clarsimp)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "\<exists>x. m + (Suc x) = n")
   apply(rename_tac i)(*strict*)
   prefer 2
   apply(rule less_delta_exists)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(rename_tac i x)(*strict*)
  apply(case_tac "i < x")
   apply(rename_tac i x)(*strict*)
   apply(rule_tac
      t = "(nat_seq (Suc m) (m + x) @ [Suc (m + x)]) ! i"
      and s = "nat_seq (Suc m) (m + x) ! i"
      in ssubst)
    apply(rename_tac i x)(*strict*)
    apply(rule nth_append_1)
    apply(force)
   apply(rename_tac i x)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      t = "nat_seq (Suc m) (m + x) ! i"
      and s = "Suc m + i"
      in ssubst)
    apply(rename_tac i x)(*strict*)
    apply(rule nat_seq_nth_compute)
     apply(rename_tac i x)(*strict*)
     apply(force)
    apply(rename_tac i x)(*strict*)
    apply(force)
   apply(rename_tac i x)(*strict*)
   apply(rule sym)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac i x)(*strict*)
    apply(force)
   apply(rename_tac i x)(*strict*)
   apply(force)
  apply(rename_tac i x)(*strict*)
  apply(subgoal_tac "i = x")
   apply(rename_tac i x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac i x)(*strict*)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      t = "(nat_seq (Suc m) (m + x) @ [Suc (m + x)]) ! x"
      and s = "[Suc (m + x)] ! (x - length (nat_seq (Suc m) (m + x)))"
      in ssubst)
   apply(rename_tac x)(*strict*)
   apply(rule nth_append_2)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rule sym)
  apply(rule_tac
      t = "Suc (m + x)"
      and s = "Suc m + x"
      in ssubst)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(rule nat_seq_nth_compute)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

lemma nat_seq_drop_first2: "
  Suc x=n-m
  \<Longrightarrow> nat_seq m (n-Suc 0) = [m]@(nat_seq (Suc m) (n-Suc 0))"
  apply(subgoal_tac "length (nat_seq m (n - Suc 0)) = (n - Suc 0) + 1 - m")
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(subgoal_tac "length (nat_seq (Suc m) (n - Suc 0)) = (n - Suc 0) + 1 - (Suc m)")
   prefer 2
   apply(rule nat_seq_length_prime)
  apply(clarsimp)
  apply(rule listEqI)
   apply(clarsimp)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t="nat_seq m (n - Suc 0) ! i"
      and s="m + i"
      in ssubst)
   apply(rename_tac i)(*strict*)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac i)(*strict*)
    apply(force)
   apply(rename_tac i)(*strict*)
   apply(force)
  apply(rename_tac i)(*strict*)
  apply(case_tac i)
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(rule_tac
      t="nat_seq (Suc m) (n - Suc 0) ! nat"
      and s="(Suc m) + nat"
      in ssubst)
   apply(rename_tac nat)(*strict*)
   apply(rule nat_seq_nth_compute)
    apply(rename_tac nat)(*strict*)
    defer
    apply(force)
   apply(rename_tac nat)(*strict*)
   apply(force)
  apply(rename_tac nat)(*strict*)
  apply(force)
  done

lemma nat_seq_pullout: "
  n\<le>m
  \<Longrightarrow> nat_seq n m = n#(nat_seq (Suc n) m)"
  apply (metis Cons_eq_appendI Suc_diff_le diff_Suc_Suc nat_seq_drop_first2 eq_Nil_appendI minus_nat.diff_0)
  done

lemma int_interval_singleton: "
  [x..x] = [x]"
  apply (metis less_irrefl order_refl upto_aux_rec upto_code zle_diff1_eq)
  done

lemma int_interval_drop_last: "
  x\<le>y
  \<Longrightarrow> [x..y+1] = [x..y]@[y+1]"
  apply (metis add_diff_cancel upto_rec2 zle_add1_eq_le zless_add1_eq)
  done

lemma int_interval_vs_nat_seq: "
  map nat [int n..int m] = nat_seq n m"
  apply(case_tac "n>m")
   apply(clarsimp)
   apply (metis nat_seqEmpty)
  apply(induct "m-n" arbitrary: m)
   apply(clarsimp)
   apply (metis int_interval_singleton list.simps(8) list.simps(9) natUptTo_n_n nat_int)
  apply(case_tac m)
   apply(clarsimp)
  apply(clarsimp)
  apply(subgoal_tac "n = nata-x")
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(subgoal_tac "Suc nata \<ge> nata - x")
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(erule_tac x="nata" in meta_allE)
  apply(clarsimp)
  apply(erule meta_impE)
   apply(force)
  apply(rule_tac t="[int (nata - x)..1 + int nata]" and s="[int (nata - x)..int nata]@[int nata+1]" in ssubst)
   apply(rule_tac t="1 + int nata" and s="int nata+1" in ssubst)
    apply(force)
   apply(rule int_interval_drop_last)
   apply(force)
  apply(rule_tac t="nat_seq (nata - x) (Suc nata)" and s="nat_seq (nata - x) (nata)@[Suc nata]" in
      ssubst)
   apply(rule nat_seq_drop_last_simp)
   apply(force)
  apply(force)
  done

end


theory T140
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory SINVAR_BLPstrict
imports "../TopoS_Helper"
begin

subsection {* Stricter Bell LaPadula SecurityInvariant *}
text{* All unclassified data sources must be labeled, default assumption: all is secret.

Warning: This is considered here an access control strategy.
By default, everything is secret and one explicitly prohibits sending to non-secret hosts.*}

datatype security_clearance = Unclassified | Confidential | Secret

(*total order*)
instantiation security_clearance :: linorder
  begin
  fun less_eq_security_clearance :: "security_clearance \<Rightarrow> security_clearance \<Rightarrow> bool" where
    "(Unclassified \<le> Unclassified) = True" |
    "(Confidential \<le> Confidential) = True" |
    "(Secret \<le> Secret) = True" |
    "(Unclassified \<le> Confidential) = True" |
    "(Confidential \<le> Secret) = True"  |
    "(Unclassified \<le> Secret) = True"  |
    "(Secret \<le> Confidential) = False"  |
    "(Confidential \<le> Unclassified) = False"  |
    "(Secret \<le> Unclassified) = False"

  fun less_security_clearance :: "security_clearance \<Rightarrow> security_clearance \<Rightarrow> bool" where
    "(Unclassified < Unclassified) = False" |
    "(Confidential < Confidential) = False" |
    "(Secret < Secret) = False" |
    "(Unclassified < Confidential) = True" |
    "(Confidential < Secret) = True"  |
    "(Unclassified < Secret) = True"  |
    "(Secret < Confidential) = False"  |
    "(Confidential < Unclassified) = False"  |
    "(Secret < Unclassified) = False"
  instance
    apply(intro_classes)
    apply(case_tac [!] x)
    apply(simp_all)
    apply(case_tac  [!] y)
    apply(simp_all)
    apply(case_tac  [!] z)
    apply(simp_all)
    done
  end

definition default_node_properties :: "security_clearance"
  where  "default_node_properties \<equiv> Secret"

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

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> security_clearance) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation \<equiv> False"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[6]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

subsection {*ENF*}
  lemma secret_default_candidate: "\<And> (nP::('v \<Rightarrow> security_clearance)) e1 e2. \<not> (nP e1) \<le> (nP e2) \<Longrightarrow> \<not> Secret \<le> (nP e2)"
    apply(case_tac "nP e1")
    apply(simp_all)
    apply(case_tac [!] "nP e2")
    apply(simp_all)
    done
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> security_clearance) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> (nP e1) > (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

  interpretation BLPstrict: SecurityInvariant_ACS sinvar verify_globals default_node_properties
  where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    unfolding receiver_violation_def
    unfolding default_node_properties_def
    apply(unfold_locales)
      apply(rule ballI)
      apply(rule SecurityInvariant_withOffendingFlows.ENF_fsts_refl_instance[OF BLP_ENF_refl])
         apply(simp_all add: BLP_ENF BLP_ENF_refl)[3]
      apply(simp add: secret_default_candidate)
     apply(erule default_uniqueness_by_counterexample_ACS)
     apply(rule_tac x="\<lparr> nodes=set [vertex_1,vertex_2], edges = set [(vertex_1,vertex_2)] \<rparr>" in exI, simp)
     apply(simp add: BLP_offending_set graph_ops valid_graph_def)
     apply(rule_tac x="(\<lambda> x. Secret)(vertex_1 := Secret, vertex_2 := Confidential)" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="set [(vertex_1,vertex_2)]" in exI, simp)
     apply(simp add: BLP_offending_set_def)
     apply(rule conjI)
      apply fastforce
     apply (case_tac otherbot, simp_all)
    apply(fact BLP_offending_set)
   done

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

hide_fact (open) sinvar_mono

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


(*<*)
theory TheoryCombination
  imports Main
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]
(*>*)

section \<open>Semantic Embedding of Carmo and Jones' Dyadic Deontic Logic (DDL) augmented with Kaplanian contexts\<close>

subsection \<open>Definition of Types\<close>

typedecl w   \<comment> \<open>  Type for possible worlds (Kaplan's "circumstances of evaluation" or "counterfactual situations")  \<close>
typedecl e   \<comment> \<open>  Type for individuals (entities eligible to become agents) \<close>
typedecl c   \<comment> \<open>  Type for Kaplanian "contexts of use" \<close>
type_synonym wo = "w\<Rightarrow>bool" \<comment> \<open>  contents/propositions are identified with their truth-sets \<close>
type_synonym cwo = "c\<Rightarrow>wo"  \<comment> \<open>  sentence meaning (Kaplan's "character") is a function from contexts to contents \<close>
type_synonym m = "cwo"      \<comment> \<open>  we use the letter 'm' for characters (reminiscent of "meaning") \<close>

subsection \<open>Semantic Characterisation of DDL\<close>

abbreviation subset::"wo\<Rightarrow>wo\<Rightarrow>bool" (infix "\<sqsubseteq>" 46) where "\<alpha> \<sqsubseteq> \<beta> \<equiv> \<forall>w. \<alpha> w  \<longrightarrow> \<beta> w"
abbreviation intersection::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<sqinter>" 48) where "\<alpha> \<sqinter> \<beta> \<equiv> \<lambda>x. \<alpha> x \<and> \<beta> x"
abbreviation union::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<squnion>" 48) where "\<alpha> \<squnion> \<beta> \<equiv> \<lambda>x. \<alpha> x \<or> \<beta> x"
abbreviation complement::"wo\<Rightarrow>wo" ("\<sim>_"[45]46) where "\<sim>\<alpha> \<equiv> \<lambda>x. \<not>\<alpha> x"
abbreviation instantiated::"wo\<Rightarrow>bool" ("\<I>_"[45]46) where "\<I> \<phi> \<equiv> \<exists>x. \<phi> x"
abbreviation setEq::"wo\<Rightarrow>wo\<Rightarrow>bool" (infix "=\<^sub>s" 46) where "\<alpha> =\<^sub>s \<beta> \<equiv> \<forall>x. \<alpha> x \<longleftrightarrow> \<beta> x"
abbreviation univSet :: "wo" ("\<top>") where "\<top> \<equiv> \<lambda>w. True"
abbreviation emptySet :: "wo" ("\<bottom>") where "\<bottom> \<equiv> \<lambda>w. False"

consts
av::"w\<Rightarrow>wo"   \<comment> \<open> set of worlds that are open alternatives (aka. actual versions) of w \<close>
pv::"w\<Rightarrow>wo"   \<comment> \<open> set of worlds that are possible alternatives (aka. potential versions) of w \<close>
ob::"wo\<Rightarrow>wo\<Rightarrow>bool" \<comment> \<open> set of propositions which are obligatory in a given context (of type wo)  \<close>

axiomatization where
sem_3a: "\<forall>w. \<I>(av w)" and \<comment> \<open>  av is serial: in every situation there is always an open alternative \<close>
sem_4a: "\<forall>w. av w \<sqsubseteq> pv w" and \<comment> \<open>  open alternatives are possible alternatives \<close>
sem_4b: "\<forall>w. pv w w" and \<comment> \<open>  pv is reflexive: every situation is a possible alternative to itself \<close>
sem_5a: "\<forall>X. \<not>(ob X \<bottom>)" and \<comment> \<open>  contradictions cannot be obligatory \<close>
sem_5b: "\<forall>X Y Z. (X \<sqinter> Y) =\<^sub>s (X \<sqinter> Z) \<longrightarrow> (ob X Y \<longleftrightarrow> ob X Z)" and
sem_5c: "\<forall>X Y Z. \<I>(X \<sqinter> Y \<sqinter> Z) \<and> ob X Y \<and> ob X Z \<longrightarrow> ob X (Y \<sqinter> Z)" and
sem_5d: "\<forall>X Y Z. (Y \<sqsubseteq> X \<and> ob X Y \<and> X \<sqsubseteq> Z) \<longrightarrow> ob Z ((Z \<sqinter> (\<sim>X)) \<squnion> Y)" and
sem_5e: "\<forall>X Y Z. Y \<sqsubseteq> X \<and> ob X Z \<and> \<I>(Y \<sqinter> Z) \<longrightarrow> ob Y Z"

subsection \<open>Verifying Semantic Conditions\<close>

lemma sem_5b1: "ob X Y \<longrightarrow> ob X (Y \<sqinter> X)" by (metis (no_types, lifting) sem_5b)
lemma sem_5b2: "(ob X (Y \<sqinter> X) \<longrightarrow> ob X Y)" by (metis (no_types, lifting) sem_5b)
lemma sem_5ab: "ob X Y \<longrightarrow> \<I>(X \<sqinter> Y)" by (metis (full_types) sem_5a sem_5b)
lemma sem_5bd1: "Y \<sqsubseteq> X \<and> ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> Y)" using sem_5b sem_5d by smt
lemma sem_5bd2: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((Z \<sqinter> (\<sim>X)) \<squnion> Y)"  using sem_5b sem_5d  by (smt sem_5b1)
lemma sem_5bd3: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> Y)"  by (smt sem_5bd2 sem_5b)
lemma sem_5bd4: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> (X \<sqinter>  Y))" using sem_5bd3 by auto
lemma sem_5bcd: "(ob X Z \<and> ob Y Z) \<longrightarrow> ob (X \<squnion> Y) Z" using sem_5b sem_5c sem_5d oops
(* 5e and 5ab justify redefinition of @{cite "O\<langle>\<phi>|\<sigma>\<rangle>"} as (ob A B)*)
lemma "ob A B \<longleftrightarrow>  (\<I>(A \<sqinter> B) \<and> (\<forall>X. X \<sqsubseteq> A \<and> \<I>(X \<sqinter> B) \<longrightarrow> ob X B))" using sem_5e sem_5ab by blast

abbreviation pand::"m\<Rightarrow>m\<Rightarrow>m" (infixr"\<^bold>\<and>" 51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<and>(\<psi> c w)"
abbreviation por::"m\<Rightarrow>m\<Rightarrow>m" (infixr"\<^bold>\<or>" 50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<or>(\<psi> c w)"
abbreviation pimp::"m\<Rightarrow>m\<Rightarrow>m" (infix"\<^bold>\<rightarrow>" 49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<longrightarrow>(\<psi> c w)"
abbreviation pequ::"m\<Rightarrow>m\<Rightarrow>m" (infix"\<^bold>\<leftrightarrow>" 48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<longleftrightarrow>(\<psi> c w)"
abbreviation pnot::"m\<Rightarrow>m" ("\<^bold>\<not>_" [52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>c w. \<not>(\<phi> c w)"

abbreviation cjboxa :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sub>a_" [52]53) where "\<^bold>\<box>\<^sub>a\<phi> \<equiv> \<lambda>c w. \<forall>v. (av w) v \<longrightarrow> (\<phi> c v)"
abbreviation cjdiaa :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sub>a_" [52]53) where "\<^bold>\<diamond>\<^sub>a\<phi> \<equiv> \<lambda>c w. \<exists>v. (av w) v \<and> (\<phi> c v)"
abbreviation cjboxp :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sub>p_" [52]53) where "\<^bold>\<box>\<^sub>p\<phi> \<equiv> \<lambda>c w. \<forall>v. (pv w) v \<longrightarrow> (\<phi> c v)"
abbreviation cjdiap :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sub>p_" [52]53) where "\<^bold>\<diamond>\<^sub>p\<phi> \<equiv> \<lambda>c w. \<exists>v. (pv w) v \<and> (\<phi> c v)"
abbreviation cjtaut :: "m" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>c w. True"
abbreviation cjcontr :: "m" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>c w. False"

abbreviation cjod :: "m\<Rightarrow>m\<Rightarrow>m" ("\<^bold>O\<langle>_|_\<rangle>"54) where "\<^bold>O\<langle>\<phi>|\<sigma>\<rangle> \<equiv> \<lambda>c w. ob (\<sigma> c) (\<phi> c)"
abbreviation cjos :: "m\<Rightarrow>m" ("\<^bold>O\<langle>_\<rangle>"[53]54) where "\<^bold>O\<langle>\<phi>\<rangle> \<equiv> \<^bold>O\<langle>\<phi>|\<^bold>\<top>\<rangle>"
abbreviation cjoa :: "m\<Rightarrow>m" ("\<^bold>O\<^sub>a_" [53]54) where "\<^bold>O\<^sub>a\<phi> \<equiv> \<lambda>c w. (ob (av w)) (\<phi> c) \<and> (\<exists>x. (av w) x \<and> \<not>(\<phi> c x))"
abbreviation cjop :: "m\<Rightarrow>m" ("\<^bold>O\<^sub>i_" [53]54) where "\<^bold>O\<^sub>i\<phi> \<equiv> \<lambda>c w. (ob (pv w)) (\<phi> c) \<and> (\<exists>x. (pv w) x \<and> \<not>(\<phi> c x))"

abbreviation modvalidctx :: "m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>M") where "\<lfloor>\<phi>\<rfloor>\<^sup>M \<equiv> \<lambda>c. \<forall>w. \<phi> c w" \<comment> \<open> context-dependent modal validity \<close>
abbreviation modvalid :: "m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<phi>\<rfloor> \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sup>M c" \<comment> \<open> general modal validity (modally valid in each context) \<close>

abbreviation mboxS5 :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>S\<^sup>5_" [52]53) where "\<^bold>\<box>\<^sup>S\<^sup>5\<phi> \<equiv> \<lambda>c w. \<forall>v. \<phi> c v"
abbreviation mdiaS5 :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sup>S\<^sup>5_" [52]53) where "\<^bold>\<diamond>\<^sup>S\<^sup>5\<phi> \<equiv> \<lambda>c w. \<exists>v. \<phi> c v"

subsection \<open>Verifying the Embedding\<close>

lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>" nitpick oops \<comment> \<open> (actual) deontic modal collapse is countersatisfiable \<close>
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>iP\<rfloor>" nitpick oops \<comment> \<open> (ideal) deontic modal collapse is countersatisfiable \<close>
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>" nitpick oops \<comment> \<open> alethic modal collapse is countersatisfiable (implies all other necessity operators) \<close>

lemma NecDDLa: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>"    by simp (* Valid only using classical (not  Kaplan's indexical) validity*)
lemma NecDDLp:  "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>"   by simp (* Valid only using classical (not  Kaplan's indexical) validity*)

subsection \<open>Verifying Axiomatic Characterisation and C&J Theorems\<close>

lemma C_2: "\<lfloor>\<^bold>O\<langle>A | B\<rangle> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sup>S\<^sup>5(B \<^bold>\<and> A)\<rfloor>"   by (simp add: sem_5ab)
lemma C_3:  "\<lfloor>((\<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> B \<^bold>\<and> C)) \<^bold>\<and> \<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>(B \<^bold>\<and> C)| A\<rangle>\<rfloor>"   by (simp add: sem_5c)
lemma C_4: "\<lfloor>(\<^bold>\<box>\<^sup>S\<^sup>5(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<langle>C|B\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>C|A\<rangle>\<rfloor>"   using sem_5e by blast
lemma C_5: "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<langle>C|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>C|B\<rangle>)\<rfloor>"   using sem_5ab sem_5e by blast
lemma C_6: "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)) \<^bold>\<rightarrow> (\<^bold>O\<langle>A|C\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>B|C\<rangle>)\<rfloor>"   by (metis sem_5b)
lemma C_7: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>S\<^sup>5\<^bold>O\<langle>B|A\<rangle>\<rfloor>"   by blast
lemma C_8: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>A \<^bold>\<rightarrow> B| \<^bold>\<top>\<rangle>\<rfloor>" using sem_5bd4   by presburger

lemma CJ_3: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aA\<rfloor>"   by (simp add: sem_4a)
lemma CJ_4: "\<lfloor>\<^bold>\<not>\<^bold>O\<langle>\<^bold>\<bottom>|A\<rangle>\<rfloor>"   by (simp add: sem_5a)
lemma CJ_5: "\<lfloor>(\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>B\<^bold>\<and>C|A\<rangle>\<rfloor>"   nitpick oops \<comment> \<open> countermodel found \<close>
lemma CJ_5_minus: "\<lfloor>\<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> (\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>B\<^bold>\<and>C|A\<rangle>\<rfloor>"   by (simp add: sem_5c)
lemma CJ_6: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>B|A\<^bold>\<and>B\<rangle>\<rfloor>"   by (smt C_2 C_4)
lemma CJ_7: "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<langle>C|A\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>C|B\<rangle>\<rfloor>"   using sem_5ab sem_5e by blast (* Valid only using classical (not Kaplan's indexical) validity*)
lemma CJ_8: "\<lfloor>C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<langle>A|C\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>B|C\<rangle>\<rfloor>"   using C_6 by simp (* Valid only using classical (not Kaplan's indexical) validity*)
lemma CJ_9a: "\<lfloor>\<^bold>\<diamond>\<^sub>p\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p\<^bold>O\<langle>B|A\<rangle>\<rfloor>"   by simp
lemma CJ_9p: "\<lfloor>\<^bold>\<diamond>\<^sub>a\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>a\<^bold>O\<langle>B|A\<rangle>\<rfloor>"   by simp
lemma CJ_9_var_a: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>a\<^bold>O\<langle>B|A\<rangle>\<rfloor>"   by simp
lemma CJ_9_var_b: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p\<^bold>O\<langle>B|A\<rangle>\<rfloor>"   by simp

section \<open>Extending the Carmo and Jones DDL Logical Framework\<close>

consts Agent::"c\<Rightarrow>e"  \<comment> \<open> function retrieving the agent corresponding to context c \<close>
consts World::"c\<Rightarrow>w"  \<comment> \<open> function retrieving the world corresponding to context c \<close>

abbreviation ldtruectx::"m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>_") where "\<lfloor>\<phi>\<rfloor>\<^sub>c \<equiv> \<phi> c (World c)" \<comment> \<open>  truth in the given context \<close>
abbreviation ldvalid::"m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>D") where "\<lfloor>\<phi>\<rfloor>\<^sup>D \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sub>c" \<comment> \<open> LD validity (true in every context) \<close>

lemma "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>A\<rfloor>\<^sup>D" by simp
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>A\<rfloor>" nitpick oops \<comment> \<open> countermodel found \<close>

lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>\<^sup>D" nitpick oops
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>\<^sup>D" nitpick oops

lemma NecLDa: "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>\<^sup>D"  nitpick oops
lemma NecLDp:  "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>\<^sup>D" nitpick oops

abbreviation ldvalidbox :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>D_" [52]53) where "\<^bold>\<box>\<^sup>D\<phi> \<equiv> \<lambda>c w. \<lfloor>\<phi>\<rfloor>\<^sup>D" \<comment> \<open> notice the D superscript \<close>
lemma "\<lfloor>\<^bold>\<box>\<^sup>D\<phi>\<rfloor>\<^sub>C \<equiv> \<forall>c.\<lfloor>\<phi>\<rfloor>\<^sub>c" by simp \<comment> \<open>  this operator works analogously to the box operator in modal logic S5 \<close>

lemma NecLD: "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sup>DA\<rfloor>\<^sup>D"  by simp

abbreviation mforall::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>c w.\<forall>x. (\<Phi> x c w)"
abbreviation mexists::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>c w.\<exists>x. (\<Phi> x c w)"
abbreviation mforallBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. (\<phi> x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexistsBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. (\<phi> x) \<equiv> \<^bold>\<exists>\<phi>"

type_synonym cwe = "c\<Rightarrow>w\<Rightarrow>e" \<comment> \<open>type alias for indexical individual terms\<close>
abbreviation cthe::"(c\<Rightarrow>w\<Rightarrow>e\<Rightarrow>bool)\<Rightarrow>cwe" ("the") where "the \<phi> \<equiv> \<lambda>c w. THE x. \<phi> c w x"
abbreviation ctheBinder::"(c\<Rightarrow>w\<Rightarrow>e\<Rightarrow>bool)\<Rightarrow>cwe" (binder"the"[8]9) where "the x. (\<phi> x) \<equiv> the \<phi>"

abbreviation dthat::"cwe\<Rightarrow>cwe" ("dthat[_]" [62]63) where "dthat[\<alpha>] \<equiv> \<lambda>c w. \<alpha> c (World c)"
abbreviation Dthat::"(c\<Rightarrow>w\<Rightarrow>e\<Rightarrow>bool)\<Rightarrow>cwe" ("Dthat[_]" [62]63) where "Dthat[\<alpha>] \<equiv> dthat[the \<alpha>] "

abbreviation ceq:: "cwe\<Rightarrow>cwe\<Rightarrow>m" (infix "\<^bold>\<approx>" 60)  where "\<alpha> \<^bold>\<approx> \<beta> \<equiv> \<lambda>c w. \<alpha> c w = \<beta> c w" (**standard equality for characters*)

lemma "\<lfloor>\<alpha> \<^bold>\<approx> dthat[\<alpha>]\<rfloor>\<^sup>D" by simp \<comment> \<open>using indexical validity\<close>
lemma "\<lfloor>\<alpha> \<^bold>\<approx> dthat[\<alpha>]\<rfloor>" nitpick oops  \<comment> \<open>counterexample if using classical validity\<close>
lemma "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(\<alpha> \<^bold>\<approx> dthat[\<alpha>])\<rfloor>\<^sup>D" nitpick oops  \<comment> \<open>counterexample\<close>
lemma "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(dthat[\<beta>] \<^bold>\<approx> dthat[\<alpha>])\<rfloor>\<^sub>x\<Longrightarrow>\<lfloor>(dthat[\<beta>] \<^bold>\<approx> dthat[\<alpha>])\<rfloor>\<^sup>D" nitpick oops  \<comment> \<open>counterexample\<close>
lemma "\<lfloor>dthat[\<beta>] \<^bold>\<approx> dthat[\<alpha>]\<rfloor>\<^sup>D \<longleftrightarrow> \<lfloor>\<beta> \<^bold>\<approx> \<alpha>\<rfloor>\<^sup>D" by simp
lemma "\<lfloor>dthat[\<beta>] \<^bold>\<approx> dthat[\<alpha>] \<^bold>\<leftrightarrow> (\<beta> \<^bold>\<approx> \<alpha>) \<rfloor>\<^sup>D" by simp

abbreviation cactually :: "m\<Rightarrow>m" ("\<^bold>\<A>_" [52]53) where "\<^bold>\<A>\<phi> \<equiv> \<lambda>c w. \<phi> c (World c)"

lemma "\<lfloor>\<phi> \<^bold>\<leftrightarrow> \<^bold>\<A>\<phi>\<rfloor>\<^sup>D" by simp
lemma "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(\<phi> \<^bold>\<leftrightarrow> \<^bold>\<A>\<phi>)\<rfloor>\<^sup>D" nitpick oops
lemma "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(\<phi> \<^bold>\<leftrightarrow> \<^bold>\<A>\<phi>)\<rfloor>" nitpick oops
lemma "\<lfloor>\<phi>\<rfloor>\<^sup>D \<longleftrightarrow>  \<lfloor>\<^bold>\<A>\<phi>\<rfloor> " by simp

abbreviation stable::"m\<Rightarrow>c\<Rightarrow>bool" where "stable \<phi> c \<equiv> \<forall>w. \<phi> c w \<longrightarrow> \<lfloor>\<phi>\<rfloor>\<^sup>M c"
abbreviation stableCharacter::"m\<Rightarrow>bool" where "stableCharacter \<phi> \<equiv> \<forall>c. stable \<phi> c"

lemma "\<forall>c. stable (\<^bold>\<A>\<phi>) c" by simp \<comment> \<open> (i)\<close>
lemma "stableCharacter \<phi> \<longrightarrow> (\<lfloor>\<phi>\<rfloor>\<^sup>D \<longrightarrow> \<lfloor>\<phi>\<rfloor>)" by blast \<comment> \<open> (ii)\<close>
lemma "stableCharacter \<phi> \<longrightarrow> (\<lfloor>\<phi>\<rfloor>\<^sup>D \<longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>a\<phi>\<rfloor>\<^sup>D)" by blast  \<comment> \<open> (iii)\<close>
lemma "\<lfloor>\<phi>\<rfloor>\<^sup>D \<longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>a\<phi>\<rfloor>\<^sup>D" nitpick oops \<comment> \<open>counterexample in the general case\<close>

(*<*)
end
(*>*)