section \<open> Imperative Version \<close>

theory Imperative
imports UpDown_Scheme Separation_Logic_Imperative_HOL.Sep_Main
begin

type_synonym pointmap = "grid_point \<Rightarrow> nat"
type_synonym impgrid = "rat array"

instance rat :: heap ..

primrec rat_pair where "rat_pair (a, b) = (of_rat a, of_rat b)"

declare rat_pair.simps [simp del]

definition
   zipWithA :: "('a::heap \<Rightarrow> 'b::heap \<Rightarrow> 'a::heap) \<Rightarrow> 'a array \<Rightarrow> 'b array \<Rightarrow> 'a array Heap"
where
  "zipWithA f a b = do {
     n \<leftarrow> Array.len a;
     Heap_Monad.fold_map (\<lambda>n. do {
       x \<leftarrow> Array.nth a n ;
       y \<leftarrow> Array.nth b n ;
       Array.upd n (f x y) a
     }) [0..<n];
     return a
   }"

theorem zipWithA [sep_heap_rules]:
  fixes xs ys :: "'a::heap list"
  assumes "length xs = length ys"
  shows "< a \<mapsto>\<^sub>a xs * b \<mapsto>\<^sub>a ys > zipWithA f a b < \<lambda>r. (a \<mapsto>\<^sub>a map (case_prod f) (zip xs ys)) * b \<mapsto>\<^sub>a ys * \<up>(a = r) >"
proof -
  { fix n and xs :: "'a list"
    let ?part_res = "\<lambda>n xs. (map (case_prod f) (zip (take n xs) (take n ys)) @ drop n xs)"
    assume "n \<le> length xs" "length xs = length ys"
    then have "< a \<mapsto>\<^sub>a xs * b \<mapsto>\<^sub>a ys > Heap_Monad.fold_map (\<lambda>n. do {
         x \<leftarrow> Array.nth a n ;
         y \<leftarrow> Array.nth b n ;
         Array.upd n (f x y) a
       }) [0..<n] < \<lambda>r. a \<mapsto>\<^sub>a ?part_res n xs * b \<mapsto>\<^sub>a ys >"
    proof (induct n arbitrary: xs)
      case 0 then show ?case by sep_auto
    next
      case (Suc n)
      note Suc.hyps [sep_heap_rules]
      have *: "(?part_res n xs)[n := f (?part_res n xs ! n) (ys ! n)] =  ?part_res (Suc n) xs"
        using Suc.prems by (simp add: nth_append take_Suc_conv_app_nth upd_conv_take_nth_drop)
      from Suc.prems show ?case
        by (sep_auto simp add: fold_map_append *)
    qed }
  note this[sep_heap_rules]
  show ?thesis
    unfolding zipWithA_def
    by (sep_auto simp add: assms)
qed

definition copy_array :: "'a::heap array \<Rightarrow> ('a::heap array) Heap" where
  "copy_array a = Array.freeze a \<bind> Array.of_list"

theorem copy_array [sep_heap_rules]:
  "< a \<mapsto>\<^sub>a xs > copy_array a < \<lambda>r. a \<mapsto>\<^sub>a xs * r \<mapsto>\<^sub>a xs >"
  unfolding copy_array_def
  by sep_auto

definition sum_array :: "rat array \<Rightarrow> rat array \<Rightarrow> unit Heap" where
  "sum_array a b = zipWithA (+) a b \<then> return ()"

theorem sum_array [sep_heap_rules]:
  fixes xs ys :: "rat list"
  shows "length xs = length ys \<Longrightarrow> < a \<mapsto>\<^sub>a xs * b \<mapsto>\<^sub>a ys > sum_array a b < \<lambda>r. (a \<mapsto>\<^sub>a map (\<lambda>(a, b). a + b) (zip xs ys)) * b \<mapsto>\<^sub>a ys >"
  unfolding sum_array_def by sep_auto

locale linearization =
  fixes dm lm :: nat
  fixes pm :: pointmap
  assumes pm: "bij_betw pm (sparsegrid dm lm) {..< card (sparsegrid dm lm)}"
begin

lemma linearizationD:
  "p \<in> sparsegrid dm lm \<Longrightarrow> pm p < card (sparsegrid dm lm)"
  using pm by (auto simp: bij_betw_def)

definition gridI :: "impgrid \<Rightarrow> (grid_point \<Rightarrow> real) \<Rightarrow> assn" where
  "gridI a v =
    (\<exists>\<^sub>A xs. a \<mapsto>\<^sub>a xs * \<up>((\<forall>p\<in>sparsegrid dm lm. v p = of_rat (xs ! pm p)) \<and> length xs = card (sparsegrid dm lm)))"

lemma gridI_nth_rule [sep_heap_rules]:
  "g \<in> sparsegrid dm lm \<Longrightarrow> < gridI a v > Array.nth a (pm g) <\<lambda>r. gridI a v * \<up> (of_rat r = v g)>"
  using pm by (sep_auto simp: bij_betw_def gridI_def)

lemma gridI_upd_rule [sep_heap_rules]:
  "g \<in> sparsegrid dm lm \<Longrightarrow>
    < gridI a v > Array.upd (pm g) x a <\<lambda>a'. gridI a (fun_upd v g (of_rat x)) * \<up>(a' = a)>"
  unfolding gridI_def using pm
  by (sep_auto simp: bij_betw_def inj_onD intro!: nth_list_update_eq[symmetric] nth_list_update_neq[symmetric])

primrec upI' :: "nat \<Rightarrow> nat \<Rightarrow> grid_point \<Rightarrow> impgrid \<Rightarrow> (rat * rat) Heap" where
  "upI' d       0 p a = return (0, 0)" |
  "upI' d (Suc l) p a = do {
       (fl, fml) \<leftarrow> upI' d l (child p left d) a ;
       (fmr, fr) \<leftarrow> upI' d l (child p right d) a ;
       val \<leftarrow> Array.nth a (pm p) ;
       Array.upd (pm p) (fml + fmr) a ;
       let result = ((fml + fmr + val / 2 ^ (lv p d) / 2) / 2) ;
       return (fl + result, fr + result)
     }"

lemma upI' [sep_heap_rules]:
  assumes lin[simp]: "d < dm"
    and l: "level p + l = lm" "l = 0 \<or> p \<in> sparsegrid dm lm"
  shows "< gridI a v > upI' d l p a <\<lambda>r. let (r', v') = up' d l p v in gridI a v' * \<up>(rat_pair r = r') >"
  using l
proof (induct l arbitrary: p v)
  note rat_pair.simps [simp]
  case 0 then show ?case by sep_auto
next
  case (Suc l)
  from Suc.prems \<open>d < dm\<close>
  have [simp]: "level (child p left d) + l = lm" "level (child p right d) + l = lm" "p \<in> sparsegrid dm lm"
    by (auto simp: sparsegrid_length)

  have [simp]: "child p left d \<notin> sparsegrid dm lm \<Longrightarrow> l = 0" "child p right d \<notin> sparsegrid dm lm \<Longrightarrow> l = 0"
    using Suc.prems by (auto simp: sparsegrid_def lgrid_def)

  note Suc(1)[sep_heap_rules]
  show ?case
    by (sep_auto split: prod.split simp: of_rat_add of_rat_divide of_rat_power of_rat_mult rat_pair_def Let_def)
qed

primrec downI' :: "nat \<Rightarrow> nat \<Rightarrow> grid_point \<Rightarrow> impgrid \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> unit Heap" where
  "downI' d       0 p a fl fr = return ()" |
  "downI' d (Suc l) p a fl fr = do {
      val \<leftarrow> Array.nth a (pm p) ;
      let fm = ((fl + fr) / 2 + val) ;
      Array.upd (pm p) (((fl + fr) / 4 + (1 / 3) * val) / 2 ^ (lv p d)) a ;
      downI' d l (child p left d) a fl fm ;
      downI' d l (child p right d) a fm fr
    }"

lemma downI' [sep_heap_rules]:
  assumes lin[simp]: "d < dm"
    and l: "level p + l = lm" "l = 0 \<or> p \<in> sparsegrid dm lm"
  shows "< gridI a v > downI' d l p a fl fr <\<lambda>r. gridI a (down' d l p (of_rat fl) (of_rat fr) v) >"
  using l
proof (induct l arbitrary: p v fl fr)
  note rat_pair.simps [simp]
  case 0 then show ?case by sep_auto
next
  case (Suc l)
  from Suc.prems \<open>d < dm\<close>
  have [simp]: "level (child p left d) + l = lm" "level (child p right d) + l = lm" "p \<in> sparsegrid dm lm"
    by (auto simp: sparsegrid_length)

  have [simp]: "child p left d \<notin> sparsegrid dm lm \<Longrightarrow> l = 0" "child p right d \<notin> sparsegrid dm lm \<Longrightarrow> l = 0"
    using Suc.prems by (auto simp: sparsegrid_def lgrid_def)

  note Suc(1)[sep_heap_rules]
  show ?case
    by (sep_auto split: prod.split simp: of_rat_add of_rat_divide of_rat_power of_rat_mult rat_pair_def Let_def fun_upd_def)
qed

definition liftI :: "(nat \<Rightarrow> nat \<Rightarrow> grid_point \<Rightarrow> impgrid \<Rightarrow> unit Heap) \<Rightarrow> nat \<Rightarrow> impgrid \<Rightarrow> unit Heap" where
  "liftI f d a =
    foldr (\<lambda> p n. n \<then> f d (lm - level p) p a) (gridgen (start dm) ({ 0 ..< dm } - { d }) lm) (return ())"

theorem liftI [sep_heap_rules]:
  assumes "d < dm"
  and f[sep_heap_rules]: "\<And>v p. p \<in> lgrid (start dm) ({0..<dm} - {d}) lm \<Longrightarrow>
    < gridI a v > f d (lm - level p) p a <\<lambda>r. gridI a (f' d (lm - level p) p v) >"
  shows "< gridI a v > liftI f d a <\<lambda>r. gridI a (Grid.lift f' dm lm d v) >"
proof -
  let ?ds = "{0..<dm} - {d}" and ?g = "gridI a"
  { fix ps assume "set ps \<subseteq> set (gridgen (start dm) ?ds lm)" and "distinct ps"
    then have "< ?g v >
        foldr (\<lambda>p n. (n :: unit Heap) \<then> f d (lm - level p) p a) ps (return ())
      <\<lambda>r. ?g (foldr (\<lambda>p \<alpha>. f' d (lm - level p) p \<alpha>) ps v) >"
      by (induct ps arbitrary: v) (sep_auto simp: gridgen_lgrid_eq)+ }
  from this[OF subset_refl gridgen_distinct]
  show ?thesis
    by (simp add: liftI_def Grid.lift_def)
qed

definition upI where "upI = liftI (\<lambda>d l p a. upI' d l p a \<then> return ())"

theorem upI [sep_heap_rules]:
  assumes [simp]: "d < dm"
  shows "< gridI a v > upI d a <\<lambda>r. gridI a (up dm lm d v) > "
  unfolding up_def upI_def
  by (sep_auto simp: lgrid_def sparsegrid_def lgrid_def split: prod.split
               intro: grid_union_dims[of "{0..<dm} - {d}" "{0..<dm}"])

definition downI where "downI = liftI (\<lambda>d l p a. downI' d l p a 0 0)"

theorem downI [sep_heap_rules]:
  assumes [simp]: "d < dm"
  shows "< gridI a v > downI d a <\<lambda>r. gridI a (down dm lm d v) > "
  unfolding down_def downI_def
  by (sep_auto simp: lgrid_def sparsegrid_def lgrid_def split: prod.split
               intro: grid_union_dims[of "{0..<dm} - {d}" "{0..<dm}"])

theorem copy_array_gridI [sep_heap_rules]:
  "< gridI a v > copy_array a < \<lambda>r. gridI a v * gridI r v >"
  unfolding gridI_def
  by sep_auto

theorem sum_array_gridI [sep_heap_rules]:
  "< gridI a v * gridI b w > sum_array a b < \<lambda>r. gridI a (sum_vector v w) * gridI b w >"
  unfolding gridI_def
  by (sep_auto simp: sum_vector_def nth_map linearizationD of_rat_add)

primrec updownI' :: "nat \<Rightarrow> impgrid \<Rightarrow> unit Heap" where
  "updownI' 0 a = return ()" |
  "updownI' (Suc d) a = do {
      b \<leftarrow> copy_array a ;
      upI d a ;
      updownI' d a ;
      updownI' d b ;
      downI d b ;
      sum_array a b
    }"

theorem updownI' [sep_heap_rules]:
  "d \<le> dm \<Longrightarrow> < gridI a v > updownI' d a <\<lambda>r. gridI a (updown' dm lm d v) >\<^sub>t"
proof (induct d arbitrary: a v)
  case (Suc d)
  note Suc.hyps [sep_heap_rules]
  from Suc.prems show ?case
    by sep_auto
qed sep_auto

definition updownI where "updownI a = updownI' dm a"

theorem updownI [sep_heap_rules]:
  "< gridI a v > updownI a <\<lambda>r. gridI a (updown dm lm v) >\<^sub>t"
  unfolding updown_def updownI_def by sep_auto

end

end


(*  Title:      HOL/Auth/n_flash.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_flash Protocol Case Study*}

theory n_flash imports n_flash_lemma_invs_on_rules n_flash_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


theory ARMv8
  imports "../State" ARMv8_Exp "../Syntax"
begin

chapter \<open>ARMv8\<close>

text \<open>Sub-Instruction Reordering\<close>
text \<open>Only pattern match on first argument due to performance issues\<close>
fun re\<^sub>i :: "('v,'r) subop \<Rightarrow> ('v,'r) subop \<Rightarrow> bool"
  where
    "re\<^sub>i fence \<alpha> = False" |
    "re\<^sub>i stfence \<alpha> = (\<alpha> \<noteq> fence \<and> wr \<alpha> \<subseteq> locals)" |
    "re\<^sub>i cfence \<alpha> = (\<alpha> \<noteq> fence \<and> rd \<alpha> \<subseteq> locals)" |
    "re\<^sub>i (cmp b) \<alpha> = (wr \<alpha> \<subseteq> locals \<and> \<alpha> \<noteq> cfence \<and> \<alpha> \<noteq> fence \<and> rd (cmp b) \<inter> wr \<alpha> = {})" |
    "re\<^sub>i \<alpha> \<beta> = (\<beta> \<noteq> fence \<and> (\<beta> = stfence \<longrightarrow> wr \<alpha> \<subseteq> locals) \<and> (\<beta> = cfence \<longrightarrow> \<not>(\<exists>b. \<alpha> = cmp b)) \<and>
                (wr \<alpha> \<union> rd \<alpha>) \<inter> rd \<beta> \<subseteq> locals \<and>
                wr \<alpha> \<inter> wr \<beta> = {} \<and>
                rd \<alpha> \<inter> wr \<beta> = {})"

text \<open>Sub-Instruction Forwarding\<close>
fun fwd\<^sub>i :: "('v,'r) subop \<Rightarrow> ('v,'r) subop \<Rightarrow> ('v,'r) subop"
  where
    "fwd\<^sub>i \<alpha> (cstore b g e) = subst\<^sub>g \<alpha> g e" |
    "fwd\<^sub>i \<alpha> (cas\<^sub>T g _ e) = subst\<^sub>g \<alpha> g e" |
    "fwd\<^sub>i \<alpha> (op r e) = subst\<^sub>r \<alpha> r e" |
    "fwd\<^sub>i \<alpha> _ = \<alpha>"

definition comp (infixr "\<Otimes>" 60)
  where "comp a b \<equiv> {(m,m'). \<exists>m''. (m,m'') \<in> a \<and> (m'',m') \<in> b}"

lemma re_consistent:
  "re\<^sub>i \<alpha> (fwd\<^sub>i \<beta> \<alpha>) \<Longrightarrow> beh\<^sub>i \<alpha> \<Otimes> beh\<^sub>i \<beta> \<supseteq> beh\<^sub>i (fwd\<^sub>i \<beta> \<alpha>) \<Otimes> beh\<^sub>i \<alpha>"
  by (cases \<alpha>; cases \<beta>; clarsimp simp add: comp_def fun_upd_twist split: if_splits)

section \<open>Auxiliary State Updates\<close>

text \<open>
We wish to support auxiliary state to support more abstract reasoning about data structures
and concurrency.
This is achieved by allowing arbitrary extensions to the state representation, which
can be updated atomically at any sub-operation.
This auxiliary state cannot influence real execution behaviour by definition.
\<close>
type_synonym ('v,'r,'a) auxop = "('v,'r) subop \<times> ('v,'r,'a) auxfn"

fun beh\<^sub>a :: "('v,'r,'a) auxop \<Rightarrow> ('v,'r,'a) state rel"
  where "beh\<^sub>a (\<alpha>,f) = beh\<^sub>i \<alpha> O {(m,m'). m' = m(aux: f)}"

fun re\<^sub>a :: "('v,'r,'a) auxop \<Rightarrow> ('v,'r,'a) auxop \<Rightarrow> bool"
  where "re\<^sub>a (\<alpha>,f) (\<beta>,f') = re\<^sub>i \<alpha> \<beta>"

fun fwd\<^sub>a :: "('v,'r,'a) auxop \<Rightarrow> ('v,'r,'a) auxop \<Rightarrow> ('v,'r,'a) auxop"
  where "fwd\<^sub>a (\<alpha>,f) \<beta> = (fwd\<^sub>i \<alpha> (fst \<beta>),f)"

section \<open>Sub-Instruction Specification Language\<close>

text \<open>
To instantiate the abstract theory, we must couple each sub-operation with its precondition
and behaviour in a tuple\<close>
type_synonym ('v,'r,'a) subbasic = "(('v,'r,'a) auxop, ('v,'r,'a) state) basic"

text \<open>Duplicate forwarding and reordering behaviour of underlying instruction\<close>
fun fwd\<^sub>s :: "('v,'r,'a) subbasic \<Rightarrow> ('v,'r,'a) auxop \<Rightarrow> ('v,'r,'a) subbasic"
  where "fwd\<^sub>s (\<alpha>,v,_) \<beta> =  (fwd\<^sub>a \<alpha> \<beta>, v, beh\<^sub>a (fwd\<^sub>a \<alpha> \<beta>))"
(*   where "fwd\<^sub>s (\<alpha>,v,_) \<beta> =  (fwd\<^sub>a \<alpha> \<beta>, wp UNIV (beh\<^sub>a \<beta>) v, beh\<^sub>a (fwd\<^sub>a \<alpha> \<beta>))"
 *)

text \<open>Lift an operation with specification\<close>
definition liftg :: "('v,'r,'a) pred \<Rightarrow> ('v,'r) subop \<Rightarrow> ('v,'r,'a) auxfn \<Rightarrow> ('v,'r,'a) subbasic"
  ("\<lfloor>_,_,_\<rfloor>" 100)
  where "liftg v \<alpha> f \<equiv> ((\<alpha>,f), v, beh\<^sub>a (\<alpha>,f))"

text \<open>Lift an operation without specification\<close>
definition liftl :: "('v,'r) subop \<Rightarrow> ('v,'r,'a) subbasic"
  ("\<lfloor>_\<rfloor>" 100)
  where "liftl \<alpha> \<equiv> ((\<alpha>,aux), UNIV, beh\<^sub>a (\<alpha>,aux))"

section \<open>ARMv8 Language Definition\<close>

text \<open>
We define a basic while language to capture the assembly level instructions
for ARMv8. Notably we do not support general jumps, constraining control flow
significantly.
\<close>
datatype ('v,'r,'a) com_armv8 =
  Skip
  | Fence
  | Load "('v,'r,'a) pred" "'v set" "('v,'r) exp" 'r "('v,'r,'a) auxfn"
  | Store "('v,'r,'a) pred" "'v set" "('v,'r) exp" 'r "('v,'r,'a) auxfn"
  | Op 'r "('v,'r) exp"
  | CAS "('v,'r,'a) pred" "'v set" 'r 'r 'r 'r 'v 'v "('v,'r,'a) auxfn"
  | Seq "('v,'r,'a) com_armv8" "('v,'r,'a) com_armv8"
  | If "('v,'r) bexp" "('v,'r,'a) com_armv8" "('v,'r,'a) com_armv8"

end


section \<open>TangleLearning\<close>

theory TangleLearning
  imports Main
          Parity_Game.MoreCoinductiveList
          Parity_Game.ParityGame
          Parity_Game.Strategy
          Parity_Game.Attractor
          Parity_Game.AttractingStrategy
          Parity_Game.WinningRegion
          Parity_Game.WinningStrategy
begin

type_synonym 'a Tangle = "'a set \<times> 'a Strategy"

type_synonym 'a AttrState = "'a set \<times> 'a Edge set"

subsection \<open>Utilities and auxiliary lemmas\<close>

lemma (in vm_path) vm_path_infinite_in_no_deadends_game:
  assumes "\<forall>v \<in> V. \<not> deadend v"
  shows "\<not> lfinite P"
proof
  assume lf:"lfinite P"
  then have "deadend (llast P)"
    using finite_llast_deadend by blast
  then show "False" using assms lf
    by (meson finite_llast_V)
qed

locale PG = ParityGame +
  assumes finite_V: "finite V"
begin

lemma finite_E[simp]: "finite E" using finite_V valid_edge_set
  by (simp add: finite_subset)

definition strategy_to_edge_set :: "'a Strategy \<Rightarrow> 'a Edge set" where
"strategy_to_edge_set \<sigma> = {(v,w) \<in> E. \<sigma> v = w}"

definition winning_prio :: " 'a set \<Rightarrow> nat" where
"winning_prio V' = Min (\<omega> ` (V' \<inter> V)) "

definition winning_prio_nodes :: "'a set \<Rightarrow> 'a set" where
"winning_prio_nodes V' = {v \<in> (V' \<inter> V). \<omega> v = winning_prio V'}"

abbreviation prio_winner :: "nat \<Rightarrow> Player" where
"prio_winner a \<equiv> (if even a then Even else Odd)"

definition node_winner :: "'a \<Rightarrow> Player" where
"node_winner v = prio_winner (\<omega> v)"

definition nodes_winner :: " 'a set \<Rightarrow> Player" where
"nodes_winner V' = prio_winner (winning_prio V')"

lemma subgame_PG: "PG (subgame V')"
proof (unfold_locales)
  show "E\<^bsub>subgame V'\<^esub> \<subseteq> V\<^bsub>subgame V'\<^esub> \<times> V\<^bsub>subgame V'\<^esub>" using subgame_Digraph[unfolded Digraph_def].
  show "V0\<^bsub>subgame V'\<^esub> \<subseteq> V\<^bsub>subgame V'\<^esub>" unfolding subgame_def using valid_player0_set by auto
  show "finite (\<omega>\<^bsub>subgame V'\<^esub> ` V\<^bsub>subgame V'\<^esub>)" by simp
  show "finite V\<^bsub>subgame V'\<^esub>" using finite_V finite_subset subgame_V by blast
qed

subsection \<open>Closed subset and dominion\<close>

definition closed :: "'a set \<Rightarrow> Player \<Rightarrow> 'a Strategy \<Rightarrow> bool" where
"closed V' p \<sigma> \<equiv> V' \<subseteq> V \<and> V' \<noteq> {} \<and>
                ParityGame.strategy (subgame V') p \<sigma> \<and>
                (\<forall>v \<in> V'.
                  (\<not> Digraph.deadend (subgame V') v) \<and>
                  (v \<in> VV p** \<longrightarrow> (\<forall>w. (v \<rightarrow> w) \<longrightarrow> w \<in> V')))"

lemma strategy_in_subgame_with_no_deadends:
  assumes "ParityGame.strategy (subgame V') p \<sigma>"
          "\<forall>v \<in> V'.\<not> Digraph.deadend (subgame V') v"
        shows "\<forall>v \<in> V'. v \<in> VV p \<longrightarrow> \<sigma> v \<in> V'" and
              "\<forall>v \<in> V'. v \<in> VV p \<longrightarrow> v \<rightarrow>\<^bsub>(subgame V')\<^esub> \<sigma> v"
proof (goal_cases)
  case 1
  show ?case proof
    fix v assume in_V':"v \<in> V'"
    have "v \<in> VV p \<longrightarrow> v \<in> ParityGame.VV (subgame V') p"
      using in_V' by force
    moreover have "v \<in> ParityGame.VV (subgame V') p \<longrightarrow> \<sigma> v \<in> V'"
      using assms(1,2) subgame_strategy_stays_in_subgame in_V' by blast
    ultimately show "v \<in> VV p \<longrightarrow> \<sigma> v \<in> V'" by auto
  qed
next
  case 2
  show ?case proof
    fix v assume in_V':"v \<in> V'"
    have subgame_VV:"v \<in> VV p \<longrightarrow> v \<in> ParityGame.VV (subgame V') p"
      using in_V' by force
    then have "v \<in> VV p \<and> \<not>Digraph.deadend (subgame V') v \<longrightarrow> v \<rightarrow> \<sigma> v"
      using assms(1)  ParityGame.strategy_def subgame_E  subgame_ParityGame by blast
    then show "v \<in> VV p \<longrightarrow> v \<rightarrow>\<^bsub>(subgame V')\<^esub> \<sigma> v"
      using assms(1,2) in_V' subgame_ParityGame subgame_VV ParityGame.strategy_def
      by blast
  qed
qed

lemma vmc_path_in_closed_subgame_lset:
  assumes "closed V' p \<sigma>" "v0 \<in> V'" "vmc_path G P v0 p \<sigma>"
  shows "lset P \<subseteq> V'"
proof -
  define T where "T = V - V'"
  have "V' \<inter> T = {}" using T_def by auto
  moreover have "\<forall>v. (v \<in> V' \<and> \<not>deadend v \<and> v \<in> VV p) \<longrightarrow> \<sigma> v \<in> V'"
    using assms(1) closed_def strategy_in_subgame_with_no_deadends(1) by auto
  moreover have "\<forall>v w. (v \<in> V' \<and> \<not>deadend v \<and> v \<in> VV p** \<and> v \<rightarrow> w) \<longrightarrow> w \<in> V'"
    using assms(1) closed_def by blast
  moreover have "lset P \<inter> T = {}"
    using calculation closed_def assms
    by (smt (verit) DiffI Player.simps disjoint_eq_subset_Compl in_mono
      order.trans vmc_path.vmc_path_lset_induction_simple vmc_path_no_deadend.v0_conforms
      vmc_path_no_deadend.v0_edge_w0 vmc_path_no_deadend.v0_no_deadend)
  ultimately show "lset P \<subseteq> V'"
    using valid_path_in_V vm_path.P_valid assms(3) vmc_path_def T_def
    by (metis Diff_eq_empty_iff Int_Diff Int_absorb2)
qed

text \<open>Assuming a player @{term p} with a strategy @{term \<sigma>}, a set of
  nodes @{term D} is called a dominion if:
  1) D is closed w.r.t. to \<sigma>: p always chooses successor according to \<sigma> and all
  nodes of p' in D along with their successors are contained in D, and
  2) winning for player p: if p is Even, then the highest priority appearing
  infinitely often in a path in D is even, vice versa.
\<close>
definition dominion :: "'a set \<Rightarrow> Player \<Rightarrow> 'a Strategy \<Rightarrow> bool" where
"dominion D p \<sigma> \<equiv> closed D p \<sigma> \<and>
                  (\<forall>v \<in> D. winning_strategy p \<sigma> v)"

lemma dominion_is_closed[simp]:"dominion D p \<sigma> \<Longrightarrow> closed D p \<sigma>"
  unfolding dominion_def by auto

lemma dominion_subset_of_winning_region:
  assumes "dominion D p \<sigma>" "strategy p \<sigma>"
  shows "D \<subseteq> winning_region p"
proof
  fix v assume in_D: "v \<in> D"
  have "v \<in> V"
    using assms(1) dominion_def closed_def by (meson in_D subsetD)
  moreover have "winning_strategy p \<sigma> v"
    using assms(1) dominion_def by (simp add: in_D)
  ultimately show "v \<in> winning_region p"
    using assms(2) dominion_def by (simp add: in_D in_mono winning_regionI)
qed

subsection \<open>Tangle\<close>

inductive_set reachable_by :: "'a \<Rightarrow> 'a set" for u where
refl: "u \<in> V \<Longrightarrow> u \<in> reachable_by u" |
trans: "v \<in> reachable_by u \<Longrightarrow> v \<rightarrow> w \<Longrightarrow> w \<in> reachable_by u"

lemma valid_path_reachability_aux:
  assumes "valid_path P" "n < llength P"
  shows "n + j < llength P \<Longrightarrow> (P $ (n + j)) \<in> reachable_by (P $ n)"
proof (induction j)
  case 0
  have "(P $ n) \<in> V" using assms(1,2) valid_path_finite_in_V by auto
  then show ?case apply(auto)
    using reachable_by.refl by auto
next
  case (Suc j)
  have "Suc (n + j)  < llength P" using "Suc"(2) by simp
  then show ?case apply(auto)
    using assms(1) valid_path_edges reachable_by.trans Suc.IH
    by (metis Suc_llength plus_enat_simps(1))
qed

lemma valid_path_reachability:
  assumes "valid_path P" "n\<le>n'" "n' < llength P"
  shows "(P $ n') \<in> reachable_by (P $ n)"
proof -
  obtain j where n': "n'=n+j" using assms(2)
    using nat_le_iff_add by blast
  from valid_path_reachability_aux[OF \<open>valid_path P\<close>, of n j] show ?thesis
    using assms unfolding n'
    by (metis enat_le_plus_same(1) order_le_less_trans plus_enat_simps(1))
qed

text \<open>Strategy defined subgame: similar to @{term subgame} but only takes edges that corresponds
to a strategy @{term \<sigma>}\<close>

definition subgame_strategy :: "'a set  \<Rightarrow> Player \<Rightarrow> 'a Strategy \<Rightarrow> ('a,'b) ParityGame_scheme" where
"subgame_strategy V' p \<sigma> = G\<lparr>verts := V \<inter> V',
                             arcs := (E \<inter> (V' \<times> V')) - {(u, v)|u v. u \<in> VV p \<and> \<sigma> u \<noteq> v},
                             player0 := V0 \<inter> V'\<rparr>"

definition scc :: "'a set \<Rightarrow> bool" where
"scc V' = (\<forall>v \<in> V'. \<forall>w \<in> V'.  w \<in> reachable_by v) "

definition tangle :: "'a set \<Rightarrow> Player \<Rightarrow> 'a Strategy \<Rightarrow> bool" where
"tangle V' p \<sigma> \<equiv> V' \<subseteq> V \<and> V' \<noteq> {} \<and>
               ParityGame.strategy (subgame V') p \<sigma> \<and>
               PG.scc (subgame_strategy V' p \<sigma>) V' \<and>
               (\<forall>v \<in> V'.
                (\<not> Digraph.deadend (subgame V') v) \<and>
                (\<forall>P. vmc_path G P v p \<sigma> \<and> lset P \<subseteq> V' \<longrightarrow> winning_path p P))"

lemma unescapable_tangle_is_dominion:
  assumes "tangle T p \<sigma>"
          "\<forall>e \<in> T. e \<in> VV p** \<longrightarrow> (\<forall>f. (e \<rightarrow> f) \<longrightarrow> f \<in> T)"
  shows "dominion T p \<sigma>"
  unfolding dominion_def
proof (rule conjI)
  have "T \<subseteq> V"
    using tangle_def[of T p \<sigma>] assms(1) by blast
  moreover have "\<forall>v \<in> T. \<not> Digraph.deadend (subgame T) v"
    using tangle_def[of T p \<sigma>] assms(1) by auto
  moreover have "ParityGame.strategy (subgame T) p \<sigma>"
    using tangle_def[of T p \<sigma>] assms(1) by auto
  ultimately show closed:"closed T p \<sigma>"
    using closed_def assms(1,2) tangle_def by auto

  then have "\<forall>v \<in> T. \<forall>P. vmc_path G P v p \<sigma> \<longrightarrow> lset P \<subseteq> T"
    using vmc_path_in_closed_subgame_lset by auto
  then have "\<forall>v \<in> T. \<forall>P. vmc_path G P v p \<sigma> \<longrightarrow> winning_path p P"
    using tangle_def assms(1) by simp
  then show "\<forall>v \<in> T. winning_strategy p \<sigma> v"
    using winning_strategyI by blast
qed

lemma SCC_in_closed_subset:
  assumes "closed V' p \<sigma>"
  shows "\<exists>S. S \<subseteq> V' \<and> PG.scc (subgame V') S"
proof
  have "\<exists>v0. v0 \<in> V'" using assms closed_def by auto
  then obtain v0 where in_V':"v0 \<in> V'" by auto
  interpret G': PG "subgame V'" using subgame_PG.

  have "G'.strategy p \<sigma>" using assms closed_def by auto
  then have "\<exists>P. vmc_path (subgame V') P v0 p \<sigma>"
    using closed_def in_V' assms G'.strategy_conforming_path_exists_single
    by (metis subgame_V')
  then obtain P' where P'_vmc: "vmc_path (subgame V') P' v0 p \<sigma>"
    by auto

  have inf:"\<not>lfinite P'" proof-
    have "vm_path (subgame V') P' v0"
      using vmc_path_def P'_vmc by metis
    moreover have "\<forall>v \<in> V\<^bsub>subgame V'\<^esub>. \<not>Digraph.deadend (subgame V') v "
      using closed_def assms  by auto
    ultimately show "\<not>lfinite P'"
      using vm_path.vm_path_infinite_in_no_deadends_game by metis
  qed
  have lset:"lset P' \<subseteq> V'"
    using assms closed_def P'_vmc vmc_path_def
    by (metis G'.valid_path_in_V subgame_V' vm_path.P_valid )

  text \<open>Define a function mapping indices to vertices in the path and prove it has infinite range\<close>
  define f where "f i = (P' $ i)" for i
    have "range f \<subseteq> V'" unfolding f_def
      using lset lset_nth_member_inf[OF inf] by blast
    moreover have "finite V'"
      using finite_V closed_def assms(1) finite_subset by metis
    ultimately have "finite (range f)" using finite_subset by auto
    then obtain n0 where n0:"\<not> (finite {n. f n = f n0})"
      using pigeonhole_infinite[of UNIV f] by auto

  define W where "W = {k. \<forall>n. k \<in> lset (ldropn n P')}"
  have not_empty: "\<exists>k . k \<in> W" proof-
    define k where "k = f n0"
    have "P' $ n0 = k" unfolding f_def k_def
      using inf by (simp add: infinite_small_llength)
    moreover {
      fix a assume "P' $ a = k"
      have "\<exists>n' > a. f n' = k" unfolding k_def
        using n0 infinite_nat_iff_unbounded by auto
      then have "\<exists>n' > a. P' $ n' = k" unfolding f_def
        using inf by (simp add:infinite_small_llength)
    }
    ultimately have "\<forall>n. k \<in> lset (ldropn n P')"
      using inf by (simp add: index_infinite_set)
    thus ?thesis unfolding W_def by blast
  qed

  obtain n1 where n1:"(\<not> finite {n. f n = f n0}) \<and> (n1 > n0) \<and> n1 \<in> {n. f n = f n0}"
    using pigeonhole_infinite[of UNIV f] n0
    by (meson infinite_nat_iff_unbounded)
  have n0_n1_eq: "P' $ n0 = P' $  n1"
    using n1 by (simp add: f_def)
  moreover have P'_valid:"G'.valid_path P'"
    using P'_vmc vmc_path_def by (metis  vm_path.P_valid)
  ultimately have "(P' $ n1) \<in> G'.reachable_by (P' $ n0)"
    using G'.valid_path_reachability inf by auto

  define cycle where "cycle = ltake (Suc (n1 - n0)) (ldrop n0 P')"
  have "lhd cycle = P' $ n0" using cycle_def
    by (metis eSuc_enat inf infinite_small_llength ldrop_enat ldropn_Suc_conv_ldropn lhd_LCons
        ltake_eSuc_LCons)
  moreover have "llast cycle = P' $ n1" unfolding cycle_def using inf n1
    by (metis enat.distinct(2) enat_ord_simps(2) infinite_small_llength lappend_ltake_ldrop
        less_Suc_eq lfinite_ldrop llast_ltake llength_ltake' lnth_lappend not_less_eq
        the_enat.simps)
  ultimately have "lhd cycle = llast cycle"
    using n0_n1_eq by auto

  have "G'.valid_path cycle" unfolding cycle_def using P'_valid
    by (metis G'.valid_path_drop G'.valid_path_prefix  ldrop_enat ltake_is_lprefix)
  have subset_V': "lset cycle \<subseteq> V'"
    using in_lset_ldropnD in_V' lset W_def cycle_def Coinductive_List.lset_ltake
    by (metis ldrop_enat subset_eq)

    oops

lemma dominion_contains_a_tangle:
  assumes "dominion D p \<sigma>"
  shows "\<exists>T. T \<subseteq> D \<and> tangle T p \<sigma>"
  unfolding tangle_def
proof
  oops

subsection \<open>Tangle Learning\<close>

definition attr_strategy_step :: "Player \<Rightarrow> 'a AttrState \<Rightarrow> 'a AttrState" where
"attr_strategy_step p Z = (let A = fst Z; \<sigma> = snd Z;
                          step_V = {v \<in> V - A. \<not>deadend v \<and>
                            (v \<in> VV p   \<longrightarrow> (\<exists>w. v\<rightarrow>w \<and> w \<in> A)) \<and>
                            (v \<in> VV p** \<longrightarrow> (\<forall>w. v\<rightarrow>w \<longrightarrow> w \<in> A))};
                          step_\<sigma> = {e|v w e. v \<in> V - A \<and> \<not>deadend v \<and>
                            (v \<in> VV p \<longrightarrow> (\<exists>w. v\<rightarrow>w \<and> w \<in> A) \<and>  (e = (v,w))) \<and>
                            (v \<in> VV p** \<longrightarrow> (\<forall>w. v\<rightarrow>w \<longrightarrow> w \<in> A))}
                               in (A \<union> step_V, \<sigma> \<union> step_\<sigma>))"

function attractor_strategy :: "Player \<Rightarrow> 'a AttrState \<Rightarrow> 'a AttrState" where
"attractor_strategy p Z = (let Z' = attr_strategy_step p Z in
                         (if Z = Z' then Z else attractor_strategy p Z'))"
  by auto

definition escapes :: "Player \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"escapes p T = {v|u v. (u \<rightarrow> v) \<and> (u \<in> T \<inter> VV p**) \<and> (v \<in> V - T)}"

definition player_tangles :: "Player \<Rightarrow> 'a Tangle set \<Rightarrow> 'a Tangle set" where
"player_tangles p T = {(Tp,\<sigma>)|Tp \<sigma>. (Tp,\<sigma>) \<in> T \<and> tangle Tp p \<sigma>}"

definition tangle_attr_step :: "Player \<Rightarrow> 'a AttrState \<Rightarrow> 'a Tangle set \<Rightarrow> 'a AttrState" where
"tangle_attr_step p Z T = (let attracted = {(Tp,\<sigma>') \<in> player_tangles p T.
                                     (escapes p Tp \<noteq> {}) \<and>
                                     (escapes p Tp \<subseteq> (fst Z))} in
                             (Union (Domain attracted),
                              Finite_Set.fold (\<lambda>A B. (strategy_to_edge_set A) \<union> B) {} (Range attracted)))"

function tangle_attractor :: "Player \<Rightarrow> 'a AttrState \<Rightarrow> 'a Tangle set \<Rightarrow> 'a AttrState" where
"tangle_attractor p Z T = (let attr_step = attr_strategy_step p Z;
                               t_attr_step = tangle_attr_step p Z T;
                               Z' = (fst attr_step \<union> fst t_attr_step,
                                     snd attr_step \<union> snd t_attr_step) in
                        (if Z = Z' then Z else tangle_attractor p Z' T))"
  by auto

end

end


(* This file contains only snippets I found useful to write, just to get to
know Isabelle a little more, and to enshrine the syntax I sometimes had a hard
time to grasp. *)
theory Snippets
imports Main "~~/src/HOL/Library/Quotient_List" Real
begin
(*p174 tutorial.pdf: lemmas and rules introduced by typedef *)
typedef 'a alphabet = "{A :: 'a set. (finite A \<and> \<not> ( A = {} ))}" by auto

typedef alph = "{0::nat..<9}"
by (metis atLeastLessThan_iff le0 zero_less_numeral)

typedef bit = "{0::nat, 1}" apply auto done

lemma "\<exists>c. x \<le> 0 \<Longrightarrow> ln x = c"
proof -
fix c::real
assume "c = (THE x. False)"
then have "x\<le>0 \<Longrightarrow> ln x = c"
 using ln_neg_is_const by simp

class bounded = ord +
fixes max :: "'a"

type_synonym data = "int alphabet"
definition A :: bit where "A \<equiv> Abs_bit 0"
definition B :: data where "B \<equiv> Abs_alphabet {0}"
lemma finnn : "finite (Rep_alphabet B)"
  apply(simp add: B_def)
apply(simp add: Abs_alphabet_inverse)
done

type_synonym ('a,'b) gggcode = "('a list \<Rightarrow> 'b list) "
definition C :: "((int, int) gggcode)" where "C l = []"

typedef finitesymbols = "{s::(nat set). \<exists>n::nat. (1 \<le> n \<and> s = {0::nat..<n})}" by auto
print_theorems

definition exfinite :: finitesymbols where "exfinite \<equiv> Abs_finitesymbols {}"
definition exfinite2 :: finitesymbols where "exfinite2 \<equiv> Abs_finitesymbols {3}"

lemma ds : "n = 0 \<longrightarrow> n \<in> {0::nat..<3}"
apply auto+
done
(*
typedef ggggggcode = "{D :: (letter list\<Rightarrow> letter list) . D [] = [] \<and> (\<forall>x. \<forall> xs. D (x#xs) = (D [x]) @ (D xs))}"
by auto

type_synonym 'a discret_source = "(nat \<Rightarrow> ('a \<Rightarrow> letter)) set"
*)

definition ex :: bit where "ex \<equiv> Abs_bit (0::nat)"
definition exalph :: "int alphabet" where "exalph == Abs_alphabet {1,2}"

fun folio :: "nat \<Rightarrow> nat" where
  "folio n = n+2"

fun test :: "nat list \<Rightarrow> nat list" where
 "test l = map folio l"

definition intset :: "nat set" where "intset == {0::nat,1}"
lemma azre: "(\<Sum>i\<in>intset. i) = 1"
unfolding intset_def
(* sledgehammer... *)
by simp

locale dummy =
fixes a::nat
fixes b::'b
fixes bc::"'b list"
assumes "a = length bc"
print_locale dummy

(*
Definition of the class of coded types, that is, types for which there is an
encoding and decoding function.
We assign a length to our type, this will be the length of the words we consider
(constant).
In practice, 'a will represent a D-ary alphabet, i.e. a finite set.
For now, there are only guarantees of well-defined functions if the sizes
match.
What if they don't?
*)

class coded = len +
fixes enc :: "'a list \<Rightarrow> bit list"
fixes dec :: "bit list \<Rightarrow> 'a list"
assumes "\<forall>x. (length x) \<le> len_of TYPE ('a) \<Longrightarrow>  dec (enc x) = x"

class block_coded = coded +
fixes block_enc :: "'a list \<Rightarrow> bit list"
fixes block_dec :: "bit list \<Rightarrow> 'a list"
assumes block_corresp1:
"\<forall>x.\<forall>xs. (length x) = len_of TYPE('a) \<Longrightarrow>
block_dec (block_enc (x @ xs)) = x @ block_dec (block_enc xs)"
assumes block_corresp2:
"\<forall>x. (length x) \<le> len_of TYPE('a) \<Longrightarrow>
block_enc x = enc x \<and> block_dev enc x = x"

type_synonym bword = "bit list"
datatype dbit = B bit | D
type_synonym dbword = "dbit list"
(* this function cleans the dirty bword of all dummy characters *)
fun d_clean :: "dbword \<Rightarrow> bword" where
"d_clean [] = []"|
"d_clean (B b # xs) = b # (d_clean xs)"|
"d_clean (D # xs) = d_clean xs"

locale fake =
fixes zn::nat
begin
(* quotient_type 'a fssset = "'a list" / "(\<lambda>xs ys. set xs = set ys)" *)

fun arbitrary_take :: "'a list \<Rightarrow> 'a list" where
  "arbitrary_take l = take zn l"

lemma sum_transform_aux:
assumes bounded: "\<forall>x \<in> H. f x < (Suc m::nat)"
shows "finite H \<Longrightarrow> (\<Sum>x\<in>H\<inter>f-`{i}.f x) = i * card (f-`{i} \<inter> H)"
proof auto
assume "finite H"
hence "card (H \<inter> (f -` {i})) = card ((f -` {i}) \<inter> H)"
using Set.Int_commute[where A=H]
by simp
thus "finite H \<Longrightarrow> card (H \<inter> f -` {i}) \<noteq> card (f -` {i} \<inter> H) \<Longrightarrow> i = 0"
by auto
qed

lemma partition:
assumes bounded: "\<forall>x \<in> H. f x < (Suc m::nat)"
shows "finite H \<Longrightarrow> H = (\<Union>i \<in> {0..m}. ( H\<inter>f-`{i}))" using bounded by auto

lemma sum_vimage_proof_aux2:
" ((n::nat) + 1) * g = (n* g + g)"
apply auto
done

lemma sum_vimage_proof_aux22:
"real ((n::int) + 1) * g = (n* g + g)"
apply auto+
apply algebra
done

lemma sum_vimage_proof_aux222:
"real ((n::nat) + 1) * g = (n* g + g)"
apply auto
apply (metis comm_monoid_mult_class.mult.right_neutral distrib_left mult.commute real_of_nat_Suc)
done

lemma sum_rw:
fixes b::real
fixes f::"nat \<Rightarrow> real"
assumes "finite F" "E \<subseteq> F"
shows "(\<Sum>i| i \<in>F. f i * log b (f i))
= (\<Sum>i|i \<in> (F-E). f i * log b (f i))
+(\<Sum>i|i \<in> E. f i * log b (f i))" using Groups_Big.setsum_diff[OF assms, of f]
by (metis (no_types) Collect_mem_eq assms(1) assms(2) setsum.subset_diff)

type_synonym ty = "nat list"
locale loc =
fixes i::'b
fixes fi :: "'b \<Rightarrow> real"
assumes 3: "fi i = 3"
begin
lemma lem: "\<And>j. fi j \<noteq> 3 \<Longrightarrow> j \<noteq> i" using 3 by auto

end

definition len :: "'c list \<Rightarrow> real" where
  "len t = length t"

interpretation ty: loc "[3::nat,1,3]" "len"
proof unfold_locales
show "len [3::nat,1,3] = 3" unfolding len_def by simp
qed

lemma qsdf: "\<And>j. len j \<noteq> 3 \<Longrightarrow> j \<noteq> [3::nat,1,3]" using ty.lem by simp

end
end


(*  Title:      HOL/HOLCF/Representable.thy
    Author:     Brian Huffman
*)

section {* Representable domains *}

theory Representable
imports Algebraic Map_Functions "~~/src/HOL/Library/Countable"
begin

default_sort cpo

subsection {* Class of representable domains *}

text {*
  We define a ``domain'' as a pcpo that is isomorphic to some
  algebraic deflation over the universal domain; this is equivalent
  to being omega-bifinite.

  A predomain is a cpo that, when lifted, becomes a domain.
  Predomains are represented by deflations over a lifted universal
  domain type.
*}

class predomain_syn = cpo +
  fixes liftemb :: "'a\<^sub>\<bottom> \<rightarrow> udom\<^sub>\<bottom>"
  fixes liftprj :: "udom\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>"
  fixes liftdefl :: "'a itself \<Rightarrow> udom u defl"

class predomain = predomain_syn +
  assumes predomain_ep: "ep_pair liftemb liftprj"
  assumes cast_liftdefl: "cast\<cdot>(liftdefl TYPE('a)) = liftemb oo liftprj"

syntax "_LIFTDEFL" :: "type \<Rightarrow> logic"  ("(1LIFTDEFL/(1'(_')))")
translations "LIFTDEFL('t)" \<rightleftharpoons> "CONST liftdefl TYPE('t)"

definition liftdefl_of :: "udom defl \<rightarrow> udom u defl"
  where "liftdefl_of = defl_fun1 ID ID u_map"

lemma cast_liftdefl_of: "cast\<cdot>(liftdefl_of\<cdot>t) = u_map\<cdot>(cast\<cdot>t)"
by (simp add: liftdefl_of_def cast_defl_fun1 ep_pair_def finite_deflation_u_map)

class "domain" = predomain_syn + pcpo +
  fixes emb :: "'a \<rightarrow> udom"
  fixes prj :: "udom \<rightarrow> 'a"
  fixes defl :: "'a itself \<Rightarrow> udom defl"
  assumes ep_pair_emb_prj: "ep_pair emb prj"
  assumes cast_DEFL: "cast\<cdot>(defl TYPE('a)) = emb oo prj"
  assumes liftemb_eq: "liftemb = u_map\<cdot>emb"
  assumes liftprj_eq: "liftprj = u_map\<cdot>prj"
  assumes liftdefl_eq: "liftdefl TYPE('a) = liftdefl_of\<cdot>(defl TYPE('a))"

syntax "_DEFL" :: "type \<Rightarrow> logic"  ("(1DEFL/(1'(_')))")
translations "DEFL('t)" \<rightleftharpoons> "CONST defl TYPE('t)"

instance "domain" \<subseteq> predomain
proof
  show "ep_pair liftemb (liftprj::udom\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>)"
    unfolding liftemb_eq liftprj_eq
    by (intro ep_pair_u_map ep_pair_emb_prj)
  show "cast\<cdot>LIFTDEFL('a) = liftemb oo (liftprj::udom\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>)"
    unfolding liftemb_eq liftprj_eq liftdefl_eq
    by (simp add: cast_liftdefl_of cast_DEFL u_map_oo)
qed

text {*
  Constants @{const liftemb} and @{const liftprj} imply class predomain.
*}

setup {*
  fold Sign.add_const_constraint
  [(@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom u"}),
   (@{const_name liftprj}, SOME @{typ "udom u \<rightarrow> 'a::predomain u"}),
   (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> udom u defl"})]
*}

interpretation predomain: pcpo_ep_pair liftemb liftprj
  unfolding pcpo_ep_pair_def by (rule predomain_ep)

interpretation "domain": pcpo_ep_pair emb prj
  unfolding pcpo_ep_pair_def by (rule ep_pair_emb_prj)

lemmas emb_inverse = domain.e_inverse
lemmas emb_prj_below = domain.e_p_below
lemmas emb_eq_iff = domain.e_eq_iff
lemmas emb_strict = domain.e_strict
lemmas prj_strict = domain.p_strict

subsection {* Domains are bifinite *}

lemma approx_chain_ep_cast:
  assumes ep: "ep_pair (e::'a::pcpo \<rightarrow> 'b::bifinite) (p::'b \<rightarrow> 'a)"
  assumes cast_t: "cast\<cdot>t = e oo p"
  shows "\<exists>(a::nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a). approx_chain a"
proof -
  interpret ep_pair e p by fact
  obtain Y where Y: "\<forall>i. Y i \<sqsubseteq> Y (Suc i)"
  and t: "t = (\<Squnion>i. defl_principal (Y i))"
    by (rule defl.obtain_principal_chain)
  def approx \<equiv> "\<lambda>i. (p oo cast\<cdot>(defl_principal (Y i)) oo e) :: 'a \<rightarrow> 'a"
  have "approx_chain approx"
  proof (rule approx_chain.intro)
    show "chain (\<lambda>i. approx i)"
      unfolding approx_def by (simp add: Y)
    show "(\<Squnion>i. approx i) = ID"
      unfolding approx_def
      by (simp add: lub_distribs Y t [symmetric] cast_t cfun_eq_iff)
    show "\<And>i. finite_deflation (approx i)"
      unfolding approx_def
      apply (rule finite_deflation_p_d_e)
      apply (rule finite_deflation_cast)
      apply (rule defl.compact_principal)
      apply (rule below_trans [OF monofun_cfun_fun])
      apply (rule is_ub_thelub, simp add: Y)
      apply (simp add: lub_distribs Y t [symmetric] cast_t)
      done
  qed
  thus "\<exists>(a::nat \<Rightarrow> 'a \<rightarrow> 'a). approx_chain a" by - (rule exI)
qed

instance "domain" \<subseteq> bifinite
by default (rule approx_chain_ep_cast [OF ep_pair_emb_prj cast_DEFL])

instance predomain \<subseteq> profinite
by default (rule approx_chain_ep_cast [OF predomain_ep cast_liftdefl])

subsection {* Universal domain ep-pairs *}

definition "u_emb = udom_emb (\<lambda>i. u_map\<cdot>(udom_approx i))"
definition "u_prj = udom_prj (\<lambda>i. u_map\<cdot>(udom_approx i))"

definition "prod_emb = udom_emb (\<lambda>i. prod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "prod_prj = udom_prj (\<lambda>i. prod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

definition "sprod_emb = udom_emb (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "sprod_prj = udom_prj (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

definition "ssum_emb = udom_emb (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "ssum_prj = udom_prj (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

definition "sfun_emb = udom_emb (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "sfun_prj = udom_prj (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

lemma ep_pair_u: "ep_pair u_emb u_prj"
  unfolding u_emb_def u_prj_def
  by (simp add: ep_pair_udom approx_chain_u_map)

lemma ep_pair_prod: "ep_pair prod_emb prod_prj"
  unfolding prod_emb_def prod_prj_def
  by (simp add: ep_pair_udom approx_chain_prod_map)

lemma ep_pair_sprod: "ep_pair sprod_emb sprod_prj"
  unfolding sprod_emb_def sprod_prj_def
  by (simp add: ep_pair_udom approx_chain_sprod_map)

lemma ep_pair_ssum: "ep_pair ssum_emb ssum_prj"
  unfolding ssum_emb_def ssum_prj_def
  by (simp add: ep_pair_udom approx_chain_ssum_map)

lemma ep_pair_sfun: "ep_pair sfun_emb sfun_prj"
  unfolding sfun_emb_def sfun_prj_def
  by (simp add: ep_pair_udom approx_chain_sfun_map)

subsection {* Type combinators *}

definition u_defl :: "udom defl \<rightarrow> udom defl"
  where "u_defl = defl_fun1 u_emb u_prj u_map"

definition prod_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
  where "prod_defl = defl_fun2 prod_emb prod_prj prod_map"

definition sprod_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
  where "sprod_defl = defl_fun2 sprod_emb sprod_prj sprod_map"

definition ssum_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
where "ssum_defl = defl_fun2 ssum_emb ssum_prj ssum_map"

definition sfun_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
  where "sfun_defl = defl_fun2 sfun_emb sfun_prj sfun_map"

lemma cast_u_defl:
  "cast\<cdot>(u_defl\<cdot>A) = u_emb oo u_map\<cdot>(cast\<cdot>A) oo u_prj"
using ep_pair_u finite_deflation_u_map
unfolding u_defl_def by (rule cast_defl_fun1)

lemma cast_prod_defl:
  "cast\<cdot>(prod_defl\<cdot>A\<cdot>B) =
    prod_emb oo prod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo prod_prj"
using ep_pair_prod finite_deflation_prod_map
unfolding prod_defl_def by (rule cast_defl_fun2)

lemma cast_sprod_defl:
  "cast\<cdot>(sprod_defl\<cdot>A\<cdot>B) =
    sprod_emb oo sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo sprod_prj"
using ep_pair_sprod finite_deflation_sprod_map
unfolding sprod_defl_def by (rule cast_defl_fun2)

lemma cast_ssum_defl:
  "cast\<cdot>(ssum_defl\<cdot>A\<cdot>B) =
    ssum_emb oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo ssum_prj"
using ep_pair_ssum finite_deflation_ssum_map
unfolding ssum_defl_def by (rule cast_defl_fun2)

lemma cast_sfun_defl:
  "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) =
    sfun_emb oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo sfun_prj"
using ep_pair_sfun finite_deflation_sfun_map
unfolding sfun_defl_def by (rule cast_defl_fun2)

text {* Special deflation combinator for unpointed types. *}

definition u_liftdefl :: "udom u defl \<rightarrow> udom defl"
  where "u_liftdefl = defl_fun1 u_emb u_prj ID"

lemma cast_u_liftdefl:
  "cast\<cdot>(u_liftdefl\<cdot>A) = u_emb oo cast\<cdot>A oo u_prj"
unfolding u_liftdefl_def by (simp add: cast_defl_fun1 ep_pair_u)

lemma u_liftdefl_liftdefl_of:
  "u_liftdefl\<cdot>(liftdefl_of\<cdot>A) = u_defl\<cdot>A"
by (rule cast_eq_imp_eq)
   (simp add: cast_u_liftdefl cast_liftdefl_of cast_u_defl)

subsection {* Class instance proofs *}

subsubsection {* Universal domain *}

instantiation udom :: "domain"
begin

definition [simp]:
  "emb = (ID :: udom \<rightarrow> udom)"

definition [simp]:
  "prj = (ID :: udom \<rightarrow> udom)"

definition
  "defl (t::udom itself) = (\<Squnion>i. defl_principal (Abs_fin_defl (udom_approx i)))"

definition
  "(liftemb :: udom u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> udom u) = u_map\<cdot>prj"

definition
  "liftdefl (t::udom itself) = liftdefl_of\<cdot>DEFL(udom)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> udom)"
    by (simp add: ep_pair.intro)
  show "cast\<cdot>DEFL(udom) = emb oo (prj :: udom \<rightarrow> udom)"
    unfolding defl_udom_def
    apply (subst contlub_cfun_arg)
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def)
    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
    apply (rule chainE)
    apply (rule chain_udom_approx)
    apply (subst cast_defl_principal)
    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
    done
qed (fact liftemb_udom_def liftprj_udom_def liftdefl_udom_def)+

end

subsubsection {* Lifted cpo *}

instantiation u :: (predomain) "domain"
begin

definition
  "emb = u_emb oo liftemb"

definition
  "prj = liftprj oo u_prj"

definition
  "defl (t::'a u itself) = u_liftdefl\<cdot>LIFTDEFL('a)"

definition
  "(liftemb :: 'a u u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a u u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a u itself) = liftdefl_of\<cdot>DEFL('a u)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a u)"
    unfolding emb_u_def prj_u_def
    by (intro ep_pair_comp ep_pair_u predomain_ep)
  show "cast\<cdot>DEFL('a u) = emb oo (prj :: udom \<rightarrow> 'a u)"
    unfolding emb_u_def prj_u_def defl_u_def
    by (simp add: cast_u_liftdefl cast_liftdefl assoc_oo)
qed (fact liftemb_u_def liftprj_u_def liftdefl_u_def)+

end

lemma DEFL_u: "DEFL('a::predomain u) = u_liftdefl\<cdot>LIFTDEFL('a)"
by (rule defl_u_def)

subsubsection {* Strict function space *}

instantiation sfun :: ("domain", "domain") "domain"
begin

definition
  "emb = sfun_emb oo sfun_map\<cdot>prj\<cdot>emb"

definition
  "prj = sfun_map\<cdot>emb\<cdot>prj oo sfun_prj"

definition
  "defl (t::('a \<rightarrow>! 'b) itself) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

definition
  "(liftemb :: ('a \<rightarrow>! 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<rightarrow>! 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<rightarrow>! 'b) itself) = liftdefl_of\<cdot>DEFL('a \<rightarrow>! 'b)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
    unfolding emb_sfun_def prj_sfun_def
    by (intro ep_pair_comp ep_pair_sfun ep_pair_sfun_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a \<rightarrow>! 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
    unfolding emb_sfun_def prj_sfun_def defl_sfun_def cast_sfun_defl
    by (simp add: cast_DEFL oo_def sfun_eq_iff sfun_map_map)
qed (fact liftemb_sfun_def liftprj_sfun_def liftdefl_sfun_def)+

end

lemma DEFL_sfun:
  "DEFL('a::domain \<rightarrow>! 'b::domain) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_sfun_def)

subsubsection {* Continuous function space *}

instantiation cfun :: (predomain, "domain") "domain"
begin

definition
  "emb = emb oo encode_cfun"

definition
  "prj = decode_cfun oo prj"

definition
  "defl (t::('a \<rightarrow> 'b) itself) = DEFL('a u \<rightarrow>! 'b)"

definition
  "(liftemb :: ('a \<rightarrow> 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<rightarrow> 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<rightarrow> 'b) itself) = liftdefl_of\<cdot>DEFL('a \<rightarrow> 'b)"

instance proof
  have "ep_pair encode_cfun decode_cfun"
    by (rule ep_pair.intro, simp_all)
  thus "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
    unfolding emb_cfun_def prj_cfun_def
    using ep_pair_emb_prj by (rule ep_pair_comp)
  show "cast\<cdot>DEFL('a \<rightarrow> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
    unfolding emb_cfun_def prj_cfun_def defl_cfun_def
    by (simp add: cast_DEFL cfcomp1)
qed (fact liftemb_cfun_def liftprj_cfun_def liftdefl_cfun_def)+

end

lemma DEFL_cfun:
  "DEFL('a::predomain \<rightarrow> 'b::domain) = DEFL('a u \<rightarrow>! 'b)"
by (rule defl_cfun_def)

subsubsection {* Strict product *}

instantiation sprod :: ("domain", "domain") "domain"
begin

definition
  "emb = sprod_emb oo sprod_map\<cdot>emb\<cdot>emb"

definition
  "prj = sprod_map\<cdot>prj\<cdot>prj oo sprod_prj"

definition
  "defl (t::('a \<otimes> 'b) itself) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

definition
  "(liftemb :: ('a \<otimes> 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<otimes> 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<otimes> 'b) itself) = liftdefl_of\<cdot>DEFL('a \<otimes> 'b)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
    unfolding emb_sprod_def prj_sprod_def
    by (intro ep_pair_comp ep_pair_sprod ep_pair_sprod_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a \<otimes> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
    unfolding emb_sprod_def prj_sprod_def defl_sprod_def cast_sprod_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff sprod_map_map)
qed (fact liftemb_sprod_def liftprj_sprod_def liftdefl_sprod_def)+

end

lemma DEFL_sprod:
  "DEFL('a::domain \<otimes> 'b::domain) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_sprod_def)

subsubsection {* Cartesian product *}

definition prod_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
  where "prod_liftdefl = defl_fun2 (u_map\<cdot>prod_emb oo decode_prod_u)
    (encode_prod_u oo u_map\<cdot>prod_prj) sprod_map"

lemma cast_prod_liftdefl:
  "cast\<cdot>(prod_liftdefl\<cdot>a\<cdot>b) =
    (u_map\<cdot>prod_emb oo decode_prod_u) oo sprod_map\<cdot>(cast\<cdot>a)\<cdot>(cast\<cdot>b) oo
      (encode_prod_u oo u_map\<cdot>prod_prj)"
unfolding prod_liftdefl_def
apply (rule cast_defl_fun2)
apply (intro ep_pair_comp ep_pair_u_map ep_pair_prod)
apply (simp add: ep_pair.intro)
apply (erule (1) finite_deflation_sprod_map)
done

instantiation prod :: (predomain, predomain) predomain
begin

definition
  "liftemb = (u_map\<cdot>prod_emb oo decode_prod_u) oo
    (sprod_map\<cdot>liftemb\<cdot>liftemb oo encode_prod_u)"

definition
  "liftprj = (decode_prod_u oo sprod_map\<cdot>liftprj\<cdot>liftprj) oo
    (encode_prod_u oo u_map\<cdot>prod_prj)"

definition
  "liftdefl (t::('a \<times> 'b) itself) = prod_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"

instance proof
  show "ep_pair liftemb (liftprj :: udom u \<rightarrow> ('a \<times> 'b) u)"
    unfolding liftemb_prod_def liftprj_prod_def
    by (intro ep_pair_comp ep_pair_sprod_map ep_pair_u_map
       ep_pair_prod predomain_ep, simp_all add: ep_pair.intro)
  show "cast\<cdot>LIFTDEFL('a \<times> 'b) = liftemb oo (liftprj :: udom u \<rightarrow> ('a \<times> 'b) u)"
    unfolding liftemb_prod_def liftprj_prod_def liftdefl_prod_def
    by (simp add: cast_prod_liftdefl cast_liftdefl cfcomp1 sprod_map_map)
qed

end

instantiation prod :: ("domain", "domain") "domain"
begin

definition
  "emb = prod_emb oo prod_map\<cdot>emb\<cdot>emb"

definition
  "prj = prod_map\<cdot>prj\<cdot>prj oo prod_prj"

definition
  "defl (t::('a \<times> 'b) itself) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

instance proof
  show 1: "ep_pair emb (prj :: udom \<rightarrow> 'a \<times> 'b)"
    unfolding emb_prod_def prj_prod_def
    by (intro ep_pair_comp ep_pair_prod ep_pair_prod_map ep_pair_emb_prj)
  show 2: "cast\<cdot>DEFL('a \<times> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<times> 'b)"
    unfolding emb_prod_def prj_prod_def defl_prod_def cast_prod_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff prod_map_map)
  show 3: "liftemb = u_map\<cdot>(emb :: 'a \<times> 'b \<rightarrow> udom)"
    unfolding emb_prod_def liftemb_prod_def liftemb_eq
    unfolding encode_prod_u_def decode_prod_u_def
    by (rule cfun_eqI, case_tac x, simp, clarsimp)
  show 4: "liftprj = u_map\<cdot>(prj :: udom \<rightarrow> 'a \<times> 'b)"
    unfolding prj_prod_def liftprj_prod_def liftprj_eq
    unfolding encode_prod_u_def decode_prod_u_def
    apply (rule cfun_eqI, case_tac x, simp)
    apply (rename_tac y, case_tac "prod_prj\<cdot>y", simp)
    done
  show 5: "LIFTDEFL('a \<times> 'b) = liftdefl_of\<cdot>DEFL('a \<times> 'b)"
    by (rule cast_eq_imp_eq)
      (simp add: cast_liftdefl cast_liftdefl_of cast_DEFL 2 3 4 u_map_oo)
qed

end

lemma DEFL_prod:
  "DEFL('a::domain \<times> 'b::domain) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_prod_def)

lemma LIFTDEFL_prod:
  "LIFTDEFL('a::predomain \<times> 'b::predomain) =
    prod_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"
by (rule liftdefl_prod_def)

subsubsection {* Unit type *}

instantiation unit :: "domain"
begin

definition
  "emb = (\<bottom> :: unit \<rightarrow> udom)"

definition
  "prj = (\<bottom> :: udom \<rightarrow> unit)"

definition
  "defl (t::unit itself) = \<bottom>"

definition
  "(liftemb :: unit u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> unit u) = u_map\<cdot>prj"

definition
  "liftdefl (t::unit itself) = liftdefl_of\<cdot>DEFL(unit)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> unit)"
    unfolding emb_unit_def prj_unit_def
    by (simp add: ep_pair.intro)
  show "cast\<cdot>DEFL(unit) = emb oo (prj :: udom \<rightarrow> unit)"
    unfolding emb_unit_def prj_unit_def defl_unit_def by simp
qed (fact liftemb_unit_def liftprj_unit_def liftdefl_unit_def)+

end

subsubsection {* Discrete cpo *}

instantiation discr :: (countable) predomain
begin

definition
  "(liftemb :: 'a discr u \<rightarrow> udom u) = strictify\<cdot>up oo udom_emb discr_approx"

definition
  "(liftprj :: udom u \<rightarrow> 'a discr u) = udom_prj discr_approx oo fup\<cdot>ID"

definition
  "liftdefl (t::'a discr itself) =
    (\<Squnion>i. defl_principal (Abs_fin_defl (liftemb oo discr_approx i oo (liftprj::udom u \<rightarrow> 'a discr u))))"

instance proof
  show 1: "ep_pair liftemb (liftprj :: udom u \<rightarrow> 'a discr u)"
    unfolding liftemb_discr_def liftprj_discr_def
    apply (intro ep_pair_comp ep_pair_udom [OF discr_approx])
    apply (rule ep_pair.intro)
    apply (simp add: strictify_conv_if)
    apply (case_tac y, simp, simp add: strictify_conv_if)
    done
  show "cast\<cdot>LIFTDEFL('a discr) = liftemb oo (liftprj :: udom u \<rightarrow> 'a discr u)"
    unfolding liftdefl_discr_def
    apply (subst contlub_cfun_arg)
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def)
    apply (simp add: Abs_fin_defl_inverse
        ep_pair.finite_deflation_e_d_p [OF 1]
        approx_chain.finite_deflation_approx [OF discr_approx])
    apply (intro monofun_cfun below_refl)
    apply (rule chainE)
    apply (rule chain_discr_approx)
    apply (subst cast_defl_principal)
    apply (simp add: Abs_fin_defl_inverse
        ep_pair.finite_deflation_e_d_p [OF 1]
        approx_chain.finite_deflation_approx [OF discr_approx])
    apply (simp add: lub_distribs)
    done
qed

end

subsubsection {* Strict sum *}

instantiation ssum :: ("domain", "domain") "domain"
begin

definition
  "emb = ssum_emb oo ssum_map\<cdot>emb\<cdot>emb"

definition
  "prj = ssum_map\<cdot>prj\<cdot>prj oo ssum_prj"

definition
  "defl (t::('a \<oplus> 'b) itself) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

definition
  "(liftemb :: ('a \<oplus> 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<oplus> 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<oplus> 'b) itself) = liftdefl_of\<cdot>DEFL('a \<oplus> 'b)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
    unfolding emb_ssum_def prj_ssum_def
    by (intro ep_pair_comp ep_pair_ssum ep_pair_ssum_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a \<oplus> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
    unfolding emb_ssum_def prj_ssum_def defl_ssum_def cast_ssum_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff ssum_map_map)
qed (fact liftemb_ssum_def liftprj_ssum_def liftdefl_ssum_def)+

end

lemma DEFL_ssum:
  "DEFL('a::domain \<oplus> 'b::domain) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_ssum_def)

subsubsection {* Lifted HOL type *}

instantiation lift :: (countable) "domain"
begin

definition
  "emb = emb oo (\<Lambda> x. Rep_lift x)"

definition
  "prj = (\<Lambda> y. Abs_lift y) oo prj"

definition
  "defl (t::'a lift itself) = DEFL('a discr u)"

definition
  "(liftemb :: 'a lift u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a lift u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a lift itself) = liftdefl_of\<cdot>DEFL('a lift)"

instance proof
  note [simp] = cont_Rep_lift cont_Abs_lift Rep_lift_inverse Abs_lift_inverse
  have "ep_pair (\<Lambda>(x::'a lift). Rep_lift x) (\<Lambda> y. Abs_lift y)"
    by (simp add: ep_pair_def)
  thus "ep_pair emb (prj :: udom \<rightarrow> 'a lift)"
    unfolding emb_lift_def prj_lift_def
    using ep_pair_emb_prj by (rule ep_pair_comp)
  show "cast\<cdot>DEFL('a lift) = emb oo (prj :: udom \<rightarrow> 'a lift)"
    unfolding emb_lift_def prj_lift_def defl_lift_def cast_DEFL
    by (simp add: cfcomp1)
qed (fact liftemb_lift_def liftprj_lift_def liftdefl_lift_def)+

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Sep_Cancel
imports Sep_Provers Sep_Tactic_Helpers Sep_Cancel_Set
begin

(* Sep_Cancel performs cancellative elimination of conjuncts *)

lemma sep_curry': "\<lbrakk>(P \<and>* F) s; \<And>s. (Q \<and>* P \<and>* F) s \<Longrightarrow> R s\<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) s"
  by (metis (full_types) sep.mult_commute sep_curry)

lemma sep_conj_sep_impl_safe:
  "(P \<longrightarrow>* P') s \<Longrightarrow> (\<And>s. ((P \<longrightarrow>* P') \<and>* Q) s \<Longrightarrow> (Q') s) \<Longrightarrow> (Q \<longrightarrow>* Q') s"
  by (rule sep_curry)

lemma  sep_conj_sep_impl_safe': "P s \<Longrightarrow> (\<And>s. (P \<and>* Q) s \<Longrightarrow> (P \<and>* R) s) \<Longrightarrow> (Q \<longrightarrow>* P \<and>* R) s"
  by (rule sep_curry)

lemma sep_wand_lens_simple: "(\<And>s. T s = (Q \<and>* R) s) \<Longrightarrow> (P \<longrightarrow>* T) s \<Longrightarrow> (P \<longrightarrow>* Q \<and>* R) s"
  by (clarsimp simp: sep_impl_def)

schematic_goal schem_impAny: " (?C \<and>* B) s \<Longrightarrow> A s" by (erule sep_mp)

ML \<open>
  fun sep_cancel_tactic ctxt concl  =
    let val thms = rev (SepCancel_Rules.get ctxt)
        val tac  = assume_tac ctxt ORELSE'
                   eresolve_tac ctxt [@{thm sep_mp}, @{thm sep_conj_empty}, @{thm sep_empty_conj}] ORELSE'
                   sep_erule_tactic ctxt thms
        val direct_tac = eresolve_tac ctxt thms
        val safe_sep_wand_tac = rotator' ctxt (resolve0_tac [@{thm sep_wand_lens_simple}]) (eresolve0_tac [@{thm sep_conj_sep_impl_safe'}])
        fun sep_cancel_tactic_inner true   = sep_erule_full_tac' tac ctxt
          | sep_cancel_tactic_inner false  = sep_erule_full_tac tac ctxt
  in sep_cancel_tactic_inner concl ORELSE'
      eresolve_tac ctxt [@{thm sep_curry'}, @{thm sep_conj_sep_impl_safe}, @{thm sep_imp_empty}, @{thm sep_empty_imp'}] ORELSE'
      safe_sep_wand_tac ORELSE'
      direct_tac
  end

  fun sep_cancel_tactic' ctxt concl =
    let
      val sep_cancel = sep_cancel_tactic ctxt
    in
      (sep_flatten ctxt THEN_ALL_NEW sep_cancel concl) ORELSE' sep_cancel concl
    end

  fun sep_cancel_method (concl,_) ctxt = SIMPLE_METHOD' (sep_cancel_tactic' ctxt concl)

  val sep_cancel_syntax =
    Method.sections [Args.add -- Args.colon >> K (Method.modifier SepCancel_Rules.add @{here})];

  val sep_cancel_syntax' =
    Scan.lift (Args.mode "concl") -- sep_cancel_syntax
\<close>

method_setup sep_cancel =
  \<open>sep_cancel_syntax' >> sep_cancel_method\<close>  \<open>Simple elimination of conjuncts\<close>

end