theory Move2
  imports Main
begin

datatype 'oid node_ref = Root | Ref 'oid

datatype ('oid, 'key, 'val) tree_op =
  MakeChild "'oid node_ref" 'key |   (* MakeChild obj key: creates a new child node at obj[key] *)
  Move "'oid node_ref" 'key 'oid |   (* Move obj key ref: moves node with ID ref to obj[key] *)
  Assign "'oid node_ref" 'key 'val | (* Assign obj key val: sets obj[key] = val to primitive value *)
  Remove 'oid                        (* Remove ref: removes/overwrites prior assignment *)

datatype ('oid, 'val) val = Child 'oid | Val 'val

type_synonym ('oid, 'key, 'val) tree_state = "('oid \<times> 'oid node_ref \<times> 'key \<times> ('oid, 'val) val) set"

text \<open>\isa{ancestor E anc child} is true if \isa{anc} is an ancestor of \isa{child}
in the element relation \isa{E}.\<close>

inductive ancestor :: "('oid, 'key, 'val) tree_state \<Rightarrow> 'oid node_ref \<Rightarrow> 'oid \<Rightarrow> bool" where
  "\<lbrakk>(oid, obj, key, Child child) \<in> E\<rbrakk> \<Longrightarrow> ancestor E obj child" |
  "\<lbrakk>ancestor E anc obj; (oid, Ref obj, key, Child child) \<in> E\<rbrakk> \<Longrightarrow> ancestor E anc child"

definition do_move :: "('oid, 'key, 'val) tree_state \<Rightarrow> 'oid \<Rightarrow> 'oid node_ref \<Rightarrow> 'key \<Rightarrow> 'oid \<Rightarrow>
                       ('oid, 'key, 'val) tree_state" where
  "do_move E oid obj key ref \<equiv>
     { e \<in> E. snd (snd (snd e)) \<noteq> Child ref } \<union> { (oid, obj, key, Child ref) }"

(* Like tree_spec, but move operation is unconditional (so cycles may occur).
   Using this to practise reasoning about the interpretation. *)
fun unconditional_spec :: "('oid, 'key, 'val) tree_state \<Rightarrow> ('oid \<times> ('oid, 'key, 'val) tree_op) \<Rightarrow>
                           ('oid, 'key, 'val) tree_state" where
  "unconditional_spec E (oid, MakeChild obj key) = E \<union> { (oid, obj, key, Child oid) }" |
  "unconditional_spec E (oid, Move obj key ref) = do_move E oid obj key ref" |
  "unconditional_spec E (oid, Assign obj key val) = E \<union> { (oid, obj, key, Val val) }" |
  "unconditional_spec E (oid, Remove ref) = { e \<in> E. fst e \<noteq> ref }"

definition unconditional_query ::
  "('oid::{linorder} \<times> ('oid, 'key, 'val) tree_op) set \<Rightarrow> ('oid, 'key, 'val) tree_state" where
  "unconditional_query ops \<equiv> {e.
     (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops))}"

(*
definition test_query :: "('oid::{linorder} \<times> ('oid, 'key, 'val) tree_op) set \<Rightarrow> 'val set" where
  "test_query ops \<equiv> {val. \<exists>oid obj key. (oid, Assign obj key val) \<in> ops}"

lemma set_comp_disj:
  shows "{x. P x \<or> x = y} = {x. P x} \<union> {y}"
  by blast

lemma test:
  shows "test_query (ops \<union> {(oid, Assign obj key val)}) = test_query ops \<union> {val}"
proof -
  obtain ops' where ops': "ops' = ops \<union> {(oid, Assign obj key val)}"
    by fastforce
  moreover have "\<And>v. (\<exists>oid obj key. (oid, Assign obj key v) \<in> ops) \<or> v = val \<longleftrightarrow>
                     (\<exists>oid obj key. (oid, Assign obj key v) \<in> ops')"
    using ops' by blast
  hence "{v. \<exists>oid obj key. (oid, Assign obj key v) \<in> ops'} =
         {v. (\<exists>oid obj key. (oid, Assign obj key v) \<in> ops) \<or> v = val}"
    by auto
  moreover have "... = {v. \<exists>oid obj key. (oid, Assign obj key v) \<in> ops} \<union> {val}"
    by blast
  ultimately show ?thesis
    using test_query_def by (metis (mono_tags, lifting))
qed*)

lemma unconditional_MakeChild:
  assumes "\<forall>i \<in> fst ` ops. i < oid"
    and "\<And>i ref. (i, Remove ref) \<in> ops \<Longrightarrow> ref < i"
  shows "unconditional_query (ops \<union> {(oid, MakeChild obj key)}) =
        (unconditional_query ops) \<union> {(oid, obj, key, Child oid)}"
proof -
  obtain ops' where ops': "ops' = ops \<union> {(oid, MakeChild obj key)}"
    by fastforce
  have no_remove: "\<nexists>i. (i, Remove oid) \<in> ops"
    using assms(1,2) by fastforce
  have "\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' oid) \<in> ops)"
    using assms(1) by auto
  hence "\<And>e. (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops))) \<or>
           e = (oid, obj, key, Child oid) \<longleftrightarrow>
       (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops' \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops') \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops') \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops')))"
    using no_remove ops' Pair_inject Un_insert_right insert_iff sup_bot.right_neutral
      tree_op.distinct(5) by force
  moreover have "\<And>e. (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops)) \<longleftrightarrow>
           (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops' \<and> (\<nexists>i. (i, Remove oid) \<in> ops'))"
    by (simp add: ops')
  ultimately have "\<And>e. (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops)) \<or>
     e = (oid, obj, key, Child oid) \<longleftrightarrow>
     (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops' \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops') \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops') \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops'))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops' \<and> (\<nexists>i. (i, Remove oid) \<in> ops'))"
    apply -
    apply(rule iffI)
    apply clarsimp
    using assms(1) no_remove ops' apply fastforce
    apply clarsimp
    using assms(1) no_remove ops' sup_bot.right_neutral tree_op.distinct(1) tree_op.distinct(3) tree_op.inject(1) by auto
  hence "{e. (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops)) \<or>
     e = (oid, obj, key, Child oid)} =
     {e. (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops' \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops') \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops') \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops'))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops' \<and> (\<nexists>i. (i, Remove oid) \<in> ops'))}"
    by auto
  moreover have "{e. (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops)) \<or>
     e = (oid, obj, key, Child oid)} =
     {e. (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or> (oid, Move obj key ref) \<in> ops) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops))} \<union> {(oid, obj, key, Child oid)}"
    by blast
  ultimately show ?thesis
    using unconditional_query_def ops' by (metis (mono_tags, lifting))
qed

lemma unconditional_Move:
  assumes "\<forall>i \<in> fst ` ops. i < oid"
    and "\<And>i ref. (i, Remove ref) \<in> ops \<Longrightarrow> ref < i"
  shows "unconditional_query (ops \<union> {(oid, Move obj key ref)}) =
    {e \<in> unconditional_query ops. snd (snd (snd e)) \<noteq> Child ref} \<union> {(oid, obj, key, Child ref)}"
  using assms(1) apply(unfold unconditional_query_def)
  apply safe
                      apply force+
  apply(clarsimp)
  apply(intro conjI)
  using assms(2) apply fastforce
  apply auto
  done

lemma unconditional_Assign:
  assumes "\<forall>i \<in> fst ` ops. i < oid"
    and "\<And>i ref. (i, Remove ref) \<in> ops \<Longrightarrow> ref < i"
  shows "unconditional_query (ops \<union> {(oid, Assign obj key val)}) =
    unconditional_query ops \<union> {(oid, obj, key, Val val)}"
  using assms by(force simp add: unconditional_query_def)

lemma unconditional_Remove:
  assumes "\<forall>i \<in> fst ` ops. i < oid"
  shows "unconditional_query (ops \<union> {(oid, Remove ref)}) =
    {e \<in> unconditional_query ops. fst e \<noteq> ref}"
  using assms by(auto simp add: unconditional_query_def)

theorem unconditional_equiv:
  assumes "sorted (map fst ops)" and "distinct (map fst ops)"
    and "\<And>i ref. (i, Remove ref) \<in> set ops \<Longrightarrow> ref < i"
  shows "foldl unconditional_spec {} ops = unconditional_query (set ops)"
using assms proof(induction ops rule: List.rev_induct, simp add: unconditional_query_def)
  case (snoc x xs)
  hence "foldl unconditional_spec {} xs = unconditional_query (set xs)"
    using distinct_butlast sorted_butlast by (simp add: sorted_append)
  moreover have remove_less: "\<And>i ref. (i, Remove ref) \<in> set xs \<Longrightarrow> ref < i"
    by (simp add: snoc.prems(3))
  moreover obtain oid oper where x_pair: "x = (oid, oper)"
    by fastforce
  moreover from this have "\<forall>i \<in> set (map fst xs). i < oid"
    using snoc by (metis disjoint_insert(1) distinct_append empty_set fst_conv less_le
      list.set(2) list.simps(8) list.simps(9) map_append singletonI sorted_append)
  hence id_max: "\<forall>i \<in> fst ` set xs. i < oid"
    by simp
  moreover have "unconditional_spec (unconditional_query (set xs)) (oid, oper) =
                 unconditional_query (set xs \<union> {(oid, oper)})"
  proof(cases oper)
    case (MakeChild obj key)
    moreover have "unconditional_spec (unconditional_query (set xs)) (oid, MakeChild obj key) =
        (unconditional_query (set xs)) \<union> {(oid, obj, key, Child oid)}"
      by simp
    moreover have "... = unconditional_query (set xs \<union> {(oid, MakeChild obj key)})"
      using unconditional_MakeChild id_max remove_less by metis
    ultimately show ?thesis
      by blast
  next
    case (Move obj key ref)
    moreover have "unconditional_spec (unconditional_query (set xs)) (oid, Move obj key ref) =
        {e \<in> unconditional_query (set xs). snd (snd (snd e)) \<noteq> Child ref} \<union> {(oid, obj, key, Child ref)}"
      by (simp add: do_move_def)
    moreover have "... = unconditional_query (set xs \<union> {(oid, Move obj key ref)})"
      using unconditional_Move id_max remove_less by(metis (mono_tags, lifting) Collect_cong)
    ultimately show ?thesis
      by blast
  next
    case (Assign obj key val)
    moreover have "unconditional_spec (unconditional_query (set xs)) (oid, Assign obj key val) =
        (unconditional_query (set xs)) \<union> {(oid, obj, key, Val val)}"
      by simp
    moreover have "... = unconditional_query (set xs \<union> {(oid, Assign obj key val)})"
      using unconditional_Assign id_max remove_less by metis
    ultimately show ?thesis
      by blast
  next
    case (Remove ref)
    moreover have "unconditional_spec (unconditional_query (set xs)) (oid, Remove ref) =
        {e \<in> unconditional_query (set xs). fst e \<noteq> ref}"
      by simp
    moreover have "... = unconditional_query (set xs \<union> {(oid, Remove ref)})"
      using unconditional_Remove id_max by fastforce
    ultimately show ?thesis
      by blast
  qed
  ultimately show ?case by auto
qed

(* The sequential opset interpretation for a tree with move operation *)
fun tree_spec :: "('oid, 'key, 'val) tree_state \<Rightarrow> ('oid \<times> ('oid, 'key, 'val) tree_op) \<Rightarrow>
                  ('oid, 'key, 'val) tree_state" where
  "tree_spec E (oid, MakeChild obj key) = E \<union> { (oid, obj, key, Child oid) }" |
  "tree_spec E (oid, Move Root key ref) = do_move E oid Root key ref" |
  "tree_spec E (oid, Move (Ref obj) key ref) =
     (if ancestor E (Ref ref) obj then E else do_move E oid (Ref obj) key ref)" |
  "tree_spec E (oid, Assign obj key val) = E \<union> { (oid, obj, key, Val val) }" |
  "tree_spec E (oid, Remove ref) = { e \<in> E. fst e \<noteq> ref }"

function (domintros) tree_query ::
  "('oid::{linorder} \<times> ('oid, 'key, 'val) tree_op) set \<Rightarrow> ('oid, 'key, 'val) tree_state" where
  "tree_query ops = {e.
     (\<exists>oid obj key ref. e = (oid, obj, key, Child ref) \<and>
           ((oid, MakeChild obj key) \<in> ops \<and> ref = oid \<or>
            (oid, Move obj key ref) \<in> ops \<and>
            (case obj of Root \<Rightarrow> True | Ref parent \<Rightarrow>
            \<not>ancestor (tree_query {oper \<in> ops. fst oper < oid}) (Ref ref) parent)) \<and>
           (\<nexists>i. (i, Remove oid) \<in> ops) \<and>
           (\<nexists>i. oid < i \<and> (\<exists>obj' key'. (i, Move obj' key' ref) \<in> ops \<and> (case obj' of Root \<Rightarrow> True | Ref parent \<Rightarrow>
            \<not>ancestor (tree_query {oper \<in> ops. fst oper < i}) (Ref ref) parent)))) \<or>
     (\<exists>oid obj key val. e = (oid, obj, key, Val val) \<and>
           (oid, Assign obj key val) \<in> ops \<and> (\<nexists>i. (i, Remove oid) \<in> ops))}"
  by pat_completeness auto

lemma tree_query_termination:
  assumes "finite S"
  shows "tree_query_dom S"
  using assms
  apply -
  apply(rule tree_query.domintros)
  sorry

lemmas tree_query_simps = tree_query.psimps[OF tree_query_termination]

end


(*  Title:      HOL/UNITY/Simple/Lift.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

The Lift-Control Example.
*)

theory Lift
imports "../UNITY_Main"
begin

record state =
  floor :: "int"            \<comment>\<open>current position of the lift\<close>
  "open" :: "bool"          \<comment>\<open>whether the door is opened at floor\<close>
  stop  :: "bool"           \<comment>\<open>whether the lift is stopped at floor\<close>
  req   :: "int set"        \<comment>\<open>for each floor, whether the lift is requested\<close>
  up    :: "bool"           \<comment>\<open>current direction of movement\<close>
  move  :: "bool"           \<comment>\<open>whether moving takes precedence over opening\<close>

axiomatization
  Min :: "int" and   \<comment>\<open>least and greatest floors\<close>
  Max :: "int"       \<comment>\<open>least and greatest floors\<close>
where
  Min_le_Max [iff]: "Min \<le> Max"

  \<comment>\<open>Abbreviations: the "always" part\<close>

definition
  above :: "state set"
  where "above = {s. \<exists>i. floor s < i & i \<le> Max & i \<in> req s}"

definition
  below :: "state set"
  where "below = {s. \<exists>i. Min \<le> i & i < floor s & i \<in> req s}"

definition
  queueing :: "state set"
  where "queueing = above \<union> below"

definition
  goingup :: "state set"
  where "goingup = above \<inter> ({s. up s}  \<union> -below)"

definition
  goingdown :: "state set"
  where "goingdown = below \<inter> ({s. ~ up s} \<union> -above)"

definition
  ready :: "state set"
  where "ready = {s. stop s & ~ open s & move s}"

  \<comment>\<open>Further abbreviations\<close>

definition
  moving :: "state set"
  where "moving = {s. ~ stop s & ~ open s}"

definition
  stopped :: "state set"
  where "stopped = {s. stop s  & ~ open s & ~ move s}"

definition
  opened :: "state set"
  where "opened = {s. stop s  &  open s  &  move s}"

definition
  closed :: "state set"  \<comment>\<open>but this is the same as ready!!\<close>
  where "closed = {s. stop s  & ~ open s &  move s}"

definition
  atFloor :: "int => state set"
  where "atFloor n = {s. floor s = n}"

definition
  Req :: "int => state set"
  where "Req n = {s. n \<in> req s}"

  \<comment>\<open>The program\<close>

definition
  request_act :: "(state*state) set"
  where "request_act = {(s,s'). s' = s (|stop:=True, move:=False|)
                                  & ~ stop s & floor s \<in> req s}"

definition
  open_act :: "(state*state) set"
  where "open_act =
         {(s,s'). s' = s (|open :=True,
                           req  := req s - {floor s},
                           move := True|)
                       & stop s & ~ open s & floor s \<in> req s
                       & ~(move s & s \<in> queueing)}"

definition
  close_act :: "(state*state) set"
  where "close_act = {(s,s'). s' = s (|open := False|) & open s}"

definition
  req_up :: "(state*state) set"
  where "req_up =
         {(s,s'). s' = s (|stop  :=False,
                           floor := floor s + 1,
                           up    := True|)
                       & s \<in> (ready \<inter> goingup)}"

definition
  req_down :: "(state*state) set"
  where "req_down =
         {(s,s'). s' = s (|stop  :=False,
                           floor := floor s - 1,
                           up    := False|)
                       & s \<in> (ready \<inter> goingdown)}"

definition
  move_up :: "(state*state) set"
  where "move_up =
         {(s,s'). s' = s (|floor := floor s + 1|)
                       & ~ stop s & up s & floor s \<notin> req s}"

definition
  move_down :: "(state*state) set"
  where "move_down =
         {(s,s'). s' = s (|floor := floor s - 1|)
                       & ~ stop s & ~ up s & floor s \<notin> req s}"

definition
  button_press  :: "(state*state) set"
      \<comment>\<open>This action is omitted from prior treatments, which therefore are
        unrealistic: nobody asks the lift to do anything!  But adding this
        action invalidates many of the existing progress arguments: various
        "ensures" properties fail. Maybe it should be constrained to only
        allow button presses in the current direction of travel, like in a
        real lift.\<close>
  where "button_press =
         {(s,s'). \<exists>n. s' = s (|req := insert n (req s)|)
                        & Min \<le> n & n \<le> Max}"

definition
  Lift :: "state program"
    \<comment>\<open>for the moment, we OMIT \<open>button_press\<close>\<close>
  where "Lift = mk_total_program
                ({s. floor s = Min & ~ up s & move s & stop s &
                          ~ open s & req s = {}},
                 {request_act, open_act, close_act,
                  req_up, req_down, move_up, move_down},
                 UNIV)"

  \<comment>\<open>Invariants\<close>

definition
  bounded :: "state set"
  where "bounded = {s. Min \<le> floor s & floor s \<le> Max}"

definition
  open_stop :: "state set"
  where "open_stop = {s. open s --> stop s}"

definition
  open_move :: "state set"
  where "open_move = {s. open s --> move s}"

definition
  stop_floor :: "state set"
  where "stop_floor = {s. stop s & ~ move s --> floor s \<in> req s}"

definition
  moving_up :: "state set"
  where "moving_up = {s. ~ stop s & up s -->
                   (\<exists>f. floor s \<le> f & f \<le> Max & f \<in> req s)}"

definition
  moving_down :: "state set"
  where "moving_down = {s. ~ stop s & ~ up s -->
                     (\<exists>f. Min \<le> f & f \<le> floor s & f \<in> req s)}"

definition
  metric :: "[int,state] => int"
  where "metric =
       (%n s. if floor s < n then (if up s then n - floor s
                                  else (floor s - Min) + (n-Min))
             else
             if n < floor s then (if up s then (Max - floor s) + (Max-n)
                                  else floor s - n)
             else 0)"

locale Floor =
  fixes n
  assumes Min_le_n [iff]: "Min \<le> n"
      and n_le_Max [iff]: "n \<le> Max"

lemma not_mem_distinct: "[| x \<notin> A;  y \<in> A |] ==> x \<noteq> y"
by blast

declare Lift_def [THEN def_prg_Init, simp]

declare request_act_def [THEN def_act_simp, simp]
declare open_act_def [THEN def_act_simp, simp]
declare close_act_def [THEN def_act_simp, simp]
declare req_up_def [THEN def_act_simp, simp]
declare req_down_def [THEN def_act_simp, simp]
declare move_up_def [THEN def_act_simp, simp]
declare move_down_def [THEN def_act_simp, simp]
declare button_press_def [THEN def_act_simp, simp]

(*The ALWAYS properties*)
declare above_def [THEN def_set_simp, simp]
declare below_def [THEN def_set_simp, simp]
declare queueing_def [THEN def_set_simp, simp]
declare goingup_def [THEN def_set_simp, simp]
declare goingdown_def [THEN def_set_simp, simp]
declare ready_def [THEN def_set_simp, simp]

(*Basic definitions*)
declare bounded_def [simp]
        open_stop_def [simp]
        open_move_def [simp]
        stop_floor_def [simp]
        moving_up_def [simp]
        moving_down_def [simp]

lemma open_stop: "Lift \<in> Always open_stop"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

lemma stop_floor: "Lift \<in> Always stop_floor"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

(*This one needs open_stop, which was proved above*)
lemma open_move: "Lift \<in> Always open_move"
apply (cut_tac open_stop)
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

lemma moving_up: "Lift \<in> Always moving_up"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
apply (auto dest: order_le_imp_less_or_eq simp add: add1_zle_eq)
done

lemma moving_down: "Lift \<in> Always moving_down"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
apply (blast dest: order_le_imp_less_or_eq)
done

lemma bounded: "Lift \<in> Always bounded"
apply (cut_tac moving_up moving_down)
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety, auto)
apply (drule not_mem_distinct, assumption, arith)+
done

subsection\<open>Progress\<close>

declare moving_def [THEN def_set_simp, simp]
declare stopped_def [THEN def_set_simp, simp]
declare opened_def [THEN def_set_simp, simp]
declare closed_def [THEN def_set_simp, simp]
declare atFloor_def [THEN def_set_simp, simp]
declare Req_def [THEN def_set_simp, simp]

text\<open>The HUG'93 paper mistakenly omits the Req n from these!\<close>

(** Lift_1 **)
lemma E_thm01: "Lift \<in> (stopped \<inter> atFloor n) LeadsTo (opened \<inter> atFloor n)"
apply (cut_tac stop_floor)
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_5*)

lemma E_thm02: "Lift \<in> (Req n \<inter> stopped - atFloor n) LeadsTo
                       (Req n \<inter> opened - atFloor n)"
apply (cut_tac stop_floor)
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_1*)

lemma E_thm03: "Lift \<in> (Req n \<inter> opened - atFloor n) LeadsTo
                       (Req n \<inter> closed - (atFloor n - queueing))"
apply (unfold Lift_def, ensures_tac "close_act")
done  (*lem_lift_1_2*)

lemma E_thm04: "Lift \<in> (Req n \<inter> closed \<inter> (atFloor n - queueing))
                       LeadsTo (opened \<inter> atFloor n)"
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_7*)

(** Lift 2.  Statements of thm05a and thm05b were wrong! **)

lemmas linorder_leI = linorder_not_less [THEN iffD1]

context Floor
begin

lemmas le_MinD = Min_le_n [THEN order_antisym]
  and Max_leD = n_le_Max [THEN [2] order_antisym]

declare le_MinD [dest!]
  and linorder_leI [THEN le_MinD, dest!]
  and Max_leD [dest!]
  and linorder_leI [THEN Max_leD, dest!]

(*lem_lift_2_0
  NOT an ensures_tac property, but a mere inclusion
  don't know why script lift_2.uni says ENSURES*)
lemma E_thm05c:
    "Lift \<in> (Req n \<inter> closed - (atFloor n - queueing))
             LeadsTo ((closed \<inter> goingup \<inter> Req n)  \<union>
                      (closed \<inter> goingdown \<inter> Req n))"
by (auto intro!: subset_imp_LeadsTo simp add: linorder_neq_iff)

(*lift_2*)
lemma lift_2: "Lift \<in> (Req n \<inter> closed - (atFloor n - queueing))
             LeadsTo (moving \<inter> Req n)"
apply (rule LeadsTo_Trans [OF E_thm05c LeadsTo_Un])
apply (unfold Lift_def)
apply (ensures_tac [2] "req_down")
apply (ensures_tac "req_up", auto)
done

(** Towards lift_4 ***)

declare if_split_asm [split]

(*lem_lift_4_1 *)
lemma E_thm12a:
     "0 < N ==>
      Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
              {s. floor s \<notin> req s} \<inter> {s. up s})
             LeadsTo
               (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac moving_up)
apply (unfold Lift_def, ensures_tac "move_up", safe)
(*this step consolidates two formulae to the goal  metric n s' \<le> metric n s*)
apply (erule linorder_leI [THEN order_antisym, symmetric])
apply (auto simp add: metric_def)
done

(*lem_lift_4_3 *)
lemma E_thm12b: "0 < N ==>
      Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
              {s. floor s \<notin> req s} - {s. up s})
             LeadsTo (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac moving_down)
apply (unfold Lift_def, ensures_tac "move_down", safe)
(*this step consolidates two formulae to the goal  metric n s' \<le> metric n s*)
apply (erule linorder_leI [THEN order_antisym, symmetric])
apply (auto simp add: metric_def)
done

(*lift_4*)
lemma lift_4:
     "0<N ==> Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
                            {s. floor s \<notin> req s}) LeadsTo
                           (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF E_thm12a E_thm12b]], auto)
done

(** towards lift_5 **)

(*lem_lift_5_3*)
lemma E_thm16a: "0<N
  ==> Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N} \<inter> goingup) LeadsTo
             (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "req_up")
apply (auto simp add: metric_def)
done

(*lem_lift_5_1 has ~goingup instead of goingdown*)
lemma E_thm16b: "0<N ==>
      Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N} \<inter> goingdown) LeadsTo
                   (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "req_down")
apply (auto simp add: metric_def)
done

(*lem_lift_5_0 proves an intersection involving ~goingup and goingup,
  i.e. the trivial disjunction, leading to an asymmetrical proof.*)
lemma E_thm16c:
     "0<N ==> Req n \<inter> {s. metric n s = N} \<subseteq> goingup \<union> goingdown"
by (force simp add: metric_def)

(*lift_5*)
lemma lift_5:
     "0<N ==> Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N}) LeadsTo
                     (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF E_thm16a E_thm16b]])
apply (drule E_thm16c, auto)
done

(** towards lift_3 **)

(*lemma used to prove lem_lift_3_1*)
lemma metric_eq_0D [dest]:
     "[| metric n s = 0;  Min \<le> floor s;  floor s \<le> Max |] ==> floor s = n"
by (force simp add: metric_def)

(*lem_lift_3_1*)
lemma E_thm11: "Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = 0}) LeadsTo
                       (stopped \<inter> atFloor n)"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "request_act", auto)
done

(*lem_lift_3_5*)
lemma E_thm13:
  "Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
  LeadsTo (stopped \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})"
apply (unfold Lift_def, ensures_tac "request_act")
apply (auto simp add: metric_def)
done

(*lem_lift_3_6*)
lemma E_thm14: "0 < N ==>
      Lift \<in>
        (stopped \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
        LeadsTo (opened \<inter> Req n \<inter> {s. metric n s = N})"
apply (unfold Lift_def, ensures_tac "open_act")
apply (auto simp add: metric_def)
done

(*lem_lift_3_7*)
lemma E_thm15: "Lift \<in> (opened \<inter> Req n \<inter> {s. metric n s = N})
             LeadsTo (closed \<inter> Req n \<inter> {s. metric n s = N})"
apply (unfold Lift_def, ensures_tac "close_act")
apply (auto simp add: metric_def)
done

(** the final steps **)

lemma lift_3_Req: "0 < N ==>
      Lift \<in>
        (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
        LeadsTo (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (blast intro!: E_thm13 E_thm14 E_thm15 lift_5 intro: LeadsTo_Trans)
done

(*Now we observe that our integer metric is really a natural number*)
lemma Always_nonneg: "Lift \<in> Always {s. 0 \<le> metric n s}"
apply (rule bounded [THEN Always_weaken])
apply (auto simp add: metric_def)
done

lemmas R_thm11 = Always_LeadsTo_weaken [OF Always_nonneg E_thm11]

lemma lift_3: "Lift \<in> (moving \<inter> Req n) LeadsTo (stopped \<inter> atFloor n)"
apply (rule Always_nonneg [THEN integ_0_le_induct])
apply (case_tac "0 < z")
(*If z \<le> 0 then actually z = 0*)
prefer 2 apply (force intro: R_thm11 order_antisym simp add: linorder_not_less)
apply (rule LeadsTo_weaken_R [OF asm_rl Un_upper1])
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF lift_4 lift_3_Req]], auto)
done

lemma lift_1: "Lift \<in> (Req n) LeadsTo (opened \<inter> atFloor n)"
apply (rule LeadsTo_Trans)
 prefer 2
 apply (rule LeadsTo_Un [OF E_thm04 LeadsTo_Un_post])
 apply (rule E_thm01 [THEN [2] LeadsTo_Trans_Un])
 apply (rule lift_3 [THEN [2] LeadsTo_Trans_Un])
 apply (rule lift_2 [THEN [2] LeadsTo_Trans_Un])
 apply (rule LeadsTo_Trans_Un [OF E_thm02 E_thm03])
apply (rule open_move [THEN Always_LeadsToI])
apply (rule Always_LeadsToI [OF open_stop subset_imp_LeadsTo], clarify)
(*The case split is not essential but makes the proof much faster.*)
apply (case_tac "open x", auto)
done

end

end


theory Planar_Subdivision
imports
  Graph_Genus
  Reachablen
  Permutations_2
begin

section \<open>Combinatorial Planarity and Subdivisions\<close>

locale subdiv1_contr = subdiv_step +
  fixes HM
  assumes H_map: "digraph_map H HM"
  assumes edge_rev_conv: "edge_rev HM = rev_H"

sublocale subdiv1_contr \<subseteq> H: digraph_map H HM
  rewrites "edge_rev HM = rev_H" by (intro H_map edge_rev_conv)+

sublocale subdiv1_contr \<subseteq> G: fin_digraph G
  by unfold_locales (auto simp: arcs_G verts_G)

context subdiv1_contr begin

  definition GM :: "'b pre_map" where
    "GM \<equiv>
      \<lparr> edge_rev = rev_G
      , edge_succ = perm_swap uw uv (perm_swap vw vu (fold perm_rem [wu, wv] (edge_succ HM)))
      \<rparr>"

  lemma edge_rev_GM:  "edge_rev GM = rev_G"
    by (simp add: GM_def)

  lemma edge_succ_GM: "edge_succ GM = perm_swap uw uv (perm_swap vw (rev_G uv) (fold perm_rem [wu, wv] (edge_succ HM)))"
    by (simp add: GM_def)

  lemma rev_H_eq_rev_G:
    assumes "x \<in> arcs G - {uv,vu}" shows "rev_H x = rev_G x"
  proof -
    have "perm_restrict rev_H (arcs G) = perm_restrict rev_G (arcs H)"
      using subdiv_step by (auto simp: subdivision_step_def)
    with assms show ?thesis
      unfolding arcs_H by (auto simp: perm_restrict_def fun_eq_iff split: if_splits)
  qed

  lemma edge_succ_permutes: "edge_succ GM permutes arcs G"
  proof -
    have "arcs H \<subseteq> (vw \<rightleftharpoons>\<^sub>F rev_G uv) ` (uw \<rightleftharpoons>\<^sub>F uv) ` arcs G \<union> {wv} \<union> {wu}"
      using subdiv_distinct_arcs in_arcs_G
      by (auto simp: arcs_H in_funswapid_image_iff swap_id_eq split: if_splits)
    then have "perm_swap uw uv (perm_swap vw (rev_G uv) (perm_rem (wv) (perm_rem (wu) (edge_succ HM)))) permutes arcs G"
      by (blast intro: perm_rem_permutes perm_swap_permutes2 permutes_subset H.edge_succ_permutes)
    then show ?thesis by (auto simp: edge_succ_GM)
  qed

  lemma out_arcs_empty:
    assumes "x \<in> verts G"
    shows "out_arcs G x = {} \<longleftrightarrow> out_arcs H x = {}"
  proof
    assume A: "out_arcs H x = {}"
    have tail_eqI: "\<And>a. tail H a = tail G a" by (simp only: tail_eq)

    { fix a assume "a \<in> out_arcs G x"
      moreover have "a \<in> arcs H \<Longrightarrow> a \<noteq> uv" "a \<in> arcs H \<Longrightarrow> a \<noteq> vu"
        using not_in_arcs_H by auto
      ultimately have "(uw \<rightleftharpoons>\<^sub>F uv) ((vw \<rightleftharpoons>\<^sub>F vu) a) \<in> out_arcs H x"
        using subdiv_distinct_arcs in_arcs_H not_in_arcs_H
        by (auto simp: arcs_G intro: tail_eqI)
    }
    then show "out_arcs G x = {}"
      using A by (auto simp del: in_out_arcs_conv)
  next
    assume A: "out_arcs G x = {}"
    have tail_eqI: "\<And>a. tail H a = tail G a" by (simp only: tail_eq)

    { fix a assume "a \<in> out_arcs H x"
      moreover have "x \<noteq> w" using assms not_in_verts_G by blast
      ultimately have "(uw \<rightleftharpoons>\<^sub>F uv) ((vw \<rightleftharpoons>\<^sub>F vu) a) \<in> out_arcs G x"
        using subdiv_distinct_arcs in_arcs_G not_in_arcs_G
        by (auto simp: arcs_H ) (auto simp: swap_id_eq intro: tail_eqI[symmetric])
    }
    then show "out_arcs H x = {}"
      using A by (auto simp del: in_out_arcs_conv)
  qed

  lemma cyclic_on_edge_succ:
    assumes "x \<in> verts G" "out_arcs G x \<noteq> {}"
    shows "cyclic_on (edge_succ GM) (out_arcs G x)"
  proof -
    have oa_Gx: "out_arcs G x = (uw \<rightleftharpoons>\<^sub>F uv) ` (vw \<rightleftharpoons>\<^sub>F vu) ` (out_arcs H x - {wu} - {wv})"
      using subdiv_distinct_arcs not_in_arcs_G in_arcs_G
      by (auto simp: in_funswapid_image_iff arcs_H swap_id_eq tail_eq[symmetric] split: if_splits)

    have "cyclic_on (perm_swap uw uv (perm_swap vw (rev_G uv) (perm_rem (wv) (perm_rem (wu) (edge_succ HM))))) (out_arcs G x)"
      unfolding oa_Gx
    proof (intro cyclic_on_perm_swap cyclic_on_perm_rem)
      show "cyclic_on (edge_succ HM) (out_arcs H x)"
        using assms by (auto simp: out_arcs_empty verts_H intro: H.edge_succ_cyclic)
      show "bij (edge_succ HM)" by (simp add: H.bij_edge_succ)
      show "bij (perm_rem (wu) (edge_succ HM))" by (simp add: H.bij_edge_succ)

      have "x \<noteq> w" using assms not_in_verts_G by auto
      then have "wu \<notin> out_arcs H x" "wv \<notin> out_arcs H x"
        by (auto simp: arc_to_ends_def)
      then show "out_arcs H x - {wu} \<noteq> {wv}" "out_arcs H x \<noteq> {wu}"
        by blast+
    qed
    then show ?thesis by (simp add: edge_succ_GM)
  qed

  lemma digraph_map_GM:
    shows "digraph_map G GM"
    by unfold_locales (auto simp: edge_rev_GM G.arev_dom edge_succ_permutes cyclic_on_edge_succ verts_G)

end

sublocale subdiv1_contr \<subseteq> GM: digraph_map G GM by (rule digraph_map_GM)

context subdiv1_contr begin

  lemma reachableGD:
    assumes "x \<rightarrow>\<^sup>*\<^bsub>G\<^esub> y" shows "x \<rightarrow>\<^sup>*\<^bsub>H\<^esub> y"
    using assms
  proof induct
    case base then show ?case by (auto simp: verts_H)
  next
    case (step x z)
    moreover
    have "u \<rightarrow>\<^sup>*\<^bsub>H\<^esub> v" "v \<rightarrow>\<^sup>*\<^bsub>H\<^esub> u" using adj_with_w by auto
    moreover
    { assume A: "(x,z) \<noteq> (u,v)" "(x,z) \<noteq> (v,u)"
      from \<open>x \<rightarrow>\<^bsub>G\<^esub> z\<close> obtain a where "a \<in> arcs G" "tail G a = x" "head G a = z"
        by auto
      with A have "a \<in> arcs H" "arc_to_ends H a = (x,z)" "tail H a = x" "head G a = z"
        by (auto simp: arcs_H tail_eq head_eq arc_to_ends_def fun_eq_iff)
      then have "x \<rightarrow>\<^bsub>H\<^esub> z" by (auto simp: arcs_ends_def intro: rev_image_eqI)
    }
    ultimately
    show ?case by (auto intro: H.reachable_trans)
  qed

  definition proj_verts_H :: "'a \<Rightarrow> 'a" where
    "proj_verts_H x \<equiv> if x = w then u else x"

  lemma proj_verts_H_in_G: "x \<in> verts H \<Longrightarrow> proj_verts_H x \<in> verts G"
    using in_verts_G by (auto simp: proj_verts_H_def verts_H)

  lemma dominatesHD:
    assumes "x \<rightarrow>\<^bsub>H\<^esub> y" shows "proj_verts_H x \<rightarrow>\<^sup>*\<^bsub>G\<^esub> proj_verts_H y"
  proof -
    have X1: "\<And>a. (w, y) = arc_to_ends G a \<Longrightarrow> a \<notin> arcs G"
      by (metis G.adj_in_verts(1) G.dominatesI not_in_verts_G)
    have X2: "\<And>a. (x, w) = arc_to_ends G a \<Longrightarrow> a \<notin> arcs G"
      by (metis G.adj_in_verts(2) G.dominatesI not_in_verts_G)
    show ?thesis
      using assms subdiv_ate_H_rev subdiv_ate in_verts_G
      by (auto simp: arcs_ends_def arcs_H arc_to_ends_eq proj_verts_H_def G_reach dest: X1 X2)
  qed

  lemma reachableHD:
    assumes reach:"x \<rightarrow>\<^sup>*\<^bsub>H\<^esub> y" shows "proj_verts_H x \<rightarrow>\<^sup>*\<^bsub>G\<^esub> proj_verts_H y"
    using assms by induct (blast intro: proj_verts_H_in_G G.reachable_trans dominatesHD)+

  lemma H_reach_conv: "\<And>x y. x \<rightarrow>\<^sup>*\<^bsub>H\<^esub> y \<longleftrightarrow> proj_verts_H x \<rightarrow>\<^sup>*\<^bsub>G\<^esub> proj_verts_H y"
    using w_reach by (auto simp: reachableHD)
      (auto simp: proj_verts_H_def verts_H split: if_splits dest: reachableGD intro: H.reachable_trans)

  lemma sccs_eq: "G.sccs_verts = (`) proj_verts_H ` H.sccs_verts" (is "?L = ?R")
  proof (intro set_eqI iffI)
    fix S assume "S \<in> ?L"
    then have "w \<notin> S" using G.sccs_verts_subsets not_in_verts_G by blast
    then have S_eq: "proj_verts_H ` proj_verts_H -` S = S"
        by (auto simp: proj_verts_H_def intro: range_eqI)
    then have "proj_verts_H -` S \<noteq> {}" using \<open>S \<in> ?L\<close> by safe (auto simp: G.sccs_verts_def)
    with \<open>S \<in> ?L\<close> have "proj_verts_H -` S \<in> H.sccs_verts"
      by (auto simp: G.in_sccs_verts_conv_reachable H.in_sccs_verts_conv_reachable H_reach_conv)
    then have "proj_verts_H ` proj_verts_H -` S \<in> (`) proj_verts_H ` H.sccs_verts" by (rule imageI)
    then show "S \<in> ?R" by (simp only: S_eq)
  next
    fix S assume "S \<in> ?R"
    have X: "\<And>v x. v \<notin> proj_verts_H ` x \<Longrightarrow> v = w \<or> (\<exists>y. v = proj_verts_H y \<and> y \<notin> x)"
      by (auto simp: proj_verts_H_def split: if_splits)
    from \<open>S \<in> ?R\<close> show "S \<in> ?L"
      using not_in_verts_G by (fastforce simp: G.reachable_in_verts G.in_sccs_verts_conv_reachable
        H.in_sccs_verts_conv_reachable H_reach_conv dest: X)
  qed

  lemma inj_on_proj_verts_H: "inj_on ((`) proj_verts_H) (pre_digraph.sccs_verts H)"
  proof (rule inj_onI)
    fix S T assume A: "S \<in> H.sccs_verts" "T \<in> H.sccs_verts" "proj_verts_H ` S = proj_verts_H ` T"
    have "\<And>x. w \<notin> x \<Longrightarrow> proj_verts_H ` x = x" by (auto simp: proj_verts_H_def)
    with A have "S \<noteq> T \<Longrightarrow> S \<inter> T \<noteq> {}"
      by (metis H.in_sccs_verts_conv_reachable Int_iff empty_iff image_eqI proj_verts_H_def w_reach(1,2))
    then show "S = T" using H.sccs_verts_disjoint[OF A(1,2)] by metis
  qed

  lemma card_sccs_verts: "card G.sccs_verts = card H.sccs_verts"
    unfolding sccs_eq by (intro card_image inj_on_proj_verts_H)

  lemma card_sccs_eq: "card G.sccs = card H.sccs"
    using card_sccs_verts G.inj_on_verts_sccs H.inj_on_verts_sccs
    by (auto simp: G.sccs_verts_conv H.sccs_verts_conv card_image)

  lemma isolated_verts_eq: "G.isolated_verts = H.isolated_verts"
    by (auto simp: G.isolated_verts_def H.isolated_verts_def verts_H out_arcs_w dest: out_arcs_empty)

  lemma card_verts: "card (verts H) = card (verts G) + 1"
    unfolding verts_H using not_in_verts_G by auto

  lemma card_arcs: "card (arcs H) = card (arcs G) + 2"
    unfolding arcs_H using not_in_arcs_G subdiv_distinct_arcs in_arcs_G by (auto simp: card_insert_if)

  lemma edge_succ_wu: "edge_succ HM wu = wv"
    using out_arcs_w out_degree_w edge_succ_permutes H.edge_succ_cyclic[of w]
    by (auto elim: eq_on_cyclic_on_iff1[where x="wu"] simp: verts_H out_degree_def)

  lemma edge_succ_wv: "edge_succ HM wv = wu"
    using out_arcs_w out_degree_w edge_succ_permutes H.edge_succ_cyclic[of w]
    by (auto elim: eq_on_cyclic_on_iff1[where x="wv"] simp: verts_H out_degree_def)

  lemmas edge_succ_w = edge_succ_wu edge_succ_wv

  lemma H_face_cycle_succ:
      "H.face_cycle_succ uw = wv"
      "H.face_cycle_succ vw = wu"
    unfolding H.face_cycle_succ_def by (auto simp: edge_succ_w)

  lemma H_edge_succ_tail_eqD:
    assumes "edge_succ HM a = b" shows "tail H a = tail H b"
    using assms H.tail_edge_succ[of a] by auto

  lemma YYY:
    "(wu \<rightleftharpoons>\<^sub>F wv) (edge_succ HM vw) = (edge_succ HM vw)"
    "(wu \<rightleftharpoons>\<^sub>F wv) (edge_succ HM uw) = (edge_succ HM uw)"
    using H.edge_succ_cyclic[of w] subdiv_distinct_verts0 by (auto simp: swap_id_eq dest: H_edge_succ_tail_eqD)

  text \<open>Project arcs of @{term H} to corresponding arcs of @{term G}\<close>
  definition proj_arcs_H :: "'b \<Rightarrow> 'b" where
    "proj_arcs_H x \<equiv>
      if x = uw \<or> x = wv then uv
      else if x = vw \<or> x = wu then vu
      else x"

  text \<open>Project arcs of @{term G} to corresponding arcs of @{term H}\<close>
  definition proj_arcs_G :: "'b \<Rightarrow> 'b" where
    "proj_arcs_G x \<equiv>
      if x = uv then uw
      else if x = vu then vw
      else x"

  lemma proj_arcs_H_simps[simp]:
      "proj_arcs_H uw = uv"
      "proj_arcs_H wv = uv"
      "proj_arcs_H vw = vu"
      "proj_arcs_H wu = vu"
      "x \<notin> {uw,vw,wu,wv} \<Longrightarrow> proj_arcs_H x = x"
      "a \<in> arcs G \<Longrightarrow> proj_arcs_H a = a"
    using subdiv_distinct_arcs not_in_arcs_G by (auto simp: proj_arcs_H_def)

  lemma proj_arcs_H_in_arcs_G: "a \<in> arcs H \<Longrightarrow> proj_arcs_H a \<in> arcs G"
    using subdiv_distinct_arcs in_arcs_G by (auto simp: proj_arcs_H_def arcs_H)

  lemma proj_arcs_eq_swap:
    assumes "a \<notin> {uv,vu,wu,wv}"
    shows "proj_arcs_H a = (uw \<rightleftharpoons>\<^sub>F uv o vw \<rightleftharpoons>\<^sub>F vu) a"
    using assms subdiv_distinct_arcs by (cases "a \<in> {uw,vw}") auto

  lemma proj_arcs_G_simps:
      "proj_arcs_G uv = uw"
      "proj_arcs_G vu = vw"
      "a \<notin> {uv,vu} \<Longrightarrow> proj_arcs_G a = a"
    using subdiv_distinct_arcs not_in_arcs_G by (auto simp: swap_id_eq proj_arcs_G_def)

  lemma proj_arcs_G_in_arcs_H:
    assumes "a \<in> arcs G" shows "proj_arcs_G a \<in> arcs H"
    using assms subdiv_distinct_arcs by (auto simp: proj_arcs_G_def arcs_H)

  lemma proj_arcs_HG: "a \<in> arcs G \<Longrightarrow> proj_arcs_H (proj_arcs_G a) = a"
    by (auto simp: proj_arcs_G_def)

  lemma fcs_proj_arcs_GH:
    assumes "a \<in> arcs H" shows "H.face_cycle_set (proj_arcs_G (proj_arcs_H a)) = H.face_cycle_set a"
  proof -
    have "H.face_cycle_set vw = H.face_cycle_set wu" "H.face_cycle_set uw = H.face_cycle_set wv"
      unfolding H.face_cycle_set_def by (auto simp add: H_face_cycle_succ[symmetric]
        self_in_orbit_step H.permutation_face_cycle_succ permutation_self_in_orbit)
    then show ?thesis
      using assms not_in_arcs_H by (cases "a \<in> {uv,vu,uw,wu,vw,wv}") (auto simp: proj_arcs_G_simps)
  qed

  lemma H_face_cycle_succ_neq_uv:
    "a \<notin> {uv,vu} \<Longrightarrow> H.face_cycle_succ a \<notin> {uv,vu}"
    using not_in_arcs_H by (cases "a \<in> arcs H") (auto dest: H.face_cycle_succ_in_arcsI)

  lemma face_cycle_succ_choose_inter:
    "{H.face_cycle_succ uw, H.face_cycle_succ vw, H.face_cycle_succ wu, H.face_cycle_succ wv} \<inter> {uv,vu} = {}"
    using subdiv_distinct_arcs H_face_cycle_succ_neq_uv by safe (simp_all, metis+)

  lemma face_cycle_succ_choose_neq:
      "H.face_cycle_succ wu \<notin> {wu,wv}"
      "H.face_cycle_succ wv \<notin> {wu,wv}"
    using subdiv_distinct_verts0 in_arcs_H
    by (auto simp del: H.edge_rev_in_arcs dest: H.tail_face_cycle_succ)

  lemma H_face_cycle_succ_G_not_in:
    assumes "a \<in> arcs G" shows "H.face_cycle_succ a \<notin> {wu,wv}"
  proof (cases "a \<in> {uv,vu}")
    case True with assms show ?thesis using subdiv_distinct_arcs by (auto simp: arcs_H)
  next
    case False with assms have "a \<in> arcs H" by (auto simp: arcs_H)
    from assms have "head H a \<noteq> w" by (auto simp: head_eq verts_G arcs_H dest: G.head_in_verts)
    then show ?thesis using H.tail_face_cycle_succ[OF \<open>a \<in> arcs H\<close>] by auto
  qed

  lemma
    face_cycle_succ_uv: "GM.face_cycle_succ uv = proj_arcs_H (H.face_cycle_succ wv)" and
    face_cycle_succ_vu: "GM.face_cycle_succ vu = proj_arcs_H (H.face_cycle_succ wu)"
    unfolding GM.face_cycle_succ_def edge_rev_GM edge_succ_GM
    using face_cycle_succ_choose_neq face_cycle_succ_choose_inter subdiv_distinct_arcs
    apply (auto simp: fun_eq_iff perm_swap_def)
    apply (auto simp: perm_rem_def edge_succ_w H.face_cycle_succ_def YYY proj_arcs_H_def)
    done

  lemma face_cycle_succ_not_uv:
    assumes "a \<in> arcs G" "a \<notin> {uv,vu}"
    shows "GM.face_cycle_succ a = proj_arcs_H (H.face_cycle_succ a)"
  proof -
    have "GM.face_cycle_succ a = (uw \<rightleftharpoons>\<^sub>F uv) ((vw \<rightleftharpoons>\<^sub>F rev_G uv) (perm_rem (wv) (perm_rem (wu) (edge_succ HM)) (((vw \<rightleftharpoons>\<^sub>F vu) ((uw \<rightleftharpoons>\<^sub>F uv) (rev_G a))))))"
      by (simp add: GM.face_cycle_succ_def perm_swap_def edge_succ_GM edge_rev_GM)
    also have "(vw \<rightleftharpoons>\<^sub>F vu) ((uw \<rightleftharpoons>\<^sub>F uv) (rev_G a)) = rev_G a"
      using assms not_in_arcs_G by (auto simp: swap_id_eq G.arev_eq_iff)
    also have "perm_rem (wv) (perm_rem (wu) (edge_succ HM)) (rev_G a) = edge_succ HM (rev_G a)"
    proof -
      have *: "\<And>a. tail H a \<noteq> w \<Longrightarrow> (wu \<rightleftharpoons>\<^sub>F wv) a = a" by (auto simp: swap_id_eq)
      from assms have "head H a \<noteq> w" "tail H (rev_G a) = head H a"
        by (auto simp: tail_eq head_eq verts_G dest: G.head_in_verts)
      then have "((wu \<rightleftharpoons>\<^sub>F wv) (edge_succ HM (rev_G a))) = edge_succ HM (rev_G a)"
        by (intro *) auto
      then show ?thesis by (auto simp: perm_rem_def edge_succ_w)
    qed
    also have "edge_succ HM (rev_G a) = H.face_cycle_succ a"
      using assms unfolding H.face_cycle_succ_def by (simp add: rev_H_eq_rev_G)
    also have "(uw \<rightleftharpoons>\<^sub>F uv) ((vw \<rightleftharpoons>\<^sub>F rev_G uv) (H.face_cycle_succ a)) = proj_arcs_H (H.face_cycle_succ a)"
    proof -
      from assms have "a \<in> arcs H" by (auto simp: arcs_H)
      then have fcs_not_in: "H.face_cycle_succ a \<notin> {uv, vu, wu, wv}"
        using assms H_face_cycle_succ_G_not_in in_arcs_G not_in_arcs_H
        by (auto simp del: G.arev_in_arcs dest: H.face_cycle_succ_closed[THEN iffD2])
      then show ?thesis by (auto simp add: proj_arcs_eq_swap)
    qed
    finally show ?thesis .
  qed

  lemmas G_face_cycle_succ = face_cycle_succ_uv face_cycle_succ_vu face_cycle_succ_not_uv

  lemma in_G_fcs_in_H_fcs:
    assumes "a \<in> arcs G"
    assumes "x \<in> GM.face_cycle_set a"
    shows "x \<in> proj_arcs_H ` H.face_cycle_set (proj_arcs_G a)"
    using \<open>x \<in> _\<close>
  proof induct
    case base show ?case
      by (rule rev_image_eqI[where x="proj_arcs_G a"]) (auto simp: \<open>a \<in> arcs G\<close> proj_arcs_G_def)
  next
    case (step b)
    { fix x assume "x \<in> H.face_cycle_set (proj_arcs_G a)"
      then have "x \<in> arcs H"
        using \<open>a \<in> arcs G\<close> by (auto dest: H.in_face_cycle_setD simp: proj_arcs_G_in_arcs_H)
      moreover
      then have "x \<notin> {uv,vu}" "x \<notin> {uw,wu,vw,wv} \<Longrightarrow> x \<in> arcs G"
        using \<open>a \<in> arcs G\<close> by (auto simp: arcs_H dest: H.in_face_cycle_setD)
      ultimately
      have "GM.face_cycle_succ (proj_arcs_H x) \<in> {proj_arcs_H (H.face_cycle_succ x),
          proj_arcs_H (H.face_cycle_succ (H.face_cycle_succ x))}"
        by (cases "x \<in> {uw,vw,wu,wv}") (auto simp: G_face_cycle_succ H_face_cycle_succ)
    }
    moreover
    have "b \<in> arcs G"
      using step(1) \<open>a \<in> arcs G\<close> by (simp add: GM.in_face_cycle_setD GM.face_cycle_set_def)
    ultimately
    show ?case using \<open>b \<in> arcs G\<close> step(2) by (auto intro: H.face_cycle_succ_inI)
  qed

  lemma in_H_fcs_in_G_fcs:
    assumes "a \<in> arcs H"
    assumes "x \<in> H.face_cycle_set a"
    shows "x \<in> proj_arcs_H -` GM.face_cycle_set (proj_arcs_H a)"
    using \<open>x \<in> _\<close>
  proof induct
    case base then show ?case by auto
  next
    case (step y)
    then have "y \<in> arcs H" using \<open>a \<in> arcs H\<close> by (auto dest: H.in_face_cycle_setD)
    moreover then have "y \<notin> {uv,vu}" by (fastforce simp: arcs_H)
    ultimately have "proj_arcs_H (H.face_cycle_succ y) = GM.face_cycle_succ (proj_arcs_H y)
        \<or> proj_arcs_H (H.face_cycle_succ y) = proj_arcs_H y"
      by (cases "y \<in> {uw,vw,wv,wu}") (auto simp: H_face_cycle_succ G_face_cycle_succ arcs_G)
    with step show ?case by (auto intro: GM.face_cycle_succ_inI)
  qed

  lemma G_fcs_eq:
    assumes "a \<in> arcs G"
    shows "GM.face_cycle_set a = proj_arcs_H ` H.face_cycle_set (proj_arcs_G a)" (is "?L = ?R")
    using assms by (auto dest: in_H_fcs_in_G_fcs[rotated] in_G_fcs_in_H_fcs[rotated]
      simp: proj_arcs_G_in_arcs_H proj_arcs_HG)

  lemma H_fcs_eq:
    assumes "a \<in> arcs H"
    shows "proj_arcs_H ` H.face_cycle_set a = GM.face_cycle_set (proj_arcs_H a)"
    using assms by (auto dest: in_H_fcs_in_G_fcs[rotated] in_G_fcs_in_H_fcs[rotated]
      simp: proj_arcs_H_in_arcs_G fcs_proj_arcs_GH)

  lemma face_cycle_sets:
    shows "GM.face_cycle_sets = (`) proj_arcs_H ` H.face_cycle_sets" (is "?L = ?R")
    unfolding GM.face_cycle_sets_def H.face_cycle_sets_def
    by (blast intro!: H_fcs_eq G_fcs_eq proj_arcs_G_in_arcs_H proj_arcs_H_in_arcs_G)

  lemma inj_on_proj_arcs_H: "inj_on ((`) proj_arcs_H) H.face_cycle_sets"
  proof (rule inj_onI)
    fix A B assume fcs: "A \<in> H.face_cycle_sets" "B \<in> H.face_cycle_sets"
      and pa_eq: "proj_arcs_H ` A = proj_arcs_H ` B"

    have xw_iff_wy:
      "\<And>X. X \<in> H.face_cycle_sets \<Longrightarrow> uw \<in> X \<longleftrightarrow> wv \<in> X"
      "\<And>X. X \<in> H.face_cycle_sets \<Longrightarrow> vw \<in> X \<longleftrightarrow> wu \<in> X"
      using H_face_cycle_succ by (auto simp: H.face_cycle_sets_def dest: H.face_cycle_succ_inI intro: H.face_cycle_succ_inD)

    have not_in_A: "uv \<notin> A" "vu \<notin> A" and not_in_B: "vu \<notin> B" "uv \<notin> B"
      using fcs not_in_arcs_H by (auto dest: H.in_face_cycle_setsD)

    have "A = proj_arcs_H -` (proj_arcs_H ` A) - {uv,vu}"
      using subdiv_distinct_arcs not_in_A by (auto simp: proj_arcs_H_def xw_iff_wy[OF fcs(1)] split: if_splits)
    also have "\<dots> = proj_arcs_H -` (proj_arcs_H ` B) - {uv,vu}" by (simp add: pa_eq)
    also have "\<dots> = B"
      using subdiv_distinct_arcs not_in_B by (auto simp: proj_arcs_H_def xw_iff_wy[OF fcs(2)] split: if_splits)
    finally show "A = B" .
  qed

  lemma card_face_cycle_sets: "card GM.face_cycle_sets = card H.face_cycle_sets"
    unfolding face_cycle_sets using inj_on_proj_arcs_H by (rule card_image)

  lemma euler_char_eq: "GM.euler_char = H.euler_char"
    by (auto simp: GM.euler_char_def H.euler_char_def card_verts card_arcs card_face_cycle_sets)

  lemma euler_genus_eq: "GM.euler_genus = H.euler_genus"
    by (auto simp: GM.euler_genus_def H.euler_genus_def euler_char_eq card_sccs_eq isolated_verts_eq)

end

lemma subdivision_genus_same_rev:
  assumes "subdivision (G, rev_G) (H, edge_rev HM)" "digraph_map H HM" "pre_digraph_map.euler_genus H HM = m"
  shows "\<exists>GM. digraph_map G GM \<and> pre_digraph_map.euler_genus G GM = m \<and> edge_rev GM = rev_G"
proof -
  from assms show ?thesis
  proof (induction rev_H\<equiv>"edge_rev HM" arbitrary: HM)
    case base then show ?case by auto
  next
    case (divide I rev_I H u v w uv uw vw)
    then interpret subdiv_step I rev_I H "edge_rev HM" u v w uv uw vw
      by unfold_locales simp

    interpret H: digraph_map H HM using \<open>digraph_map H HM\<close> .
    interpret IH: subdiv1_contr I rev_I H "edge_rev HM" u v w uv uw vw HM
      by unfold_locales simp

    have eulerI: "IH.GM.euler_genus = m" by (auto simp: IH.euler_genus_eq divide)
    with _ IH.digraph_map_GM show ?case by (rule divide) (simp add: IH.edge_rev_GM)
  qed
qed

lemma subdivision_genus:
  assumes "subdivision (G, rev_G) (H, rev_H)" "digraph_map H HM" "pre_digraph_map.euler_genus H HM = m"
  shows "\<exists>GM. digraph_map G GM \<and> pre_digraph_map.euler_genus G GM = m"
proof -
  interpret H: digraph_map H HM by fact
  show ?thesis
    using subdivision_genus_same_rev subdivision_choose_rev assms H.bidirected_digraph by metis
qed

lemma subdivision_comb_planar:
  assumes "subdivision (G, rev_G) (H, rev_H)" "comb_planar H" shows "comb_planar G"
  using assms unfolding comb_planar_def by (metis subdivision_genus)

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Traces
imports Main
begin
(*>*)

section\<open>Traces\<close>

text\<open>

A \emph{trace} is a non-empty sequence of states. This custom type has
the advantage over the standard HOL list type of providing a more
suitable induction rule. We use these to give a semantics to
knowledge-based programs in \S\ref{sec:kbps-theory-kbps-semantics}.

\<close>

datatype 's Trace = tInit "'s"
                  | tStep "'s Trace" "'s" (infixl "\<leadsto>" 65)

fun tFirst :: "'s Trace \<Rightarrow> 's" where
    "tFirst (tInit s) = s"
  | "tFirst (t \<leadsto> s) = tFirst t"

fun tLast :: "'s Trace \<Rightarrow> 's" where
    "tLast (tInit s) = s"
  | "tLast (t \<leadsto> s) = s"
(*<*)

lemma tLast_tInit_comp[simp]: "tLast \<circ> tInit = id"
  by (rule ext) simp
(*>*)

text\<open>

We provide a few of the standard list operations: @{term "tLength"},
@{term "tMap"} and @{term "tZip"}. Our later ease hinges on taking the
length of a trace to be zero-based.

\<close>

fun tLength :: "'s Trace \<Rightarrow> nat" where
    "tLength (tInit s) = 0"
  | "tLength (t \<leadsto> s) = 1 + tLength t"

(*<*)
lemma tLength_0_conv:
  "(tLength t = 0) \<longleftrightarrow> (\<exists>s. t = tInit s)"
  by (cases t) simp_all

lemma tLength_g0_conv:
  "(tLength t > 0) \<longleftrightarrow> (\<exists>s t'. t = t' \<leadsto> s \<and> tLength t = Suc (tLength t'))"
  by (cases t) simp_all

lemma tLength_Suc:
  "tLength t = Suc n \<Longrightarrow> (\<exists>s t'. t = t' \<leadsto> s \<and> tLength t' = n)"
  by (cases t) simp_all

lemma trace_induct2[consumes 1, case_names tInit tStep]:
  assumes tLen: "tLength t = tLength t'"
      and tI: "\<And>s s'. P (tInit s) (tInit s')"
      and tS: "\<And>s s' t t'. \<lbrakk> tLength t = tLength t'; P t t' \<rbrakk>
               \<Longrightarrow> P (t \<leadsto> s) (t' \<leadsto> s')"
  shows "P t t'"
using tLen
proof (induct t arbitrary: t')
  case (tInit s t') with tI show ?case by (auto iff: tLength_0_conv)
next
  case (tStep t s t') with tS show ?case by (cases t') simp_all
qed
(*>*)

fun tMap where
  "tMap f (tInit x) = tInit (f x)"
| "tMap f (xs \<leadsto> x) = tMap f xs \<leadsto> f x"

(*<*)
lemma tLength_tMap[iff]: "tLength (tMap f t) = tLength t"
  by (induct t) simp_all

lemma tMap_is_tInit[iff]: "(tMap f t = tInit s) \<longleftrightarrow> (\<exists>s'. t = tInit s' \<and> f s' = s)"
  by (cases t) simp_all

lemma tInit_is_tMap[iff]: "(tInit s = tMap f t) \<longleftrightarrow> (\<exists>s'. t = tInit s' \<and> f s' = s)"
  by (cases t) auto

lemma tStep_is_tMap_conv[iff]:
 "(tp \<leadsto> s = tMap f t) \<longleftrightarrow> (\<exists>tp' s'. t = tp' \<leadsto> s' \<and> s = f s' \<and> tp = tMap f tp')"
  by (cases t) auto

lemma tMap_is_tStep_conv[iff]:
 "(tMap f t = tp \<leadsto> s) \<longleftrightarrow> (\<exists>tp' s'. t = tp' \<leadsto> s' \<and> s = f s' \<and> tMap f tp' = tp)"
  by (cases t) auto

lemma tMap_eq_imp_tLength_eq:
  assumes "tMap f t = tMap f' t'"
  shows "tLength t = tLength t'"
using assms
proof (induct t arbitrary: t')
  case (tStep tp s t')
  then obtain tp' s' where t': "t' = tp' \<leadsto> s'" by fastforce
  moreover with tStep have "tLength tp' = tLength tp" by simp
  with t' show ?case by simp
qed auto

lemma tMap_tFirst[iff]:
  "tFirst (tMap f t) = f (tFirst t)"
  by (induct t) simp_all

lemma tMap_tLast[iff]:
  "tLast (tMap f t) = f (tLast t)"
  by (induct t) simp_all

lemma tMap_tFirst_inv:
  assumes M: "tMap f t = tMap f' t'"
  shows "f (tFirst t) = f' (tFirst t')"
proof -
  from M have L: "tLength t = tLength t'" by (rule tMap_eq_imp_tLength_eq)
  from L M show ?thesis by (induct rule: trace_induct2, simp_all)
qed

lemma tMap_tLast_inv:
  assumes M: "tMap f t = tMap f' t'"
  shows "f (tLast t) = f' (tLast t')"
proof -
  from M have L: "tLength t = tLength t'" by (rule tMap_eq_imp_tLength_eq)
  from L M show ?thesis by (induct rule: trace_induct2, simp_all)
qed
(*>*)

fun tZip where
  "tZip f (tInit x) (tInit y) = tInit (f x y)"
| "tZip f (xs \<leadsto> x) (ys \<leadsto> y) = tZip f xs ys \<leadsto> f x y"
(*<*)

lemma tLength_tZip[iff]: "tLength xs = tLength ys \<Longrightarrow> tLength (tZip f xs ys) = tLength xs"
  by (induct rule: trace_induct2) simp_all

(*>*)
(*<*)
end
(*>*)


(*  Title:      HOL/MicroJava/BV/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

More about options.
*)

header {* \isaheader{More about Options} *}

theory Opt
imports
  Err
begin

definition le :: "'a ord \<Rightarrow> 'a option ord"
where
  "le r o\<^sub>1 o\<^sub>2 =
  (case o\<^sub>2 of None \<Rightarrow> o\<^sub>1=None | Some y \<Rightarrow> (case o\<^sub>1 of None \<Rightarrow> True | Some x \<Rightarrow> x \<sqsubseteq>\<^sub>r y))"

definition opt :: "'a set \<Rightarrow> 'a option set"
where
  "opt A = insert None {Some y |y. y \<in> A}"

definition sup :: "'a ebinop \<Rightarrow> 'a option ebinop"
where
  "sup f o\<^sub>1 o\<^sub>2 =
  (case o\<^sub>1 of None \<Rightarrow> OK o\<^sub>2
           | Some x \<Rightarrow> (case o\<^sub>2 of None \<Rightarrow> OK o\<^sub>1
                                 | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z))))"

definition esl :: "'a esl \<Rightarrow> 'a option esl"
where
  "esl = (\<lambda>(A,r,f). (opt A, le r, sup f))"

lemma unfold_le_opt:
  "o\<^sub>1 \<sqsubseteq>\<^bsub>le r\<^esub> o\<^sub>2 =
  (case o\<^sub>2 of None \<Rightarrow> o\<^sub>1=None |
              Some y \<Rightarrow> (case o\<^sub>1 of None \<Rightarrow> True | Some x \<Rightarrow> x \<sqsubseteq>\<^sub>r y))"
(*<*)
apply (unfold lesub_def le_def)
apply (rule refl)
done
(*>*)

lemma le_opt_refl: "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> x"
(*<*) by (simp add: unfold_le_opt split: option.split) (*<*)

lemma le_opt_trans [rule_format]:
  "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> y \<longrightarrow> y \<sqsubseteq>\<^bsub>le r\<^esub> z \<longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> z"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_opt_antisym [rule_format]:
  "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> y \<longrightarrow> y \<sqsubseteq>\<^bsub>le r\<^esub> x \<longrightarrow> x=y"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
(*>*)

lemma order_le_opt [intro!,simp]: "order r \<Longrightarrow> order(le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done
(*>*)

lemma None_bot [iff]:  "None \<sqsubseteq>\<^bsub>le r\<^esub> ox"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma Some_le [iff]: "(Some x \<sqsubseteq>\<^bsub>le r\<^esub> z) = (\<exists>y. z = Some y \<and> x \<sqsubseteq>\<^sub>r y)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma le_None [iff]: "(x \<sqsubseteq>\<^bsub>le r\<^esub> None) = (x = None)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma OK_None_bot [iff]: "OK None \<sqsubseteq>\<^bsub>Err.le (le r)\<^esub> x"
(*<*) by (simp add: lesub_def Err.le_def le_def split: option.split err.split) (*>*)

lemma sup_None1 [iff]: "x \<squnion>\<^bsub>sup f\<^esub> None = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma sup_None2 [iff]: "None \<squnion>\<^bsub>sup f\<^esub> x = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma None_in_opt [iff]: "None \<in> opt A"
(*<*) by (simp add: opt_def) (*>*)

lemma Some_in_opt [iff]: "(Some x \<in> opt A) = (x \<in> A)"
(*<*) by (unfold opt_def) auto (*>*)

lemma semilat_opt [intro, simp]:
  "err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
(*<*)
proof -
  assume s: "err_semilat L"
  obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
  let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
  from s obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x \<sqsubseteq>\<^bsub>?r0\<^esub> x \<squnion>\<^bsub>?f0\<^esub> y" and
    ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y \<sqsubseteq>\<^bsub>?r0\<^esub> x \<squnion>\<^bsub>?f0\<^esub> y" and
    lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x \<sqsubseteq>\<^bsub>?r0\<^esub> z \<and> y \<sqsubseteq>\<^bsub>?r0\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f0\<^esub> y \<sqsubseteq>\<^bsub>?r0\<^esub> z"
    by (unfold semilat_def sl_def) simp

  let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"

  from ord have "order ?r" by simp
  moreover
  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y assume x: "x \<in> ?A" and y: "y \<in> ?A"

    { fix a b assume ab: "x = OK a" "y = OK b"
      with x have a: "\<And>c. a = Some c \<Longrightarrow> c \<in> A" by (clarsimp simp add: opt_def)
      from ab y have b: "\<And>d. b = Some d \<Longrightarrow> d \<in> A" by (clarsimp simp add: opt_def)
      { fix c d assume "a = Some c" "b = Some d"
        with ab x y have "c \<in> A & d \<in> A" by (simp add: err_def opt_def Bex_def)
        with clo have "f c d \<in> err A"
          by (simp add: closed_def plussub_def err_def' lift2_def)
        moreover fix z assume "f c d = OK z"
        ultimately have "z \<in> A" by simp
      } note f_closed = this
      have "sup f a b \<in> ?A"
      proof (cases a)
        case None thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }
    thus "x \<squnion>\<^bsub>?f\<^esub> y \<in> ?A" by (simp add: plussub_def lift2_def split: err.split)
  qed
  moreover
  { fix a b c assume "a \<in> opt A" and "b \<in> opt A" and "a \<squnion>\<^bsub>sup f\<^esub> b = OK c"
    moreover from ord have "order r" by simp
    moreover
    { fix x y z assume "x \<in> A" and "y \<in> A"
      hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
      with ub1 ub2
      have "(OK x) \<sqsubseteq>\<^bsub>Err.le r\<^esub> (OK x) \<squnion>\<^bsub>lift2 f\<^esub> (OK y) \<and>
            (OK y) \<sqsubseteq>\<^bsub>Err.le r\<^esub> (OK x) \<squnion>\<^bsub>lift2 f\<^esub> (OK y)"
        by blast
      moreover assume "x \<squnion>\<^sub>f y = OK z"
      ultimately have "x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately have "a \<sqsubseteq>\<^bsub>le r\<^esub> c \<and> b \<sqsubseteq>\<^bsub>le r\<^esub> c"
      by (auto simp add: sup_def le_def lesub_def plussub_def
               dest: order_refl split: option.splits err.splits)
  }
  hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
  moreover
  have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> z \<and> y \<sqsubseteq>\<^bsub>?r\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x \<in> ?A"   "y \<in> ?A"   "z \<in> ?A"
    assume xz: "x \<sqsubseteq>\<^bsub>?r\<^esub> z" and yz: "y \<sqsubseteq>\<^bsub>?r\<^esub> z"
    { fix a b c assume ok: "x = OK a"  "y = OK b"  "z = OK c"
      { fix d e g  assume some: "a = Some d"  "b = Some e"  "c = Some g"
        with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A"  by simp
        with lub
        have "\<lbrakk> OK d \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g; OK e \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g \<rbrakk> \<Longrightarrow> OK d \<squnion>\<^bsub>lift2 f\<^esub> OK e \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g"
          by blast
        hence "\<lbrakk> d \<sqsubseteq>\<^sub>r g; e \<sqsubseteq>\<^sub>r g \<rbrakk> \<Longrightarrow> \<exists>y. d \<squnion>\<^sub>f e = OK y \<and> y \<sqsubseteq>\<^sub>r g" by simp
        with ok some xyz xz yz have "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]
      from ok xyz xz yz have "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }
    with xyz xz yz show "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed
  ultimately show "err_semilat (Opt.esl L)"
    by (unfold semilat_def esl_def sl_def) simp
qed
(*>*)

lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
(*<*)
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done
(*>*)

lemma Top_le_conv:  "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
(*<*)
apply (unfold top_def)
apply (blast intro: order_antisym)
done
(*>*)

lemma acc_le_optI [intro!]: "acc A r \<Longrightarrow> acc (opt A) (le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "\<exists>a. Some a \<in> Q")
 apply (erule_tac x = "{a . Some a \<in> Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done
(*>*)

lemma map_option_in_optionI:
  "\<lbrakk> ox \<in> opt S; \<forall>x\<in>S. ox = Some x \<longrightarrow> f x \<in> S \<rbrakk>
  \<Longrightarrow> map_option f ox \<in> opt S"
(*<*)
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done
(*>*)

end


section "Eta Normalization"

theory EtaNorm
  imports Term BetaNorm
begin
(* Again from Lambda calculus from @{dir "~~/src/HOL/Proofs/Lambda"} and modified*)

inductive
  eta :: "term \<Rightarrow> term \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<eta>" 50)
where
    eta [simp, intro]: "\<not> is_dependent s \<Longrightarrow> Abs T (s $ Bv 0) \<rightarrow>\<^sub>\<eta> decr 0 s"
  | appL [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> s $ u \<rightarrow>\<^sub>\<eta> t $ u"
  | appR [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> u $ s \<rightarrow>\<^sub>\<eta> u $ t"
  | abs [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> Abs T s \<rightarrow>\<^sub>\<eta> Abs T t"

abbreviation
  eta_reds :: "term \<Rightarrow> term \<Rightarrow> bool"   (infixl "\<rightarrow>\<^sub>\<eta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<equiv> eta\<^sup>*\<^sup>* s t"

abbreviation
  eta_red0 :: "term \<Rightarrow> term \<Rightarrow> bool"   (infixl "\<rightarrow>\<^sub>\<eta>\<^sup>=" 50) where
  "s \<rightarrow>\<^sub>\<eta>\<^sup>= t \<equiv> eta\<^sup>=\<^sup>= s t"

inductive_cases eta_cases [elim!]:
  "Abs T s \<rightarrow>\<^sub>\<eta> z"
  "s $ t \<rightarrow>\<^sub>\<eta> u"
  "Bv i \<rightarrow>\<^sub>\<eta> t"

lemma subst_bv2_not_free [simp]: "\<not> loose_bvar1 s i \<Longrightarrow> subst_bv2 s i t = subst_bv2 s i u"
  by (induction s arbitrary: i t u) (simp_all add:)

lemma free_lift [simp]:
    "loose_bvar1 (lift t k) i = (i < k \<and> loose_bvar1 t i \<or> k < i \<and> loose_bvar1 t (i - 1))"
  by (induct t arbitrary: i k) (auto cong: conj_cong)

lemma free_subst_bv2 [simp]:
    "loose_bvar1 (subst_bv2 s k t) i =
      (loose_bvar1 s k \<and> loose_bvar1 t i \<or> loose_bvar1 s (if i < k then i else i + 1))"
  apply (induct s arbitrary: i k t)
  using free_lift apply (simp_all add: diff_Suc split: nat.split)
  by blast

lemma free_eta: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> loose_bvar1 t i = loose_bvar1 s i"
  apply (induct arbitrary: i set: eta)
  apply (simp_all cong: conj_cong)
  using is_dependent_def loose_bvar1_decr''' loose_bvar1_decr'''' by blast

lemma not_free_eta:
    "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> \<not> loose_bvar1 s i \<Longrightarrow> \<not> loose_bvar1 t i"
  by (simp add: free_eta)

lemma no_loose_bvar1_subst_bv2_decr: "\<not> loose_bvar1 t i \<Longrightarrow> subst_bv2 t i x = decr i t"
  by (induction t i x rule: subst_bv2.induct) auto

lemma eta_subst_bv2 [simp]:
    "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> subst_bv2 s i u \<rightarrow>\<^sub>\<eta> subst_bv2 t i u"
proof (induction s t arbitrary: u i rule: eta.induct)
  case (eta s T)
  hence 1: "\<not> loose_bvar1 s 0"
    using is_dependent_def by simp
  have "decr 0 s = subst_bv2 s 0 dummy" for dummy
    using no_loose_bvar1_subst_bv2_decr[symmetric, OF 1, of dummy] .
  from this obtain dummy where dummy: "decr 0 s = subst_bv2 s 0 dummy"
    by simp

  show ?case
    using 1 apply (simp add: dummy subst_bv2_subst_bv2 [symmetric])
    using free_lift is_dependent_def no_loose_bvar1_subst_bv2_decr by auto
qed auto

theorem lift_subst_bv2_dummy: "\<not> loose_bvar s i \<Longrightarrow> lift (decr i s) i = s"
  by (induct s arbitrary: i) simp_all

lemma decr_is_closed[simp]: "is_closed t \<Longrightarrow> decr lev t = t"
  by (metis is_open_def lift_subst_bv2_dummy lift_def loose_bvar_Suc loose_bvar_incr_bvar no_loose_bvar_no_incr zero_induct)

lemma eta_reducible_imp_eta_step: "eta_reducible t \<Longrightarrow> \<exists>t'. t \<rightarrow>\<^sub>\<eta> t'"
  by (induction t rule: eta_reducible.induct) auto

lemma eta_step_imp_eta_reducible: "t \<rightarrow>\<^sub>\<eta> t' \<Longrightarrow> eta_reducible t"
proof (induction t t' rule: eta.induct)
  case (abs s t T)
  show ?case
  proof(cases s)
    case (App u v)
    then show ?thesis by (cases v; use abs eta_reducible_Abs in metis)
  qed (use abs in auto)
qed auto

lemma eta_reds_appR: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> u $ s \<rightarrow>\<^sub>\<eta>\<^sup>* u $ t"
  by (induction s t rule: rtranclp.induct) (auto simp add: rtranclp.rtrancl_into_rtrancl)
lemma eta_reds_appL: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s $ u \<rightarrow>\<^sub>\<eta>\<^sup>* t $ u"
  by (induction s t rule: rtranclp.induct) (auto simp add: rtranclp.rtrancl_into_rtrancl)
lemma eta_reds_abs: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> Abs T s \<rightarrow>\<^sub>\<eta>\<^sup>* Abs T t"
  by (induction s t rule: rtranclp.induct) (auto simp add: rtranclp.rtrancl_into_rtrancl)

lemma eta_norm_imp_eta_reds: assumes "eta_norm t = t'" shows "t \<rightarrow>\<^sub>\<eta>\<^sup>* t'"
using assms proof (induction t arbitrary: t' rule: eta_norm.induct)
  case (1 T body)
  then show ?case
  proof (cases "eta_norm body")
    case (App f u)
    then show ?thesis
      using 1 apply (clarsimp simp add: is_dependent_def eta_reds_abs split: term.splits nat.splits if_splits)
      by (metis eta.eta eta_reds_abs eta_reducible.simps(11) is_dependent_def
          not_eta_reducible_eta_norm not_eta_reducible_imp_eta_norm_no_change rtranclp.simps)
  qed (auto simp add: is_dependent_def eta_reds_abs split: term.splits nat.splits if_splits)
next
  case (2 f u)
  hence "f \<rightarrow>\<^sub>\<eta>\<^sup>* eta_norm f" "u \<rightarrow>\<^sub>\<eta>\<^sup>* eta_norm u"
    by simp_all
  then show ?case using 2
    by (metis eta_norm.simps(2) eta_reds_appL eta_reds_appR rtranclp_trans)
qed auto

lemma rtrancl_eta_App:
    "s \<rightarrow>\<^sub>\<eta>\<^sup>* s' \<Longrightarrow> t \<rightarrow>\<^sub>\<eta>\<^sup>* t' \<Longrightarrow> s $ t \<rightarrow>\<^sub>\<eta>\<^sup>* s' $ t'"
  by (blast intro!: eta_reds_appR eta_reds_appL intro: rtranclp_trans)

lemma eta_preserves_typ_of1: "t \<rightarrow>\<^sub>\<eta> t' \<Longrightarrow> typ_of1 Ts t = Some \<tau> \<Longrightarrow> typ_of1 Ts t' = Some \<tau>"
proof (induction Ts t arbitrary: \<tau> t' rule: typ_of1.induct)
  case (1 uu uv T)
  then show ?case
    using eta_step_imp_eta_reducible by fastforce
next
  case (2 Ts i)
  then show ?case
    using eta_step_imp_eta_reducible by fastforce
next
  case (3 uw ux T)
  then show ?case
    using eta_step_imp_eta_reducible by fastforce
next
  case (4 Ts T body)
  then show ?case
  proof(cases body)
    case (Abs B b)
    then show ?thesis using 4
      by (metis eta_cases(1) term.distinct(19) typ_of1.simps(4) typ_of_Abs_body_typ')
  next
    case (App u v)
    note oApp = App
    then show ?thesis
    proof(cases "is_dependent u")
      case True
      then show ?thesis
        by (metis "4.IH" "4.prems"(1) "4.prems"(2) App eta_cases(1) term.inject(5)
            typ_of1.simps(4) typ_of_Abs_body_typ')
    next
      case False
      then show ?thesis
      proof(cases v)
        case (Ct n T)
        then show ?thesis
          using 4 oApp False typ_of_Abs_body_typ'
          by (metis eta_cases(1) term.distinct(3) term.inject(5) typ_of1.simps(4))
      next
        case (Fv n T)
        then show ?thesis
          using 4 oApp False typ_of_Abs_body_typ'
          by (metis eta_cases(1) term.distinct(9) term.inject(5) typ_of1.simps(4))
      next
        case (Bv n)
        then show ?thesis
        proof(cases n)
          case 0 thm 4
          show ?thesis
          proof(cases rule: eta_cases(1)[OF "4.prems"(1)])
            case (1 s)
            thm "4"(3)
            obtain rty where "typ_of1 (T#Ts) (s $ Bv 0) = Some (rty)"
              using typ_of_Abs_body_typ'[OF "4"(3)] "1"(3) "1"(1) by blast
            moreover have "\<tau> = T \<rightarrow> rty"
              by (metis "1"(1) "4.prems"(2) calculation option.inject typ_of_Abs_body_typ')
            ultimately have "typ_of1 (T#Ts) s = Some \<tau>"
              using typ_of1_arg_typ
              by (metis length_Cons nth_Cons_0 typ_of1.simps(2) zero_less_Suc)
            hence "typ_of1 Ts (decr 0 s) = Some \<tau>"
              by (metis "1"(3) append_Cons append_Nil is_dependent_def list.size(3) typ_of1_decr)
            then show ?thesis
              using 1 oApp False typ_of_Abs_body_typ' Bv 0 by auto
          next
            case (2 t)
            then show ?thesis
              using oApp False typ_of_Abs_body_typ' Bv 0
              by (metis "4.IH" "4.prems"(2) typ_of1.simps(4))
          qed
        next
          case (Suc nat)
          then show ?thesis
            using 4 oApp False typ_of_Abs_body_typ' Bv
            apply -
            apply (rule eta_cases(1)[of T body t'])
            apply blast
            apply blast
            apply (metis "4.IH" "4.prems"(2) typ_of1.simps(4))
            done
        qed
      next
        case (Abs T t)
        then show ?thesis
          using 4 oApp False typ_of_Abs_body_typ'
          (* Help metis a bit *)
          apply -
          apply (erule eta.cases(1))
          by (metis term.distinct(15) term.distinct(19) term.inject(4) term.inject(5)
              typ_of1.simps(4))+
      next
        case (App f u)
        then show ?thesis
          using 4 oApp False typ_of_Abs_body_typ'
          by (metis eta_cases(1) term.distinct(17) term.inject(5) typ_of1.simps(4))
      qed
    qed
  qed (use 4 in auto)
next
  case (5 Ts f u)
  then show ?case
    by (smt bind.bind_lunit eta_cases(2) typ_of1.simps(5) typ_of1_split_App_obtains)
qed

lemma eta_preserves_typ_of: "t \<rightarrow>\<^sub>\<eta> t' \<Longrightarrow> typ_of t = Some \<tau> \<Longrightarrow> typ_of t' = Some \<tau>"
  using eta_preserves_typ_of1 typ_of_def by simp

lemma eta_star_preserves_typ_of1: "r \<rightarrow>\<^sub>\<eta>\<^sup>* s \<Longrightarrow> typ_of1 Ts r = Some T  \<Longrightarrow> typ_of1 Ts s = Some T"
proof (induction rule: rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case
    by simp
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    using eta_preserves_typ_of1 by blast
qed

lemma eta_star_preserves_typ_of: "r \<rightarrow>\<^sub>\<eta>\<^sup>* s \<Longrightarrow> typ_of r = Some T  \<Longrightarrow> typ_of s = Some T"
  using eta_star_preserves_typ_of1 typ_of_def by simp

lemma subst_bvs1'_decr: "\<forall>x\<in>set us. is_closed x  \<Longrightarrow> \<not> loose_bvar1 t k
  \<Longrightarrow> subst_bvs1' (decr k t) k us = decr k (subst_bvs1' t (Suc k) us)"
  by (induction k t arbitrary: us rule: decr.induct) (auto simp add: is_open_def)

lemma subst_bvs_decr: "\<forall>x\<in>set us. is_closed x  \<Longrightarrow> \<not> is_dependent t
  \<Longrightarrow> subst_bvs us (decr 0 t) = decr 0 (subst_bvs1' t 1 us)"
  by (simp add: is_dependent_def subst_bvs1'_decr subst_bvs_subst_bvs1')

end


(*  Title:      HOL/Lifting_Set.thy
    Author:     Brian Huffman and Ondrej Kuncar
*)

section {* Setup for Lifting/Transfer for the set type *}

theory Lifting_Set
imports Lifting
begin

subsection {* Relator and predicator properties *}

lemma rel_setD1: "\<lbrakk> rel_set R A B; x \<in> A \<rbrakk> \<Longrightarrow> \<exists>y \<in> B. R x y"
  and rel_setD2: "\<lbrakk> rel_set R A B; y \<in> B \<rbrakk> \<Longrightarrow> \<exists>x \<in> A. R x y"
by(simp_all add: rel_set_def)

lemma rel_set_conversep [simp]: "rel_set A\<inverse>\<inverse> = (rel_set A)\<inverse>\<inverse>"
  unfolding rel_set_def by auto

lemma rel_set_eq [relator_eq]: "rel_set (op =) = (op =)"
  unfolding rel_set_def fun_eq_iff by auto

lemma rel_set_mono[relator_mono]:
  assumes "A \<le> B"
  shows "rel_set A \<le> rel_set B"
using assms unfolding rel_set_def by blast

lemma rel_set_OO[relator_distr]: "rel_set R OO rel_set S = rel_set (R OO S)"
  apply (rule sym)
  apply (intro ext, rename_tac X Z)
  apply (rule iffI)
  apply (rule_tac b="{y. (\<exists>x\<in>X. R x y) \<and> (\<exists>z\<in>Z. S y z)}" in relcomppI)
  apply (simp add: rel_set_def, fast)
  apply (simp add: rel_set_def, fast)
  apply (simp add: rel_set_def, fast)
  done

lemma Domainp_set[relator_domain]:
  "Domainp (rel_set T) = (\<lambda>A. Ball A (Domainp T))"
unfolding rel_set_def Domainp_iff[abs_def]
apply (intro ext)
apply (rule iffI)
apply blast
apply (rename_tac A, rule_tac x="{y. \<exists>x\<in>A. T x y}" in exI, fast)
done

lemma left_total_rel_set[transfer_rule]:
  "left_total A \<Longrightarrow> left_total (rel_set A)"
  unfolding left_total_def rel_set_def
  apply safe
  apply (rename_tac X, rule_tac x="{y. \<exists>x\<in>X. A x y}" in exI, fast)
done

lemma left_unique_rel_set[transfer_rule]:
  "left_unique A \<Longrightarrow> left_unique (rel_set A)"
  unfolding left_unique_def rel_set_def
  by fast

lemma right_total_rel_set [transfer_rule]:
  "right_total A \<Longrightarrow> right_total (rel_set A)"
using left_total_rel_set[of "A\<inverse>\<inverse>"] by simp

lemma right_unique_rel_set [transfer_rule]:
  "right_unique A \<Longrightarrow> right_unique (rel_set A)"
  unfolding right_unique_def rel_set_def by fast

lemma bi_total_rel_set [transfer_rule]:
  "bi_total A \<Longrightarrow> bi_total (rel_set A)"
by(simp add: bi_total_alt_def left_total_rel_set right_total_rel_set)

lemma bi_unique_rel_set [transfer_rule]:
  "bi_unique A \<Longrightarrow> bi_unique (rel_set A)"
  unfolding bi_unique_def rel_set_def by fast

lemma set_relator_eq_onp [relator_eq_onp]:
  "rel_set (eq_onp P) = eq_onp (\<lambda>A. Ball A P)"
  unfolding fun_eq_iff rel_set_def eq_onp_def Ball_def by fast

lemma bi_unique_rel_set_lemma:
  assumes "bi_unique R" and "rel_set R X Y"
  obtains f where "Y = image f X" and "inj_on f X" and "\<forall>x\<in>X. R x (f x)"
proof
  def f \<equiv> "\<lambda>x. THE y. R x y"
  { fix x assume "x \<in> X"
    with `rel_set R X Y` `bi_unique R` have "R x (f x)"
      by (simp add: bi_unique_def rel_set_def f_def) (metis theI)
    with assms `x \<in> X`
    have  "R x (f x)" "\<forall>x'\<in>X. R x' (f x) \<longrightarrow> x = x'" "\<forall>y\<in>Y. R x y \<longrightarrow> y = f x" "f x \<in> Y"
      by (fastforce simp add: bi_unique_def rel_set_def)+ }
  note * = this
  moreover
  { fix y assume "y \<in> Y"
    with `rel_set R X Y` *(3) `y \<in> Y` have "\<exists>x\<in>X. y = f x"
      by (fastforce simp: rel_set_def) }
  ultimately show "\<forall>x\<in>X. R x (f x)" "Y = image f X" "inj_on f X"
    by (auto simp: inj_on_def image_iff)
qed

subsection {* Quotient theorem for the Lifting package *}

lemma Quotient_set[quot_map]:
  assumes "Quotient R Abs Rep T"
  shows "Quotient (rel_set R) (image Abs) (image Rep) (rel_set T)"
  using assms unfolding Quotient_alt_def4
  apply (simp add: rel_set_OO[symmetric])
  apply (simp add: rel_set_def, fast)
  done

subsection {* Transfer rules for the Transfer package *}

subsubsection {* Unconditional transfer rules *}

context
begin
interpretation lifting_syntax .

lemma empty_transfer [transfer_rule]: "(rel_set A) {} {}"
  unfolding rel_set_def by simp

lemma insert_transfer [transfer_rule]:
  "(A ===> rel_set A ===> rel_set A) insert insert"
  unfolding rel_fun_def rel_set_def by auto

lemma union_transfer [transfer_rule]:
  "(rel_set A ===> rel_set A ===> rel_set A) union union"
  unfolding rel_fun_def rel_set_def by auto

lemma Union_transfer [transfer_rule]:
  "(rel_set (rel_set A) ===> rel_set A) Union Union"
  unfolding rel_fun_def rel_set_def by simp fast

lemma image_transfer [transfer_rule]:
  "((A ===> B) ===> rel_set A ===> rel_set B) image image"
  unfolding rel_fun_def rel_set_def by simp fast

lemma UNION_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) UNION UNION"
  unfolding Union_image_eq [symmetric, abs_def] by transfer_prover

lemma Ball_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> op =) ===> op =) Ball Ball"
  unfolding rel_set_def rel_fun_def by fast

lemma Bex_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> op =) ===> op =) Bex Bex"
  unfolding rel_set_def rel_fun_def by fast

lemma Pow_transfer [transfer_rule]:
  "(rel_set A ===> rel_set (rel_set A)) Pow Pow"
  apply (rule rel_funI, rename_tac X Y, rule rel_setI)
  apply (rename_tac X', rule_tac x="{y\<in>Y. \<exists>x\<in>X'. A x y}" in rev_bexI, clarsimp)
  apply (simp add: rel_set_def, fast)
  apply (rename_tac Y', rule_tac x="{x\<in>X. \<exists>y\<in>Y'. A x y}" in rev_bexI, clarsimp)
  apply (simp add: rel_set_def, fast)
  done

lemma rel_set_transfer [transfer_rule]:
  "((A ===> B ===> op =) ===> rel_set A ===> rel_set B ===> op =) rel_set rel_set"
  unfolding rel_fun_def rel_set_def by fast

lemma bind_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) Set.bind Set.bind"
  unfolding bind_UNION [abs_def] by transfer_prover

lemma INF_parametric [transfer_rule]:
  "(rel_set A ===> (A ===> HOL.eq) ===> HOL.eq) INFIMUM INFIMUM"
  unfolding INF_def [abs_def] by transfer_prover

lemma SUP_parametric [transfer_rule]:
  "(rel_set R ===> (R ===> HOL.eq) ===> HOL.eq) SUPREMUM SUPREMUM"
  unfolding SUP_def [abs_def] by transfer_prover

subsubsection {* Rules requiring bi-unique, bi-total or right-total relations *}

lemma member_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(A ===> rel_set A ===> op =) (op \<in>) (op \<in>)"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast

lemma right_total_Collect_transfer[transfer_rule]:
  assumes "right_total A"
  shows "((A ===> op =) ===> rel_set A) (\<lambda>P. Collect (\<lambda>x. P x \<and> Domainp A x)) Collect"
  using assms unfolding right_total_def rel_set_def rel_fun_def Domainp_iff by fast

lemma Collect_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "((A ===> op =) ===> rel_set A) Collect Collect"
  using assms unfolding rel_fun_def rel_set_def bi_total_def by fast

lemma inter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> rel_set A) inter inter"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast

lemma Diff_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> rel_set A) (op -) (op -)"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def
  unfolding Ball_def Bex_def Diff_eq
  by (safe, simp, metis, simp, metis)

lemma subset_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> op =) (op \<subseteq>) (op \<subseteq>)"
  unfolding subset_eq [abs_def] by transfer_prover

lemma right_total_UNIV_transfer[transfer_rule]:
  assumes "right_total A"
  shows "(rel_set A) (Collect (Domainp A)) UNIV"
  using assms unfolding right_total_def rel_set_def Domainp_iff by blast

lemma UNIV_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "(rel_set A) UNIV UNIV"
  using assms unfolding rel_set_def bi_total_def by simp

lemma right_total_Compl_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set A ===> rel_set A) (\<lambda>S. uminus S \<inter> Collect (Domainp A)) uminus"
  unfolding Compl_eq [abs_def]
  by (subst Collect_conj_eq[symmetric]) transfer_prover

lemma Compl_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set A ===> rel_set A) uminus uminus"
  unfolding Compl_eq [abs_def] by transfer_prover

lemma right_total_Inter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>S. Inter S \<inter> Collect (Domainp A)) Inter"
  unfolding Inter_eq[abs_def]
  by (subst Collect_conj_eq[symmetric]) transfer_prover

lemma Inter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) Inter Inter"
  unfolding Inter_eq [abs_def] by transfer_prover

lemma filter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> op=) ===> rel_set A ===> rel_set A) Set.filter Set.filter"
  unfolding Set.filter_def[abs_def] rel_fun_def rel_set_def by blast

lemma finite_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set A ===> op =) finite finite"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (auto dest: finite_imageD)

lemma card_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set A ===> op =) card card"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (simp add: card_image)

lemma vimage_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((A ===> B) ===> rel_set B ===> rel_set A) vimage vimage"
  unfolding vimage_def[abs_def] by transfer_prover

lemma Image_parametric [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set (rel_prod A B) ===> rel_set A ===> rel_set B) op `` op ``"
by(intro rel_funI rel_setI)
  (force dest: rel_setD1 bi_uniqueDr[OF assms], force dest: rel_setD2 bi_uniqueDl[OF assms])

end

lemma (in comm_monoid_set) F_parametric [transfer_rule]:
  fixes A :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
  assumes "bi_unique A"
  shows "rel_fun (rel_fun A (op =)) (rel_fun (rel_set A) (op =)) F F"
proof(rule rel_funI)+
  fix f :: "'b \<Rightarrow> 'a" and g S T
  assume "rel_fun A (op =) f g" "rel_set A S T"
  with `bi_unique A` obtain i where "bij_betw i S T" "\<And>x. x \<in> S \<Longrightarrow> f x = g (i x)"
    by (auto elim: bi_unique_rel_set_lemma simp: rel_fun_def bij_betw_def)
  then show "F f S = F g T"
    by (simp add: reindex_bij_betw)
qed

lemmas setsum_parametric = setsum.F_parametric
lemmas setprod_parametric = setprod.F_parametric

end