theory TreeCode
  imports "../00Utils/Environment"
begin

datatype tree_code =
  TLookup nat
  | TPushCon nat
  | TPushLam "tree_code list"
  | TApply

datatype tclosure =
  TConst nat
  | TLam "tclosure list" "tree_code list"

type_synonym tree_stack_frame = "tclosure list \<times> tree_code list"

datatype tree_code_state = TS "tclosure list" "tree_stack_frame list"

fun full_block :: "tree_code list \<Rightarrow> nat \<rightharpoonup> nat" where
  "full_block [] n = Some n"
| "full_block (TLookup x # cd) n = full_block cd (Suc n)"
| "full_block (TPushCon k # cd) n = full_block cd (Suc n)"
| "full_block (TPushLam cd' # cd) n = full_block cd (Suc n)"
| "full_block (TApply # cd) 0 = None"
| "full_block (TApply # cd) (Suc n) = full_block cd n"

primrec full_code_closure :: "tree_code \<Rightarrow> bool" where
  "full_code_closure (TLookup x) = True"
| "full_code_closure (TPushCon k) = True"
| "full_code_closure (TPushLam cd) = (full_block cd 0 = Some 1 \<and> list_all full_code_closure cd)"
| "full_code_closure TApply = True"

primrec full_closure :: "tclosure \<Rightarrow> bool" where
  "full_closure (TConst k) = True"
| "full_closure (TLam env cd) =
    (list_all full_closure env \<and> full_block cd 0 = Some 1 \<and> list_all full_code_closure cd)"

primrec full_frame :: "tree_stack_frame \<Rightarrow> bool" where
  "full_frame (env, cd) = (list_all full_closure env \<and> list_all full_code_closure cd)"

primrec full_state :: "tree_code_state \<Rightarrow> bool" where
  "full_state (TS env s) = (list_all full_closure env \<and> list_all full_frame s)"

inductive evalt :: "tree_code_state \<Rightarrow> tree_code_state \<Rightarrow> bool" (infix "\<leadsto>\<^sub>t" 50) where
  evt_lookup [simp]: "lookup env x = Some v \<Longrightarrow>
    TS vs ((env, TLookup x # cd) # sfs) \<leadsto>\<^sub>t TS (v # vs) ((env, cd) # sfs)"
| evt_pushcon [simp]: "TS vs ((env, TPushCon k # cd) # sfs) \<leadsto>\<^sub>t TS (TConst k # vs) ((env, cd) # sfs)"
| evt_pushlam [simp]: "TS vs ((env, TPushLam cd' # cd) # sfs) \<leadsto>\<^sub>t
    TS (TLam env cd' # vs) ((env, cd) # sfs)"
| evt_apply [simp]: "TS (v # TLam env' cd' # vs) ((env, TApply # cd) # sfs) \<leadsto>\<^sub>t
    TS vs ((v # env', cd') # (env, cd) # sfs)"
| evt_return [simp]: "TS vs ((env, []) # sfs) \<leadsto>\<^sub>t TS vs sfs"

lemma [simp]: "full_block cd 0 = Some (Suc 0) \<Longrightarrow> cd \<noteq> [] \<and> cd \<noteq> [TApply]"
proof (induction cd)
  case (Cons op cd)
  thus ?case by (induction op) simp_all
qed simp_all

lemma preservation [simp]: "\<Sigma> \<leadsto>\<^sub>t \<Sigma>' \<Longrightarrow> full_state \<Sigma> \<Longrightarrow> full_state \<Sigma>'"
  by (induction \<Sigma> \<Sigma>' rule: evalt.induct) auto

theorem determinismt: "\<Sigma> \<leadsto>\<^sub>t \<Sigma>' \<Longrightarrow> \<Sigma> \<leadsto>\<^sub>t \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction \<Sigma> \<Sigma>' rule: evalt.induct)
  case (evt_lookup env x v vs cd sfs)
  from evt_lookup(2, 1) show ?case
    by (induction "TS vs ((env, TLookup x # cd) # sfs)" \<Sigma>'' rule: evalt.induct) simp_all
next
  case (evt_pushcon vs env k cd sfs)
  thus ?case by (induction "TS vs ((env, TPushCon k # cd) # sfs)" \<Sigma>'' rule: evalt.induct) simp_all
next
  case (evt_pushlam vs env cd' cd sfs)
  thus ?case by (induction "TS vs ((env, TPushLam cd' # cd) # sfs)" \<Sigma>'' rule: evalt.induct) simp_all
next
  case (evt_apply v env' cd' vs env cd sfs)
  thus ?case
    by (induction "TS (v # TLam env' cd' # vs) ((env, TApply # cd) # sfs)" \<Sigma>'' rule: evalt.induct)
       simp_all
next
  case (evt_return vs env sfs)
  thus ?case by (induction "TS vs ((env, []) # sfs)" \<Sigma>'' rule: evalt.induct) simp_all
qed

end


theory Program_Graph imports "../LTS/LTS" Datalog begin

section \<open>Actions\<close>

datatype (fv_arith: 'v) arith =
  Integer int
  | Arith_Var 'v
  | Arith_Op "'v arith" "int \<Rightarrow> int \<Rightarrow> int" "'v arith"
  | Minus "'v arith"

datatype (fv_boolean: 'v) boolean =
  true
  | false
  | Rel_Op "'v arith" "int \<Rightarrow> int \<Rightarrow> bool" "'v arith"
  | Bool_Op "'v boolean" "bool \<Rightarrow> bool \<Rightarrow> bool" "'v boolean"
  | Neg "'v boolean"

datatype 'v action =
  Asg 'v "'v arith" ("_ ::= _" [1000, 61] 61)
  | Bool "'v boolean"
  | Skip

section \<open>Memories\<close>

type_synonym 'v memory = "'v \<Rightarrow> int"

section \<open>Semantics\<close>

fun sem_arith :: "'v arith \<Rightarrow> 'v memory \<Rightarrow> int" where
  "sem_arith (Integer n) \<sigma> = n"
| "sem_arith (Arith_Var x) \<sigma> = \<sigma> x"
| "sem_arith (Arith_Op a1 op a2) \<sigma> = op (sem_arith a1 \<sigma>) (sem_arith a2 \<sigma>)"
| "sem_arith (Minus a) \<sigma> = - (sem_arith a \<sigma>)"

fun sem_bool :: "'v boolean \<Rightarrow> 'v memory \<Rightarrow> bool" where
  "sem_bool true \<sigma> = True"
| "sem_bool false \<sigma> = False"
| "sem_bool (Rel_Op a1 op a2) \<sigma> = op (sem_arith a1 \<sigma>) (sem_arith a2 \<sigma>)"
| "sem_bool (Bool_Op b1 op b2) \<sigma> = op (sem_bool b1 \<sigma>) (sem_bool b2 \<sigma>)"
| "sem_bool (Neg b) \<sigma> = (\<not>(sem_bool b \<sigma>))"

fun sem_action :: "'v action \<Rightarrow> 'v memory \<rightharpoonup> 'v memory" where
  "sem_action (x ::= a) \<sigma> = Some (\<sigma>(x := sem_arith a \<sigma>))"
| "sem_action (Bool b) \<sigma> = (if sem_bool b \<sigma> then Some \<sigma> else None)"
| "sem_action Skip \<sigma> = Some \<sigma>"

section \<open>Program Graphs\<close>

subsection \<open>Types\<close>

type_synonym ('n,'v) edge = "'n \<times> 'v action \<times> 'n"

type_synonym ('n,'v) program_graph = "('n,'v) edge set \<times> 'n \<times> 'n"

type_synonym ('n,'v) config = "'n * 'v memory"

subsection \<open>Program Graph Locale\<close>

locale program_graph =
  fixes pg :: "('n,'v) program_graph"
begin

definition edge_set where
  "edge_set = fst pg"

definition start where
  "start = fst (snd pg)"

definition "end" where
  "end = snd (snd pg)"

definition pg_rev :: "('n,'v) program_graph" where
  "pg_rev = (rev_edge ` edge_set, end, start)"

subsubsection \<open>Execution Sequences\<close>

fun initial_config_of :: "('n,'v) config \<Rightarrow> bool" where
  "initial_config_of (q,\<sigma>) \<longleftrightarrow> q = start"

fun final_config_of :: "('n,'v) config \<Rightarrow> bool" where
  "final_config_of (q,\<sigma>) \<longleftrightarrow> q = end"

inductive exe_step :: "('n,'v) config \<Rightarrow> 'v action \<Rightarrow> ('n,'v) config \<Rightarrow> bool" where
  "(q1, \<alpha>, q2) \<in> edge_set \<Longrightarrow> sem_action \<alpha> \<sigma> = Some \<sigma>' \<Longrightarrow> exe_step (q1,\<sigma>) \<alpha> (q2,\<sigma>')"

end

subsection \<open>Finite Program Graph Locale\<close>

locale finite_program_graph = program_graph pg
  for pg :: "('n::finite,'v) program_graph" +
  assumes "finite edge_set"
begin

lemma finite_pg_rev: "finite (fst pg_rev)"
  by (metis finite_program_graph_axioms finite_program_graph_def finite_imageI fst_conv pg_rev_def)

end

end


theory Turtle
imports Main
        "$HIPSTER_HOME/IsaHipster"

begin

type_synonym angle = int
type_synonym point = "int * int"
type_synonym distance = int

record turtle =     facing :: angle
                    loc :: point
                    fly :: bool

type_synonym instant = "((turtle * turtle) * string) list"
type_synonym transiton = "turtle \<Rightarrow> turtle option"

datatype prog = Empty "(prog list)" | Node transiton "(prog list)"

fun endPoint :: "point \<Rightarrow> angle \<Rightarrow> distance \<Rightarrow> point" where
  "endPoint (x, y) d l = (x + l * d, y + l * d)"

fun moveT :: "distance \<Rightarrow> turtle \<Rightarrow> turtle" where
  "moveT n t = t \<lparr> loc := endPoint (loc t) (facing t) n \<rparr>"

fun rotateT :: "angle \<Rightarrow> turtle \<Rightarrow> turtle" where
  "rotateT d t = t \<lparr> facing := (facing t + d) mod 6 \<rparr>"

definition initTurtle :: "turtle" where
  "initTurtle = \<lparr> facing = 0, loc = (0, 0), fly = False\<rparr>"

definition empty :: "prog" where
 "empty = Empty []"

fun K :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" where
  "K b x = b"

definition die :: "prog" where
  "die = Node (K None) []"

fun transit :: "(turtle \<Rightarrow> turtle) \<Rightarrow> prog" where
  "transit f = Node (Some o f) []"

definition idle :: "prog" where
  "idle = transit id"

definition penup :: "prog" where
  "penup = transit (\<lambda> t. t \<lparr>fly := True\<rparr>)"

definition pendown :: "prog" where
  "pendown = transit (\<lambda> t. t \<lparr>fly := False\<rparr>)"

fun forward :: "distance \<Rightarrow> prog" where
  "forward n = transit (moveT n)"

fun backward :: "distance \<Rightarrow> prog" where
  "backward n = transit (moveT (- n))"

fun right :: "angle \<Rightarrow> prog" where
  "right d = transit (rotateT (- d))"

fun left :: "angle \<Rightarrow> prog" where
  "left d = transit (rotateT d)"

fun getCh :: "prog \<Rightarrow> prog list" where
  "getCh (Empty  cs) = cs"
| "getCh (Node _ cs) = cs"

fun getOp :: "prog \<Rightarrow> prog list \<Rightarrow> prog" where
  "getOp (Empty  _) = Empty"
| "getOp (Node t _) = Node t"

function inject :: "int \<Rightarrow> prog \<Rightarrow> (int \<Rightarrow> prog \<Rightarrow> bool) \<Rightarrow> (prog \<Rightarrow> prog \<Rightarrow> prog) \<Rightarrow> prog \<Rightarrow> prog" where
  "inject n new fcond gtrans p =
    (if fcond n p then gtrans new p
                  else getOp p (map (inject ((\<lambda>p . case p of Empty _ \<Rightarrow> n
                                                           | Node _ _ \<Rightarrow> n + 1) p) new fcond gtrans) (getCh p)))"
by auto

fun replace :: "int \<Rightarrow> prog \<Rightarrow> (int \<Rightarrow> prog \<Rightarrow> bool) \<Rightarrow> prog \<Rightarrow> prog" where
  "replace n new f = inject n new f (\<lambda>r _. r)"

fun append :: "int \<Rightarrow> prog \<Rightarrow> (int \<Rightarrow> prog \<Rightarrow> bool) \<Rightarrow> prog \<Rightarrow> prog" where
  "append n new f = inject n new f (\<lambda>r p. getOp p [r])"

fun isLeaf :: "prog \<Rightarrow> bool" where
  "isLeaf p = List.null (getCh p)"

fun isLastAction :: "prog \<Rightarrow> bool" where (* also possible via a definition, of course *)
  "isLastAction p = isLeaf p"

fun hasEmptyAction :: "prog \<Rightarrow> bool" where
  "hasEmptyAction (Empty _) = True"
| "hasEmptyAction _         = False"

fun isEmpty :: "prog \<Rightarrow> bool" where
  "isEmpty (Empty []) = True"
| "isEmpty (Empty cs) = list_all isEmpty cs"
| "isEmpty _          = False"

fun seq :: "prog \<Rightarrow> prog \<Rightarrow> prog" (infixr ">*>" 65) where
  "seq p q = append 0 q (\<lambda>_ x. isLeaf x) p"

fun par :: "prog \<Rightarrow> prog \<Rightarrow> prog" (infixr "<|>" 65) where
  "par p q = Empty [p, q]"

fun lifespan :: "int => prog => prog" where
  "lifespan n = replace 0 die (\<lambda>i _. i = n)"

fun limited :: "int => prog => prog" where
  "limited n = replace 0 (Empty []) (\<lambda>i _. i = n)"

fun times :: "int \<Rightarrow> prog \<Rightarrow> prog" where
  "times n p = (if n \<le> 0 then Empty [] else p >*> times (n - 1) p)"

function forever :: "prog \<Rightarrow> prog" where
  "forever p = p >*> forever p"
by auto

fun firstAction :: "prog \<Rightarrow> prog list \<Rightarrow> prog" where
  "firstAction p l = getOp p l"

fun restActions :: "prog \<Rightarrow> prog list" where
  "restActions p = getCh p"

lemma test: "(p <|> q) >*> r = (p >*> r) <|> (q >*> r)"
by hipster_induct_schemes

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_list_elem_nub_r
imports "../../Test_Base"
begin

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

fun filter :: "('a => bool) => 'a list => 'a list" where
"filter p (nil2) = nil2"
| "filter p (cons2 y xs) =
     (if p y then cons2 y (filter p xs) else filter p xs)"

(*fun did not finish the proof*)
function nubBy :: "('a => ('a => bool)) => 'a list => 'a list" where
"nubBy x (nil2) = nil2"
| "nubBy x (cons2 z xs) =
     cons2 z (nubBy x (filter (% (y2 :: 'a) => (~ ((x z) y2))) xs))"
by pat_completeness auto

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

theorem property0 :
  "((elem x (nubBy (% (y :: 'a) => % (z :: 'a) => (y = z)) xs)) ==>
      (elem x xs))"
  oops

end


theory GC1
imports GC0
begin

(*============================================================*)
section \<open> Level 1 definitions \<close>

(* TODO: make Heap use Addrs? At the moment, achieving the same through ALL_ADDR` invariant *)

(* Heap maps addresses to nodes, which are sequences of optional addresses*)
type_synonym AddrO= "Addr option"
type_synonym Node = "AddrO VDMSeq" \<comment> \<open>Node = seq of [Addr]\<close>
type_synonym Heap = "Addr \<rightharpoonup> Node"

term "{ x | x . Some x \<in> elems (the ((Map.empty::Heap) x)) }"

lemma "{ x | x . (x::nat) < 3 } = { y . y < 3}" by simp

term "the (those (filter (\<lambda> x . (case x of None \<Rightarrow> False | Some y \<Rightarrow> True)) xs))"

value "those [Some (0::nat), Some 1, Some 2]"
find_theorems name:filter name:List

abbreviation
  ALL_RADDR :: "Addrs rel"
where
  "ALL_RADDR \<equiv> UNIV \<times> UNIV" (* TODO: this isn't quite right *)

(* Isabelle is picky about option types, thus the encoding below - thanks to Andrius Velikys *)
definition
  child_rel :: "Heap \<Rightarrow> Addr rel"
  where
    "child_rel hp \<equiv> {(a,b) | a b . a \<in> dom hp \<and> Some b \<in> elems (the (hp a)) }"

lemmas child_rel_defs = child_rel_def elems_def

(* ran(s \<triangleleft> (child_rel hp)) has the wrong type given child_rel does not return a map
   but a relation. But we know that ran of \<triangleleft> is just relational image, which is ``. *)
definition
  reach :: "Addr VDMSet \<Rightarrow> Heap \<Rightarrow> Addr VDMSet"
where
  "reach s hp \<equiv> (child_rel hp)\<^sup>* `` s"

lemmas reach_defs = reach_def child_rel_defs

(*lemma "the ((hp::Heap) b) = A \<Longrightarrow> the (A $ j) = B" using[[show_types]]*)

text \<open> Cliff's Lemma 1 \<close>
lemma l_reach_hp_lemma1:
  "(\<exists> a . a \<in> (reach s hp) \<and> a \<notin> s \<longrightarrow> (\<exists> b j . b \<in> dom hp \<and> the ((the (hp b)) $ j) \<notin> s))"
  \<comment> \<open>using [[rule_trace,simp_trace]]\<close>
  find_theorems "\<exists> _ . _ \<longrightarrow> _"
  (*apply (intro exI impI, safe, auto, intro exI) *)
  apply simp
    oops

lemma l_reach_hp_lemma1:
  "(\<exists> a . a \<in> (reach s hp) \<and> a \<notin> s) \<longrightarrow> (\<exists> b j . b \<in> dom hp \<and> the ((the (hp b)) $ j) \<notin> s)"
  apply (safe, simp)
  unfolding reach_def
  find_theorems "_ \<in> _ `` _" elim
  apply (erule ImageE)
  find_theorems "_ \<in> _\<^sup>*" elim
  apply (erule rtranclE)
    apply simp (* base case is ruled out by condition a \<notin> s *)
  unfolding child_rel_def
    apply simp
  apply (erule conjE)
  apply (rule_tac x=y in exI)
  apply simp
  unfolding elems_def
  oops

lemma l_reach_hp_lemma1:
  "(\<exists> a . a \<in> (reach s hp) \<and> a \<notin> s) \<longrightarrow> (\<exists> b . b \<in> dom hp \<and> (\<exists> j . j \<in> inds (the (hp b)) \<and> the ((the (hp b)) $ j) \<notin> s))"
  apply (safe)
  unfolding reach_def
  find_theorems "_ \<in> _ `` _" elim
  apply (erule ImageE)
  find_theorems "_ \<in> _\<^sup>*" elim
  apply (erule rtranclE)
    apply simp (* base case is ruled out by condition a \<notin> s *)
  unfolding child_rel_def
    apply simp
  apply (erule conjE)
  apply (rule_tac x=y in exI)
  unfolding inds_def
  apply simp
  (* needs a lemma linking elems + inds *)
  unfolding elems_def
  oops

lemma l_reach_hp_lemma1:
  "(\<exists> a . a \<in> (reach s hp) \<and> a \<notin> s) \<longrightarrow> (\<exists> b . b \<in> dom hp \<and> (\<exists> j . j \<in> inds (the (hp b)) \<and> the ((the (hp b)) $ j) \<notin> s))"
  apply (safe)
  unfolding reach_def
  find_theorems "_ \<in> _ `` _" elim
  apply (erule ImageE)
  find_theorems "_ \<in> _\<^sup>*" elim
  apply (erule rtranclE)
    apply simp (* base case is ruled out by condition a \<notin> s *)
  unfolding child_rel_def
    apply simp
  apply (erule conjE)
  apply (rule_tac x=y in exI)
  apply (simp add: l_elems_of_inds)
    by auto

text \<open> Cliff's Lemma 2 \<close>
lemma l_subset_reach: "s1 \<subseteq> s2 \<Longrightarrow> reach s1 hp \<subseteq> reach s2 hp"
  unfolding reach_def apply safe
  unfolding Image_def apply safe
  apply (rule_tac x=xa in bexI)
  apply simp
  by blast

lemma l_filter_within_reach: "s \<subseteq> reach s hp"
  unfolding reach_def
  apply safe
  unfolding Image_def
  apply safe
  apply (rule_tac x=x in bexI)
  by simp+

lemma l_reach_empty[simp]: "reach {} hp = {}"
  unfolding reach_def
  by simp

definition
  empty_heap :: "Heap"
  where
 "empty_heap \<equiv> (\<lambda> x . if x \<in> ALL_ADDR then Some [] else None)"
 \<comment> \<open>type ([]::(Addr option) list)\<close>

lemma l_empty_heap_last_child_rel_E:
  "(y, z) \<in> child_rel empty_heap \<Longrightarrow> y \<in> s \<Longrightarrow> z \<in> s"
  unfolding child_rel_def empty_heap_def
  apply safe
  by (simp split:if_splits)

lemma l_empty_heap_reach[simp]: "reach s empty_heap = s"
  unfolding reach_def
  apply (safe)
   defer
  find_theorems "_ `` _" intro
  apply (rule rev_ImageI)
  apply simp
  find_theorems "_\<^sup>*" intro
  apply (rule rtrancl_refl)
  (* find_theorems "(_,_) \<in> _\<^sup>* \<Longrightarrow> _"
  apply (induct "(child_rel empty_heap)")*)
  (*find_theorems "_\<^sup>*" elim
  apply (erule rtranclE)
  apply simp *)
  (*find_theorems "_\<^sup>*" name:induc
    apply (induct rule:rtrancl_induct)  *)
  apply (erule rtrancl_induct)
  by (simp_all add: l_empty_heap_last_child_rel_E)

lemma l_empty_heap_image_eq: "s \<noteq> {} \<Longrightarrow> s \<subseteq> dom empty_heap \<Longrightarrow> ran (s \<triangleleft> empty_heap) = {[]}"
  apply safe
  unfolding dom_restr_def ran_def restrict_map_def
   apply safe
  unfolding empty_heap_def
   apply (simp_all split: if_splits)
  apply (rule_tac x=x in exI)
  apply safe
  using domIff by fastforce

lemma l_empty_heap_image_subset: "s \<subseteq> dom empty_heap \<Longrightarrow> ran (s \<triangleleft> empty_heap) \<subseteq> {[]}"
  apply safe
  unfolding dom_restr_def ran_def restrict_map_def
   apply safe
  unfolding empty_heap_def
  by (simp_all split: if_splits)

lemma l_in_ALL_ADDR: "\<exists> x . x \<in> ALL_ADDR"
  using l_ALL_ADDR_not_empty by blast

lemma l_empty_heap_image_x: "x \<in> dom empty_heap \<Longrightarrow> ran ({x} \<triangleleft> empty_heap) = {[]}"
  apply (rule l_empty_heap_image_eq)
  apply simp
  unfolding empty_heap_def
  by safe

lemma l_empty_heap_ALL_ADDR_absorb[simp]: "ALL_ADDR \<triangleleft> empty_heap = empty_heap"
  apply (rule ext)
  unfolding dom_restr_def empty_heap_def
  by (simp)

(*------------------------------------------------------------*)
subsection \<open> Sigma level 1 \<close>

record Sigma1 =
  roots1 :: "Addr VDMSet"
  hp1    :: "Heap"
  free1  :: "Addr VDMSet"

definition
  garbage1 :: "Addr VDMSet \<Rightarrow> Heap \<Rightarrow> Addr VDMSet \<Rightarrow> Addr VDMSet"
where
  "garbage1 r hp f \<equiv> ALL_ADDR - (f \<union> (reach r hp))"

definition
  inv_Sigma1 :: "Addr VDMSet \<Rightarrow> Heap \<Rightarrow> Addr VDMSet \<Rightarrow> \<bool>"
where
  "inv_Sigma1 roots heap free \<equiv>
      dom heap = ALL_ADDR \<and>
      ran (free \<triangleleft> heap) \<subseteq> {[]} \<and>
      free \<inter> (reach roots heap) = {}"
\<comment> \<open>\<and>  free \<union> (reach roots heap) \<union> (garbage1 roots heap free) = ALL_ADDR\<close>

lemma f_Sigma1_no_free_reach:
  "inv_Sigma1 roots heap free \<Longrightarrow> free \<inter> (reach roots heap) = {}"
  unfolding inv_Sigma1_def by simp

lemma f_Sigma1_no_free_roots:
  "inv_Sigma1 roots heap free \<Longrightarrow> free \<inter> roots = {}"
  unfolding reach_def
  apply (frule f_Sigma1_no_free_reach)
  apply safe
  find_theorems "_ = {} \<Longrightarrow> _"
  apply (drule_tac a=x in equals0D, erule notE)
  apply simp
  unfolding inv_Sigma1_def
  by (meson contra_subsetD l_filter_within_reach)

lemma f_Sigma1_no_free_garbage:
  "inv_Sigma1 roots heap free \<Longrightarrow> free \<inter> garbage1 roots heap free = {}"
  apply (frule f_Sigma1_no_free_reach)
  apply (frule f_Sigma1_no_free_roots)
  apply safe
  apply (drule_tac a=x in equals0D, erule notE, simp)
  unfolding garbage1_def
  by safe

lemma f_Sigma1_no_reach_garbage:
  "inv_Sigma1 roots heap free \<Longrightarrow>
    (reach roots heap) \<inter> garbage1 roots heap free = {}"
  apply (frule f_Sigma1_no_free_garbage)
  unfolding inv_Sigma1_def garbage1_def
  apply (elim conjE, rotate_tac 3, erule subst)
  using [[show_brackets]]
  nitpick
  oops
lemma l_Sigma1_cliff_identify:
    "(ran (free \<triangleleft> (heap::Heap)) \<subseteq> {([])}) = (\<forall> a \<in> free \<inter> dom heap . (the(heap a)) = [])"
  using [[show_types]]
  apply safe
  find_theorems "_ \<subseteq> _" elim
  apply (erule subsetCE, simp_all)
  unfolding ran_def
   apply safe
   apply (rule_tac x=a in exI)
   apply (simp add: dom_restr_def)
  apply (erule_tac x=a in ballE)
   apply (metis dom_restr_def not_None_eq option.sel restrict_map_def)
    by (metis domI l_dom_r_iff)

definition
  inv_Sigma1_R :: "Sigma1 \<Rightarrow> \<bool>"
where
  "inv_Sigma1_R s \<equiv> inv_Sigma1 (roots1 s) (hp1 s) (free1 s)"

lemmas inv_Sigma1_defs = inv_Sigma1_R_def inv_Sigma1_def

lemma l_empty_heap_dom[simp]: "dom empty_heap = ALL_ADDR"
  unfolding empty_heap_def
  apply safe
  by (simp_all split:if_splits)

lemma l_empty_heap_apply: "x \<in> ALL_ADDR \<Longrightarrow> empty_heap x = Some []"
  unfolding empty_heap_def by simp

lemma l_empty_heap_ran[simp]: "ran empty_heap = {[]}"
  unfolding empty_heap_def ran_def
  apply safe
  apply (simp_all split:if_splits)
  apply (rule exI[of _ an_addr])
  by (simp)

typedef Sigma1Type = "{ s . inv_Sigma1_R s }"
  morphisms s1t_t (* st: Sigma1Type \<Rightarrow> Sigma1 *)
            s1t_r (* rc: Sigma1 \<Rightarrow> Sigma1Type *)
  unfolding inv_Sigma1_defs
  apply simp
  apply (rule exI[of _ "\<lparr>roots1={}, hp1 = empty_heap, free1 = ALL_ADDR\<rparr>"])
  apply (safe)
  apply (simp_all add: l_empty_heap_apply)
  unfolding empty_heap_def garbage1_def
  by (simp_all split:if_splits)

definition
  inv_Sigma1_T :: "Sigma1Type \<Rightarrow> \<bool>"
where
  "inv_Sigma1_T s \<equiv> inv_Sigma1_R (s1t_t s)"

definition
  retr0 :: "Sigma1 \<Rightarrow> Sigma0"
  where
 "retr0 s1 \<equiv>  \<lparr>busy0 = reach (roots1 s1) (hp1  s1), free0 = (free1  s1)\<rparr>"

 theorem l_sigma0_sigma1_adequacy0: "inv_Sigma0_R s0 \<Longrightarrow> \<exists> s1 . inv_Sigma1_R s1 \<and> retr0 s1 = s0"
  unfolding retr0_def
  apply (rule_tac x="\<lparr>roots1 = (busy0 s0), hp1 = empty_heap, free1 = (free0 s0)\<rparr>" in exI)
  apply (safe, simp_all)
  unfolding inv_Sigma0_defs inv_Sigma1_defs
  apply (cases s0, simp)
  apply (elim conjE)
  find_theorems "ran(_ \<triangleleft> _)"
  apply (intro conjI l_empty_heap_image_subset)
  using l_empty_heap_dom apply blast
  done
  \<comment> \<open>by (simp add: garbage1_def sup_commute)\<close>

definition
  retr0T :: "Sigma1Type \<Rightarrow> Sigma0Type"
  where
 "retr0T s1 \<equiv>  (s0t_r (retr0 (s1t_t s1)))"

text \<open> Cliff's Theorem 2 \<close>
theorem l_sigma0_sigma1_adequacy: "\<forall> s0 . \<exists> s1 . retr0T s1 = s0"
  by (metis (full_types) s0t_r_cases s1t_t_cases l_sigma0_sigma1_adequacy0 mem_Collect_eq retr0T_def)

(*================================================================*)

instantiation Sigma1Type :: VDM
begin

definition
  "st_inv_Sigma1Type s \<longleftrightarrow> inv_Sigma1_T s"

lemma l_Sigma1_valid: "inv_Sigma1_T s"
using inv_Sigma1_T_def s1t_t by auto

instance
  using inv_Sigma1_T_def st_inv_Sigma1Type_def s1t_t
  by (intro_classes, auto)

end

lemma l1_s1t_inv: "inv_Sigma1_T s"
  by (simp add: l_Sigma1_valid)

(*
rely missing garbage \<subseteq> garbage'?
Collector
ext   wr free
      rd roots, hp
pre   True
rely  free' \<subseteq> free
guar  free \<subseteq> free'
post  (ALL_ADDR - (reach roots hp)) \<subseteq> \<Union> (hat free)
*)

definition
  roots1_constant :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
  where
  "roots1_constant s s' \<equiv> (roots1 (s1t_t s)) = (roots1 (s1t_t s'))"

definition
  collector1_frame :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
 "collector1_frame s s' \<equiv>
    (let hp1'=(hp1 (s1t_t s')); hp1 =(hp1 (s1t_t s))
     in
      roots1_constant s s' \<and>  hp1' = hp1)"

definition
  collector1_pre :: "Sigma1Type \<Rightarrow> \<bool>"
where
  "collector1_pre s \<equiv> True"

definition
  collector1_post :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
  "collector1_post s s' \<equiv>
    (let free1 =(free1 (s1t_t s));
         roots1=(roots1 (s1t_t s));
         hp1=(hp1 (s1t_t s))
      in
      (ALL_ADDR - (reach roots1 hp1)) \<subseteq> \<Union> (hat free1))"

definition
  collector1_rely :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
  "collector1_rely s s' \<equiv>
    (let free1'=(free1 (s1t_t s')); free1 =(free1 (s1t_t s));
         roots1 =(roots1 (s1t_t s)); hp1 =(hp1 (s1t_t s))
      in roots1_constant s s' \<and>

         free1' \<subseteq> free1)"
\<comment> \<open> (garbage1 roots1 free1 hp1) \<subseteq> (garbage1 roots1 free1' hp1) \<and> \<close>

definition
  collector1_guar :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
  "collector1_guar s s' \<equiv>
    (let free1'=(free1 (s1t_t s')); free1 =(free1 (s1t_t s))
      in collector1_frame s s' \<and> free1 \<subseteq> free1')"

lemmas collector1_defs = Let_def collector1_pre_def hat_def collector1_frame_def roots1_constant_def
                         collector1_post_def collector1_rely_def collector1_guar_def

(*context RG_VCG
begin*)

lemma l2_collector1_fsb: "collector1_pre s \<Longrightarrow> \<exists>s'. collector1_post s s'"
  unfolding collector1_defs reach_def
  by simp

lemma l3_collector1_rely_refl: "collector1_rely s s"
  unfolding collector1_defs
  by simp

lemma l4_collector1_guar_refl: "collector1_guar s s"
  unfolding collector1_defs
  by simp

lemma l5_collector1_rely_trans: "collector1_rely s t \<Longrightarrow> collector1_rely t u \<Longrightarrow> collector1_rely s u"
  unfolding collector1_defs
  apply safe
  apply (simp add: garbage1_def)+
  by blast

lemma l6_collector1_guar_trans: "collector1_guar s t \<Longrightarrow> collector1_guar t u \<Longrightarrow> collector1_guar s u"
  unfolding collector1_defs
  apply safe
  apply simp_all
  by blast

lemma l7_collector1_post_guar: "collector1_pre s \<Longrightarrow> (\<exists>s'. collector1_post s s' \<and> collector1_guar s s')"
  unfolding collector1_defs by blast

lemma l8_collector1_pre_rely: "collector1_pre s \<Longrightarrow> collector1_rely s s' \<Longrightarrow> collector1_pre s'"
  unfolding collector1_defs by blast

lemma l9_collector1_rely_comp_post:
  "collector1_pre s \<Longrightarrow> (collector1_rely ;; collector1_post) s s' \<Longrightarrow> collector1_post s s'"
  apply (erule spec_compE)
  unfolding collector1_defs by blast

lemma l11_collector1_post_comp_rely:
  "(collector1_post ;; collector1_rely) s s' \<Longrightarrow> collector1_post s s'"
  apply (erule spec_compE)
  unfolding collector1_defs by blast

interpretation Sigma1Type : VDM inv_Sigma1_T
  apply (unfold_locales)
  apply (simp add: l1_s1t_inv)
  done

interpretation collector1: RG_VCG
  inv_Sigma1_T collector1_pre collector1_post collector1_rely collector1_guar
  apply (unfold_locales, safe)
  apply (simp add: l2_collector1_fsb)
  apply (simp add: l3_collector1_rely_refl)
  apply (simp add: l4_collector1_guar_refl)
  apply (rule l5_collector1_rely_trans, simp_all)
  apply (rule l6_collector1_guar_trans, simp_all)
  apply (simp add: l7_collector1_post_guar)
  apply (simp add: l8_collector1_pre_rely)
  apply (simp add: l9_collector1_rely_comp_post)
  apply (simp add: l11_collector1_post_comp_rely)
  done

(*
Mutator
ext   wr hp, free
      rd roots
pre   True
rely  free' -\<triangleleft> hp' = free' -\<triangleleft> hp \<and>
      free \<subseteq> free'
guar  free' \<subseteq> free
post  True
*)

definition
  mutator1_frame :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
 "mutator1_frame s s' \<equiv> roots1_constant s s'"

definition
  mutator1_pre :: "Sigma1Type \<Rightarrow> \<bool>"
where
  "mutator1_pre s \<equiv> True"

definition
  mutator1_post :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
  "mutator1_post s s' \<equiv> True"

definition
  mutator1_rely :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
  "mutator1_rely s s' \<equiv>
    (let free1'=(free1 (s1t_t s')); free1 =(free1 (s1t_t s));
         roots1'=(roots1 (s1t_t s')); roots1 =(roots1 (s1t_t s));
         hp1'=(hp1 (s1t_t s')); hp1 =(hp1 (s1t_t s))
      in roots1_constant s s' \<and>
         (free1' -\<triangleleft> hp1') = (free1' -\<triangleleft> hp1) \<and>
         free1 \<subseteq> free1')"

definition
  mutator1_guar :: "Sigma1Type \<Rightarrow> Sigma1Type \<Rightarrow> \<bool>"
where
  "mutator1_guar s s' \<equiv>
    (let free1'=(free1 (s1t_t s')); free1 =(free1 (s1t_t s));
         roots1 =(roots1 (s1t_t s));
         hp1'=(hp1 (s1t_t s')); hp1 =(hp1 (s1t_t s))
      in mutator1_frame s s' \<and>
         free1' \<subseteq> free1 )"
\<comment> \<open>(garbage1 roots1 free1 hp1) \<subseteq> (garbage1 roots1 free1' hp1') \<and> \<close>

lemmas mutator1_defs = Let_def mutator1_pre_def mutator1_frame_def roots1_constant_def
                         mutator1_post_def mutator1_rely_def mutator1_guar_def

lemma l2_mutator1_fsb: "mutator1_pre s \<Longrightarrow> \<exists>s'. mutator1_post s s'"
  unfolding mutator1_defs by simp

lemma l3_mutator1_rely_refl: "mutator1_rely s s"
  unfolding mutator1_defs
  by simp

lemma l4_mutator1_guar_refl: "mutator1_guar s s"
  unfolding mutator1_defs
  by simp

lemma l_dom_antires_apply: "(S -\<triangleleft> f) l = (if l \<in> S then None else f l)"
by (metis dom_antirestr_def)

lemma l5_mutator1_rely_trans_aux: "\<lbrakk>a1 \<subseteq> a2 ; a2 \<subseteq> a3; a2 -\<triangleleft> f2 = a2 -\<triangleleft> f1; a3 -\<triangleleft> f3 = a3 -\<triangleleft> f2\<rbrakk> \<Longrightarrow> a3 -\<triangleleft> f2 = a3 -\<triangleleft> f1"
  apply (rule ext)
  apply (simp add: l_dom_antires_apply, safe)
  by (metis (full_types) contra_subsetD dom_antirestr_def)
    thm contra_subsetD set_mp
  (*
  "e": Try this: by (metis (full_types) contra_subsetD dom_antirestr_def) (17 ms)
  "spass": Try this: by (metis dom_antirestr_def set_mp) (10 ms)
  "cvc4": Try this: by (metis domIff f_in_dom_ar_apply_subsume l_in_dom_ar set_mp) (740 ms)
  *)

lemma l5_mutator1_rely_trans: "mutator1_rely s t \<Longrightarrow> mutator1_rely t u \<Longrightarrow> mutator1_rely s u"
  unfolding mutator1_defs
  apply (safe,simp_all)
  apply (rule l5_mutator1_rely_trans_aux, simp+)
  by blast

lemma l6_mutator1_guar_trans: "mutator1_guar s t \<Longrightarrow> mutator1_guar t u \<Longrightarrow> mutator1_guar s u"
  unfolding mutator1_defs
  apply safe
  apply (simp add: garbage1_def)+
  by blast+

lemma l7_mutator1_post_guar: "mutator1_pre s \<Longrightarrow> (\<exists>s'. mutator1_post s s' \<and> mutator1_guar s s')"
  unfolding mutator1_defs by blast

lemma l8_mutator1_pre_rely: "mutator1_pre s \<Longrightarrow> mutator1_rely s s' \<Longrightarrow> mutator1_pre s'"
  unfolding mutator1_defs by blast

lemma l9_mutator1_rely_comp_post:
  "mutator1_pre s \<Longrightarrow> (mutator1_rely ;; mutator1_post) s s' \<Longrightarrow> mutator1_post s s'"
  apply (erule spec_compE)
  unfolding mutator1_defs by blast

lemma l11_mutator1_post_comp_rely:
  "(mutator1_post ;; mutator1_rely) s s' \<Longrightarrow> mutator1_post s s'"
  apply (erule spec_compE)
  unfolding mutator1_defs by blast

interpretation mutator1: RG_VCG
  inv_Sigma1_T mutator1_pre mutator1_post mutator1_rely mutator1_guar
  apply (unfold_locales, safe)
  apply (simp add: l2_mutator1_fsb)
  apply (simp add: l3_mutator1_rely_refl)
  apply (simp add: l4_mutator1_guar_refl)
  apply (rule l5_mutator1_rely_trans, simp_all)
  apply (rule l6_mutator1_guar_trans, simp_all)
  apply (simp add: l7_mutator1_post_guar)
  apply (simp add: l8_mutator1_pre_rely)
  apply (simp add: l9_mutator1_rely_comp_post)
  apply (simp add: l11_mutator1_post_comp_rely)
  done

text \<open> Cliff's Theorem 3 ? \<close>
lemma l_collector1_coherence: "mutator1_guar s s' \<longleftrightarrow> collector1_rely s s'"
  unfolding mutator1_defs collector1_defs garbage1_def
  by (safe)

lemma l_mutator1_coherence: "collector1_guar s s' \<Longrightarrow> mutator1_rely s s'"
  unfolding Let_def mutator1_rely_def collector1_guar_def collector1_frame_def
            roots1_constant_def garbage1_def
  by (safe,simp)

lemma l_mutator1_coherence_not: "mutator1_rely s s' \<Longrightarrow> collector1_guar s s'"
  unfolding Let_def mutator1_rely_def collector1_guar_def collector1_frame_def
            roots1_constant_def garbage1_def
  apply (safe) oops

end


theory Example2
  imports Trace
begin

(* Some lemmas sorried out where proven in other files *)

datatype state = State nat nat nat nat

datatype variable = IA | FA | IB | FB

datatype expr = Var variable
              | BinOp "nat \<Rightarrow> nat \<Rightarrow> nat" expr expr
              | UnOp "nat \<Rightarrow> nat" expr
              | Val nat

primrec vars :: "expr \<Rightarrow> variable set" where
  "vars (Var n) = {n}"
| "vars (BinOp f e1 e2) = vars e1 \<union> vars e2"
| "vars (UnOp f e) = vars e"
| "vars (Val n) = {}"

fun lookup :: "state \<Rightarrow> variable \<Rightarrow> nat" where
  "lookup (State ia fa ib fb) IA = ia"
| "lookup (State ia fa ib fb) FA = fa"
| "lookup (State ia fa ib fb) IB = ib"
| "lookup (State ia fa ib fb) FB = fb"

primrec eval :: "state \<Rightarrow> expr \<Rightarrow> nat" where
  "eval \<sigma> (Var v) = lookup \<sigma> v"
| "eval \<sigma> (BinOp f e1 e2) = f (eval \<sigma> e1) (eval \<sigma> e2)"
| "eval \<sigma> (UnOp f e) = f (eval \<sigma> e)"
| "eval \<sigma> (Val n) = n"

lift_definition ends :: "'a set \<Rightarrow> 'a trace"
  is "\<lambda>P. {t. lfinite t \<and> t \<noteq> LNil \<and> snd (llast t) \<in> P}" by simp

lemma atomic_iso: "X \<le> Y \<Longrightarrow> \<langle>X\<rangle> \<le> \<langle>Y\<rangle>"
  by transfer auto

lemma ends_test: "ends P \<cdot> test Q \<le>\<^sub>\<pi> ends (P \<inter> Q)"
  apply (simp add: proj_leq_def test_def proj_def)
  apply transfer
  apply simp
  apply (rule Mumble_iso)
  apply (subst fin_l_prod)
  apply (simp add: FIN_def)
  apply (metis (lifting) Collect_mono)
  apply auto
  apply (simp add: atomic_def image_def)
  apply auto
  apply (simp add: atomic_def image_def)
  apply (erule bexE)
  apply simp
  apply (smt Con_def Id_onD' lappend_code(2) lappend_consistent lfinite.simps llast_LCons llast_lappend_LCons mem_Collect_eq)
  apply (simp add: atomic_def image_def)
  apply (erule bexE)
  apply simp
  by (metis Id_onD' Id_on_fst lappend_code(2) lfinite_LCons llast_lappend llast_singleton llist.distinct(1))

lemma test_ends: "test P \<le> ends P"
  apply (simp add: test_def)
  apply transfer
  apply (simp add: atomic_def)
  apply (rule Mumble_iso)
  by (auto simp add: image_def)

lemma Mumble_empty: "{}\<^sup>\<dagger> = {}"
  by (auto simp add: Mumble_def)

fun update :: "variable \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> state" where
  "update IA ia' (State ia fa ib fb) = (State ia' fa ib fb)"
| "update FA fa' (State ia fa ib fb) = (State ia fa' ib fb)"
| "update IB ib' (State ia fa ib fb) = (State ia fa ib' fb)"
| "update FB fb' (State ia fa ib fb) = (State ia fa ib fb')"

abbreviation assigns_notation :: "state set \<Rightarrow> variable \<Rightarrow> expr \<Rightarrow> state set"
  ("_\<lbrakk>_ := _\<rbrakk>" [100,100,100] 101) where
  "P\<lbrakk>x := e\<rbrakk> \<equiv> (\<lambda>\<sigma>. update x (eval \<sigma> e) \<sigma>) ` P"

definition preserves :: "'a set \<Rightarrow> 'a trace" where
  "preserves P = \<langle>{(\<sigma>, \<sigma>'). \<sigma> \<in> P \<longrightarrow> \<sigma>' \<in> P}\<rangle>\<^sup>\<star>"

lemma preserves_RG [simp,intro!]: "preserves X \<in> RG"
  by (simp add: preserves_def, transfer, auto)

definition unchanged :: "variable set \<Rightarrow> state trace" where
  "unchanged Vars \<equiv> \<langle>{(\<sigma>, \<sigma>'). \<forall>v\<in>Vars. lookup \<sigma> v = lookup \<sigma>' v}\<rangle>\<^sup>\<star>"

lemma unchanged_RG [intro!]: "unchanged X \<in> RG"
  by (simp add: unchanged_def, transfer, auto)

definition decreasing :: "variable set \<Rightarrow> state trace" where
  "decreasing Vars \<equiv> \<langle>{(\<sigma>, \<sigma>'). \<forall>v\<in>Vars. lookup \<sigma> v \<le> lookup \<sigma>' v}\<rangle>\<^sup>\<star>"

lemma atomic_shuffle [simp]: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle> = \<langle>R\<rangle>\<^sup>\<star> \<cdot> \<langle>S\<rangle> \<cdot> \<langle>R\<rangle>\<^sup>\<star>"
  sorry

lift_definition atomic_fn :: "(state \<Rightarrow> state) \<Rightarrow> state trace"
  is "\<lambda>f. {LCons (x, f x) LNil |x. True}" by simp

definition assign_value :: "variable \<Rightarrow> nat \<Rightarrow> state trace" (infix "\<leftharpoondown>" 110) where
  "x \<leftharpoondown> v = atomic_fn (update x v)"

definition assign :: "variable \<Rightarrow> expr \<Rightarrow> state trace" (infix ":=" 110) where
  "x := e = (\<Squnion>v. test {\<sigma>. eval \<sigma> e = v} \<cdot> x \<leftharpoondown> v)"

lemma assignment:
  assumes "(x := e) \<le> g"
  shows "(unchanged (vars e) \<sqinter> preserves P \<sqinter> preserves (P\<lbrakk>x := e\<rbrakk>)), g \<turnstile> \<lbrace>ends P\<rbrace> x := e \<lbrace>ends (P\<lbrakk>x := e\<rbrakk>)\<rbrace>"
  sorry

notation
  times (infixr ";//" 63)

no_notation par (infixl "\<parallel>" 69)

notation par (infixr "//\<parallel>" 62)

definition while_inv :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a trace \<Rightarrow> 'a trace" ("WHILE _ //INVARIANT _ //DO _ //WEND" [64,64,64] 63) where
  "WHILE b INVARIANT i DO p WEND = (test b ; p)\<^sup>\<star> ; test (- b)"

definition if_then_else :: "'a set \<Rightarrow> 'a trace \<Rightarrow> 'a trace \<Rightarrow> 'a trace" ("IF _ //THEN _ //ELSE _" [64,64,64] 64) where
  "IF b THEN  p ELSE q = test b \<cdot> p + test b \<cdot> q"

definition LEN :: "nat" where "LEN = 10"

definition array :: "nat \<Rightarrow> nat" where
  "array n = n"

definition loop1_inv :: "(nat \<Rightarrow> bool) \<Rightarrow> state set" where
  "loop1_inv p = {\<sigma>. (\<forall>v. even v \<and> v < lookup \<sigma> IA \<longrightarrow> \<not> p (array v)) \<and> even (lookup \<sigma> IA) \<and> ((p (array (lookup \<sigma> FA)) \<and> lookup \<sigma> FA \<le> LEN) \<or> lookup \<sigma> FA = LEN)}"

definition loop2_inv :: "(nat \<Rightarrow> bool) \<Rightarrow> state set" where
  "loop2_inv p = {\<sigma>. (\<forall>v. odd v \<and> v < lookup \<sigma> IB \<longrightarrow> \<not> p (array v)) \<and> odd (lookup \<sigma> IB) \<and> ((p (array (lookup \<sigma> FB)) \<and> lookup \<sigma> FB \<le> LEN) \<or> lookup \<sigma> FB = LEN)}"

definition FIND :: "(nat \<Rightarrow> bool) \<Rightarrow> state trace" where
  "FIND p \<equiv>
  FA := Val LEN;
  FB := Val LEN;
  ( IA := Val 0;
    WHILE {\<sigma>. lookup \<sigma> IA < lookup \<sigma> FA \<and> lookup \<sigma> IA < lookup \<sigma> FB}
    INVARIANT loop1_inv p
    DO
      IF {\<sigma>. p (array (lookup \<sigma> IA))}
      THEN FA := Var IA
      ELSE IA := BinOp op + (Var IA) (Val 2)
    WEND
  \<parallel> IB := Val 1;
    WHILE {\<sigma>. lookup \<sigma> IB < lookup \<sigma> FA \<and> lookup \<sigma> IB < lookup \<sigma> FB}
    INVARIANT loop2_inv p
    DO
      IF {\<sigma>. p (array (lookup \<sigma> IB))}
      THEN FB := Var IB
      ELSE IB := BinOp op + (Var IB) (Val 2)
    WEND)"

lemma sequential: "r, g \<turnstile> \<lbrace>p\<rbrace> c1 \<lbrace>x\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>x\<rbrace> c2 \<lbrace>q\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c1 \<cdot> c2 \<lbrace>q\<rbrace>"
  by (metis sequential)

lemma while:
  assumes "ends p \<le> ends i"
  and "ends (-b \<inter> i) \<le> ends q"
  and "r, g \<turnstile> \<lbrace>ends (i \<inter> b)\<rbrace> c \<lbrace>ends i\<rbrace>"
  shows "r, g \<turnstile> \<lbrace>ends p\<rbrace> WHILE b INVARIANT i DO c WEND \<lbrace>ends q\<rbrace>"
  sorry

lemma if_then_else:
  assumes "r, g \<turnstile> \<lbrace>ends (p \<inter> b)\<rbrace> c1 \<lbrace>ends q\<rbrace>"
  and "r, g \<turnstile> \<lbrace>ends (p \<inter> - b)\<rbrace> c2 \<lbrace>ends q\<rbrace>"
  shows "r, g \<turnstile> \<lbrace>ends p\<rbrace> IF b THEN c1 ELSE c2 \<lbrace>ends q\<rbrace>"
  sorry

lemma preserves_inter_leq: "x \<le> preserves X \<Longrightarrow> x \<le> preserves Y \<Longrightarrow> x \<le> preserves (X \<inter> Y)"
  sorry

lemma lookup_update [simp]: "lookup (update v x n) v = x"
  by (induct v) (induct n, simp)+

lemma [intro]: "1 \<le> unchanged V"
  apply (simp add: unchanged_def)
  by (smt star_ref)

lemma [intro]: "1 \<le> preserves X"
  apply (simp add: preserves_def)
  by (smt star_ref)

lemma [intro]: "1 \<le> decreasing X"
  apply (simp add: decreasing_def)
  by (smt star_ref)

find_theorems "op \<in>" "op `"

lemma [intro]: "\<langle>X\<rangle>\<^sup>\<star> \<in> RG"
  apply transfer
  apply simp
  apply (intro Set.imageI)
  by auto

lemma [intro]: "decreasing V \<in> RG"
  by (auto simp add: decreasing_def)

lemma [intro]: "1 \<in> RG"
  by (metis rg_unit)

(* This example only considers finite traces *)
lemma [intro]: "x \<le> \<langle>UNIV\<rangle>\<^sup>\<star>"
  sorry

lemma assignment_var:
  assumes "P\<lbrakk>x := e\<rbrakk> \<le> Q"
  and "r \<le> unchanged (vars e) \<sqinter> preserves P \<sqinter> preserves (P\<lbrakk>x := e\<rbrakk>)" and "r \<in> RG"
  and "x := e \<le> g" and "g \<in> RG"
  shows "r, g \<turnstile> \<lbrace>ends P\<rbrace> x := e \<lbrace>ends Q\<rbrace>"
  sorry

lemma strengthen_guar: "x \<le> g \<Longrightarrow> g \<in> RG \<Longrightarrow> r, x \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"
  by (auto simp add: quintuple_def proj_leq_def)

lemma weaken_rely: "r \<le> x \<Longrightarrow> r \<in> RG \<Longrightarrow> x, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"
  apply (auto simp add: quintuple_def proj_leq_def)
  by (metis mult_isol par_comm par_isor proj_leq_def proj_leq_trans2)

lemma weaken_precondition: "p \<le> x \<Longrightarrow> r, g \<turnstile> \<lbrace>x\<rbrace> c \<lbrace>q\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"
  apply (auto simp add: quintuple_def proj_leq_def)
  by (metis mult_isor proj_leq_def proj_leq_trans2)

lemma strengthen_postcondition_proj: "x \<le>\<^sub>\<pi> q \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>x\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"
  by (auto simp add: quintuple_def proj_leq_def)

lemma strengthen_postcondition: "x \<le> q \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>x\<rbrace> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>"
  apply (auto simp add: quintuple_def proj_leq_def)
  by (metis order.trans proj_iso)

lemma mumble_LCons_not_LNil: "ys \<in> mumble (LCons (\<sigma>, \<sigma>') xs) \<Longrightarrow> ys \<noteq> LNil"
  by (induct rule: mumble.induct) auto

lemma mumble_llast: "ys \<in> mumble (LCons (\<sigma>, \<sigma>') xs) \<Longrightarrow> snd (llast (LCons (\<sigma>, \<sigma>') xs)) \<in> P \<Longrightarrow> snd (llast ys) \<in> P"
  apply (induct rule: mumble.induct)
  apply auto
  by (metis llast_LCons llast_lappend llist.distinct(1) snd_conv)

lemma ends_inter [simp]: "ends P \<sqinter> ends Q = ends (P \<inter> Q)"
  apply transfer
  apply (auto simp add: Mumble_def)
  apply (rule_tac x = "mumble xs" in exI)
  apply auto
  apply (rule_tac x = xs in exI)
  apply auto
  by (metis mumble_llast)+

lemma ends_mono: "P \<subseteq> Q \<Longrightarrow> ends P \<le> ends Q"
  by transfer (auto simp add: Mumble_def)

lemma [intro]: "x \<in> RG \<Longrightarrow> y \<in> RG \<Longrightarrow> x \<sqinter> y \<in> RG"
  by (metis rg_meet_closed)

lemma [simp]: "unchanged {} = \<langle>UNIV\<rangle>\<^sup>\<star>"
  apply (simp add: unchanged_def)
  apply (rule arg_cong) back back
  by auto

lemma rg_mono: "X \<le> Y \<Longrightarrow> \<langle>X\<rangle>\<^sup>\<star> \<le> \<langle>Y\<rangle>\<^sup>\<star>"
  by (intro star_iso[rule_format] atomic_iso) assumption

lemma helper_var_lem: "x \<notin> V \<Longrightarrow> va \<in> V \<Longrightarrow> lookup xb va = lookup (update x v xb) va"
  apply (induct xb)
  apply (induct va)
  apply (induct x)
  apply simp_all
  apply (induct x)
  apply simp_all
  apply (induct x)
  apply simp_all
  apply (induct x)
  by simp_all

lemma atomic_assign_unchanged: "x \<notin> V \<Longrightarrow> x \<leftharpoondown> v \<le> unchanged V"
  apply (simp add: unchanged_def assign_value_def)
  apply transfer
  apply simp
  apply (rule Mumble_iso)
  apply auto
  apply (intro atomic_star_elemI)
  apply auto
  by (metis helper_var_lem)

lemma [intro]: "x \<notin> V \<Longrightarrow> x := v \<le> unchanged V"
  apply (simp add: unchanged_def assign_def)
  apply (simp only: SUP_def)
  apply (rule Sup_least)
  apply auto
  apply (simp add: test_def assign_value_def)
  apply transfer
  apply simp
  apply (rule Mumble_iso)
  apply (subst fin_l_prod)
  apply (simp add: atomic_def image_def FIN_def)
  apply force
  apply (simp add: image_def)
  apply auto
  apply (intro atomic_star_elemI)
  apply (simp_all add: image_def atomic_def)
  apply (erule bexE)
  apply simp
  apply (erule bexE)
  apply safe
  apply force
  by (metis helper_var_lem lmember_code(1) lmember_code(2) lset_lmember prod.inject)

lemma [intro]: "X \<le> unchanged {x} \<Longrightarrow> X \<le> decreasing {x}"
  apply (subgoal_tac "unchanged {x} \<le> decreasing {x}")
  apply auto
  apply (simp add: unchanged_def decreasing_def)
  apply (rule rg_mono)
  by auto

lemma preserves_empty [simp]: "preserves {} = \<langle>UNIV\<rangle>\<^sup>\<star>"
  by (auto intro: arg_cong simp add: preserves_def)

lemma rg_inter: "trans X \<Longrightarrow> trans Y \<Longrightarrow> \<langle>X\<rangle>\<^sup>\<star> \<sqinter> \<langle>Y\<rangle>\<^sup>\<star> = \<langle>X \<inter> Y\<rangle>\<^sup>\<star>"
  by transfer (metis Mumble_atomic Mumble_atomic_star rely_inter trancl_id)

lemma findp_correctness:
  assumes "FA := Var IA \<le> decreasing {FA}" (* We need an atomic command that combine's a test with an assignment (a guarded assignment *)
  and "FB := Var IB \<le> decreasing {FB}"
  shows "1, \<langle>UNIV\<rangle>\<^sup>\<star> \<turnstile> \<lbrace>ends UNIV\<rbrace> FIND P \<lbrace>ends {\<sigma>. P (array (min (lookup \<sigma> FA) (lookup \<sigma> FB))) \<or> (lookup \<sigma> FA = LEN \<and> lookup \<sigma> FB = LEN)}\<rbrace>"
  apply (simp add: FIND_def)

  (* First two assignments *)
  apply (rule_tac x = "ends {\<sigma>. lookup \<sigma> FA = LEN}" in sequential)
  apply (rule assignment_var)
    apply (auto simp add: image_def)
  apply (rule_tac x = "ends {\<sigma>. lookup \<sigma> FA = LEN \<and> lookup \<sigma> FB = LEN}" in sequential)
  apply (rule assignment_var)
    apply (auto simp add: image_def)
    apply (metis lookup.simps(2) state.exhaust update.simps(4))

  (* Weakening and strengthening to apply parallel *)
  apply (rule_tac x = "decreasing {FA} \<sqinter> unchanged {IB, FB} \<parallel> decreasing {FB} \<sqinter> unchanged {IA, FA}" in strengthen_guar)
    apply auto
  apply (rule_tac x = "(decreasing {FB} \<sqinter> unchanged {IA, FA}) \<sqinter> (decreasing {FA} \<sqinter> unchanged {IB, FB})" in weaken_rely)
    apply auto
    apply (rule_tac x = "ends {\<sigma>. lookup \<sigma> FA = LEN} \<sqinter> ends {\<sigma>. lookup \<sigma> FB = LEN}" in weaken_precondition)
    apply (force intro: ends_mono)
  apply (rule_tac x = "ends (loop1_inv P \<inter> - {\<sigma>. lookup \<sigma> IA < lookup \<sigma> FA \<and> lookup \<sigma> IA < lookup \<sigma> FB})
                     \<sqinter> ends (loop2_inv P \<inter> - {\<sigma>. lookup \<sigma> IB < lookup \<sigma> FA \<and> lookup \<sigma> IB < lookup \<sigma> FB})" in strengthen_postcondition)
    apply (subst ends_inter)
    apply (rule ends_mono)
    apply (simp add: loop1_inv_def loop2_inv_def)
    apply clarify
    apply (metis min_def min_max.inf_absorb2)

  (* Ready to apply parallel *)
  apply (rule parallel)

    (* First loop *)
  apply (rule_tac x = "ends {\<sigma>. lookup \<sigma> FA = LEN \<and> lookup \<sigma> IA = 0}" in sequential)
  apply (rule assignment_var)
    apply (simp add: image_def)
    apply clarify
    apply (metis lookup.simps(2) lookup_update state.exhaust update.simps(1))
    apply (rule le_infI2)
    apply simp
    apply (intro conjI)
    apply force
    apply (simp add: unchanged_def preserves_def)
    apply (rule rg_mono)
    apply force
    apply (simp add: unchanged_def preserves_def)
    apply (rule rg_mono)
    apply (simp add: image_def)
    apply clarify
    apply (metis lookup.simps(1) lookup.simps(2) state.exhaust update.simps(1))
    apply force
    apply simp
    apply (intro conjI)
    apply force
    apply force
    apply force
  apply (rule while)
    apply (rule ends_mono)
    apply (simp add: loop1_inv_def)
    apply clarify
    apply (metis even_zero_nat less_nat_zero_code)
    apply (rule ends_mono)
    apply (simp add: loop1_inv_def)
    apply (rule if_then_else)
      apply (rule assignment_var)
      apply (simp add: loop1_inv_def image_def)
      apply clarify
      apply (rule_tac y = xa in state.exhaust)
      apply simp
      apply (metis dual_order.strict_trans not_less)
      apply (simp add: decreasing_def unchanged_def)
      apply (intro conjI)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply blast
      apply (simp add: preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply clarify
      apply (simp add: loop1_inv_def)
      apply (simp add: preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply safe
      apply (simp add: loop1_inv_def image_def)
      apply clarify
      apply (rule_tac y = b in state.exhaust)
      apply (rule_tac y = \<sigma> in state.exhaust)
      apply simp
      apply (rule_tac x = "State nat2 nat2a nat3 nat4" in bexI)
      apply simp
      apply simp
      apply blast
      defer
      apply blast
      apply (rule assignment_var)
      apply (simp add: loop1_inv_def image_def)
      apply clarify
      apply (rule_tac y = xa in state.exhaust)
      apply simp
      apply clarify
      apply (metis dual_order.order_iff_strict even_Suc le_less_linear not_less_eq)
      apply simp
      apply (intro conjI)
      apply (simp add: unchanged_def decreasing_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply blast
      apply (simp add: unchanged_def decreasing_def preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply (simp add: loop1_inv_def)
      apply clarify
      apply (metis dual_order.strict_trans1)
      apply (simp add: unchanged_def decreasing_def preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply (simp add: loop1_inv_def)
      apply clarify
      apply (rule_tac y = a in state.exhaust)
      apply (rule_tac y = b in state.exhaust)
      apply (rule_tac y = \<sigma> in state.exhaust)
      apply (simp add: image_def)
      apply (erule_tac x = "State nat1b nat2a nat3a nat4a" in ballE)
      apply clarsimp
      apply simp
      apply blast
      defer
      apply blast

  (* Second loop *)
  apply (rule_tac x = "ends {\<sigma>. lookup \<sigma> FB = LEN \<and> lookup \<sigma> IB = 1}" in sequential)
  apply (rule assignment_var)
    apply (simp add: image_def)
    apply clarify
    apply (metis lookup.simps(4) lookup_update state.exhaust update.simps(3))
    apply (rule le_infI2)
    apply simp
    apply (intro conjI)
    apply force
    apply (simp add: unchanged_def preserves_def)
    apply (rule rg_mono)
    apply force
    apply (simp add: unchanged_def preserves_def)
    apply (rule rg_mono)
    apply (simp add: image_def)
    apply clarify
    apply (metis lookup.simps(3) lookup.simps(4) state.exhaust update.simps(3))
    apply force
    apply simp
    apply (intro conjI)
    apply force
    apply force
    apply force
  apply (rule while)
    apply (rule ends_mono)
    apply (simp add: loop2_inv_def)
    apply clarify
    apply (metis even_Suc even_zero_nat less_Suc0)
    apply (rule ends_mono)
    apply (simp add: loop1_inv_def)
    apply (rule if_then_else)
      apply (rule assignment_var)
      apply (simp add: loop2_inv_def image_def)
      apply clarify
      apply (rule_tac y = xa in state.exhaust)
      apply simp
      apply (metis dual_order.strict_trans1 linear)
      apply (simp add: decreasing_def unchanged_def)
      apply (intro conjI)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply blast
      apply (simp add: preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply clarify
      apply (simp add: loop2_inv_def)
      apply (simp add: preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply safe
      apply (simp add: loop2_inv_def image_def)
      apply clarify
      apply (rule_tac y = b in state.exhaust)
      apply (rule_tac y = \<sigma> in state.exhaust)
      apply simp
      apply (rule_tac x = "State nat1 nat2 nat3 nat4a" in bexI)
      apply simp_all
      apply blast
      defer
      apply blast
      apply (rule assignment_var)
      apply (simp add: loop2_inv_def image_def)
      apply clarify
      apply (rule_tac y = xa in state.exhaust)
      apply simp
      apply clarify
      apply (metis dual_order.order_iff_strict even_Suc le_less_linear not_less_eq)
      apply simp
      apply (intro conjI)
      apply (simp add: unchanged_def decreasing_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply blast
      apply (simp add: unchanged_def decreasing_def preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply (simp add: loop2_inv_def)
      apply clarify
      apply (metis dual_order.strict_trans1)
      apply (simp add: unchanged_def decreasing_def preserves_def)
      apply (subst rg_inter)
      apply (simp add: trans_def)
      apply (simp add: trans_def)
      apply (rule rg_mono)
      apply (simp add: loop2_inv_def)
      apply clarify
      apply (rule_tac y = a in state.exhaust)
      apply (rule_tac y = b in state.exhaust)
      apply (rule_tac y = \<sigma> in state.exhaust)
      apply (simp add: image_def)
      apply (erule_tac x = "State nat1a nat2a nat3b nat4a" in ballE)
      apply clarsimp
      apply simp
      apply blast
      defer
      apply blast

  (* Simple atomic goals *)
  apply safe
  apply auto
  apply (metis assms(1))
  by (metis assms(2))


(*  Title:      HOL/UNITY/Comp/Progress.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

David Meier's thesis
*)

section{*Progress Set Examples*}

theory Progress imports "../UNITY_Main" begin

subsection {*The Composition of Two Single-Assignment Programs*}
text{*Thesis Section 4.4.2*}

definition FF :: "int program" where
    "FF = mk_total_program (UNIV, {range (\<lambda>x. (x, x+1))}, UNIV)"

definition GG :: "int program" where
    "GG = mk_total_program (UNIV, {range (\<lambda>x. (x, 2*x))}, UNIV)"

subsubsection {*Calculating @{term "wens_set FF (atLeast k)"}*}

lemma Domain_actFF: "Domain (range (\<lambda>x::int. (x, x + 1))) = UNIV"
by force

lemma FF_eq:
      "FF = mk_program (UNIV, {range (\<lambda>x. (x, x+1))}, UNIV)"
by (simp add: FF_def mk_total_program_def totalize_def totalize_act_def
              program_equalityI Domain_actFF)

lemma wp_actFF:
     "wp (range (\<lambda>x::int. (x, x + 1))) (atLeast k) = atLeast (k - 1)"
by (force simp add: wp_def)

lemma wens_FF: "wens FF (range (\<lambda>x. (x, x+1))) (atLeast k) = atLeast (k - 1)"
by (force simp add: FF_eq wens_single_eq wp_actFF)

lemma single_valued_actFF: "single_valued (range (\<lambda>x::int. (x, x + 1)))"
by (force simp add: single_valued_def)

lemma wens_single_finite_FF:
     "wens_single_finite (range (\<lambda>x. (x, x+1))) (atLeast k) n =
      atLeast (k - int n)"
apply (induct n, simp)
apply (force simp add: wens_FF
            def_wens_single_finite_Suc_eq_wens [OF FF_eq single_valued_actFF])
done

lemma wens_single_FF_eq_UNIV:
     "wens_single (range (\<lambda>x::int. (x, x + 1))) (atLeast k) = UNIV"
apply (auto simp add: wens_single_eq_Union)
apply (rule_tac x="nat (k-x)" in exI)
apply (simp add: wens_single_finite_FF)
done

lemma wens_set_FF:
     "wens_set FF (atLeast k) = insert UNIV (atLeast ` atMost k)"
apply (auto simp add: wens_set_single_eq [OF FF_eq single_valued_actFF]
                      wens_single_FF_eq_UNIV wens_single_finite_FF)
apply (erule notE)
apply (rule_tac x="nat (k-xa)" in range_eqI)
apply (simp add: wens_single_finite_FF)
done

subsubsection {*Proving @{term "FF \<in> UNIV leadsTo atLeast (k::int)"}*}

lemma atLeast_ensures: "FF \<in> atLeast (k - 1) ensures atLeast (k::int)"
apply (simp add: Progress.wens_FF [symmetric] wens_ensures)
apply (simp add: wens_ensures FF_eq)
done

lemma atLeast_leadsTo: "FF \<in> atLeast (k - int n) leadsTo atLeast (k::int)"
apply (induct n)
 apply (simp_all add: leadsTo_refl)
apply (rule_tac A = "atLeast (k - int n - 1)" in leadsTo_weaken_L)
 apply (blast intro: leadsTo_Trans atLeast_ensures, force)
done

lemma UN_atLeast_UNIV: "(\<Union>n. atLeast (k - int n)) = UNIV"
apply auto
apply (rule_tac x = "nat (k - x)" in exI, simp)
done

lemma FF_leadsTo: "FF \<in> UNIV leadsTo atLeast (k::int)"
apply (subst UN_atLeast_UNIV [symmetric])
apply (rule leadsTo_UN [OF atLeast_leadsTo])
done

text{*Result (4.39): Applying the leadsTo-Join Theorem*}
theorem "FF\<squnion>GG \<in> atLeast 0 leadsTo atLeast (k::int)"
apply (subgoal_tac "FF\<squnion>GG \<in> (atLeast 0 \<inter> atLeast 0) leadsTo atLeast k")
 apply simp
apply (rule_tac T = "atLeast 0" in leadsTo_Join)
  apply (rule leadsTo_weaken_L [OF FF_leadsTo], simp)
 apply (simp add: awp_iff_constrains FF_def, safety)
apply (simp add: awp_iff_constrains GG_def wens_set_FF, safety)
done

end


(*  Title:      HOL/Nunchaku_Examples/Refute_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2015

Examples for the Refute tool adapted to Nunchaku. Based on

    Title:      HOL/ex/Refute_Examples.thy
    Author:     Tjark Weber
    Copyright   2003-2007
*)

section {* Examples for the Refute Tool Adapted to Nunchaku *}

theory Refute_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, max_potential = 0, timeout = 240]

lemma "P \<and> Q"
apply (rule conjI)
nunchaku [expect = genuine] 1
nunchaku [expect = genuine] 2
nunchaku [expect = genuine]
nunchaku [expect = genuine]
oops

subsection {* Examples and Test Cases *}

subsubsection {* Propositional logic *}

lemma "True"
nunchaku [expect = none]
apply auto
done

lemma "False"
nunchaku [expect = genuine]
oops

lemma "P"
nunchaku [expect = genuine]
oops

lemma "\<not> P"
nunchaku [expect = genuine]
oops

lemma "P \<and> Q"
nunchaku [expect = genuine]
oops

lemma "P \<or> Q"
nunchaku [expect = genuine]
oops

lemma "P \<longrightarrow> Q"
nunchaku [expect = genuine]
oops

lemma "(P :: bool) = Q"
nunchaku [expect = genuine]
oops

lemma "(P \<or> Q) \<longrightarrow> (P \<and> Q)"
nunchaku [expect = genuine]
oops

subsubsection {* Predicate logic *}

lemma "P x y z"
nunchaku [expect = genuine]
oops

lemma "P x y \<longrightarrow> P y x"
nunchaku [expect = genuine]
oops

lemma "P (f (f x)) \<longrightarrow> P x \<longrightarrow> P (f x)"
nunchaku [expect = genuine]
oops

subsubsection {* Equality *}

lemma "P = True"
nunchaku [expect = genuine]
oops

lemma "P = False"
nunchaku [expect = genuine]
oops

lemma "x = y"
nunchaku [expect = genuine]
oops

lemma "f x = g x"
nunchaku [expect = genuine]
oops

lemma "(f :: 'a \<Rightarrow> 'b) = g"
nunchaku [expect = genuine]
oops

lemma "(f :: ('d \<Rightarrow> 'd) \<Rightarrow> ('c \<Rightarrow> 'd)) = g"
nunchaku [expect = genuine]
oops

lemma "distinct [a, b]"
nunchaku [expect = genuine]
apply simp
nunchaku [expect = genuine]
oops

subsubsection {* First-Order Logic *}

lemma "\<exists>x. P x"
nunchaku [expect = genuine]
oops

lemma "\<forall>x. P x"
nunchaku [expect = genuine]
oops

lemma "\<exists>!x. P x"
nunchaku [expect = genuine]
oops

lemma "Ex P"
nunchaku [expect = genuine]
oops

lemma "All P"
nunchaku [expect = genuine]
oops

lemma "Ex1 P"
nunchaku [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
nunchaku [expect = genuine]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
nunchaku [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
nunchaku [expect = genuine]
oops

text {* A true statement (also testing names of free and bound variables being identical) *}

lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
nunchaku [expect = none]
apply fast
done

text {* "A type has at most 4 elements." *}

lemma "\<not> distinct [a, b, c, d, e]"
nunchaku [expect = genuine]
apply simp
nunchaku [expect = genuine]
oops

lemma "distinct [a, b, c, d]"
nunchaku [expect = genuine]
apply simp
nunchaku [expect = genuine]
oops

text {* "Every reflexive and symmetric relation is transitive." *}

lemma "\<lbrakk>\<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x\<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
nunchaku [expect = genuine]
oops

text {* The ``Drinker's theorem'' *}

lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
nunchaku [expect = none]
apply (auto simp add: ext)
done

text {* And an incorrect version of it *}

lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
nunchaku [expect = genuine]
oops

text {* "Every function has a fixed point." *}

lemma "\<exists>x. f x = x"
nunchaku [expect = genuine]
oops

text {* "Function composition is commutative." *}

lemma "f (g x) = g (f x)"
nunchaku [expect = genuine]
oops

text {* "Two functions that are equivalent w.r.t.\ the same predicate 'P' are equal." *}

lemma "((P :: ('a \<Rightarrow> 'b) \<Rightarrow> bool) f = P g) \<longrightarrow> (f x = g x)"
nunchaku [expect = genuine]
oops

subsubsection {* Higher-Order Logic *}

lemma "\<exists>P. P"
nunchaku [expect = none]
apply auto
done

lemma "\<forall>P. P"
nunchaku [expect = genuine]
oops

lemma "\<exists>!P. P"
nunchaku [expect = none]
apply auto
done

lemma "\<exists>!P. P x"
nunchaku [expect = genuine]
oops

lemma "P Q \<or> Q x"
nunchaku [expect = genuine]
oops

lemma "x \<noteq> All"
nunchaku [expect = genuine]
oops

lemma "x \<noteq> Ex"
nunchaku [expect = genuine]
oops

lemma "x \<noteq> Ex1"
nunchaku [expect = genuine]
oops

text {* ``The transitive closure of an arbitrary relation is non-empty.'' *}

definition trans :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "trans P \<longleftrightarrow> (ALL x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

definition subset :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "subset P Q \<longleftrightarrow> (ALL x y. P x y \<longrightarrow> Q x y)"

definition trans_closure :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "trans_closure P Q \<longleftrightarrow> (subset Q P) \<and> (trans P) \<and> (ALL R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"

lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
nunchaku [expect = genuine]
oops

text {* ``The union of transitive closures is equal to the transitive closure of unions.'' *}

lemma "(\<forall>x y. (P x y \<or> R x y) \<longrightarrow> T x y) \<longrightarrow> trans T \<longrightarrow> (\<forall>Q. (\<forall>x y. (P x y \<or> R x y) \<longrightarrow> Q x y) \<longrightarrow> trans Q \<longrightarrow> subset T Q)
 \<longrightarrow> trans_closure TP P
 \<longrightarrow> trans_closure TR R
 \<longrightarrow> (T x y = (TP x y \<or> TR x y))"
nunchaku [expect = genuine]
oops

text {* ``Every surjective function is invertible.'' *}

lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
nunchaku [expect = genuine]
oops

text {* ``Every invertible function is surjective.'' *}

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nunchaku [expect = genuine]
oops

text {* ``Every point is a fixed point of some function.'' *}

lemma "\<exists>f. f x = x"
nunchaku [expect = none]
apply (rule_tac x = "\<lambda>x. x" in exI)
apply simp
done

text {* Axiom of Choice: first an incorrect version *}

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nunchaku [expect = genuine]
oops

text {* And now two correct ones *}

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
nunchaku [expect = none]
apply (simp add: choice)
done

lemma "(\<forall>x. \<exists>!y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nunchaku [expect = none]
apply auto
 apply (simp add: ex1_implies_ex choice)
apply fast
done

subsubsection {* Metalogic *}

lemma "\<And>x. P x"
nunchaku [expect = genuine]
oops

lemma "f x \<equiv> g x"
nunchaku [expect = genuine]
oops

lemma "P \<Longrightarrow> Q"
nunchaku [expect = genuine]
oops

lemma "\<lbrakk>P; Q; R\<rbrakk> \<Longrightarrow> S"
nunchaku [expect = genuine]
oops

lemma "(x \<equiv> Pure.all) \<Longrightarrow> False"
nunchaku [expect = genuine]
oops

lemma "(x \<equiv> (op \<equiv>)) \<Longrightarrow> False"
nunchaku [expect = genuine]
oops

lemma "(x \<equiv> (op \<Longrightarrow>)) \<Longrightarrow> False"
nunchaku [expect = genuine]
oops

subsubsection {* Schematic Variables *}

schematic_goal "?P"
nunchaku [expect = none]
apply auto
done

schematic_goal "x = ?y"
nunchaku [expect = none]
apply auto
done

subsubsection {* Abstractions *}

lemma "(\<lambda>x. x) = (\<lambda>x. y)"
nunchaku [expect = genuine]
oops

lemma "(\<lambda>f. f x) = (\<lambda>f. True)"
nunchaku [expect = genuine]
oops

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
nunchaku [expect = none]
apply simp
done

subsubsection {* Sets *}

lemma "P (A :: 'a set)"
nunchaku [expect = genuine]
oops

lemma "P (A :: 'a set set)"
nunchaku [expect = genuine]
oops

lemma "{x. P x} = {y. P y}"
nunchaku [expect = none]
apply simp
done

lemma "x \<in> {x. P x}"
nunchaku [expect = genuine]
oops

lemma "P (op \<in>)"
nunchaku [expect = genuine]
oops

lemma "P (op \<in> x)"
nunchaku [expect = genuine]
oops

lemma "P Collect"
nunchaku [expect = genuine]
oops

lemma "A \<union> B = A \<inter> B"
nunchaku [expect = genuine]
oops

lemma "(A \<inter> B) \<union> C = (A \<union> C) \<inter> B"
nunchaku [expect = genuine]
oops

lemma "Ball A P \<longrightarrow> Bex A P"
nunchaku [expect = genuine]
oops

subsubsection {* @{const undefined} *}

lemma "undefined"
nunchaku [expect = genuine]
oops

lemma "P undefined"
nunchaku [expect = genuine]
oops

lemma "undefined x"
nunchaku [expect = genuine]
oops

lemma "undefined undefined"
nunchaku [expect = genuine]
oops

subsubsection {* @{const The} *}

lemma "The P"
nunchaku [expect = genuine]
oops

lemma "P The"
nunchaku [expect = genuine]
oops

lemma "P (The P)"
nunchaku [expect = genuine]
oops

lemma "(THE x. x = y) = z"
nunchaku [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (The P)"
nunchaku [expect = genuine]
oops

subsubsection {* @{const Eps} *}

lemma "Eps P"
nunchaku [expect = genuine]
oops

lemma "P Eps"
nunchaku [expect = genuine]
oops

lemma "P (Eps P)"
nunchaku [expect = genuine]
oops

lemma "(SOME x. x=y) = z"
nunchaku [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (Eps P)"
nunchaku [expect = none]
apply (auto simp add: someI)
done

subsubsection {* Operations on Natural Numbers *}

lemma "(x :: nat) + y = 0"
nunchaku [expect = genuine]
oops

lemma "(x :: nat) = x + x"
nunchaku [expect = genuine]
oops

lemma "(x :: nat) - y + y = x"
nunchaku [expect = genuine]
oops

lemma "(x :: nat) = x * x"
nunchaku [expect = genuine]
oops

lemma "(x :: nat) < x + y"
nunchaku [expect = genuine]
oops

text {* \<times> *}

lemma "P (x :: 'a \<times> 'b)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a \<times> 'b. P x"
nunchaku [expect = genuine]
oops

lemma "P (x, y)"
nunchaku [expect = genuine]
oops

lemma "P (fst x)"
nunchaku [expect = genuine]
oops

lemma "P (snd x)"
nunchaku [expect = genuine]
oops

lemma "P Pair"
nunchaku [expect = genuine]
oops

lemma "P (case x of Pair a b \<Rightarrow> f a b)"
nunchaku [expect = genuine]
oops

subsubsection {* Subtypes (typedef), typedecl *}

text {* A completely unspecified non-empty subset of @{typ "'a"}: *}

definition "myTdef = insert (undefined :: 'a) (undefined :: 'a set)"

typedef 'a myTdef = "myTdef :: 'a set"
unfolding myTdef_def by auto

lemma "(x :: 'a myTdef) = y"
nunchaku [expect = genuine]
oops

typedecl myTdecl

definition "T_bij = {(f :: 'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"

typedef 'a T_bij = "T_bij :: ('a \<Rightarrow> 'a) set"
unfolding T_bij_def by auto

lemma "P (f :: (myTdecl myTdef) T_bij)"
nunchaku [expect = genuine]
oops

subsubsection {* Inductive Datatypes *}

text {* unit *}

lemma "P (x :: unit)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: unit. P x"
nunchaku [expect = genuine]
oops

lemma "P ()"
nunchaku [expect = genuine]
oops

lemma "P (case x of () \<Rightarrow> u)"
nunchaku [expect = genuine]
oops

text {* option *}

lemma "P (x :: 'a option)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a option. P x"
nunchaku [expect = genuine]
oops

lemma "P None"
nunchaku [expect = genuine]
oops

lemma "P (Some x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
nunchaku [expect = genuine]
oops

text {* + *}

lemma "P (x :: 'a + 'b)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a + 'b. P x"
nunchaku [expect = genuine]
oops

lemma "P (Inl x)"
nunchaku [expect = genuine]
oops

lemma "P (Inr x)"
nunchaku [expect = genuine]
oops

lemma "P Inl"
nunchaku [expect = genuine]
oops

lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
nunchaku [expect = genuine]
oops

text {* Non-recursive datatypes *}

datatype T1 = A | B

lemma "P (x :: T1)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: T1. P x"
nunchaku [expect = genuine]
oops

lemma "P A"
nunchaku [expect = genuine]
oops

lemma "P B"
nunchaku [expect = genuine]
oops

lemma "rec_T1 a b A = a"
nunchaku [expect = none]
apply simp
done

lemma "rec_T1 a b B = b"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_T1 a b x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
nunchaku [expect = genuine]
oops

datatype 'a T2 = C T1 | D 'a

lemma "P (x :: 'a T2)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a T2. P x"
nunchaku [expect = genuine]
oops

lemma "P D"
nunchaku [expect = genuine]
oops

lemma "rec_T2 c d (C x) = c x"
nunchaku [expect = none]
apply simp
done

lemma "rec_T2 c d (D x) = d x"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_T2 c d x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
nunchaku [expect = genuine]
oops

datatype ('a, 'b) T3 = E "'a \<Rightarrow> 'b"

lemma "P (x :: ('a, 'b) T3)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: ('a, 'b) T3. P x"
nunchaku [expect = genuine]
oops

lemma "P E"
nunchaku [expect = genuine]
oops

lemma "rec_T3 e (E x) = e x"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_T3 e x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of E f \<Rightarrow> e f)"
nunchaku [expect = genuine]
oops

text {* Recursive datatypes *}

text {* nat *}

lemma "P (x :: nat)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: nat. P x"
nunchaku [expect = genuine]
oops

lemma "P (Suc 0)"
nunchaku [expect = genuine]
oops

lemma "P Suc"
nunchaku [expect = none]
oops

lemma "rec_nat zero suc 0 = zero"
nunchaku [expect = none]
apply simp
done

lemma "rec_nat zero suc (Suc x) = suc x (rec_nat zero suc x)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_nat zero suc x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
nunchaku [expect = genuine]
oops

text {* 'a list *}

lemma "P (xs :: 'a list)"
nunchaku [expect = genuine]
oops

lemma "\<forall>xs :: 'a list. P xs"
nunchaku [expect = genuine]
oops

lemma "P [x, y]"
nunchaku [expect = genuine]
oops

lemma "rec_list nil cons [] = nil"
nunchaku [expect = none]
apply simp
done

lemma "rec_list nil cons (x#xs) = cons x xs (rec_list nil cons xs)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_list nil cons xs)"
nunchaku [expect = genuine]
oops

lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
nunchaku [expect = genuine]
oops

lemma "(xs :: 'a list) = ys"
nunchaku [expect = genuine]
oops

lemma "a # xs = b # xs"
nunchaku [expect = genuine]
oops

datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList

lemma "P (x :: BitList)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: BitList. P x"
nunchaku [expect = genuine]
oops

lemma "P (Bit0 (Bit1 BitListNil))"
nunchaku [expect = genuine]
oops

lemma "rec_BitList nil bit0 bit1 BitListNil = nil"
nunchaku [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit0 xs) = bit0 xs (rec_BitList nil bit0 bit1 xs)"
nunchaku [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit1 xs) = bit1 xs (rec_BitList nil bit0 bit1 xs)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_BitList nil bit0 bit1 x)"
nunchaku [expect = genuine]
oops

datatype 'a BinTree = Leaf 'a | Node "'a BinTree" "'a BinTree"

lemma "P (x :: 'a BinTree)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a BinTree. P x"
nunchaku [expect = genuine]
oops

lemma "P (Node (Leaf x) (Leaf y))"
nunchaku [expect = genuine]
oops

lemma "rec_BinTree l n (Leaf x) = l x"
nunchaku [expect = none]
apply simp
done

lemma "rec_BinTree l n (Node x y) = n x y (rec_BinTree l n x) (rec_BinTree l n y)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_BinTree l n x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of Leaf a \<Rightarrow> l a | Node a b \<Rightarrow> n a b)"
nunchaku [expect = genuine]
oops

text {* Mutually recursive datatypes *}

datatype 'a aexp = Number 'a | ITE "'a bexp" "'a aexp" "'a aexp"
 and 'a bexp = Equal "'a aexp" "'a aexp"

lemma "P (x :: 'a aexp)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a aexp. P x"
nunchaku [expect = genuine]
oops

lemma "P (ITE (Equal (Number x) (Number y)) (Number x) (Number y))"
nunchaku [expect = genuine]
oops

lemma "P (x :: 'a bexp)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a bexp. P x"
nunchaku [expect = genuine]
oops

lemma "rec_aexp number ite equal (Number x) = number x"
nunchaku [expect = none]
apply simp
done

lemma "rec_aexp number ite equal (ITE x y z) =
  ite x y z (rec_bexp number ite equal x) (rec_aexp number ite equal y)
    (rec_aexp number ite equal z)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_aexp number ite equal x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of Number a \<Rightarrow> number a | ITE b a1 a2 \<Rightarrow> ite b a1 a2)"
nunchaku [expect = genuine]
oops

lemma "rec_bexp number ite equal (Equal x y) =
  equal x y (rec_aexp number ite equal x) (rec_aexp number ite equal y)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_bexp number ite equal x)"
nunchaku [expect = genuine]
oops

lemma "P (case x of Equal a1 a2 \<Rightarrow> equal a1 a2)"
nunchaku [expect = genuine]
oops

datatype X = A | B X | C Y and Y = D X | E Y | F

lemma "P (x :: X)"
nunchaku [expect = genuine]
oops

lemma "P (y :: Y)"
nunchaku [expect = genuine]
oops

lemma "P (B (B A))"
nunchaku [expect = genuine]
oops

lemma "P (B (C F))"
nunchaku [expect = genuine]
oops

lemma "P (C (D A))"
nunchaku [expect = genuine]
oops

lemma "P (C (E F))"
nunchaku [expect = genuine]
oops

lemma "P (D (B A))"
nunchaku [expect = genuine]
oops

lemma "P (D (C F))"
nunchaku [expect = genuine]
oops

lemma "P (E (D A))"
nunchaku [expect = genuine]
oops

lemma "P (E (E F))"
nunchaku [expect = genuine]
oops

lemma "P (C (D (C F)))"
nunchaku [expect = genuine]
oops

lemma "rec_X a b c d e f A = a"
nunchaku [expect = none]
apply simp
done

lemma "rec_X a b c d e f (B x) = b x (rec_X a b c d e f x)"
nunchaku [expect = none]
apply simp
done

lemma "rec_X a b c d e f (C y) = c y (rec_Y a b c d e f y)"
nunchaku [expect = none]
apply simp
done

lemma "rec_Y a b c d e f (D x) = d x (rec_X a b c d e f x)"
nunchaku [expect = none]
apply simp
done

lemma "rec_Y a b c d e f (E y) = e y (rec_Y a b c d e f y)"
nunchaku [expect = none]
apply simp
done

lemma "rec_Y a b c d e f F = f"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_X a b c d e f x)"
nunchaku [expect = genuine]
oops

lemma "P (rec_Y a b c d e f y)"
nunchaku [expect = genuine]
oops

text {* Other datatype examples *}

text {* Indirect recursion is implemented via mutual recursion. *}

datatype XOpt = CX "XOpt option" | DX "bool \<Rightarrow> XOpt option"

lemma "P (x :: XOpt)"
nunchaku [expect = genuine]
oops

lemma "P (CX None)"
nunchaku [expect = genuine]
oops

lemma "P (CX (Some (CX None)))"
nunchaku [expect = genuine]
oops

lemma "P (rec_X cx dx n1 s1 n2 s2 x)"
nunchaku [expect = genuine]
oops

datatype 'a YOpt = CY "('a \<Rightarrow> 'a YOpt) option"

lemma "P (x :: 'a YOpt)"
nunchaku [expect = genuine]
oops

lemma "P (CY None)"
nunchaku [expect = genuine]
oops

lemma "P (CY (Some (\<lambda>a. CY None)))"
nunchaku [expect = genuine]
oops

datatype Trie = TR "Trie list"

lemma "P (x :: Trie)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: Trie. P x"
nunchaku [expect = genuine]
oops

lemma "P (TR [TR []])"
nunchaku [expect = genuine]
oops

datatype InfTree = Leaf | Node "nat \<Rightarrow> InfTree"

lemma "P (x :: InfTree)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: InfTree. P x"
nunchaku [expect = genuine]
oops

lemma "P (Node (\<lambda>n. Leaf))"
nunchaku [expect = genuine]
oops

lemma "rec_InfTree leaf node Leaf = leaf"
nunchaku [expect = none]
apply simp
done

lemma "rec_InfTree leaf node (Node g) =
  node ((\<lambda>InfTree. (InfTree, rec_InfTree leaf node InfTree)) \<circ> g)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_InfTree leaf node x)"
nunchaku [expect = genuine]
oops

datatype 'a lambda = Var 'a | App "'a lambda" "'a lambda" | Lam "'a \<Rightarrow> 'a lambda"

lemma "P (x :: 'a lambda)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'a lambda. P x"
nunchaku [expect = genuine]
oops

lemma "P (Lam (\<lambda>a. Var a))"
nunchaku [expect = none]
nunchaku [card 'a = 4, card "'a lambda" = 5, expect = genuine]
oops

lemma "rec_lambda var app lam (Var x) = var x"
nunchaku [expect = none]
apply simp
done

lemma "rec_lambda var app lam (App x y) = app x y (rec_lambda var app lam x) (rec_lambda var app lam y)"
nunchaku [expect = none]
apply simp
done

lemma "rec_lambda var app lam (Lam x) = lam ((\<lambda>lambda. (lambda, rec_lambda var app lam lambda)) \<circ> x)"
nunchaku [expect = none]
apply simp
done

lemma "P (rec_lambda v a l x)"
nunchaku [expect = genuine]
oops

text {* Taken from "Inductive datatypes in HOL", p. 8: *}

datatype (dead 'a, 'b) T = C "'a \<Rightarrow> bool" | D "'b list"
datatype 'c U = E "('c, 'c U) T"

lemma "P (x :: 'c U)"
nunchaku [expect = genuine]
oops

lemma "\<forall>x :: 'c U. P x"
nunchaku [expect = genuine]
oops

lemma "P (E (C (\<lambda>a. True)))"
nunchaku [expect = genuine]
oops

subsubsection {* Records *}

record ('a, 'b) point =
  xpos :: 'a
  ypos :: 'b

lemma "(x :: ('a, 'b) point) = y"
nunchaku [expect = genuine]
oops

record ('a, 'b, 'c) extpoint = "('a, 'b) point" +
  ext :: 'c

lemma "(x :: ('a, 'b, 'c) extpoint) = y"
nunchaku [expect = genuine]
oops

subsubsection {* Inductively Defined Sets *}

inductive_set undefinedSet :: "'a set" where
"undefined \<in> undefinedSet"

lemma "x \<in> undefinedSet"
nunchaku [expect = genuine]
oops

inductive_set evenCard :: "'a set set"
where
"{} \<in> evenCard" |
"\<lbrakk>S \<in> evenCard; x \<notin> S; y \<notin> S; x \<noteq> y\<rbrakk> \<Longrightarrow> S \<union> {x, y} \<in> evenCard"

lemma "S \<in> evenCard"
nunchaku [expect = genuine]
oops

inductive_set
even :: "nat set"
and odd :: "nat set"
where
"0 \<in> even" |
"n \<in> even \<Longrightarrow> Suc n \<in> odd" |
"n \<in> odd \<Longrightarrow> Suc n \<in> even"

lemma "n \<in> odd"
nunchaku [expect = genuine]
oops

consts f :: "'a \<Rightarrow> 'a"

inductive_set a_even :: "'a set" and a_odd :: "'a set" where
"undefined \<in> a_even" |
"x \<in> a_even \<Longrightarrow> f x \<in> a_odd" |
"x \<in> a_odd \<Longrightarrow> f x \<in> a_even"

lemma "x \<in> a_odd"
nunchaku [expect = genuine]
oops

subsubsection {* Examples Involving Special Functions *}

lemma "card x = 0"
nunchaku [expect = genuine]
oops

lemma "finite x"
nunchaku [expect = none]
oops

lemma "xs @ [] = ys @ []"
nunchaku [expect = genuine]
oops

lemma "xs @ ys = ys @ xs"
nunchaku [expect = genuine]
oops

lemma "f (lfp f) = lfp f"
nunchaku [expect = genuine]
oops

lemma "f (gfp f) = gfp f"
nunchaku [expect = genuine]
oops

lemma "lfp f = gfp f"
nunchaku [expect = genuine]
oops

subsubsection {* Axiomatic Type Classes and Overloading *}

text {* A type class without axioms: *}

class classA

lemma "P (x :: 'a :: classA)"
nunchaku [expect = genuine]
oops

text {* An axiom with a type variable (denoting types which have at least two elements): *}

class classC =
  assumes classC_ax: "\<exists>x y. x \<noteq> y"

lemma "P (x :: 'a :: classC)"
nunchaku [expect = genuine]
oops

lemma "\<exists>x y. (x :: 'a :: classC) \<noteq> y"
nunchaku [expect = none]
sorry

text {* A type class for which a constant is defined: *}

class classD =
  fixes classD_const :: "'a \<Rightarrow> 'a"
  assumes classD_ax: "classD_const (classD_const x) = classD_const x"

lemma "P (x :: 'a :: classD)"
nunchaku [expect = genuine]
oops

text {* A type class with multiple superclasses: *}

class classE = classC + classD

lemma "P (x :: 'a :: classE)"
nunchaku [expect = genuine]
oops

text {* OFCLASS: *}

lemma "OFCLASS('a :: type, type_class)"
nunchaku [expect = none]
apply intro_classes
done

lemma "OFCLASS('a :: classC, type_class)"
nunchaku [expect = none]
apply intro_classes
done

lemma "OFCLASS('a :: type, classC_class)"
nunchaku [expect = genuine]
oops

text {* Overloading: *}

consts inverse :: "'a \<Rightarrow> 'a"

defs (overloaded)
inverse_bool: "inverse (b :: bool) \<equiv> \<not> b"
inverse_set: "inverse (S :: 'a set) \<equiv> -S"
inverse_pair: "inverse p \<equiv> (inverse (fst p), inverse (snd p))"

lemma "inverse b"
nunchaku [expect = genuine]
oops

lemma "P (inverse (S :: 'a set))"
nunchaku [expect = genuine]
oops

lemma "P (inverse (p :: 'a \<times> 'b))"
nunchaku [expect = genuine]
oops

end


(*  Title:      HOL/Cardinals/Wellorder_Extension.thy
    Author:     Christian Sternagel, JAIST
*)

section {* Extending Well-founded Relations to Wellorders *}

theory Wellorder_Extension
imports Main Order_Union
begin

subsection {* Extending Well-founded Relations to Wellorders *}

text {*A \emph{downset} (also lower set, decreasing set, initial segment, or
downward closed set) is closed w.r.t.\ smaller elements.*}
definition downset_on where
  "downset_on A r = (\<forall>x y. (x, y) \<in> r \<and> y \<in> A \<longrightarrow> x \<in> A)"

(*
text {*Connection to order filters of the @{theory Cardinals} theory.*}
lemma (in wo_rel) ofilter_downset_on_conv:
  "ofilter A \<longleftrightarrow> downset_on A r \<and> A \<subseteq> Field r"
  by (auto simp: downset_on_def ofilter_def under_def)
*)

lemma downset_onI:
  "(\<And>x y. (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A) \<Longrightarrow> downset_on A r"
  by (auto simp: downset_on_def)

lemma downset_onD:
  "downset_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A"
  unfolding downset_on_def by blast

text {*Extensions of relations w.r.t.\ a given set.*}
definition extension_on where
  "extension_on A r s = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> s \<longrightarrow> (x, y) \<in> r)"

lemma extension_onI:
  "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A; (x, y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r) \<Longrightarrow> extension_on A r s"
  by (auto simp: extension_on_def)

lemma extension_onD:
  "extension_on A r s \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> (x, y) \<in> s \<Longrightarrow> (x, y) \<in> r"
  by (auto simp: extension_on_def)

lemma downset_on_Union:
  assumes "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p"
  shows "downset_on (Field (\<Union>R)) p"
  using assms by (auto intro: downset_onI dest: downset_onD)

lemma chain_subset_extension_on_Union:
  assumes "chain\<^sub>\<subseteq> R" and "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
  shows "extension_on (Field (\<Union>R)) (\<Union>R) p"
  using assms
  by (simp add: chain_subset_def extension_on_def)
     (metis (no_types) mono_Field set_mp)

lemma downset_on_empty [simp]: "downset_on {} p"
  by (auto simp: downset_on_def)

lemma extension_on_empty [simp]: "extension_on {} p q"
  by (auto simp: extension_on_def)

text {*Every well-founded relation can be extended to a wellorder.*}
theorem well_order_extension:
  assumes "wf p"
  shows "\<exists>w. p \<subseteq> w \<and> Well_order w"
proof -
  let ?K = "{r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p}"
  def I \<equiv> "init_seg_of \<inter> ?K \<times> ?K"
  have I_init: "I \<subseteq> init_seg_of" by (simp add: I_def)
  then have subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
    by (auto simp: init_seg_of_def chain_subset_def Chains_def)
  have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow>
      Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p"
    by (simp add: Chains_def I_def) blast
  have FI: "Field I = ?K" by (auto simp: I_def init_seg_of_def Field_def)
  then have 0: "Partial_order I"
    by (auto simp: partial_order_on_def preorder_on_def antisym_def antisym_init_seg_of refl_on_def
      trans_def I_def elim: trans_init_seg_of)
  { fix R assume "R \<in> Chains I"
    then have Ris: "R \<in> Chains init_seg_of" using mono_Chains [OF I_init] by blast
    have subch: "chain\<^sub>\<subseteq> R" using `R \<in> Chains I` I_init
      by (auto simp: init_seg_of_def chain_subset_def Chains_def)
    have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r" and
      "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)" and
      "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p" and
      "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
      using Chains_wo [OF `R \<in> Chains I`] by (simp_all add: order_on_defs)
    have "Refl (\<Union>R)" using `\<forall>r\<in>R. Refl r`  unfolding refl_on_def by fastforce
    moreover have "trans (\<Union>R)"
      by (rule chain_subset_trans_Union [OF subch `\<forall>r\<in>R. trans r`])
    moreover have "antisym (\<Union>R)"
      by (rule chain_subset_antisym_Union [OF subch `\<forall>r\<in>R. antisym r`])
    moreover have "Total (\<Union>R)"
      by (rule chain_subset_Total_Union [OF subch `\<forall>r\<in>R. Total r`])
    moreover have "wf ((\<Union>R) - Id)"
    proof -
      have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
      with `\<forall>r\<in>R. wf (r - Id)` wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
      show ?thesis by fastforce
    qed
    ultimately have "Well_order (\<Union>R)" by (simp add: order_on_defs)
    moreover have "\<forall>r\<in>R. r initial_segment_of \<Union>R" using Ris
      by (simp add: Chains_init_seg_of_Union)
    moreover have "downset_on (Field (\<Union>R)) p"
      by (rule downset_on_Union [OF `\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p`])
    moreover have "extension_on (Field (\<Union>R)) (\<Union>R) p"
      by (rule chain_subset_extension_on_Union [OF subch `\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p`])
    ultimately have "\<Union>R \<in> ?K \<and> (\<forall>r\<in>R. (r,\<Union>R) \<in> I)"
      using mono_Chains [OF I_init] and `R \<in> Chains I`
      by (simp (no_asm) add: I_def del: Field_Union) (metis Chains_wo)
  }
  then have 1: "\<forall>R\<in>Chains I. \<exists>u\<in>Field I. \<forall>r\<in>R. (r, u) \<in> I" by (subst FI) blast
  txt {*Zorn's Lemma yields a maximal wellorder m.*}
  from Zorns_po_lemma [OF 0 1] obtain m :: "('a \<times> 'a) set"
    where "Well_order m" and "downset_on (Field m) p" and "extension_on (Field m) m p" and
    max: "\<forall>r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p \<and>
      (m, r) \<in> I \<longrightarrow> r = m"
    by (auto simp: FI)
  have "Field p \<subseteq> Field m"
  proof (rule ccontr)
    let ?Q = "Field p - Field m"
    assume "\<not> (Field p \<subseteq> Field m)"
    with assms [unfolded wf_eq_minimal, THEN spec, of ?Q]
      obtain x where "x \<in> Field p" and "x \<notin> Field m" and
      min: "\<forall>y. (y, x) \<in> p \<longrightarrow> y \<notin> ?Q" by blast
    txt {*Add @{term x} as topmost element to @{term m}.*}
    let ?s = "{(y, x) | y. y \<in> Field m}"
    let ?m = "insert (x, x) m \<union> ?s"
    have Fm: "Field ?m = insert x (Field m)" by (auto simp: Field_def)
    have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
      using `Well_order m` by (simp_all add: order_on_defs)
    txt {*We show that the extension is a wellorder.*}
    have "Refl ?m" using `Refl m` Fm by (auto simp: refl_on_def)
    moreover have "trans ?m" using `trans m` `x \<notin> Field m`
      unfolding trans_def Field_def Domain_unfold Domain_converse [symmetric] by blast
    moreover have "antisym ?m" using `antisym m` `x \<notin> Field m`
      unfolding antisym_def Field_def Domain_unfold Domain_converse [symmetric] by blast
    moreover have "Total ?m" using `Total m` Fm by (auto simp: Relation.total_on_def)
    moreover have "wf (?m - Id)"
    proof -
      have "wf ?s" using `x \<notin> Field m`
        by (simp add: wf_eq_minimal Field_def Domain_unfold Domain_converse [symmetric]) metis
      thus ?thesis using `wf (m - Id)` `x \<notin> Field m`
        wf_subset [OF `wf ?s` Diff_subset]
        by (fastforce intro!: wf_Un simp add: Un_Diff Field_def)
    qed
    ultimately have "Well_order ?m" by (simp add: order_on_defs)
    moreover have "extension_on (Field ?m) ?m p"
      using `extension_on (Field m) m p` `downset_on (Field m) p`
      by (subst Fm) (auto simp: extension_on_def dest: downset_onD)
    moreover have "downset_on (Field ?m) p"
      apply (subst Fm)
      using `downset_on (Field m) p` and min
      unfolding downset_on_def Field_def by blast
    moreover have "(m, ?m) \<in> I"
      using `Well_order m` and `Well_order ?m` and
      `downset_on (Field m) p` and `downset_on (Field ?m) p` and
      `extension_on (Field m) m p` and `extension_on (Field ?m) ?m p` and
      `Refl m` and `x \<notin> Field m`
      by (auto simp: I_def init_seg_of_def refl_on_def)
    ultimately
    --{*This contradicts maximality of m:*}
    show False using max and `x \<notin> Field m` unfolding Field_def by blast
  qed
  have "p \<subseteq> m"
    using `Field p \<subseteq> Field m` and `extension_on (Field m) m p`
    unfolding Field_def extension_on_def by auto fast
  with `Well_order m` show ?thesis by blast
qed

text {*Every well-founded relation can be extended to a total wellorder.*}
corollary total_well_order_extension:
  assumes "wf p"
  shows "\<exists>w. p \<subseteq> w \<and> Well_order w \<and> Field w = UNIV"
proof -
  from well_order_extension [OF assms] obtain w
    where "p \<subseteq> w" and wo: "Well_order w" by blast
  let ?A = "UNIV - Field w"
  from well_order_on [of ?A] obtain w' where wo': "well_order_on ?A w'" ..
  have [simp]: "Field w' = ?A" using well_order_on_Well_order [OF wo'] by simp
  have *: "Field w \<inter> Field w' = {}" by simp
  let ?w = "w \<union>o w'"
  have "p \<subseteq> ?w" using `p \<subseteq> w` by (auto simp: Osum_def)
  moreover have "Well_order ?w" using Osum_Well_order [OF * wo] and wo' by simp
  moreover have "Field ?w = UNIV" by (simp add: Field_Osum)
  ultimately show ?thesis by blast
qed

corollary well_order_on_extension:
  assumes "wf p" and "Field p \<subseteq> A"
  shows "\<exists>w. p \<subseteq> w \<and> well_order_on A w"
proof -
  from total_well_order_extension [OF `wf p`] obtain r
    where "p \<subseteq> r" and wo: "Well_order r" and univ: "Field r = UNIV" by blast
  let ?r = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"
  from `p \<subseteq> r` have "p \<subseteq> ?r" using `Field p \<subseteq> A` by (auto simp: Field_def)
  have 1: "Field ?r = A" using wo univ
    by (fastforce simp: Field_def order_on_defs refl_on_def)
  have "Refl r" "trans r" "antisym r" "Total r" "wf (r - Id)"
    using `Well_order r` by (simp_all add: order_on_defs)
  have "refl_on A ?r" using `Refl r` by (auto simp: refl_on_def univ)
  moreover have "trans ?r" using `trans r`
    unfolding trans_def by blast
  moreover have "antisym ?r" using `antisym r`
    unfolding antisym_def by blast
  moreover have "total_on A ?r" using `Total r` by (simp add: total_on_def univ)
  moreover have "wf (?r - Id)" by (rule wf_subset [OF `wf(r - Id)`]) blast
  ultimately have "well_order_on A ?r" by (simp add: order_on_defs)
  with `p \<subseteq> ?r` show ?thesis by blast
qed

end