theory Blockchain
  imports Main "HOL-Library.Tree"
begin

(* -- TYPES / Hash / Block Datatype / BlockTree Datatype --*)
type_synonym Transactions = nat
type_synonym Party = nat
type_synonym Slot = nat

datatype Hash = H nat nat

definition "Slotzero = 0"
type_synonym Parties = "Party list"

fun Winner :: "Party \<Rightarrow> Slot \<Rightarrow> bool" where
"Winner P S = (if P = S then True else False)"

record Block =
  sl :: Slot
  txs :: Transactions
  pred :: Hash
  bid :: Party

type_synonym Chain = "Block list"
type_synonym Chains = "Chain list"
type_synonym BlockPool = "Block list"

definition "GenBlock = \<lparr>sl = 0, txs = 0, pred = H 0 0 ,bid = 0\<rparr>"
definition "Block1 = \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 1\<rparr>"
definition "Block2 = \<lparr> sl = 2, txs = 0, pred = H 1 1, bid = 1\<rparr>"
definition "Block3 = \<lparr> sl = 3, txs = 0, pred = H 2 1, bid = 1\<rparr>"

datatype T = Leaf | Node Block T T

definition "tree0 = Node GenBlock Leaf Leaf"

(*-- Functions for valid_chain --*)
fun HashCompare' :: "Hash \<Rightarrow> Block \<Rightarrow> bool" where
"HashCompare' (H a b) bl1 = ((a = sl bl1) \<and> (b = bid bl1))"

fun HashCompare :: "Block \<Rightarrow> Block \<Rightarrow> bool" where
"HashCompare bl1 bl2 = HashCompare' (pred bl2) bl1"

fun valid_blocks ::"Block \<Rightarrow> Block \<Rightarrow> bool" where
"valid_blocks b1 b2 =  ( HashCompare b2 b1 \<and>(sl b2 < sl b1))"

fun valid_chain :: "Chain \<Rightarrow> bool" where
"valid_chain [] = False"|
"valid_chain [b1] = (if b1 = GenBlock then True else False)"|
"valid_chain (b1#b2#c) = (if valid_blocks b1 b2 \<and> (b1 \<noteq> GenBlock) then valid_chain (b2#c) else False)"

fun block_get where
"block_get (Node m l r) = m"|
"block_get Leaf = GenBlock"

fun valid_t_weak where
"valid_t_weak (Node m Leaf Leaf) = True"|
"valid_t_weak (Node m Leaf r) = ((valid_blocks (block_get r) m )\<and> valid_t_weak r)"|
"valid_t_weak (Node m l Leaf) = ((valid_blocks (block_get l) m )\<and> valid_t_weak l)"|
"valid_t_weak (Node m l r) =
(valid_blocks (block_get l) m  \<and> valid_blocks (block_get r) m \<and> valid_t_weak r \<and> valid_t_weak l)"|
"valid_t_weak Leaf = True"

fun hash_t where
"hash_t (Node m Leaf Leaf) = True"|
"hash_t (Node m Leaf r) = ((HashCompare m (block_get r)  )\<and> hash_t r)"|
"hash_t (Node m l Leaf) = ((HashCompare m (block_get l)  )\<and> hash_t l)"|
"hash_t(Node m l r) =
(HashCompare m (block_get l)  \<and> HashCompare m (block_get r)  \<and> hash_t r \<and> hash_t l)"|
"hash_t Leaf = True"

fun sl_t where
"sl_t (Node m Leaf Leaf) = True"|
"sl_t (Node m Leaf r) = ((sl m < sl (block_get r)  )\<and> sl_t r)"|
"sl_t (Node m l Leaf) = ((sl m < sl (block_get l)  )\<and> sl_t l)"|
"sl_t(Node m l r) =
(sl m < sl (block_get l)  \<and> sl m < sl (block_get r)  \<and> sl_t r \<and> sl_t l)"|
"sl_t Leaf = True"

(*-- Functions for allBlocks/allBlocks' and extendTree --*)
fun allBlocks :: "T \<Rightarrow> BlockPool" where
"allBlocks (Node m l r) = allBlocks l @ allBlocks r @ [m]"|
"allBlocks Leaf = []"

fun allBlocksAppend :: "Block \<Rightarrow>BlockPool list\<Rightarrow> BlockPool list" where
"allBlocksAppend Bl BlP = (map (\<lambda> bl. bl @ [Bl]) BlP)"

fun allBlocks' :: "T \<Rightarrow> BlockPool list" where
"allBlocks' (Node m l r) =( allBlocksAppend m (allBlocks' l) @allBlocksAppend m (allBlocks' r))"|
"allBlocks' Leaf = [[]]"

fun valid_t where
"valid_t Leaf = True"|
"valid_t t = (\<forall>c\<in>set(allBlocks' t).valid_chain c)"

value "allBlocks' (Node GenBlock (Node Block1 Leaf (Node Block2 (Node Block3 (Node Block4 Leaf (Node Block6 Leaf Leaf)) Leaf) (Node Block5 Leaf Leaf))) Leaf)"

fun extendTree :: "T \<Rightarrow> Block \<Rightarrow> T" where
"extendTree (Node Bl1 Leaf Leaf) Bl2 =  (
  if valid_blocks Bl2 Bl1 then (Node Bl1 (Node Bl2 Leaf Leaf) Leaf)
  else (Node Bl1 Leaf Leaf)) "|
"extendTree (Node Bl1 t1 Leaf) Bl2 =  (
  if valid_blocks Bl2 Bl1 then (Node Bl1 t1 (Node Bl2 Leaf Leaf))
  else (Node Bl1 (extendTree t1 Bl2) Leaf))"|
"extendTree (Node Bl1 Leaf t1) Bl2 =  (
  if valid_blocks Bl2 Bl1 then (Node Bl1 (Node Bl2 Leaf Leaf) t1)
  else (Node Bl1  Leaf (extendTree t1 Bl2)))"|
"extendTree (Node Bl1 t1 t2) Bl2 =(Node Bl1 (extendTree t1 Bl2) (extendTree t2 Bl2))"|
"extendTree Leaf Bl2 = Leaf"

(*-- Functions for finding best_chain --*)

fun best_c :: "Slot \<Rightarrow> BlockPool list \<Rightarrow> (Block list \<times> nat \<times> bool) option"where
"best_c slot list = (let list' = map (\<lambda> l. (l,sl (hd l), valid_chain l)) list
  in find (\<lambda> (c,s,v).v\<and>(s\<le>slot)) list')"

fun get_first :: "(Block list \<times> nat \<times> bool) option \<Rightarrow>Block list" where
"get_first a = (case a of None \<Rightarrow> [] | Some a \<Rightarrow> fst a)"

fun best_chain :: "Slot \<Rightarrow> T \<Rightarrow> Chain" where
"best_chain s Leaf = []"|
"best_chain s (Node x l r) = (if s > 0 then get_first ( best_c s (allBlocks' (Node x l r)))else [GenBlock])"

fun block_eq :: "Block \<Rightarrow> Block \<Rightarrow> bool" where
"block_eq bl1 b2 = ((sl bl1 = sl b2)\<and>(txs bl1 = txs b2)\<and>(pred bl1 = pred b2)\<and>(bid bl1 = bid b2))"

fun blockpool_eq_set :: "BlockPool \<Rightarrow> BlockPool \<Rightarrow> bool" where
"blockpool_eq_set bpl1 bpl2 = (set(bpl1) = set(bpl2)) "

fun blockpool_eq :: "BlockPool \<Rightarrow> BlockPool \<Rightarrow> bool" where
"blockpool_eq Nil Nil= True"|
"blockpool_eq a b = (((set a \<inter> set b) =set a)\<and>((set a \<inter> set b) =set b))"

fun blocktree_eq :: "T \<Rightarrow> T \<Rightarrow> bool" where
"blocktree_eq (Node t1 t2 t3) (Node t_1 t_2 t_3) =((Node t1 t2 t3) = (Node t_1 t_2 t_3))"|
"blocktree_eq Leaf b = False"|
"blocktree_eq a Leaf = False"

(* Unit Testing Code*)

definition "test_tree_bad = (Node GenBlock (Node \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 1\<rparr>
 (Node \<lparr>sl = 2, txs =1, pred = H 1 1, bid = 1\<rparr> Leaf Leaf) Leaf) (Node \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 4\<rparr>
Leaf (Node \<lparr>sl = 2, txs =1, pred = H 1 1, bid = 1\<rparr> Leaf Leaf)))"
definition "test_tree_bad2 = (Node GenBlock (Node \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 1\<rparr>
 (Node \<lparr>sl = 2, txs =1, pred = H 1 1, bid = 1\<rparr> Leaf Leaf) Leaf) (Node \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 4\<rparr>
Leaf (Node \<lparr>sl = 2, txs =1, pred = H 1 1, bid = 4\<rparr> Leaf Leaf)))"
definition "test_tree = (Node GenBlock
(Node \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 1\<rparr> (Node \<lparr>sl = 2, txs =1, pred = H 1 1, bid = 1\<rparr>
 (Node \<lparr>sl = 3, txs =1, pred = H 2 1, bid = 6\<rparr> Leaf Leaf) Leaf) Leaf)
 (Node \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 4\<rparr> Leaf (Node \<lparr>sl = 2, txs =1, pred = H 1 4, bid = 1\<rparr> Leaf Leaf)))"
definition "extend_block = \<lparr>sl = 4, txs = 1, pred = H 3 6, bid = 4\<rparr>"

value "valid_blocks Block3 Block2"
value "valid_chain [Block1,GenBlock]"
value "Block1 # [GenBlock]"

value "(extendTree tree0 Block1) = (Node GenBlock (Node Block1 Leaf Leaf)  Leaf)"
value "extendTree (T.Node \<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr> T.Leaf (T.Node \<lparr>sl = 1, txs = 0, pred = H 0 0, bid = 0\<rparr> T.Leaf T.Leaf))  \<lparr>sl =1 , txs = 0, pred = H 0 0, bid = 0\<rparr> "
value "valid_chain  (\<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr>#[\<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 1\<rparr>])"

value "valid_chain [Block3,Block2,Block1,GenBlock]"
value "valid_chain [\<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr>, \<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr>, \<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr>]"
value "HashCompare  \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr> \<lparr>sl = 2, txs = 1, pred = H 1 1, bid = 2\<rparr>"

value "HashCompare GenBlock Block1"
value "HashCompare Block1 Block2"
value "HashCompare Block2 Block3"
value "HashCompare GenBlock Block2"
value "HashCompare Block2 Block1"
value "HashCompare Block1 GenBlock"

value "valid_blocks Block1 GenBlock"
value "valid_blocks Block2 Block1"
value "valid_blocks Block3 Block2"
value "valid_blocks Block2 Block3"
value "b#[c]"

value "valid_t test_tree_bad"

value "valid_t test_tree_bad2"

value "valid_t test_tree"

value "best_chain 0 test_tree"

value "best_chain 3 test_tree"

value "best_chain 4 (extendTree test_tree extend_block)"

value "valid_chain(best_chain 4 (extendTree test_tree extend_block))"

value "valid_chain [\<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr>, \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr>, \<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr>]"

value "best_c (3::nat) (allBlocks'((Node GenBlock (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr> (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf) Leaf)
 (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf))) )"

value "best_chain 10  ((Node GenBlock (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr> (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf) Leaf)
 (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf)))"

value "best_c (3::nat) (allBlocks' ((Node GenBlock (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr>  Leaf Leaf)
 (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 2\<rparr> Leaf Leaf))))"

value "allBlocks' ((Node GenBlock (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr> (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf) Leaf)
 (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf)))"

value "valid_chain (best_chain 0 (Node GenBlock (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr> (Node \<lparr>sl = 1, txs = 1, pred = H 1 1, bid = 1\<rparr> (Node \<lparr>sl = 2, txs = 2, pred = H 1 1, bid = 2\<rparr> Leaf Leaf) Leaf) Leaf)
 (Node \<lparr>sl = 1, txs = 1, pred = H 1 1, bid = 1\<rparr> Leaf Leaf)))"

value "best_chain 2  ((Node GenBlock (Node \<lparr>sl = 1, txs = 1, pred = H 0 0, bid = 1\<rparr> (Node \<lparr>sl = 1, txs = 1, pred = H 1 1, bid = 1\<rparr> Leaf Leaf) Leaf)
 (Node \<lparr>sl = 1, txs = 1, pred = H 1 1, bid = 1\<rparr> Leaf Leaf)))"
value "allBlocks'  (Node \<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 1\<rparr> Leaf Leaf)"

value "valid_chain (best_chain 4 (T.Node \<lparr>sl = 0, txs = 0, pred = H 0 0, bid = 0\<rparr> T.Leaf T.Leaf))"

definition "testblock = \<lparr>sl = 1, txs = 1, pred = H 2 1, bid = 1 \<rparr>"

definition "testblock2 = \<lparr>sl = 2, txs = 1, pred = H 1 1, bid = 1 \<rparr>"

value "extendTree (Node testblock Leaf Leaf) testblock2"
value"allBlocks (extendTree (Node testblock Leaf Leaf) testblock2)"
value"allBlocks (Node testblock Leaf Leaf)@[testblock2]"
value"blockpool_eq (allBlocks (extendTree (Node testblock Leaf Leaf) testblock2)) (allBlocks (Node testblock Leaf Leaf)@[testblock2])"
value"blockpool_eq_set (allBlocks (extendTree (Node testblock Leaf Leaf) testblock2)) (allBlocks (Node testblock Leaf Leaf)@[testblock2])"

(*-- LEMMAS + PROOFS -- *)

export_code HashCompare' HashCompare GenBlock  blockpool_eq_set  block_eq valid_blocks valid_chain  allBlocks allBlocksAppend allBlocks' tree0 extendTree valid_t valid_t_weak best_c get_first best_chain blocktree_eq  in Haskell

lemma initialTree : "allBlocks tree0 = [GenBlock]"
  by (simp add: GenBlock_def tree0_def)

lemma initialExtend : "(extendTree tree0 b \<noteq> tree0)
\<Longrightarrow> set (allBlocks (extendTree tree0 b)) = set ([b]@ allBlocks tree0)"
  apply(simp add : GenBlock_def tree0_def)
  by auto

lemma base_best_valid :"valid_chain(best_chain s (Node GenBlock Leaf Leaf))"
  apply(auto) apply(simp add:GenBlock_def) done

lemma initialExtendValid : "valid_t tree0 \<Longrightarrow>valid_t (extendTree tree0 b)"
  apply(simp add: GenBlock_def tree0_def) done

lemma initialExtendweakValid : "valid_t_weak tree0 \<Longrightarrow>valid_t_weak (extendTree tree0 b)"
  by (simp add: tree0_def)

lemma initialBestChain : "valid_t (extendTree tree0 b)
\<Longrightarrow> valid_chain( best_chain s (extendTree tree0 b)) "
  apply(simp add: GenBlock_def tree0_def) done

lemma ExtendInitial : "(extendTree tree0 Block1) = (Node GenBlock (Node Block1 Leaf Leaf) Leaf)"
  by (simp add: GenBlock_def tree0_def Block1_def)

lemma "extendTree Leaf B = Leaf"
  by simp

lemma SameBlock : assumes "block_eq bl1 bl2" shows "bl1 = bl2"
  using assms apply(auto) done

lemma SamePool : assumes "blockpool_eq (x) (y)" shows "set x = set y"
  using assms
  by (smt (verit, best) blockpool_eq.elims(2))

lemma SameTreeBase : assumes "blocktree_eq T1 T2" shows "T1 = T2"
  using assms SameBlock
  using blocktree_eq.elims(2) by blast

lemma SameTree : assumes "blocktree_eq T1 T2" shows "blockpool_eq (allBlocks T1) (allBlocks T2)"
  using assms SamePool
  by (metis (no_types, opaque_lifting) SameTreeBase blockpool_eq.simps(1) blockpool_eq.simps(3) inf.idem valid_chain.cases)

lemma BaseExtend : "(extendTree t b \<noteq> t)
\<Longrightarrow> set (allBlocks (extendTree t b)) = set ([b]@ allBlocks t)"
proof(induction "t")
  case Leaf
  then show ?case
    by simp
next
  case (Node x1 t1 t2) note Nodex1 = this
  then show ?case proof (cases "t1")
    case Leaf note Leaft1 = this
    then show ?thesis proof (cases "t2")
      case Leaf
      then show ?thesis using Nodex1 Leaft1
        by auto
    next
      case (Node x21 x22 x23)
      then show ?thesis using Nodex1 Leaft1
        by auto
    qed
  next
    case (Node x21 x22 x23) note Nodet1 = this
    then show ?thesis proof (cases "t2")
      case Leaf
      then show ?thesis using Nodex1 Nodet1
        by auto
    next
      case (Node x21 x22 x23)
      then show ?thesis using Nodex1 Nodet1
        by fastforce
    qed
  qed
qed

lemma GenExtend : assumes "valid_t t\<and> extendTree t b \<noteq> t" shows
"set (allBlocks (extendTree t b)) =set ([b]@ allBlocks t)"
proof(cases "t")
  case Leaf note LeafCase = this
  then show ?thesis using assms LeafCase
    by simp
next
  case (Node x1 t1 t2) note t1Node = this
  then show ?thesis proof(cases "t1")
    case Leaf note t2Leaf = this
    then show ?thesis proof(cases "t2")
      case Leaf
      then show ?thesis using t1Node t2Leaf assms BaseExtend apply(auto)done
    next
      case (Node x21 x22 x23)
      then show ?thesis using t1Node t2Leaf assms  BaseExtend apply(auto) done
    qed
  next
    case (Node x1 t11 t12)
    then show ?thesis using assms BaseExtend apply(auto) done
  qed
qed

lemma best_c_none : "best_c n [] = None"
  by(simp)

lemma find_in : \<open>find p ls = Some l\<Longrightarrow> l\<in> set(ls)\<close>
proof(induction ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  then show ?case
    by (metis find_Some_iff nth_mem)
qed

lemma best_c_in : "best_c n bl \<noteq> None \<Longrightarrow> get_first(best_c n bl) \<in> set(bl)"
  apply(simp add: find_in)
proof(induction bl)
  case Nil
  then show ?case
    by simp
next
  case (Cons a bl)
  then show ?case
    by auto
qed

lemma slThan : assumes "r \<noteq> Leaf \<and> l\<noteq>Leaf\<and>valid_t_weak (Node m l r)\<and>block_get (Node m l r) = m"
  shows "( sl m < sl (block_get r) \<and> sl m < sl(block_get l))"
  using assms apply(auto) apply(rule valid_t_weak.cases)
  apply auto[1]
  apply simp+
   apply (metis allBlocks.elims valid_blocks.elims(2) valid_t_weak.simps(4))
  apply(rule block_get.cases)
  apply auto[1]
  by (metis allBlocks.elims valid_blocks.elims(2) valid_t_weak.simps(4))

lemma predThan : assumes "r \<noteq> Leaf \<and> l\<noteq>Leaf\<and>valid_t_weak (Node m l r)"
  shows "( HashCompare m (block_get r) \<and> HashCompare m (block_get l))"
  using assms apply(auto) apply(rule valid_t_weak.cases)
  apply auto[1]  apply simp+apply(rule block_get.cases)  apply blast
  apply (metis HashCompare.elims(2) valid_blocks.elims(2) valid_t.cases valid_t_weak.simps(5))
  by (metis (no_types, lifting) HashCompare.elims(2)
      block_get.elims valid_blocks.elims(2) valid_t_weak.simps(5))

lemma slThan2 : assumes "r \<noteq> Leaf \<and> l\<noteq>Leaf\<and> sl_t (Node m l r)\<and>block_get (Node m l r) = m"
  shows "( sl m < sl (block_get r) \<and> sl m < sl(block_get l))"
  using assms apply(auto) apply(rule valid_t_weak.cases)
  apply auto[1]
  apply simp+
  apply (metis T.distinct(1) T.inject  assms block_get.elims sl_t.simps(5))
  by (metis block_get.elims sl_t.simps(4))

lemma predThan2 : assumes "r \<noteq> Leaf \<and> l\<noteq>Leaf\<and>hash_t(Node m l r)"
  shows "( HashCompare m (block_get r) \<and> HashCompare m (block_get l))"
  using assms predThan apply(auto) apply(rule valid_t_weak.cases)
  apply auto[1]   apply simp+ apply(rule block_get.cases)  apply blast
  apply (metis HashCompare.elims(2) block_get.elims hash_t.simps(5))
  by (metis HashCompare.elims(2) block_get.elims hash_t.simps(5))

(* DRAFTS FOR UNFINISHED PROOFS *)
lemma hashAll : assumes "valid_t_weak(Node m l r)" shows "(hash_t (Node m l r))"
 proof(cases "l")
   case Leaf note lleaf=this
   then show ?thesis proof(cases "r")
     case Leaf
     then show ?thesis using assms
       by (simp add: lleaf)
   next
     case (Node x21 x22 x23)
     then show ?thesis using assms lleaf predThan predThan2 apply(auto) oops
   qed
   next
   case (Node x21 x22 x23) note rnode=this
   then show ?thesis proof(cases "r")
     case Leaf
     then show ?thesis using assms rnode apply(auto) oops
   next
     case (Node x1 t1 t2)
     then show ?thesis using assms rnode slThan slThan2 predThan predThan2 apply(auto) apply(rule valid_t_weak.cases)
  apply auto[1]   apply simp+ apply(rule block_get.elims)  apply blast apply blast apply(simp add: GenBlock_def) oops
   qed
 qed

lemma validSame : assumes "valid_t_weak t" shows "sl_t t \<and> hash_t t"
proof(cases "t")
  case Leaf
  then show ?thesis by simp
next
  case (Node x21 x22 x23)
  then show ?thesis using assms apply(auto) oops
qed

lemma slThanAll : assumes "r\<noteq>Leaf \<and>l \<noteq>Leaf\<and>valid_t_weak(Node m l r)" shows "(sl_t (Node m l r))"
 proof(cases "l")
   case Leaf note lleaf=this
   then show ?thesis proof(cases "r")
     case Leaf
     then show ?thesis using assms
       by simp
   next
     case (Node x21 x22 x23)
     then show ?thesis using assms lleaf
       by simp
   qed
   next
   case (Node x21 x22 x23) note rnode=this
   then show ?thesis proof(cases "r")
     case Leaf
     then show ?thesis using assms rnode
       by simp
   next
     case (Node x1 t1 t2)
     then show ?thesis using assms rnode slThan slThan2 apply(auto) oops
   qed
 qed

lemma validExtend : assumes "valid_t_weak t" shows "valid_t_weak (extendTree t b)"
proof(cases "t")
  case Leaf
  then show ?thesis
    by simp
next
  case (Node x1 t1 t2) note t = this
  then show ?thesis proof(cases "t1")
    case Leaf note leaft1=this
    then show ?thesis proof(cases "t2")
      case Leaf
      then show ?thesis using assms leaft1 t apply(auto) done
    next
      case (Node x21 x22 x23)
      then show ?thesis  using assms leaft1 t  initialExtendweakValid slThan
        apply(simp add: tree0_def GenBlock_def) apply(auto)
        apply(rule HashCompare'.cases HashCompare'.elims HashCompare'.simps)
        apply(rule valid_t_weak.cases valid_t_weak.elims valid_t_weak.simps valid_t_weak.induct)
        apply(rule extendTree.cases extendTree.elims extendTree.simps extendTree.induct)
        apply(rule block_get.cases block_get.elims block_get.simps)
        apply auto[1] apply(rule valid_t.cases valid_t.elims valid_t.simps valid_t_weak.induct)
        apply(simp+)  oops
    qed
  next
    case (Node x21 x22 x23)
    then show ?thesis oops
  qed
qed

lemma best_valid: assumes "x = GenBlock\<and>valid_t_weak (Node x l r)"
  shows "valid_chain (best_chain s (Node x l r))"
proof(cases "l")
  case Leaf note lleaf = this
  then show ?thesis proof(cases "r")
    case Leaf
    then show ?thesis using assms lleaf apply(auto) apply(simp add: GenBlock_def) done
  next
    case (Node x21 x22 x23)
    then show ?thesis using assms lleaf apply(auto) apply(simp add: GenBlock_def) done
  qed
next
  case (Node x21 x22 x23) note lnode = this
  then show ?thesis proof(cases "r")
    case Leaf
    then show ?thesis using assms lnode find_in best_c_in base_best_valid apply(auto)
      apply(simp add: GenBlock_def find_def o_def) oops
  next
    case (Node x1 x2 x3)
    then show ?thesis using assms lnode find_in best_c_in base_best_valid apply(auto)
      apply(simp add: GenBlock_def append_def find_def map_def set_def) oops
  qed
qed


theory Environment_Functor imports
  Applicative_Lifting.Applicative_Environment
begin

subsection \<open>The environment functor\<close>

type_synonym ('i, 'a) envir = "'i \<Rightarrow> 'a"

lemma const_apply [simp]: "const x i = x"
by(simp add: const_def)

context includes applicative_syntax begin

lemma ap_envir_apply [simp]: "(f \<diamondop> x) i = f i (x i)"
by(simp add: apf_def)

definition all_envir :: "('i, bool) envir \<Rightarrow> bool"
where "all_envir p \<longleftrightarrow> (\<forall>x. p x)"

lemma all_envirI [Pure.intro!, intro!]: "(\<And>x. p x) \<Longrightarrow> all_envir p"
by(simp add: all_envir_def)

lemma all_envirE [Pure.elim 2, elim]: "all_envir p \<Longrightarrow> (p x \<Longrightarrow> thesis) \<Longrightarrow> thesis"
by(simp add: all_envir_def)

lemma all_envirD: "all_envir p \<Longrightarrow> p x"
by(simp add: all_envir_def)

definition pred_envir :: "('a \<Rightarrow> bool) \<Rightarrow> ('i, 'a) envir \<Rightarrow> bool"
where "pred_envir p f = all_envir (const p \<diamondop> f)"

lemma pred_envir_conv: "pred_envir p f \<longleftrightarrow> (\<forall>x. p (f x))"
by(auto simp add: pred_envir_def)

lemma pred_envirI [Pure.intro!, intro!]: "(\<And>x. p (f x)) \<Longrightarrow> pred_envir p f"
by(auto simp add: pred_envir_def)

lemma pred_envirD: "pred_envir p f \<Longrightarrow> p (f x)"
by(auto simp add: pred_envir_def)

lemma pred_envirE [Pure.elim 2, elim]: "pred_envir p f \<Longrightarrow> (p (f x) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
by(simp add: pred_envir_conv)

lemma pred_envir_mono: "\<lbrakk> pred_envir p f; \<And>x. p (f x) \<Longrightarrow> q (g x) \<rbrakk> \<Longrightarrow> pred_envir q g"
by blast

definition rel_envir :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('i, 'a) envir \<Rightarrow> ('i, 'b) envir \<Rightarrow> bool"
where "rel_envir p f g \<longleftrightarrow> all_envir (const p \<diamondop> f \<diamondop> g)"

lemma rel_envir_conv: "rel_envir p f g \<longleftrightarrow> (\<forall>x. p (f x) (g x))"
by(auto simp add: rel_envir_def)

lemma rel_envir_conv_rel_fun: "rel_envir = rel_fun (=)"
by(simp add: rel_envir_conv rel_fun_def fun_eq_iff)

lemma rel_envirI [Pure.intro!, intro!]: "(\<And>x. p (f x) (g x)) \<Longrightarrow> rel_envir p f g"
by(auto simp add: rel_envir_def)

lemma rel_envirD: "rel_envir p f g \<Longrightarrow> p (f x) (g x)"
by(auto simp add: rel_envir_def)

lemma rel_envirE [Pure.elim 2, elim]: "rel_envir p f g \<Longrightarrow> (p (f x) (g x) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
by(simp add: rel_envir_conv)

lemma rel_envir_mono: "\<lbrakk> rel_envir p f g; \<And>x. p (f x) (g x) \<Longrightarrow> q (f' x) (g' x) \<rbrakk> \<Longrightarrow> rel_envir q f' g'"
by blast

lemma rel_envir_mono1: "\<lbrakk> pred_envir p f; \<And>x. p (f x) \<Longrightarrow> q (f' x) (g' x) \<rbrakk> \<Longrightarrow> rel_envir q f' g'"
by blast

lemma pred_envir_mono2: "\<lbrakk> rel_envir p f g; \<And>x. p (f x) (g x) \<Longrightarrow> q (f' x) \<rbrakk> \<Longrightarrow> pred_envir q f'"
by blast

end

end


section \<open>\isaheader{The type of associative lists}\<close>
theory Assoc_List
  imports
  "HOL-Library.AList"
  "../Iterator/SetIteratorOperations"
begin

subsection \<open>Type \<open>('a, 'b) assoc_list\<close>\<close>

typedef ('k, 'v) assoc_list = "{xs :: ('k \<times> 'v) list. distinct (map fst xs)}"
morphisms impl_of Assoc_List
by(rule exI[where x="[]"]) simp

lemma assoc_list_ext: "impl_of xs = impl_of ys \<Longrightarrow> xs = ys"
by(simp add: impl_of_inject)

lemma expand_assoc_list_eq: "xs = ys \<longleftrightarrow> impl_of xs = impl_of ys"
by(simp add: impl_of_inject)

lemma impl_of_distinct [simp, intro]: "distinct (map fst (impl_of al))"
using impl_of[of al] by simp

lemma impl_of_distinct_full [simp, intro]: "distinct (impl_of al)"
using impl_of_distinct[of al]
unfolding distinct_map by simp

lemma Assoc_List_impl_of [code abstype]: "Assoc_List (impl_of al) = al"
by(rule impl_of_inverse)

subsection \<open>Primitive operations\<close>

definition empty :: "('k, 'v) assoc_list"
where [code del]: "empty = Assoc_List []"

definition lookup :: "('k, 'v) assoc_list \<Rightarrow> 'k \<Rightarrow> 'v option"
where [code]: "lookup al = map_of (impl_of al)"

definition update_with :: "'v \<Rightarrow> 'k \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) assoc_list \<Rightarrow> ('k, 'v) assoc_list"
where [code del]: "update_with v k f al = Assoc_List (AList.update_with_aux v k f (impl_of al))"

definition delete :: "'k \<Rightarrow> ('k, 'v) assoc_list \<Rightarrow> ('k, 'v) assoc_list"
where [code del]: "delete k al = Assoc_List (AList.delete_aux k (impl_of al))"

definition iteratei :: "('k, 'v) assoc_list \<Rightarrow> ('s\<Rightarrow>bool) \<Rightarrow> ('k \<times> 'v \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> 's"
where [code]: "iteratei al c f = foldli (impl_of al) c f"

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

lemma impl_of_update_with [code abstract]:
  "impl_of (update_with v k f al) = AList.update_with_aux v k f (impl_of al)"
by(simp add: update_with_def Assoc_List_inverse)

lemma impl_of_delete [code abstract]:
  "impl_of (delete k al) = AList.delete_aux k (impl_of al)"
by(simp add: delete_def Assoc_List_inverse)

subsection \<open>Abstract operation properties\<close>

lemma lookup_empty [simp]: "lookup empty k = None"
by(simp add: empty_def lookup_def Assoc_List_inverse)

lemma lookup_empty': "lookup empty = Map.empty"
by(rule ext) simp

lemma lookup_update_with [simp]:
  "lookup (update_with v k f al) = (lookup al)(k \<mapsto> case lookup al k of None \<Rightarrow> f v | Some v \<Rightarrow> f v)"
by(simp add: lookup_def update_with_def Assoc_List_inverse map_of_update_with_aux)

lemma lookup_delete [simp]: "lookup (delete k al) = (lookup al)(k := None)"
by(simp add: lookup_def delete_def Assoc_List_inverse distinct_delete map_of_delete_aux')

lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup m))"
by(simp add: lookup_def finite_dom_map_of)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
unfolding iteratei_def[abs_def] lookup_def map_to_set_def
by (simp add: set_iterator_foldli_correct)

subsection \<open>Derived operations\<close>

definition update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key, 'val) assoc_list \<Rightarrow> ('key, 'val) assoc_list"
where "update k v = update_with v k (\<lambda>_. v)"

definition set :: "('key, 'val) assoc_list \<Rightarrow> ('key \<times> 'val) set"
where "set al = List.set (impl_of al)"

lemma lookup_update [simp]: "lookup (update k v al) = (lookup al)(k \<mapsto> v)"
by(simp add: update_def split: option.split)

lemma set_empty [simp]: "set empty = {}"
by(simp add: set_def empty_def Assoc_List_inverse)

lemma set_update_with:
  "set (update_with v k f al) =
  (set al - {k} \<times> UNIV \<union> {(k, f (case lookup al k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by(simp add: set_def update_with_def Assoc_List_inverse set_update_with_aux lookup_def)

lemma set_update: "set (update k v al) = (set al - {k} \<times> UNIV \<union> {(k, v)})"
by(simp add: update_def set_update_with)

lemma set_delete: "set (delete k al) = set al - {k} \<times> UNIV"
by(simp add: set_def delete_def Assoc_List_inverse set_delete_aux)

subsection \<open>Type classes\<close>

instantiation assoc_list :: (equal, equal) equal begin

definition "equal_class.equal (al :: ('a, 'b) assoc_list) al' == impl_of al = impl_of al'"

instance
proof
qed (simp add: equal_assoc_list_def impl_of_inject)

end

instantiation assoc_list :: (type, type) size begin

definition "size (al :: ('a, 'b) assoc_list) = length (impl_of al)"

instance ..
end

hide_const (open) impl_of empty lookup update_with set update delete iteratei

subsection \<open>@{const map_ran}\<close>

text \<open>@{term map_ran} with more general type - lemmas replicated from AList in HOL/Library\<close>

hide_const (open) map_ran

primrec
  map_ran :: "('key \<Rightarrow> 'val \<Rightarrow> 'val') \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val') list"
where
    "map_ran f [] = []"
  | "map_ran f (p#ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"

lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
  by (induct al) auto

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (induct al) auto

lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
  by (induct al) (auto simp add: dom_map_ran)

lemma map_ran_filter: "map_ran f [(a, _)\<leftarrow>ps. fst p \<noteq> a] = [(a, _)\<leftarrow>map_ran f ps. fst p \<noteq> a]"
  by (induct ps) auto

lemma clearjunk_map_ran: "AList.clearjunk (map_ran f al)
  = map_ran f (AList.clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: AList.delete_eq map_ran_filter)

text \<open>new lemmas and definitions\<close>

lemma map_ran_cong [fundef_cong]:
  "\<lbrakk> al = al'; \<And>k v. (k, v) \<in> set al \<Longrightarrow> f k v = g k v \<rbrakk> \<Longrightarrow> map_ran f al = map_ran g al'"
by hypsubst_thin (induct al', auto)

lemma size_list_delete: "size_list f (AList.delete a al) \<le> size_list f al"
by(induct al) simp_all

lemma size_list_clearjunk: "size_list f (AList.clearjunk al) \<le> size_list f al"
by(induct al)(auto simp add: clearjunk_delete intro: le_trans[OF size_list_delete])

lemma set_delete_conv: "set (AList.delete a al) = set al - ({a} \<times> UNIV)"
proof(induct al)
  case (Cons kv al)
  thus ?case by(cases kv) auto
qed simp

lemma set_clearjunk_subset: "set (AList.clearjunk al) \<subseteq> set al"
by(induct al)(auto simp add: clearjunk_delete set_delete_conv)

lemma map_ran_conv_map:
  "map_ran f xs = map (\<lambda>(k, v). (k, f k v)) xs"
by(induct xs) auto

lemma card_dom_map_of: "distinct (map fst al) \<Longrightarrow> card (dom (map_of al)) = length al"
by(induct al)(auto simp add: card_insert_if finite_dom_map_of dom_map_of_conv_image_fst)

lemma map_of_map_inj_fst:
  assumes "inj f"
  shows "map_of (map (\<lambda>(k, v). (f k, v)) xs) (f x) = map_of xs x"
by(induct xs)(auto dest: injD[OF \<open>inj f\<close>])

lemma length_map_ran [simp]: "length (map_ran f xs) = length xs"
by(induct xs) simp_all

lemma length_update:
  "length (AList.update k v xs)
  = (if k \<in> fst ` set xs then length xs else Suc (length xs))"
by(induct xs) simp_all

lemma length_distinct:
  "distinct (map fst xs) \<Longrightarrow> length (AList.delete k xs)
  = (if k \<in> fst ` set xs then length xs - 1 else length xs)"
  by(induct xs)(auto split: if_split_asm simp add: in_set_conv_nth)

lemma finite_Assoc_List_set_image:
  assumes "finite (Assoc_List.set ` A)"
  shows "finite A"
proof -
  have "Assoc_List.set ` A = set ` Assoc_List.impl_of ` A"
    by (auto simp add: Assoc_List.set_def)
  with assms finite_set_image have "finite (Assoc_List.impl_of ` A)" by auto
  with assoc_list_ext show ?thesis by (metis inj_onI finite_imageD)
qed

end


(*  Title:      RSAPSS/Wordoperations.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

section  \<open>Extensions to the Word theory required for SHA1\<close>

theory WordOperations
imports Word
begin

type_synonym bv = "bit list"

datatype HEX = x0 | x1 | x2 | x3 | x4 | x5 | x6 | x7 | x8 | x9 | xA | xB | xC | xD | xE | xF

definition
  bvxor: "bvxor a b = bv_mapzip (\<oplus>\<^sub>b) a b"

definition
  bvand: "bvand a b = bv_mapzip (\<and>\<^sub>b) a b"

definition
  bvor: "bvor a b = bv_mapzip (\<or>\<^sub>b) a b"

primrec last where
  "last [] = Zero"
| "last (x#r) = (if (r=[]) then x else (last r))"

primrec dellast where
  "dellast [] = []"
| "dellast (x#r) = (if (r = []) then [] else (x#dellast r))"

fun bvrol where
  "bvrol a 0 = a"
| "bvrol [] x = []"
| "bvrol (x#r) (Suc n) = bvrol (r@[x]) n"

fun bvror where
  "bvror a 0 = a"
| "bvror [] x = []"
| "bvror x (Suc n) = bvror (last x # dellast x) n"

fun selecthelp where
  "selecthelp [] n = (if (n <= 0) then [Zero] else (Zero # selecthelp [] (n-(1::nat))))"
| "selecthelp (x#l) n = (if (n <= 0) then [x] else (x # selecthelp l (n-(1::nat))))"

fun select where
  "select [] i n = (if (i <= 0) then (selecthelp [] n) else select [] (i-(1::nat)) (n-(1::nat)))"
| "select (x#l) i n = (if (i <= 0) then (selecthelp (x#l) n) else select l (i-(1::nat)) (n-(1::nat)))"

definition
  addmod32: "addmod32 a b =
    rev (select (rev (nat_to_bv ((bv_to_nat a) + (bv_to_nat b)))) 0 31)"

definition
  bv_prepend: "bv_prepend x b bv = replicate x b @ bv"

primrec zerolist where
  "zerolist 0 = []"
| "zerolist (Suc n) = zerolist n  @ [Zero]"

primrec hextobv where
  "hextobv x0 = [Zero,Zero,Zero,Zero]"
| "hextobv x1 = [Zero,Zero,Zero,One]"
| "hextobv x2 = [Zero,Zero,One,Zero]"
| "hextobv x3 = [Zero,Zero,One,One]"
| "hextobv x4 = [Zero,One,Zero,Zero]"
| "hextobv x5 = [Zero,One,Zero,One]"
| "hextobv x6 = [Zero,One,One,Zero]"
| "hextobv x7 = [Zero,One,One,One]"
| "hextobv x8 = [One,Zero,Zero,Zero]"
| "hextobv x9 = [One,Zero,Zero,One]"
| "hextobv xA = [One,Zero,One,Zero]"
| "hextobv xB = [One,Zero,One,One]"
| "hextobv xC = [One,One,Zero,Zero]"
| "hextobv xD = [One,One,Zero,One]"
| "hextobv xE = [One,One,One,Zero]"
| "hextobv xF = [One,One,One,One]"

primrec hexvtobv where
  "hexvtobv [] = []"
| "hexvtobv (x#r) = hextobv x @ hexvtobv r"

lemma selectlenhelp: "length (selecthelp l i) = (i + 1)"
proof (induct i arbitrary: l)
  case 0
  show "length (selecthelp l 0) = 0 + 1"
  proof (cases l)
    case Nil
    then have "selecthelp l 0 = [Zero]" by simp
    then show ?thesis by simp
  next
    case (Cons a as)
    then have "selecthelp l 0 = [a]" by simp
    then show ?thesis by simp
  qed
next
  case (Suc x)
  show "length (selecthelp l (Suc x)) = (Suc x) + 1"
  proof (cases l)
    case Nil
    then have "selecthelp l (Suc x) = Zero # selecthelp l x" by simp
    then show "length (selecthelp l (Suc x)) = Suc x + 1" using Suc by simp
  next
    case (Cons a b)
    then have "selecthelp l (Suc x) = a # selecthelp b x" by simp
    then have "length (selecthelp l (Suc x)) = 1 + length (selecthelp b x)" by simp
    then show "length (selecthelp l (Suc x)) = Suc x + 1" using Suc by simp
  qed
qed

lemma selectlenhelp2:  "\<And>i. \<forall>l j. \<exists>k. select l i j = select k 0 (j - i)"
proof (auto)
  fix i
  show "\<And>l j. \<exists>k. select l i j = select k 0 (j - i)"
  proof (induct i)
    fix l and j
    have "select l 0 j = select l 0 (j-(0::nat))" by simp
    then show "\<exists>k. select l 0 j = select k 0 (j - (0::nat))" by auto
  next
    case (Suc x)
    have b: "select l (Suc x) j = select (tl l) x (j-(1::nat))"
    proof (cases l)
      case Nil
      then have "select l (Suc x) j = select l x (j-(1::nat))" by simp
      moreover have "tl l = l" using Nil by simp
      ultimately show ?thesis by (simp)
    next
      case (Cons head tail)
      then have "select l (Suc x) j = select tail x (j-(1::nat))" by simp
      moreover have "tail = tl l" using Cons by simp
      ultimately show ?thesis by simp
    qed
    have "\<exists>k. select l x j = select k 0 (j - (x::nat))" using Suc by simp
    moreover have  "\<exists>k. select (tl l) x (j-(1::nat)) = select k 0 (j-(1::nat)-(x::nat))" using Suc[of "tl l" "j-(1::nat)"] by auto
    ultimately have "\<exists>k. select l (Suc x) j = select k 0 (j-(1::nat) - (x::nat))" using b by auto
    then show "\<exists>k. select l (Suc x) j = select k 0 (j - Suc x)" by simp
  qed
qed

lemma selectlenhelp3: "\<forall>j. select l 0 j = selecthelp l j"
proof
  fix j
  show "select l 0 j = selecthelp l j"
  proof (cases l)
    case Nil
    assume "l=[]"
    then show "select l 0 j = selecthelp l j" by simp
  next
    case (Cons a b)
    then show "select l 0 j = selecthelp l j" by simp
  qed
qed

lemma selectlen: "length (select l i j) = j - i + 1"
proof -
  from selectlenhelp2 have "\<exists>k. select l i j = select k 0 (j-i)" by simp
  then have "\<exists>k. length (select l i j) = length (select k 0 (j-i))" by auto
  then have c: "\<exists>k. length (select l i j) = length (selecthelp k (j-i))"
    using selectlenhelp3 by simp
  from c obtain k where d: "length (select l i j) = length (selecthelp k (j-i))" by auto
  have "0<=j-i" by arith
  then have "length (selecthelp k (j-i)) = j-i+1" using selectlenhelp by simp
  then show "length (select l i j) = j-i+1" using d by simp
qed

lemma addmod32len: "\<And> a b. length (addmod32 a b) = 32"
  using selectlen [of _ 0 31] addmod32 by simp

end


theory SINVAR_NonInterference
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant NonInterference *}

datatype node_config = Interfering | Unrelated

definition default_node_properties :: "node_config"
  where  "default_node_properties = Interfering"

definition undirected_reachable :: "'v graph \<Rightarrow> 'v => 'v set" where
  "undirected_reachable G v = (succ_tran (undirected G) v) - {v}"

lemma undirected_reachable_mono:
  "E' \<subseteq> E \<Longrightarrow> undirected_reachable \<lparr>nodes = N, edges = E'\<rparr> n \<subseteq> undirected_reachable \<lparr>nodes = N, edges = E\<rparr> n"
unfolding undirected_reachable_def undirected_def succ_tran_def
by (fastforce intro: trancl_mono)

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> n \<in> (nodes G). (nP n) = Interfering \<longrightarrow> (nP ` (undirected_reachable G n)) \<subseteq> {Unrelated})"

lemma "sinvar G nP \<longleftrightarrow>
  (\<forall> n \<in> {v' \<in> (nodes G). (nP v') = Interfering}. {nP v' | v'. v' \<in> undirected_reachable G n} \<subseteq> {Unrelated})"
by auto

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

text{*simplifications for sets we need in the uniqueness proof*}
  lemma tmp1: "{(b, a). a = vertex_1 \<and> b = vertex_2} = {(vertex_2, vertex_1)}" by auto
  lemma tmp6: "{(vertex_1, vertex_2), (vertex_2, vertex_1)}\<^sup>+ =
    {(vertex_1, vertex_1), (vertex_2, vertex_2), (vertex_1, vertex_2), (vertex_2, vertex_1)}"
    apply(rule)
     apply(rule)
     apply(case_tac x, simp)
     apply(erule_tac r="{(vertex_1, vertex_2), (vertex_2, vertex_1)}" in trancl_induct)
      apply(auto)
     apply (metis (mono_tags) insertCI r_r_into_trancl)+
  done
  lemma tmp2: "(insert (vertex_1, vertex_2) {(b, a). a = vertex_1 \<and> b = vertex_2})\<^sup>+ =
    {(vertex_1, vertex_1), (vertex_2, vertex_2), (vertex_1, vertex_2), (vertex_2, vertex_1)}"
    apply(subst tmp1)
    apply(fact tmp6)
    done
  lemma tmp3: "{(b, a). False} = {}" by simp
  lemma tmp4: "{(e1, e2). e1 = vertex_1 \<and> e2 = vertex_2 \<and> (e1 = vertex_1 \<longrightarrow> e2 \<noteq> vertex_2)} = {}" by blast
  lemma tmp5: "{(b, a). a = vertex_1 \<and> b = vertex_2 \<or> a = vertex_1 \<and> b = vertex_2 \<and> (a = vertex_1 \<longrightarrow> b \<noteq> vertex_2)} =
    {(vertex_2, vertex_1)}" by fastforce
  lemma unique_default_example: "undirected_reachable \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
    by(auto simp add: undirected_def undirected_reachable_def succ_tran_def tmp2)
  lemma unique_default_example_hlp1: "delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)} =
    \<lparr>nodes = {vertex_1, vertex_2}, edges = {}\<rparr>"
    by(simp add: delete_edges_def)
  lemma unique_default_example_2:
    "undirected_reachable (delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1,vertex_2 )}) vertex_1 = {}"
    apply(simp add: undirected_def undirected_reachable_def succ_tran_def unique_default_example_hlp1)
    apply(subst tmp3)
    by auto
  lemma unique_default_example_3:
    "undirected_reachable (delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1,vertex_2 )}) vertex_2 = {}"
    apply(simp add: undirected_def undirected_reachable_def succ_tran_def unique_default_example_hlp1)
    apply(subst tmp3)
    by auto
  lemma unique_default_example_4:
    "(undirected_reachable (add_edge vertex_1 vertex_2 (delete_edges \<lparr>nodes = {vertex_1, vertex_2},
    edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)})) vertex_1) = {vertex_2}"
    apply(simp add: delete_edges_def add_edge_def undirected_def undirected_reachable_def succ_tran_def)
    apply(subst tmp4)
    apply(subst tmp5)
    apply(simp)
    apply(subst tmp6)
    by force
  lemma unique_default_example_5:
    "(undirected_reachable (add_edge vertex_1 vertex_2 (delete_edges \<lparr>nodes = {vertex_1, vertex_2},
    edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)})) vertex_2) = {vertex_1}"
    apply(simp add: delete_edges_def add_edge_def undirected_def undirected_reachable_def succ_tran_def)
    apply(subst tmp4)
    apply(subst tmp5)
    apply(simp)
    apply(subst tmp6)
    by force

  (*lemma empty_undirected_reachable_false: "xb \<in> undirected_reachable \<lparr>nodes = nodes G, edges = {(e1, e2). False}\<rparr> na \<longleftrightarrow> False"
    apply(simp add: undirected_reachable_def succ_tran_def undirected_def)
    apply(subst tmp3)
    by fastforce*)

  lemma empty_undirected_reachable_false: "xb \<in> undirected_reachable (delete_edges G (edges G)) na \<longleftrightarrow> False"
    apply(simp add: undirected_reachable_def succ_tran_def undirected_def delete_edges_edges_empty)
    apply(subst tmp3)
    by fastforce

subsubsection{*monotonic and preliminaries*}

interpretation NonInterference: SecurityInvariant_IFS
where default_node_properties = SINVAR_NonInterference.default_node_properties
and sinvar = SINVAR_NonInterference.sinvar
  unfolding SINVAR_NonInterference.default_node_properties_def
  apply unfold_locales
   apply(rule ballI)
   apply(drule SINVAR_NonInterference.offending_notevalD)
   apply(simp)
   apply clarify
   apply(rename_tac xa)
   apply(case_tac "nP xa")
    (*case Interfering*)
    apply simp
    apply(erule_tac x=n and A="nodes G" in ballE)
     prefer 2
     apply fast
    apply(simp)
    apply(thin_tac "wf_graph G")
    apply(thin_tac "(a,b) \<in> f")
    apply(thin_tac "n \<in> nodes G")
    apply(thin_tac "nP n = Interfering")
    apply(erule disjE)
     apply (metis fun_upd_other fun_upd_same imageI node_config.distinct(1) set_rev_mp singleton_iff)
    apply (metis fun_upd_other fun_upd_same imageI node_config.distinct(1) set_rev_mp singleton_iff)
   (*case Unrelated*)
   apply simp
  (*unique: *)
  apply(erule default_uniqueness_by_counterexample_IFS)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:delete_edges_set_nodes)
  apply (simp split: prod.split_asm prod.split)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := Interfering, vertex_2 := Interfering)" in exI, simp)
  apply(rule conjI)
   apply(simp add: unique_default_example)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(simp add: unique_default_example)
  apply(simp add: unique_default_example_2)
  apply(simp add: unique_default_example_3)
  apply(simp add: unique_default_example_4)
  apply(simp add: unique_default_example_5)
  apply(case_tac otherbot)
   apply simp
  apply(simp add:graph_ops)
  done

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

hide_const (open) sinvar receiver_violation default_node_properties

--{*Hide all the helper lemmas.*}
hide_fact tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 unique_default_example
          unique_default_example_2 unique_default_example_3 unique_default_example_4
          unique_default_example_5 empty_undirected_reachable_false

end


theory ETCS_Empty
  imports ETCS_Coproduct
begin

section  \<open>Axiom 8: Empty Set\<close>

axiomatization
  initial_func :: "cset \<Rightarrow> cfunc" ("\<alpha>\<^bsub>_\<^esub>" 100) and
  emptyset :: "cset" ("\<emptyset>")
where
  initial_func_type[type_rule]: "initial_func X :  \<emptyset> \<rightarrow> X" and
  initial_func_unique: "h : \<emptyset> \<rightarrow> X \<Longrightarrow> h = initial_func X" and
  emptyset_is_empty: "\<not>(x \<in>\<^sub>c \<emptyset>)"

(*characteristic_function_exists:
    "\<forall> X m. ((m : B \<rightarrow> X) \<and> monomorphism(m)) \<longrightarrow> (\<exists>! \<chi>. is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m \<chi> )"*)

definition initial_object :: "cset \<Rightarrow> bool" where
  "initial_object(X) \<longleftrightarrow> (\<forall> Y. \<exists>! f. f : X \<rightarrow> Y)"

lemma emptyset_is_initial:
  "initial_object(\<emptyset>)"
  using initial_func_type initial_func_unique initial_object_def by blast

lemma initial_iso_empty:
  assumes "initial_object(X)"
  shows "X \<cong> \<emptyset>"
  by (metis assms cfunc_type_def comp_type emptyset_is_empty epi_mon_is_iso initial_object_def injective_def injective_imp_monomorphism is_isomorphic_def singletonI surjective_def surjective_is_epimorphism)

(* Exercise 2.4.6 *)
lemma coproduct_with_zero_does_nothing:
  shows "X \<Coprod> \<emptyset> \<cong> X"
proof -
  have comp1: "((left_coproj X \<emptyset>) \<circ>\<^sub>c (id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>)) \<circ>\<^sub>c (left_coproj X \<emptyset>) = left_coproj X \<emptyset>"
  proof -
    have "((left_coproj X \<emptyset>) \<circ>\<^sub>c (id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>)) \<circ>\<^sub>c (left_coproj X \<emptyset>) =
            (left_coproj X \<emptyset>) \<circ>\<^sub>c ((id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>) \<circ>\<^sub>c (left_coproj X \<emptyset>))"
      by (typecheck_cfuncs, simp add: comp_associative2)
    also have "... = (left_coproj X \<emptyset>) \<circ>\<^sub>c id(X)"
      by (typecheck_cfuncs, metis left_coproj_cfunc_coprod)
    also have "... = left_coproj X \<emptyset>"
      by (typecheck_cfuncs, metis id_right_unit2)
    then show ?thesis using calculation by auto
  qed
  have comp2: "((left_coproj X \<emptyset>) \<circ>\<^sub>c (id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>)) \<circ>\<^sub>c (right_coproj X \<emptyset>) = right_coproj X \<emptyset>"
  proof -
    have "((left_coproj X \<emptyset>) \<circ>\<^sub>c (id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>)) \<circ>\<^sub>c (right_coproj X \<emptyset>) =
             (left_coproj X \<emptyset>) \<circ>\<^sub>c ((id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>) \<circ>\<^sub>c (right_coproj X \<emptyset>))"
      by (typecheck_cfuncs, simp add: comp_associative2)
    also have "... = (left_coproj X \<emptyset>) \<circ>\<^sub>c \<alpha>\<^bsub>X\<^esub>"
      by (typecheck_cfuncs, metis right_coproj_cfunc_coprod)
    also have "... = right_coproj X \<emptyset>"
      by (typecheck_cfuncs, metis initial_func_unique)
    then show ?thesis using calculation by auto
  qed
  then have fact1: "((left_coproj X \<emptyset>)\<amalg>(right_coproj X \<emptyset>)) \<circ>\<^sub>c (left_coproj X \<emptyset>) = (left_coproj X \<emptyset>)"
    using left_coproj_cfunc_coprod by (typecheck_cfuncs, blast)
  then have fact2: "((left_coproj X \<emptyset>)\<amalg>(right_coproj X \<emptyset>)) \<circ>\<^sub>c (right_coproj X \<emptyset>) = (right_coproj X \<emptyset>)"
    using right_coproj_cfunc_coprod by (typecheck_cfuncs, blast)
  then have concl: "(left_coproj X \<emptyset>) \<circ>\<^sub>c (id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>) = ((left_coproj X \<emptyset>)\<amalg>(right_coproj X \<emptyset>))"
    using cfunc_coprod_unique comp1 comp2 by (typecheck_cfuncs, blast)
  also have "... = id(X\<Coprod>\<emptyset>)"
    using cfunc_coprod_unique id_left_unit2 by (typecheck_cfuncs, auto)
  then have "isomorphism(id(X) \<amalg> \<alpha>\<^bsub>X\<^esub>)"
    unfolding isomorphism_def
    by (rule_tac x="left_coproj X \<emptyset>" in exI, typecheck_cfuncs, simp add: cfunc_type_def concl left_coproj_cfunc_coprod)
  then show "X\<Coprod>\<emptyset> \<cong> X"
    using cfunc_coprod_type id_type initial_func_type is_isomorphic_def by blast
qed

(* Proposition 2.4.7 *)
lemma function_to_empty_is_iso:
  assumes "f: X \<rightarrow> \<emptyset>"
  shows "isomorphism(f)"
  by (metis assms cfunc_type_def comp_type emptyset_is_empty epi_mon_is_iso injective_def injective_imp_monomorphism singletonI surjective_def surjective_is_epimorphism)

lemma zero_times_X:
  "\<emptyset> \<times>\<^sub>c X \<cong> \<emptyset>"
  using cfunc_type_def function_to_empty_is_iso is_isomorphic_def left_cart_proj_type by blast

lemma X_times_zero:
  "X \<times>\<^sub>c \<emptyset> \<cong> \<emptyset>"
  using cfunc_type_def function_to_empty_is_iso is_isomorphic_def right_cart_proj_type by blast

(* Proposition  2.4.8 *)
lemma no_el_iff_iso_0:
  "\<not>(nonempty(X)) \<longleftrightarrow> X \<cong> \<emptyset>"
proof auto
  assume "X \<cong> \<emptyset>"
  then show "nonempty X \<Longrightarrow> False "
    using comp_type emptyset_is_empty is_isomorphic_def nonempty_def by blast
  have "\<not>(nonempty(X))"
    using \<open>nonempty X \<Longrightarrow> False\<close> by blast
next
  assume "\<not>(nonempty(X))"
  obtain f where f_type: "f: \<emptyset> \<rightarrow> X"
    using initial_func_type by blast  (* f = \<alpha>_X *)

  have  f_inj: "injective(f)"
    using cfunc_type_def emptyset_is_empty f_type injective_def by auto
  then have f_mono: "monomorphism(f)"
    using  cfunc_type_def f_type injective_imp_monomorphism by blast
  have f_surj: "surjective(f)"
    using \<open>\<not> nonempty X\<close> cfunc_type_def f_type nonempty_def surjective_def by auto
  then have epi_f: "epimorphism(f)"
    using surjective_is_epimorphism by blast
  then have iso_f: "isomorphism(f)"
    using cfunc_type_def epi_mon_is_iso f_mono f_type by blast
  then show "X \<cong> \<emptyset>"
    using f_type is_isomorphic_def isomorphic_is_symmetric by blast
qed

lemma initial_maps_mono:
  assumes "initial_object(X)"
  assumes "f : X \<rightarrow> Y"
  shows "monomorphism(f)"
  by (metis UNIV_I assms cfunc_type_def initial_iso_empty injective_def injective_imp_monomorphism no_el_iff_iso_0 nonempty_def)

lemma iso_empty_initial:
  assumes "X \<cong> \<emptyset>"
  shows "initial_object(X)"
  unfolding initial_object_def
  by (meson assms comp_type is_isomorphic_def isomorphic_is_symmetric isomorphic_is_transitive no_el_iff_iso_0 nonempty_def one_separator terminal_func_type)

lemma function_to_empty_set_is_iso:
  assumes "f: X \<rightarrow> Y"
  assumes "\<not>(nonempty(Y))"
  shows "isomorphism(f)"
  by (metis assms cfunc_type_def comp_type epi_mon_is_iso injective_def injective_imp_monomorphism nonempty_def singletonI surjective_def surjective_is_epimorphism)

lemma prod_iso_to_empty_right:
  assumes "nonempty(X)"
  assumes "X \<times>\<^sub>c Y \<cong> \<emptyset>"
  shows "\<not>(nonempty(Y))"
  by (meson assms cfunc_prod_type no_el_iff_iso_0 nonempty_def)

lemma prod_iso_to_empty_left:
  assumes "nonempty(Y)"
  assumes "X \<times>\<^sub>c Y \<cong> \<emptyset>"
  shows "\<not>(nonempty(X))"
  using assms prod_iso_to_empty_right by blast

lemma empty_subset: "(\<emptyset>, \<alpha>\<^bsub>X\<^esub>) \<subseteq>\<^sub>c X"
  by (metis UNIV_I cfunc_type_def emptyset_is_empty initial_func_type injective_def injective_imp_monomorphism subobject_of_def2)

(* Proposition 2.2.1 *)
lemma "card ({(X,m). (X,m) \<subseteq>\<^sub>c one}//{((X,m1),(Y,m2)). X \<cong> Y}) = 2"
proof -
  have one_subobject: "(one, id one) \<subseteq>\<^sub>c one"
    using element_monomorphism id_type subobject_of_def2 by blast
  have empty_subobject: "(\<emptyset>, \<alpha>\<^bsub>one\<^esub>) \<subseteq>\<^sub>c one"
    by (simp add: empty_subset)

  have subobject_one_or_empty: "\<And>X m. (X,m) \<subseteq>\<^sub>c one \<Longrightarrow> X \<cong> one \<or> X \<cong> \<emptyset>"
  proof -
    fix X m
    assume X_m_subobject: "(X, m) \<subseteq>\<^sub>c one"

    obtain \<chi> where \<chi>_pullback: "is_pullback X one one \<Omega> (\<beta>\<^bsub>X\<^esub>) \<t> m \<chi>"
      using X_m_subobject characteristic_function_exists subobject_of_def2 by blast
    then have \<chi>_true_or_false: "\<chi> = \<t> \<or> \<chi> = \<f>"
      unfolding is_pullback_def square_commutes_def using true_false_only_truth_values by auto

    have true_iso_one: "\<chi> = \<t> \<Longrightarrow> X \<cong> one"
    proof -
      assume \<chi>_true: "\<chi> = \<t>"
      then have "\<exists>! x. x \<in>\<^sub>c X"
        using \<chi>_pullback unfolding is_pullback_def
        by (clarsimp, (erule_tac x=one in allE, erule_tac x="id one" in allE, erule_tac x="id one" in allE), metis comp_type id_type square_commutes_def terminal_func_unique)
      then show "X \<cong> one"
        using single_elem_iso_one by auto
    qed

    have false_iso_one: "\<chi> = \<f> \<Longrightarrow> X \<cong> \<emptyset>"
    proof -
      assume \<chi>_false: "\<chi> = \<f>"
      have "\<nexists> x. x \<in>\<^sub>c X"
      proof auto
        fix x
        assume x_in_X: "x \<in>\<^sub>c X"
        have "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub> = \<f> \<circ>\<^sub>c m"
          using \<chi>_false \<chi>_pullback is_pullback_def square_commutes_def by auto
        then have "\<t> \<circ>\<^sub>c (\<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c x) = \<f> \<circ>\<^sub>c (m \<circ>\<^sub>c x)"
          by (smt X_m_subobject comp_associative2 false_func_type subobject_of_def2
              terminal_func_type true_func_type x_in_X)
        then have "\<t> = \<f>"
          by (smt X_m_subobject cfunc_type_def comp_type false_func_type id_right_unit id_type
              subobject_of_def2 terminal_func_unique true_func_type x_in_X)
        then show False
          using true_false_distinct by auto
      qed
      then show "X \<cong> \<emptyset>"
        using no_el_iff_iso_0 nonempty_def by blast
    qed

    show "X \<cong> one \<or> X \<cong> \<emptyset>"
      using \<chi>_true_or_false false_iso_one true_iso_one by blast
  qed

  have classes_distinct: "{(X, m). X \<cong> \<emptyset>} \<noteq> {(X, m). X \<cong> one}"
    by (metis case_prod_eta curry_case_prod emptyset_is_empty id_isomorphism id_type is_isomorphic_def mem_Collect_eq)

  have "{(X, m). (X, m) \<subseteq>\<^sub>c one} // {((X, m1), Y, m2). X \<cong> Y} = {{(X, m). X \<cong> \<emptyset>}, {(X, m). X \<cong> one}}"
    unfolding quotient_def apply auto
    using isomorphic_is_symmetric isomorphic_is_transitive subobject_one_or_empty apply blast+
    using empty_subobject apply (rule_tac x=\<emptyset> in exI, auto simp add: isomorphic_is_symmetric)
    using one_subobject apply (rule_tac x=one in exI, auto simp add: isomorphic_is_symmetric)
    done
  then show "card ({(X, m). (X, m) \<subseteq>\<^sub>c one} // {((X, m1), Y, m2). X \<cong> Y}) = 2"
    by (simp add: classes_distinct)
qed

lemma coprod_with_init_obj1:
  assumes "initial_object Y"
  shows "X \<Coprod> Y \<cong> X"
  by (meson assms coprod_pres_iso coproduct_with_zero_does_nothing initial_iso_empty isomorphic_is_reflexive isomorphic_is_transitive)

lemma coprod_with_init_obj2:
  assumes "initial_object X"
  shows "X \<Coprod> Y \<cong> Y"
  using assms coprod_with_init_obj1 coproduct_commutes isomorphic_is_transitive by blast

lemma prod_with_term_obj1:
  assumes "terminal_object(X)"
  shows  "X \<times>\<^sub>c Y \<cong> Y"
  by (meson assms isomorphic_is_reflexive isomorphic_is_transitive one_terminal_object one_x_A_iso_A prod_pres_iso terminal_objects_isomorphic)

lemma prod_with_term_obj2:
  assumes "terminal_object(Y)"
  shows  "X \<times>\<^sub>c Y \<cong> X"
  by (meson assms isomorphic_is_transitive prod_with_term_obj1 product_commutes)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_pow_pow
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
"times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun formulapow3 :: "Nat => Nat => Nat" where
"formulapow3 x (Z) = S Z"
| "formulapow3 x (S z) = times x (formulapow3 x z)"

fun formulapow2 :: "Nat => Nat => Nat" where
"formulapow2 x (Z) = S Z"
| "formulapow2 x (S z) = times x (formulapow2 x z)"

fun formulapow :: "Nat => Nat => Nat" where
"formulapow x (Z) = S Z"
| "formulapow x (S z) = times x (formulapow x z)"

theorem property0 :
  "((formulapow x (times y z)) = (formulapow2 (formulapow3 x y) z))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_NStoogeSort2Sorts
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((z <= y2) & (ordered (cons2 y2 xs)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort2 xs)"
  oops

end


;;; -*- syntax: common-lisp; package: KEIM; base: 10; mode: Theory -*-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;;                                                                          ;;
;;   Copyright (C) 1996 by AG Siekmann, Fachbereich Informatik,             ;;
;;   Universitaet des Saarlandes, Saarbruecken, Germany.                    ;;
;;   All rights reserved.                                                   ;;
;;   For information about this program, write to:                          ;;
;;     OMEGA Project                                                        ;;
;;     AG Siekmann/FB Informatik                                            ;;
;;     Universitaet des Saarlandes                                          ;;
;;     Postfach 1150                                                        ;;
;;     D-66041 Saarbruecken                                                 ;;
;;     Germany                                                              ;;
;;   electronic mail: keim@cs.uni-sb.de                                     ;;
;;                                                                          ;;
;;   The author makes no representations about the suitability of this      ;;
;;   software for any purpose.  It is provided "AS IS" without express or   ;;
;;   implied warranty.  In particular, it must be understood that this      ;;
;;   software is an experimental version, and is not suitable for use in    ;;
;;   any safety-critical application, and the author denies a license for   ;;
;;   such use.                                                              ;;
;;                                                                          ;;
;;   You may use, copy, modify and distribute this software for any         ;;
;;   noncommercial and non-safety-critical purpose.  Use of this software   ;;
;;   in a commercial product is not included under this license.  You must  ;;
;;   maintain this copyright statement in all copies of this software that  ;;
;;   you modify or distribute.                                              ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;

(in-package :omega)

(th~deftheory magma
              (uses integer morphism)
	      (help "Magma (groupoid) theory"))

;; Concept of order! Defined in the same way as cardinality

(th~defdef order
	   (in magma)
	   (type-variables bb)
           (definition
             (lam (G (o bb))
                  (that (lam (x num)
                             (and (in x Nat)
                                  (exists (lam (F (num bb))
                                               (bijective G (first-n-nats x) F))))))))
           (help "Definition of the finite order of sets."))

;;; Formalisation of a^n with respect to an operation

(th~defconstant power-of-operation
  (in magma)
  (type (all-types AA (aa aa num (aa aa aa))))
  (help "The power-operation induced by an operation."))

(th~defaxiom the-power-of-an-operation-1
	     (in magma)
	     (formula (all-types aa
			  (forall (lam (op (aa aa aa))
			  (forall (lam (x aa)
				       (and
					(= (power-of-operation op 1 x) x)
					(forall-sort (lam (n num)
							  (= (power-of-operation op (s n) x)
							     (power-of-operation op n (op x x)))) pos-nat))))))))
	     (help "Inductive axiomatic definition of power-of-operation."))

(th~defaxiom the-power-of-an-operation-2
	     (in magma)
	     (formula (all-types aa
			     (forall (lam (op (aa aa aa))
					  (and
					   (= (power-of-operation op 1) (lam (x aa) x))
					   (forall-sort (lam (n num)
							     (= (power-of-operation op (s n))
								(lam (x aa) (op x (power-of-operation op n x))))) pos-nat))))))
	     (help "Inductive axiomatic definition of power-of-operation."))

(th~deftheorem the-power-op-of-plus
	     (in magma)
	     (conclusion
	      (forall-sort (lam (n num)
				(= (power-of-operation plus (s n))
				   (lam (x num) (times n x))))
			   pos-nat))
	     (help "power-operation of plus is times."))

(th~deftheorem the-power-op-of-times
	     (in magma)
	     (conclusion
	      (forall-sort (lam (n num)
				(= (power-of-operation times (s n))
				   (lam (x num) (power x n))))
			   pos-nat))
	     (help "power-operation of times is power."))

(th~defdef order-of-element ; now in magma
  (in magma)
  ;(type (all-types AA (o num aa (aa aa aa) (o  aa) )))
  (help "Relation that a given element x of a structure (set, op) has order n.")
  (type-variables aa)
  (definition
    (lam (S (o aa))
    (lam (op (aa aa aa))
    (lam (x aa)
    (lam (n num)
	 (and (pos-nat n)       ;; n in  Nat\{0}
	      (exists-sort (lam (e aa)    ;;x^n=e
				(and (and (closed-under S op)
					  (unit S Op e))
				     (and (= (power-of-operation op n x) e)
					  (forall-sort (lam (m num) ;; n is smallest such number
							    (implies (= (power-of-operation op m x) e)
								     (= m n)))
						       (integer-intervall 1 n)))))
			   S))))))))

;;Formalisation of trace

(th~defdef trace-of-element
  (in magma)
  (definition
    (all-types AA
	       (lam (op (aa aa aa))
			(lam (x aa)
			     (lam (y aa)
				  (exists-sort (lam (n num)
						    (= y (power-of-operation op n x)))
				   pos-nat))))))
  (help "The set that is the trace of an element with respect to an operation.")
  )

;;;
;;; Definition of MAGMA
;;;

(th~defdef magma
	   (in magma)
	   (type-variables aa)
	   (definition
	     (lam (M (o aa))
		  (lam (op (aa aa aa))
		       (and (not-empty M)
			    (closed-under M op)))))
	   (help "Definition of a Magma."))


theory Lmap_lappend_distrib
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"
(*hipster lmap lappend*)
lemma lemma_a [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
  apply (coinduction  arbitrary: y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
  apply (coinduction  arbitrary: x2 y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "lappend y LNil = y"
apply (coinduction  arbitrary: y rule: Lmap_lappend_distrib.Llist.coinduct_strong)
by simp

lemma lemma_ac [thy_expl]: "lappend LNil y = y"
apply (coinduction  arbitrary: y rule: Lmap_lappend_distrib.Llist.coinduct_strong)
by simp

lemma lemma_ad [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
apply (coinduction  arbitrary: y rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by (smt Llist.collapse(1) Llist.sel(2) lappend.disc_iff(2) lappend.simps(3) lappend.simps(4))

lemma lemma_ae [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
by simp

lemma lemma_af [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by blast

lemma lemma_ag [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
apply (coinduction  arbitrary: y rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by (metis Llist.collapse(1) Llist.sel(2) lappend.ctr(1))

lemma lemma_ah [thy_expl]: "ltl (lmap y z) = lmap y (ltl z)"
apply (coinduction  arbitrary: y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by (smt Llist.case_eq_if Llist.disc(1) Llist.disc_eq_case(1) Llist.sel(1) Llist.simps(5) lmap.code ltl_def)

lemma lemma_ai [thy_expl]: "ltl (lappend z (lmap y z)) = lappend (ltl z) (lmap y z)"
apply (coinduction  arbitrary: y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by (smt lappend.disc_iff(2) lappend.simps(3) lappend.simps(4) lemma_ab lmap.ctr(1) lmap.disc(2))

lemma lemma_aj [thy_expl]: "lappend (lmap y z) (lmap y x2) = lmap y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by (smt Llist.case_eq_if lappend.disc_iff(2) lappend.simps(3) lappend.simps(4))

lemma lemma_ak [thy_expl]: "ltl (lappend (lmap y z) (ltl z)) = lappend (lmap y (ltl z)) (ltl z)"
apply (coinduction  arbitrary: y z rule: Lmap_lappend_distrib.Llist.coinduct_strong)
apply simp
by (smt Llist.case_eq_if Llist.collapse(2) Llist.sel(1) Llist.sel(2) lemma_aa lemma_ab lemma_ah lmap.ctr(1) lmap.disc(2) lnull_def)

lemma unknown [thy_expl]: "ltl (lappend (lmap y z) z) = lappend (lmap y (ltl z)) z"
oops

theorem  lmap_lappend_distrib:
  "lmap f (lappend xs ys) = lappend (lmap f xs) (lmap f ys)"
  by (simp add: lemma_aj)
  (*by hipster_coinduct_sledgehammer doesn't return anything after a long time? *)
end


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

Examples of performing binary arithmetic by simplification.
*)

theory BinEx imports ZF begin
(*All runtimes below are on a 300MHz Pentium*)

lemma "#13  $+  #19 = #32"
by simp (*0 secs*)

lemma "#1234  $+  #5678 = #6912"
by simp (*190 msec*)

lemma "#1359  $+  #-2468 = #-1109"
by simp (*160 msec*)

lemma "#93746  $+  #-46375 = #47371"
by simp (*300 msec*)

lemma "$- #65745 = #-65745"
by simp (*80 msec*)

(* negation of \<not>54321 *)
lemma "$- #-54321 = #54321"
by simp (*90 msec*)

lemma "#13  $*  #19 = #247"
by simp (*110 msec*)

lemma "#-84  $*  #51 = #-4284"
by simp (*210 msec*)

(*The worst case for 8-bit operands *)
lemma "#255  $*  #255 = #65025"
by simp (*730 msec*)

lemma "#1359  $*  #-2468 = #-3354012"
by simp (*1.04 secs*)

(** Comparisons **)

lemma "(#89) $* #10 \<noteq> #889"
by simp

lemma "(#13) $< #18 $- #4"
by simp

lemma "(#-345) $< #-242 $+ #-100"
by simp

lemma "(#13557456) $< #18678654"
by simp

lemma "(#999999) $\<le> (#1000001 $+ #1) $- #2"
by simp

lemma "(#1234567) $\<le> #1234567"
by simp

(*** Quotient and remainder\<And>[they could be faster] ***)

lemma "#23 zdiv #3 = #7"
by simp

lemma "#23 zmod #3 = #2"
by simp

(** negative dividend **)

lemma "#-23 zdiv #3 = #-8"
by simp

lemma "#-23 zmod #3 = #1"
by simp

(** negative divisor **)

lemma "#23 zdiv #-3 = #-8"
by simp

lemma "#23 zmod #-3 = #-1"
by simp

(** Negative dividend and divisor **)

lemma "#-23 zdiv #-3 = #7"
by simp

lemma "#-23 zmod #-3 = #-2"
by simp

end