theory DBM_Basics
  imports DBM Paths_Cycles
begin

fun get_const where
  "get_const (Le c) = c" |
  "get_const (Lt c) = c" |
  "get_const \<infinity> = undefined"

subsection \<open>Discourse on updating DBMs\<close>

abbreviation DBM_update :: "('t::time) DBM \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('t DBMEntry) \<Rightarrow> ('t::time) DBM"
where
  "DBM_update M m n v \<equiv> (\<lambda> x y. if m = x \<and> n = y then v else M x y)"

fun DBM_upd :: "('t::time) DBM \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> 't DBMEntry) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 't DBM"
where
  "DBM_upd M f 0 0 _ = DBM_update M 0 0 (f 0 0)" |
  "DBM_upd M f (Suc i) 0 n = DBM_update (DBM_upd M f i n n) (Suc i) 0 (f (Suc i) 0)" |
  "DBM_upd M f i (Suc j) n = DBM_update (DBM_upd M f i j n) i (Suc j) (f i (Suc j))"

lemma upd_1:
assumes "j \<le> n"
shows "DBM_upd M1 f (Suc m) n N (Suc m) j = DBM_upd M1 f (Suc m) j N (Suc m) j"
using assms
by (induction n) auto

lemma upd_2:
assumes "i \<le> m"
shows "DBM_upd M1 f (Suc m) n N i j = DBM_upd M1 f (Suc m) 0 N i j"
using assms
proof (induction n)
  case 0 thus ?case by blast
next
  case (Suc n)
  thus ?case by simp
qed

lemma upd_3:
assumes "m \<le> N" "n \<le> N" "j \<le> n" "i \<le> m"
shows "(DBM_upd M1 f m n N) i j = (DBM_upd M1 f i j N) i j"
using assms
proof (induction m arbitrary: n i j, goal_cases)
  case (1 n) thus ?case by (induction n) auto
next
  case (2 m n i j) thus ?case
  proof (cases "i = Suc m")
    case True thus ?thesis using upd_1[OF \<open>j \<le> n\<close>] by blast
    next
    case False
    with \<open>i \<le> Suc m\<close> have "i \<le> m" by auto
    with upd_2[OF this] have "DBM_upd M1 f (Suc m) n N i j = DBM_upd M1 f m N N i j" by force
    also have "\<dots> = DBM_upd M1 f i j N i j" using False 2 by force
    finally show ?thesis .
  qed
qed

lemma upd_id:
  assumes "m \<le> N" "n \<le> N" "i \<le> m" "j \<le> n"
  shows "(DBM_upd M1 f m n N) i j = f i j"
proof -
  from assms upd_3 have "DBM_upd M1 f m n N i j = DBM_upd M1 f i j N i j" by blast
  also have "\<dots> = f i j" by (cases i; cases j; fastforce)
  finally show ?thesis .
qed

subsection \<open>Zones and DBMs\<close>

definition DBM_zone_repr :: "('t::time) DBM \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('c, 't :: time) zone"
("[_]\<^bsub>_,_\<^esub>" [72,72,72] 72)
where
  "[M]\<^bsub>v,n\<^esub> = {u . DBM_val_bounded v u M n}"

lemma dbm_entry_val_mono_1:
  "dbm_entry_val u (Some c) (Some c') b \<Longrightarrow> b \<preceq> b' \<Longrightarrow> dbm_entry_val u (Some c) (Some c') b'"
proof (induction b, goal_cases)
  case 1 thus ?case using le_dbm_le le_dbm_lt by (induction b'; fastforce)
next
  case 2 thus ?case using lt_dbm_le lt_dbm_lt by (induction b'; fastforce)
next
  case 3 thus ?case unfolding dbm_le_def by auto
qed

lemma dbm_entry_val_mono_3:
  "dbm_entry_val u (Some c) None b \<Longrightarrow> b \<preceq> b' \<Longrightarrow> dbm_entry_val u (Some c) None b'"
proof (induction b, goal_cases)
  case 1 thus ?case using le_dbm_le le_dbm_lt by (induction b'; fastforce)
next
  case 2 thus ?case using lt_dbm_le lt_dbm_lt by (induction b'; fastforce)
next
  case 3 thus ?case unfolding dbm_le_def by auto
qed

lemma DBM_le_subset:
  "\<forall> i j. i \<le> n \<longrightarrow> j \<le> n \<longrightarrow> M i j \<preceq> M' i j \<Longrightarrow> u \<in> [M]\<^bsub>v,n\<^esub> \<Longrightarrow> u \<in> [M']\<^bsub>v,n\<^esub>"
proof -
  assume A: "\<forall>i j. i \<le> n \<longrightarrow> j \<le> n \<longrightarrow> M i j \<preceq> M' i j" "u \<in> [M]\<^bsub>v,n\<^esub>"
  hence "DBM_val_bounded v u M n" by (simp add: DBM_zone_repr_def)
  with A(1) have "DBM_val_bounded v u M' n" unfolding DBM_val_bounded_def
  proof (auto, goal_cases)
    case 1 from this(1,2) show ?case unfolding less_eq[symmetric] by fastforce
  next
    case (2 c)
    hence "dbm_entry_val u None (Some c) (M 0 (v c))" "M 0 (v c) \<preceq> M' 0 (v c)" by auto
    thus ?case using dbm_entry_val_mono_2 by fast
  next
    case (3 c)
    hence "dbm_entry_val u (Some c) None (M (v c) 0)" "M (v c) 0 \<preceq> M' (v c) 0" by auto
    thus ?case using dbm_entry_val_mono_3 by fast
  next
    case (4 c1 c2)
    hence "dbm_entry_val u (Some c1) (Some c2) (M (v c1) (v c2))" "M (v c1) (v c2) \<preceq> M' (v c1) (v c2)"
    by auto
    thus ?case using dbm_entry_val_mono_1 by fast
  qed
  thus "u \<in> [M']\<^bsub>v,n\<^esub>" by (simp add: DBM_zone_repr_def)
qed

subsection \<open>DBMs Without Negative Cycles are Non-Empty\<close>

text \<open>
  We need all of these assumptions for the proof that matrices without negative cycles
  represent non-negative zones:
    * Abelian (linearly ordered) monoid
    * Time is non-trivial
    * Time is dense
\<close>
lemmas (in linordered_ab_monoid_add) comm = add.commute

lemma sum_gt_neutral_dest':
  "(a :: (('a :: time) DBMEntry)) \<ge> \<one> \<Longrightarrow> a + b > \<one> \<Longrightarrow> \<exists> d. Le d \<le> a \<and> Le (-d) \<le> b \<and> d \<ge> 0"
proof -
  assume "a + b > \<one>" "a \<ge> \<one>"
  show ?thesis
  proof (cases "b \<ge> \<one>")
    case True
    with \<open>a \<ge> \<one>\<close> show ?thesis by (auto simp: neutral)
  next
    case False
    hence "b < Le 0" by (auto simp: neutral)
    with \<open>a \<ge> \<one>\<close> \<open>a + b > \<one>\<close> show ?thesis
    proof (cases a, cases b, auto simp: neutral, goal_cases)
      case (1 a' b')
      from 1(2) have "a' + b' > 0" by (auto elim: dbm_lt.cases simp: less mult)
      hence "b' > -a'" by (metis add.commute diff_0 diff_less_eq)
      with \<open>Le 0 \<le> Le a'\<close> show ?case
      by (auto simp: dbm_le_def less_eq le_dbm_le)
    next
      case (2 a' b')
      from this(2) have "a' + b' > 0" by (auto elim: dbm_lt.cases simp: less mult)
      hence "b' > -a'" by (metis add.commute diff_0 diff_less_eq)
      with \<open>Le 0 \<le> Le a'\<close> show ?case
      by (auto simp: dbm_le_def less_eq le_dbm_le)
    next
      case (3 a') thus ?case by (auto simp: dbm_le_def less_eq)
    next
      case (4 a')
      thus ?case
      proof (cases b, auto, goal_cases)
        case (1 b')
        have "b' < 0" using 1(2) by (metis dbm_lt.intros(3) less less_asym neqE)
        from 1 have "a' + b' > 0" by (auto elim: dbm_lt.cases simp: less mult)
        then have "-b' < a'" by (metis diff_0 diff_less_eq)
        with \<open>b' < 0\<close> show ?case by (auto simp: dbm_le_def less_eq)
      next
        case (2 b')
        then have A: "b' \<le> 0" "a' > 0" by (auto elim: dbm_lt.cases simp: less less_eq dbm_le_def)
        show ?case
        proof (cases "b' = 0")
          case True
          from dense[OF A(2)] obtain d where d: "d > 0" "d < a'" by auto
          then have "Le (-d) < Lt b'" "Le d < Lt a'" unfolding less using True by auto
          with d(1) show ?thesis by - (rule exI[where x = "d"], auto)
        next
          case False
          with A(1) have *: "- b' > 0" by simp
          from 2 have "a' + b' > 0" by (auto elim: dbm_lt.cases simp: less mult)
          then have "-b' < a'" by (metis less_add_same_cancel1 minus_add_cancel minus_less_iff)
          from dense[OF this] obtain d where d:
            "d > -b'" "-d < b'" "d < a'"
          by (auto simp add: minus_less_iff)
          then have "Le (-d) < Lt b'" "Le d < Lt a'" unfolding less by auto
          with d(1) * show ?thesis
          by - (rule exI[where x = "d"], auto,
                meson d(2) dual_order.order_iff_strict less_trans neg_le_0_iff_le)
        qed
      next
        case 3 thus ?case by (auto simp: dbm_le_def less_eq)
      qed
    next
      case 5 thus ?case
      proof (cases b, auto, goal_cases)
        case (1 b')
        from this(2) have "-b' \<ge> 0"
        by (metis dbm_lt.intros(3) leI less less_asym neg_less_0_iff_less)
        let ?d = "- b'"
        have "Le ?d \<le> \<infinity>" "Le (- ?d) \<le> Le b'" by (auto simp: any_le_inf)
        with \<open>-b' \<ge> 0\<close> show ?case by auto
      next
        case (2 b')
        then have "b' \<le> 0" by (auto elim: dbm_lt.cases simp: less)
        from non_trivial_neg obtain e :: 'a where e:"e < 0" by blast
        let ?d = "- (b' + e)"
        from e \<open>b' \<le> 0\<close> have "Le ?d \<le> \<infinity>" "Le (- ?d) \<le> Lt b'" "b' + e < 0"
        by (auto simp: dbm_lt.intros(4) less less_imp_le any_le_inf add_nonpos_neg)
        then have "Le ?d \<le> \<infinity>" "Le (- ?d) \<le> Lt b'" "?d \<ge> 0"
        using less_imp_le neg_0_le_iff_le by blast+
        thus ?case by auto
      qed
    qed
  qed
qed

lemma sum_gt_neutral_dest:
  "(a :: (('a :: time) DBMEntry)) + b > \<one> \<Longrightarrow> \<exists> d. Le d \<le> a \<and> Le (-d) \<le> b"
proof -
  assume A: "a + b > \<one>"
  then have A': "b + a > \<one>" by (simp add: comm)
  show ?thesis
  proof (cases "a \<ge> \<one>")
    case True
    with A sum_gt_neutral_dest' show ?thesis by auto
  next
    case False
    { assume "b \<le> \<one>"
      with False have "a \<le> \<one>" "b \<le> \<one>" by auto
      from add_mono[OF this] have "a + b \<le> \<one>" by auto
      with A have False by auto
    }
    then have "b \<ge> \<one>" by fastforce
    with sum_gt_neutral_dest'[OF this A'] show ?thesis by auto
  qed
qed

subsection \<open>
  Negative Cycles in DBMs
\<close>

lemma DBM_val_bounded_neg_cycle1:
fixes i xs assumes
  bounded: "DBM_val_bounded v u M n" and A:"i \<le> n" "set xs \<subseteq> {0..n}" "len M i i xs < \<one>" and
  surj_on: "\<forall> k \<le> n. k > 0 \<longrightarrow> (\<exists> c. v c = k)" and at_most: "i \<noteq> 0" "cnt 0 xs \<le> 1"
shows False
proof -
  from A(1) surj_on at_most obtain c where c: "v c = i" by auto
  with DBM_val_bounded_len'3[OF bounded at_most(2), of c c] A(1,2) surj_on
  have bounded:"dbm_entry_val u (Some c) (Some c) (len M i i xs)" by force
  from A(3) have "len M i i xs \<prec> Le 0" by (simp add: neutral less)
  then show False using bounded by (cases rule: dbm_lt.cases) (auto elim: dbm_entry_val.cases)
qed

lemma cnt_0_I:
  "x \<notin> set xs \<Longrightarrow> cnt x xs = 0"
by (induction xs) auto

lemma distinct_cnt: "distinct xs \<Longrightarrow> cnt x xs \<le> 1"
 apply (induction xs)
  apply simp
  apply (rename_tac a xs)
 apply (case_tac "x = a")
using cnt_0_I by fastforce+

lemma DBM_val_bounded_neg_cycle:
fixes i xs assumes
  bounded: "DBM_val_bounded v u M n" and A:"i \<le> n" "set xs \<subseteq> {0..n}" "len M i i xs < \<one>" and
  surj_on: "\<forall> k \<le> n. k > 0 \<longrightarrow> (\<exists> c. v c = k)"
shows False
proof -
  from negative_len_shortest[OF _ A(3)] obtain j ys where ys:
    "distinct (j # ys)" "len M j j ys < \<one>" "j \<in> set (i # xs)" "set ys \<subseteq> set xs"
  by blast
  show False
  proof (cases "ys = []")
    case True
    show ?thesis
    proof (cases "j = 0")
      case True
      with \<open>ys = []\<close> ys bounded show False unfolding DBM_val_bounded_def neutral less_eq[symmetric]
      by auto
    next
      case False
      with \<open>ys = []\<close> DBM_val_bounded_neg_cycle1[OF bounded _ _ ys(2) surj_on] ys(3) A(1,2)
      show False by auto
    qed
  next
    case False
    from distinct_arcs_ex[OF _ _ this, of j 0 j] ys(1) obtain a b where arc:
      "a \<noteq> 0" "(a, b) \<in> set (arcs j j ys)"
    by auto
    from cycle_rotate_2'[OF False this(2)] obtain zs where zs:
      "len M j j ys = len M a a (b # zs)" "set (a # b # zs) = set (j # ys)"
      "1 + length zs = length ys" "set (arcs j j ys) = set (arcs a a (b # zs))"
    by blast
    with distinct_card[OF ys(1)] have "distinct (a # b # zs)" by (intro card_distinct) auto
    with distinct_cnt[of "b # zs"] have *: "cnt 0 (b # zs) \<le> 1" by fastforce
    show ?thesis
     apply (rule DBM_val_bounded_neg_cycle1[OF bounded _ _ _ surj_on \<open>a \<noteq> 0\<close> *])
       using zs(2) ys(3,4) A(1,2) apply fastforce+
    using zs(1) ys(2) by simp
  qed
qed

subsection \<open>Floyd-Warshall Algorithm Preservers Zones\<close>

lemma D_dest: "x = D m i j k \<Longrightarrow>
  x \<in> {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
using Min_elem_dest[OF D_base_finite'' D_base_not_empty] by (fastforce simp add: D_def)

lemma FW_zone_equiv:
  "\<forall> k \<le> n. k > 0 \<longrightarrow> (\<exists> c. v c = k) \<Longrightarrow> [M]\<^bsub>v,n\<^esub> = [FW M n]\<^bsub>v,n\<^esub>"
proof safe
  fix u assume A: "u \<in> [FW M n]\<^bsub>v,n\<^esub>"
  { fix i j assume "i \<le> n" "j \<le> n"
    hence "FW M n i j \<le> M i j" using fw_mono[of n n n i j M n] by simp
    hence "FW M n i j \<preceq> M i j" by (simp add: less_eq)
  }
  with DBM_le_subset[of n "FW M n" M] A show "u \<in> [M]\<^bsub>v,n\<^esub>" by auto
next
  fix u assume u:"u \<in> [M]\<^bsub>v,n\<^esub>" and surj_on: "\<forall> k \<le> n. k > 0 \<longrightarrow> (\<exists> c. v c = k)"
  hence *:"DBM_val_bounded v u M n" by (simp add: DBM_zone_repr_def)
  note ** = DBM_val_bounded_neg_cycle[OF this _ _ _ surj_on]
  have cyc_free: "cyc_free M n" using ** by fastforce
  with cycle_free_diag_equiv have cycle_free: "cycle_free M n" by auto
  from cycle_free_diag[OF this] have diag_ge_zero: "\<forall>k\<le>n. M k k \<ge> Le 0" unfolding neutral by auto

  have "DBM_val_bounded v u (FW M n) n" unfolding DBM_val_bounded_def
  proof (auto, goal_cases)
    case 1
    from fw_shortest_path[OF cycle_free, of 0 n 0 n n] have **:
      "D M 0 0 n = FW M n 0 0"
    by (simp add: neutral)
    from D_dest[OF **[symmetric]] obtain xs where xs:
        "FW M n 0 0 = len M 0 0 xs" "set xs \<subseteq> {0..n}"
        "0 \<notin> set xs" "distinct xs"
    by auto
    with cyc_free have "FW M n 0 0 \<ge> \<one>" by auto
    then show ?case unfolding neutral less_eq by simp
  next
    case (2 c)
    with fw_shortest_path[OF cycle_free, of 0 n "v c" n n] have **:
      "D M 0 (v c) n = FW M n 0 (v c)"
    by (simp add: neutral)
    from D_dest[OF **[symmetric]] obtain xs where xs:
        "FW M n 0 (v c) = len M 0 (v c) xs" "set xs \<subseteq> {0..n}"
        "0 \<notin> set xs" "v c \<notin> set xs" "distinct xs"
    by auto
    show ?case unfolding xs(1) using xs surj_on \<open>v c \<le> n\<close>
    by - (rule DBM_val_bounded_len'2[OF * xs(3)]; auto)
  next
    case (3 c)
    with fw_shortest_path[OF cycle_free, of "v c" n 0 n n] have **:
      "D M (v c) 0 n = FW M n (v c) 0"
    by (simp add: neutral)
    with D_dest[OF **[symmetric]] obtain xs where xs:
      "FW M n (v c) 0 = len M (v c) 0 xs" "set xs \<subseteq> {0..n}"
      "0 \<notin> set xs" "v c \<notin> set xs" "distinct xs"
    by auto
    show ?case unfolding xs(1) using xs surj_on \<open>v c \<le> n\<close>
    by - (rule DBM_val_bounded_len'1[OF * xs(3)]; auto)
  next
    case (4 c1 c2)
    with fw_shortest_path[OF cycle_free, of "v c1" n "v c2" n n]
    have "D M (v c1) (v c2) n = FW M n (v c1) (v c2)" by (simp add: neutral)
    from D_dest[OF this[symmetric]] obtain xs where xs:
      "FW M n (v c1) (v c2) = len M (v c1) (v c2) xs" "set xs \<subseteq> {0..n}"
      "v c1 \<notin> set xs" "v c2 \<notin> set xs" "distinct xs"
    by auto
    show ?case
    unfolding xs(1)
     apply (rule DBM_val_bounded_len'3[OF *])
        using xs surj_on \<open>v c1 \<le> n\<close> \<open>v c2 \<le> n\<close> apply auto
     apply (drule distinct_cnt[of _ 0])
    by auto
  qed
  then show "u \<in> [FW M n]\<^bsub>v,n\<^esub>" unfolding DBM_zone_repr_def by simp
qed

lemma new_negative_cycle_aux':
  fixes M :: "('a :: time) DBM"
  fixes i j d
  defines "M' \<equiv> \<lambda> i' j'. if (i' = i \<and> j' = j) then Le d
                       else if (i' = j \<and> j' = i) then Le (-d)
                       else M i' j'"
  assumes "i \<le> n" "j \<le> n" "set xs \<subseteq> {0..n}" "cycle_free M n" "length xs = m"
  assumes "len M' i i (j # xs) < \<one> \<or> len M' j j (i # xs) < \<one>"
  assumes "i \<noteq> j"
  shows "\<exists>xs. set xs \<subseteq> {0..n} \<and> j \<notin> set xs \<and> i \<notin> set xs
              \<and> (len M' i i (j # xs) < \<one> \<or> len M' j j (i # xs) < \<one>)" using assms
proof (induction _ m arbitrary: xs rule: less_induct)
  case (less x)
  { fix b a xs assume A: "(i, j) \<notin> set (arcs b a xs)" "(j, i) \<notin> set (arcs b a xs)"
    with \<open>i \<noteq> j\<close> have "len M' b a xs = len M b a xs"
    unfolding M'_def by (induction xs arbitrary: b) auto
  } note * = this
  { fix a xs assume A:"(i, j) \<notin> set (arcs a a xs)" "(j, i) \<notin> set (arcs a a xs)"
    assume a: "a \<le> n" and xs: "set xs \<subseteq> {0..n}" and cycle: "\<not> len M' a a xs \<ge> \<one>"
    from *[OF A] have "len M' a a xs = len M a a xs" .
    with \<open>cycle_free M n\<close> \<open>i \<le> n\<close> cycle xs a have False unfolding cycle_free_def by auto
  } note ** = this
  { fix a :: nat fix ys :: "nat list"
    assume A: "ys \<noteq> []" "length ys \<le> length xs" "set ys \<subseteq> set xs" "a \<le> n"
    assume cycle: "len M' a a ys < \<one>"
    assume arcs: "(i, j) \<in> set (arcs a a ys) \<or> (j, i) \<in> set (arcs a a ys)"
    from arcs have ?thesis
    proof
      assume "(i, j) \<in> set (arcs a a ys)"
      from cycle_rotate_2[OF \<open>ys \<noteq> []\<close> this, of M']
      obtain ws where ws: "len M' a a ys = len M' i i (j # ws)" "set ws \<subseteq> set (a # ys)"
        "length ws < length ys" by auto
      with cycle less.hyps(1)[OF _ less.hyps(2) , of "length ws" ws] less.prems A
      show ?thesis by fastforce
    next
      assume "(j, i) \<in> set (arcs a a ys)"
      from cycle_rotate_2[OF \<open>ys \<noteq> []\<close> this, of M']
      obtain ws where ws: "len M' a a ys = len M' j j (i # ws)" "set ws \<subseteq> set (a # ys)"
        "length ws < length ys" by auto
      with cycle less.hyps(1)[OF _ less.hyps(2) , of "length ws" ws] less.prems A
      show ?thesis by fastforce
    qed
  } note *** = this
  { fix a :: nat fix ys :: "nat list"
    assume A: "ys \<noteq> []" "length ys \<le> length xs" "set ys \<subseteq> set xs" "a \<le> n"
    assume cycle: "\<not> len M' a a ys \<ge> \<one>"
    with A **[of a ys] less.prems
    have "(i, j) \<in> set (arcs a a ys) \<or> (j, i) \<in> set (arcs a a ys)" by auto
    with ***[OF A] cycle have ?thesis by auto
  } note neg_cycle_IH = this
  from cycle_free_diag[OF \<open>cycle_free M n\<close>] have "\<forall>i. i \<le> n \<longrightarrow> Le 0 \<le> M i i" unfolding neutral by auto
  then have M'_diag: "\<forall>i. i \<le> n \<longrightarrow> Le 0 \<le> M' i i" unfolding M'_def using \<open>i \<noteq> j\<close> by auto
  from less(8) show ?thesis
  proof standard
    assume cycle:"len M' i i (j # xs) < \<one>"
    show ?thesis
    proof (cases "i \<in> set xs")
      case False
      then show ?thesis
      proof (cases "j \<in> set xs")
        case False
        with \<open>i \<notin> set xs\<close> show ?thesis using less.prems(3,6) by auto
      next
        case True
        then obtain ys zs where ys_zs: "xs = ys @ j # zs" by (meson split_list)
        with len_decomp[of "j # xs" "j # ys" j zs M' i i]
        have len: "len M' i i (j # xs) = M' i j + len M' j j ys + len M' j i zs" by auto
        show ?thesis
        proof (cases "len M' j j ys \<ge> \<one>")
          case True
          have "len M' i i (j # zs) = M' i j + len M' j i zs" by simp
          also from len True have "M' i j + len M' j i zs \<le> len M' i i (j # xs)"
          by (metis add_le_impl add_lt_neutral comm not_le)
          finally have cycle': "len M' i i (j # zs) < \<one>" using cycle by auto
          from ys_zs less.prems(5) have "x > length zs" by auto
          from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of zs]
          show ?thesis by auto
        next
          case False
          with M'_diag less.prems have "ys \<noteq> []" by (auto simp: neutral)
          from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
        qed
      qed
    next
      case True
      then obtain ys zs where ys_zs: "xs = ys @ i # zs" by (meson split_list)
      with len_decomp[of "j # xs" "j # ys" i zs M' i i]
      have len: "len M' i i (j # xs) = M' i j + len M' j i ys + len M' i i zs" by auto
      show ?thesis
      proof (cases "len M' i i zs \<ge> \<one>")
        case True
        have "len M' i i (j # ys) = M' i j + len M' j i ys" by simp
        also from len True have "M' i j + len M' j i ys \<le> len M' i i (j # xs)"
        by (metis add_lt_neutral comm not_le)
        finally have cycle': "len M' i i (j # ys) < \<one>" using cycle by auto
        from ys_zs less.prems(5) have "x > length ys" by auto
        from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of ys]
        show ?thesis by auto
      next
        case False
        with less.prems(1,7) M'_diag have "zs \<noteq> []" by (auto simp: neutral)
        from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
      qed
    qed
  next
    assume cycle:"len M' j j (i # xs) < \<one>"
    show ?thesis
    proof (cases "j \<in> set xs")
      case False
      then show ?thesis
      proof (cases "i \<in> set xs")
        case False
        with \<open>j \<notin> set xs\<close> show ?thesis using less.prems(3,6) by auto
      next
        case True
        then obtain ys zs where ys_zs: "xs = ys @ i # zs" by (meson split_list)
        with len_decomp[of "i # xs" "i # ys" i zs M' j j]
        have len: "len M' j j (i # xs) = M' j i + len M' i i ys + len M' i j zs" by auto
        show ?thesis
        proof (cases "len M' i i ys \<ge> \<one>")
          case True
          have "len M' j j (i # zs) = M' j i + len M' i j zs" by simp
          also from len True have "M' j i + len M' i j zs \<le> len M' j j (i # xs)"
          by (metis add_le_impl add_lt_neutral comm not_le)
          finally have cycle': "len M' j j (i # zs) < \<one>" using cycle by auto
          from ys_zs less.prems(5) have "x > length zs" by auto
          from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of zs]
          show ?thesis by auto
        next
          case False
          with less.prems M'_diag have "ys \<noteq> []" by (auto simp: neutral)
          from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
        qed
      qed
    next
      case True
      then obtain ys zs where ys_zs: "xs = ys @ j # zs" by (meson split_list)
      with len_decomp[of "i # xs" "i # ys" j zs M' j j]
      have len: "len M' j j (i # xs) = M' j i + len M' i j ys + len M' j j zs" by auto
      show ?thesis
      proof (cases "len M' j j zs \<ge> \<one>")
        case True
        have "len M' j j (i # ys) = M' j i + len M' i j ys" by simp
        also from len True have "M' j i + len M' i j ys \<le> len M' j j (i # xs)"
        by (metis add_lt_neutral comm not_le)
        finally have cycle': "len M' j j (i # ys) < \<one>" using cycle by auto
        from ys_zs less.prems(5) have "x > length ys" by auto
        from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of ys]
        show ?thesis by auto
      next
        case False
        with less.prems(2,7) M'_diag have "zs \<noteq> []" by (auto simp: neutral)
        from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
      qed
    qed
  qed
qed

lemma new_negative_cycle_aux:
  fixes M :: "('a :: time) DBM"
  fixes i d
  defines "M' \<equiv> \<lambda> i' j'. if (i' = i \<and> j' = 0) then Le d
                       else if (i' = 0 \<and> j' = i) then Le (-d)
                       else M i' j'"
  assumes "i \<le> n" "set xs \<subseteq> {0..n}" "cycle_free M n" "length xs = m"
  assumes "len M' 0 0 (i # xs) < \<one> \<or> len M' i i (0 # xs) < \<one>"
  assumes "i \<noteq> 0"
  shows "\<exists>xs. set xs \<subseteq> {0..n} \<and> 0 \<notin> set xs \<and> i \<notin> set xs
              \<and> (len M' 0 0 (i # xs) < \<one> \<or> len M' i i (0 # xs) < \<one>)" using assms
proof (induction _ m arbitrary: xs rule: less_induct)
  case (less x)
  { fix b a xs assume A: "(0, i) \<notin> set (arcs b a xs)" "(i, 0) \<notin> set (arcs b a xs)"
    then have "len M' b a xs = len M b a xs"
    unfolding M'_def by (induction xs arbitrary: b) auto
  } note * = this
  { fix a xs assume A:"(0, i) \<notin> set (arcs a a xs)" "(i, 0) \<notin> set (arcs a a xs)"
    assume a: "a \<le> n" and xs: "set xs \<subseteq> {0..n}" and cycle: "\<not> len M' a a xs \<ge> \<one>"
    from *[OF A] have "len M' a a xs = len M a a xs" .
    with \<open>cycle_free M n\<close> \<open>i \<le> n\<close> cycle xs a have False unfolding cycle_free_def by auto
  } note ** = this
  { fix a :: nat fix ys :: "nat list"
    assume A: "ys \<noteq> []" "length ys \<le> length xs" "set ys \<subseteq> set xs" "a \<le> n"
    assume cycle: "len M' a a ys < \<one>"
    assume arcs: "(0, i) \<in> set (arcs a a ys) \<or> (i, 0) \<in> set (arcs a a ys)"
    from arcs have ?thesis
    proof
      assume "(0, i) \<in> set (arcs a a ys)"
      from cycle_rotate_2[OF \<open>ys \<noteq> []\<close> this, of M']
      obtain ws where ws: "len M' a a ys = len M' 0 0 (i # ws)" "set ws \<subseteq> set (a # ys)"
        "length ws < length ys" by auto
      with cycle less.hyps(1)[OF _ less.hyps(2) , of "length ws" ws] less.prems A
      show ?thesis by fastforce
    next
      assume "(i, 0) \<in> set (arcs a a ys)"
      from cycle_rotate_2[OF \<open>ys \<noteq> []\<close> this, of M']
      obtain ws where ws: "len M' a a ys = len M' i i (0 # ws)" "set ws \<subseteq> set (a # ys)"
        "length ws < length ys" by auto
      with cycle less.hyps(1)[OF _ less.hyps(2) , of "length ws" ws] less.prems A
      show ?thesis by fastforce
    qed
  } note *** = this
  { fix a :: nat fix ys :: "nat list"
    assume A: "ys \<noteq> []" "length ys \<le> length xs" "set ys \<subseteq> set xs" "a \<le> n"
    assume cycle: "\<not> len M' a a ys \<ge> \<one>"
    with A **[of a ys]  less.prems(2)
    have "(0, i) \<in> set (arcs a a ys) \<or> (i, 0) \<in> set (arcs a a ys)" by auto
    with ***[OF A] cycle have ?thesis by auto
  } note neg_cycle_IH = this
  from cycle_free_diag[OF \<open>cycle_free M n\<close>] have "\<forall>i. i \<le> n \<longrightarrow> Le 0 \<le> M i i" unfolding neutral by auto
  then have M'_diag: "\<forall>i. i \<le> n \<longrightarrow> Le 0 \<le> M' i i" unfolding M'_def using \<open>i \<noteq> 0\<close> by auto
  from less(7) show ?thesis
  proof standard
    assume cycle:"len M' 0 0 (i # xs) < \<one>"
    show ?thesis
    proof (cases "0 \<in> set xs")
      case False
      thus ?thesis
      proof (cases "i \<in> set xs")
        case False
        with \<open>0 \<notin> set xs\<close> show ?thesis using less.prems by auto
      next
        case True
        then obtain ys zs where ys_zs: "xs = ys @ i # zs" by (meson split_list)
        with len_decomp[of "i # xs" "i # ys" i zs M' 0 0]
        have len: "len M' 0 0 (i # xs) = M' 0 i + len M' i i ys + len M' i 0 zs" by auto
        show ?thesis
        proof (cases "len M' i i ys \<ge> \<one>")
          case True
          have "len M' 0 0 (i # zs) = M' 0 i + len M' i 0 zs" by simp
          also from len True have "M' 0 i + len M' i 0 zs \<le> len M' 0 0 (i # xs)"
          by (metis add_le_impl add_lt_neutral comm not_le)
          finally have cycle': "len M' 0 0 (i # zs) < \<one>" using cycle by auto
          from ys_zs less.prems(4) have "x > length zs" by auto
          from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of zs]
          show ?thesis by auto
        next
          case False
          with less.prems(1,6) M'_diag have "ys \<noteq> []" by (auto simp: neutral)
          from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
        qed
      qed
    next
      case True
      then obtain ys zs where ys_zs: "xs = ys @ 0 # zs" by (meson split_list)
      with len_decomp[of "i # xs" "i # ys" 0 zs M' 0 0]
      have len: "len M' 0 0 (i # xs) = M' 0 i + len M' i 0 ys + len M' 0 0 zs" by auto
      show ?thesis
      proof (cases "len M' 0 0 zs \<ge> \<one>")
        case True
        have "len M' 0 0 (i # ys) = M' 0 i + len M' i 0 ys" by simp
        also from len True have "M' 0 i + len M' i 0 ys \<le> len M' 0 0 (i # xs)"
        by (metis add_lt_neutral comm not_le)
        finally have cycle': "len M' 0 0 (i # ys) < \<one>" using cycle by auto
        from ys_zs less.prems(4) have "x > length ys" by auto
        from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of ys]
        show ?thesis by auto
      next
        case False
        with less.prems(1,6) M'_diag have "zs \<noteq> []" by (auto simp: neutral)
        from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
      qed
    qed
  next
    assume cycle: "len M' i i (0 # xs) < \<one>"
    show ?thesis
    proof (cases "i \<in> set xs")
      case False
      thus ?thesis
      proof (cases "0 \<in> set xs")
        case False
        with \<open>i \<notin> set xs\<close> show ?thesis using less.prems by auto
      next
        case True
        then obtain ys zs where ys_zs: "xs = ys @ 0 # zs" by (meson split_list)
        with len_decomp[of "0 # xs" "0 # ys" 0 zs M' i i]
        have len: "len M' i i (0 # xs) = M' i 0 + len M' 0 0 ys + len M' 0 i zs" by auto
        show ?thesis
        proof (cases "len M' 0 0 ys \<ge> \<one>")
          case True
          have "len M' i i (0 # zs) = M' i 0 + len M' 0 i zs" by simp
          also from len True have "M' i 0 + len M' 0 i zs \<le> len M' i i (0 # xs)"
          by (metis add_le_impl add_lt_neutral comm not_le)
          finally have cycle': "len M' i i (0 # zs) < \<one>" using cycle by auto
          from ys_zs less.prems(4) have "x > length zs" by auto
          from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of zs]
          show ?thesis by auto
        next
          case False
          with less.prems(1,6) M'_diag have "ys \<noteq> []" by (auto simp: neutral)
          from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
        qed
      qed
    next
      case True
      then obtain ys zs where ys_zs: "xs = ys @ i # zs" by (meson split_list)
      with len_decomp[of "0 # xs" "0 # ys" i zs M' i i]
      have len: "len M' i i (0 # xs) = M' i 0 + len M' 0 i ys + len M' i i zs" by auto
      show ?thesis
      proof (cases "len M' i i zs \<ge> \<one>")
        case True
        have "len M' i i (0 # ys) = M' i 0 + len M' 0 i ys" by simp
        also from len True have "M' i 0 + len M' 0 i ys \<le> len M' i i (0 # xs)"
        by (metis add_lt_neutral comm not_le)
        finally have cycle': "len M' i i (0 # ys) < \<one>" using cycle by auto
        from ys_zs less.prems(4) have "x > length ys" by auto
        from cycle' less.prems ys_zs less.hyps(1)[OF this less.hyps(2) , of ys]
        show ?thesis by auto
      next
        case False
        with less.prems(1,6) M'_diag have "zs \<noteq> []" by (auto simp: neutral)
        from neg_cycle_IH[OF this] ys_zs False less.prems(1,2) show ?thesis by auto
      qed
    qed
  qed
qed

section \<open>The Characteristic Property of Canonical DBMs\<close>

theorem fix_index':
  fixes M :: "(('a :: time) DBMEntry) mat"
  assumes "Le r \<le> M i j" "Le (-r) \<le> M j i" "cycle_free M n" "canonical M n" "i \<le> n" "j \<le> n" "i \<noteq> j"
  defines "M' \<equiv> \<lambda> i' j'. if (i' = i \<and> j' = j) then Le r
                       else if (i' = j \<and> j' = i) then Le (-r)
                       else M i' j'"
  shows "(\<forall> u. DBM_val_bounded v u M' n \<longrightarrow> DBM_val_bounded v u M n) \<and> cycle_free M' n"
proof -
  note A = assms
  note r = assms(1,2)
  from \<open>cycle_free M n\<close> have diag_cycles: "\<forall>i xs. i \<le> n \<and> set xs \<subseteq> {0..n} \<longrightarrow> Le 0 \<le> len M i i xs"
  unfolding cycle_free_def neutral by auto
  let ?M' = "\<lambda> i' j'. if (i' = i \<and> j' = j) then Le r
                       else if (i' = j \<and> j' = i) then Le (-r)
                       else M i' j'"
  have "?M' i' j' \<le> M i' j'" when "i' \<le> n" "j' \<le> n" for i' j' using assms by auto
  with DBM_le_subset[folded less_eq, of n ?M' M] have "DBM_val_bounded v u M n"
  if "DBM_val_bounded v u ?M' n" for u unfolding DBM_zone_repr_def using that by auto
  then have not_empty:"\<forall> u. DBM_val_bounded v u ?M' n \<longrightarrow> DBM_val_bounded v u M n" by auto
  { fix a xs assume prems: "a \<le> n" "set xs \<subseteq> {0..n}" and cycle: "\<not> len ?M' a a xs \<ge> \<one>"
    { fix b assume A: "(i, j) \<notin> set (arcs b a xs)" "(j, i) \<notin> set (arcs b a xs)"
      with \<open>i \<noteq> j\<close> have "len ?M' b a xs = len M b a xs" by (induction xs arbitrary: b) auto
    } note * = this
    { fix a b xs assume A: "i \<notin> set (a # xs)" "j \<notin> set (a # xs)"
      then have "len ?M' a b xs = len M a b xs" by (induction xs arbitrary: a, auto)
    } note ** = this
    { assume A:"(i, j) \<notin> set (arcs a a xs)" "(j, i) \<notin> set (arcs a a xs)"
      from *[OF this] have "len ?M' a a xs = len M a a xs" .
      with \<open>cycle_free M n\<close> prems cycle have False by (auto simp: cycle_free_def)
    }
    then have arcs:"(i, j) \<in> set (arcs a a xs) \<or> (j, i) \<in> set (arcs a a xs)" by auto
    with \<open>i \<noteq> j\<close> have "xs \<noteq> []" by auto
    from arcs obtain xs where xs: "set xs \<subseteq> {0..n}"
      "len ?M' i i (j # xs) < \<one> \<or> len ?M' j j (i # xs) < \<one>"
    proof (standard, goal_cases)
      case 1
      from cycle_rotate_2'[OF \<open>xs \<noteq> []\<close> this(2), of ?M'] prems obtain ys where
        "len ?M' i i (j # ys) = len ?M' a a xs" "set ys \<subseteq> {0..n}"
      by fastforce
      with 1 cycle show ?thesis by fastforce
    next
      case 2
      from cycle_rotate_2'[OF \<open>xs \<noteq> []\<close> this(2), of ?M'] prems obtain ys where
        "len ?M' j j (i # ys) = len ?M' a a xs" "set ys \<subseteq> {0..n}"
      by fastforce
      with 2 cycle show ?thesis by fastforce
    qed
    from new_negative_cycle_aux'[OF \<open>i \<le> n\<close> \<open>j \<le> n\<close> this(1) \<open>cycle_free M n\<close> _ this(2) \<open>i \<noteq> j\<close>]
    obtain xs where xs:
      "set xs \<subseteq> {0..n}" "i \<notin> set xs" "j \<notin> set xs"
      "len ?M' i i (j # xs) < \<one> \<or> len ?M' j j (i # xs) < \<one>"
    by auto
    from this(4) have False
    proof
      assume A: "len ?M' j j (i # xs) < \<one>"
      show False
      proof (cases xs)
        case Nil
        with \<open>i \<noteq> j\<close> have *:"?M' j i = Le (-r)" "?M' i j = Le r" by simp+
        from Nil have "len ?M' j j (i # xs) = ?M' j i + ?M' i j" by simp
        with * have "len ?M' j j (i # xs) = Le 0" by (simp add: mult)
        then show False using A by (simp add: neutral)
      next
        case (Cons y ys)
        have *:"M i y + M y j \<ge> M i j"
        using \<open>canonical M n\<close> Cons xs \<open>i \<le> n\<close> \<open>j \<le> n\<close> by (simp add: mult less_eq)
        have "Le 0 = Le (-r) + Le r" by (simp add: mult)
        also have "\<dots> \<le> Le (-r) + M i j" using r by (simp add: add_mono)
        also have "\<dots> \<le> Le (-r) + M i y + M y j" using * by (simp add: add_mono assoc)
        also have "\<dots> \<le> Le (-r) + ?M' i y + len M y j ys"
        using canonical_len[OF \<open>canonical M n\<close>] xs(1-3) \<open>i \<le> n\<close> \<open>j \<le> n\<close> Cons by (simp add: add_mono)
        also have "\<dots> = len ?M' j j (i # xs)" using Cons \<open>i \<noteq> j\<close> ** xs(1-3) by (simp add: assoc)
        also have "\<dots> < Le 0" using A by (simp add: neutral)
        finally show False by simp
      qed
    next
      assume A: "len ?M' i i (j # xs) < \<one>"
      show False
      proof (cases xs)
        case Nil
        with \<open>i \<noteq> j\<close> have *:"?M' j i = Le (-r)" "?M' i j = Le r" by simp+
        from Nil have "len ?M' i i (j # xs) = ?M' i j + ?M' j i" by simp
        with * have "len ?M' i i (j # xs) = Le 0" by (simp add: mult)
        then show False using A by (simp add: neutral)
      next
        case (Cons y ys)
        have *:"M j y + M y i \<ge> M j i"
        using \<open>canonical M n\<close> Cons xs \<open>i \<le> n\<close> \<open>j \<le> n\<close> by (simp add: mult less_eq)
        have "Le 0 = Le r + Le (-r)" by (simp add: mult)
        also have "\<dots> \<le> Le r + M j i" using r by (simp add: add_mono)
        also have "\<dots> \<le> Le r + M j y + M y i" using * by (simp add: add_mono assoc)
        also have "\<dots> \<le> Le r + ?M' j y + len M y i ys"
        using canonical_len[OF \<open>canonical M n\<close>] xs(1-3) \<open>i \<le> n\<close> \<open>j \<le> n\<close> Cons by (simp add: add_mono)
        also have "\<dots> = len ?M' i i (j # xs)" using Cons \<open>i \<noteq> j\<close> ** xs(1-3) by (simp add: assoc)
        also have "\<dots> < Le 0" using A by (simp add: neutral)
        finally show False by simp
      qed
    qed
  } note * = this
  have "cycle_free ?M' n" using negative_cycle_dest_diag * by fastforce
  then show ?thesis using not_empty \<open>i \<noteq> j\<close> r unfolding M'_def by auto
qed

lemma fix_index:
  fixes M :: "(('a :: time) DBMEntry) mat"
  assumes "M 0 i + M i 0 > \<one>" "cycle_free M n" "canonical M n" "i \<le> n" "i \<noteq> 0"
  shows
  "\<exists> (M' :: ('a DBMEntry) mat). ((\<exists> u. DBM_val_bounded v u M' n) \<longrightarrow> (\<exists> u. DBM_val_bounded v u M n))
     \<and> M' 0 i + M' i 0 = \<one> \<and> cycle_free M' n
     \<and> (\<forall> j. i \<noteq> j \<and> M 0 j + M j 0 = \<one> \<longrightarrow> M' 0 j + M' j 0 = \<one>)
     \<and> (\<forall> j. i \<noteq> j \<and> M 0 j + M j 0 > \<one> \<longrightarrow> M' 0 j + M' j 0 > \<one>)"
proof -
  note A = assms
  from sum_gt_neutral_dest[OF assms(1)] obtain d where d: "Le d \<le> M i 0" "Le (-d) \<le> M 0 i" by auto
  have "i \<noteq> 0" using A by - (rule ccontr; simp)
  let ?M' = "\<lambda>i' j'. if i' = i \<and> j' = 0 then Le d else if i' = 0 \<and> j' = i then Le (-d) else M i' j'"
  from fix_index'[OF d(1,2) A(2,3,4) _ \<open>i \<noteq> 0\<close>] have M':
    "\<forall>u. DBM_val_bounded v u ?M' n \<longrightarrow> DBM_val_bounded v u M n" "cycle_free ?M' n"
  by auto
  moreover from \<open>i \<noteq> 0\<close> have "\<forall> j. i \<noteq> j \<and> M 0 j + M j 0 = \<one> \<longrightarrow> ?M' 0 j + ?M' j 0 = \<one>" by auto
  moreover from \<open>i \<noteq> 0\<close> have "\<forall> j. i \<noteq> j \<and> M 0 j + M j 0 > \<one> \<longrightarrow> ?M' 0 j + ?M' j 0 > \<one>" by auto
  moreover from \<open>i \<noteq> 0\<close> have "?M' 0 i + ?M' i 0 = \<one>" unfolding neutral mult by auto
  ultimately show ?thesis by blast
qed

subsubsection \<open>
  Putting it together
\<close>

lemma FW_not_empty:
  "DBM_val_bounded v u (FW M' n) n \<Longrightarrow> DBM_val_bounded v u M' n"
proof -
  assume A: "DBM_val_bounded v u (FW M' n) n"
  have "\<forall>i j. i \<le> n \<longrightarrow> j \<le> n \<longrightarrow> FW M' n i j \<le> M' i j" using fw_mono by blast
  from DBM_le_subset[of n "FW M' n" M' _ v, OF this[unfolded less_eq]]
  show "DBM_val_bounded v u M' n" using A by (auto simp: DBM_zone_repr_def)
qed

lemma fix_indices:
  fixes M :: "(('a :: time) DBMEntry) mat"
  assumes "set xs \<subseteq> {0..n}" "distinct xs"
  assumes "cyc_free M n" "canonical M n"
  shows
  "\<exists> (M' :: ('a DBMEntry) mat). ((\<exists> u. DBM_val_bounded v u M' n) \<longrightarrow> (\<exists> u. DBM_val_bounded v u M n))
     \<and> (\<forall> i \<in> set xs. i \<noteq> 0 \<longrightarrow> M' 0 i + M' i 0 = \<one>) \<and> cyc_free M' n
     \<and> (\<forall> i\<le>n. i \<notin> set xs \<and> M 0 i + M i 0 = \<one> \<longrightarrow> M' 0 i + M' i 0 = \<one>)" using assms
proof (induction xs arbitrary: M)
  case Nil then show ?case by auto
next
  case (Cons i xs)
  show ?case
  proof (cases "M 0 i + M i 0 \<le> \<one> \<or> i = 0")
    case True
    note T = this
    show ?thesis
    proof (cases "i = 0")
      case False
      from Cons.prems have "0 \<le> n" "set [i] \<subseteq> {0..n}" by auto
      with Cons.prems(3) False T have "M 0 i + M i 0 = \<one>" by fastforce
      with Cons.IH[OF _ _ Cons.prems(3,4)] Cons.prems(1,2) show ?thesis by auto
    next
      case True
      with Cons.IH[OF _ _ Cons.prems(3,4)] Cons.prems(1,2) show ?thesis by auto
    qed
  next
    case False
    with Cons.prems have "\<one> < M 0 i + M i 0" "i \<le> n" "i \<noteq> 0" by auto
    with fix_index[OF this(1) cycle_free_diag_intro[OF Cons.prems(3)] Cons.prems(4) this(2,3), of v]
    obtain M' :: "('a DBMEntry) mat" where M':
      "((\<exists>u. DBM_val_bounded v u M' n) \<longrightarrow> (\<exists>u. DBM_val_bounded v u M n))" "(M' 0 i + M' i 0 = \<one>)"
      "cyc_free M' n" "\<forall>j\<le>n. i \<noteq> j \<and> M 0 j + M j 0 > \<one> \<longrightarrow> M' 0 j + M' j 0 > \<one>"
      "\<forall>j. i \<noteq> j \<and> M 0 j + M j 0 = \<one> \<longrightarrow> M' 0 j + M' j 0 = \<one>"
    using cycle_free_diag_equiv by blast
    let ?M' = "FW M' n"
    from fw_canonical[of M' n] cycle_free_diag_equiv \<open>cyc_free M' n\<close> have "canonical ?M' n" by auto
    from FW_cyc_free_preservation[OF \<open>cyc_free M' n\<close>] have "cyc_free ?M' n"
    by auto
    from FW_fixed_preservation[OF \<open>i \<le> n\<close> M'(2) \<open>canonical ?M' n\<close> \<open>cyc_free ?M' n\<close>]
    have fixed:"?M' 0 i + ?M' i 0 = \<one>" by (auto simp: add_mono)
    from Cons.IH[OF _ _ \<open>cyc_free ?M' n\<close> \<open>canonical ?M' n\<close>] Cons.prems(1,2,3)
    obtain M'' :: "('a DBMEntry) mat"
    where M'': "((\<exists>u. DBM_val_bounded v u M'' n) \<longrightarrow> (\<exists>u. DBM_val_bounded v u ?M' n))"
      "(\<forall>i\<in>set xs. i \<noteq> 0 \<longrightarrow> M'' 0 i + M'' i 0 = \<one>)" "cyc_free M'' n"
      "(\<forall>i\<le>n. i \<notin> set xs \<and> ?M' 0 i + ?M' i 0 = \<one> \<longrightarrow> M'' 0 i + M'' i 0 = \<one>)"
    by auto
    from FW_fixed_preservation[OF _ _ \<open>canonical ?M' n\<close> \<open>cyc_free ?M' n\<close>] M'(5)
    have "\<forall>j\<le>n. i \<noteq> j \<and> M 0 j + M j 0 = \<one> \<longrightarrow> ?M' 0 j + ?M' j 0 = \<one>" by auto
    with M''(4) have "\<forall>j\<le>n. j \<notin> set (i # xs) \<and> M 0 j + M j 0 = \<one> \<longrightarrow> M'' 0 j + M'' j 0 = \<one>" by auto
    moreover from M''(2) M''(4) fixed Cons.prems(2) \<open>i \<le> n\<close>
    have "(\<forall>i\<in>set (i#xs). i \<noteq> 0 \<longrightarrow> M'' 0 i + M'' i 0 = \<one>)" by auto
    moreover from M''(1) M'(1) FW_not_empty[of v _ M' n]
    have "(\<exists>u. DBM_val_bounded v u M'' n) \<longrightarrow> (\<exists>u. DBM_val_bounded v u M n)" by auto
    ultimately show ?thesis using \<open>cyc_free M'' n\<close> M''(4) by auto
  qed
qed

lemma cyc_free_obtains_valuation:
  "cyc_free M n \<Longrightarrow> \<forall> c. v c \<le> n \<longrightarrow> v c > 0 \<Longrightarrow> \<exists> u. DBM_val_bounded v u M n"
proof -
  assume A: "cyc_free M n" "\<forall> c. v c \<le> n \<longrightarrow> v c > 0"
  let ?M = "FW M n"
  from fw_canonical[of M n] cycle_free_diag_equiv A have "canonical ?M n" by auto
  from FW_cyc_free_preservation[OF A(1) ] have "cyc_free ?M n" .
  have "set [0..<n+1] \<subseteq> {0..n}" "distinct [0..<n+1]" by auto
  from fix_indices[OF this \<open>cyc_free ?M n\<close> \<open>canonical ?M n\<close>]
  obtain M' :: "('a DBMEntry) mat" where M':
    "(\<exists>u. DBM_val_bounded v u M' n) \<longrightarrow> (\<exists>u. DBM_val_bounded v u (FW M n) n)"
    "\<forall>i\<in>set [0..<n + 1]. i \<noteq> 0 \<longrightarrow> M' 0 i + M' i 0 = \<one>" "cyc_free M' n"
  by blast
  let ?M' = "FW M' n"
  have "\<And> i. i \<le> n \<Longrightarrow> i \<in> set [0..<n + 1]" by auto
  with M'(2) have M'_fixed: "\<forall>i\<le>n. i \<noteq> 0 \<longrightarrow> M' 0 i + M' i 0 = \<one>" by fastforce
  from fw_canonical[of M' n] cycle_free_diag_equiv M'(3) have "canonical ?M' n" by blast
  from FW_fixed_preservation[OF _ _ this FW_cyc_free_preservation[OF M'(3)]] M'_fixed
  have fixed: "\<forall>i\<le>n. i \<noteq> 0 \<longrightarrow> ?M' 0 i + ?M' i 0 = \<one>" by auto
  have *: "\<And>i. i \<le> n \<Longrightarrow> i \<noteq> 0 \<Longrightarrow> \<exists> d. ?M' 0 i = Le (-d) \<and> ?M' i 0 = Le d"
  proof -
    fix i assume i: "i \<le> n" "i \<noteq> 0"
    from i fixed have *:"dbm_add (?M' 0 i) (?M' i 0) = Le 0" by (auto simp add: mult neutral)
    moreover
    { fix a b :: 'a assume "a + b = 0"
      then have "a = -b" by (simp add: eq_neg_iff_add_eq_0)
    }
    ultimately show "\<exists>d. ?M' 0 i = Le (-d) \<and> ?M' i 0 = Le d"
    by (cases "?M' 0 i"; cases "?M' i 0"; simp)
  qed
  then obtain f where f: "\<forall> i\<le>n. i \<noteq> 0 \<longrightarrow> Le (f i) = ?M' i 0 \<and> Le (- f i) = ?M' 0 i" by metis
  let ?u = "\<lambda> c. f (v c)"
  have "DBM_val_bounded v ?u ?M' n"
  proof (auto simp add: DBM_val_bounded_def, goal_cases)
    case 1
    from cyc_free_diag_dest'[OF FW_cyc_free_preservation[OF M'(3)]] show ?case
    unfolding neutral less_eq by fast
  next
    case (2 c)
    with A(2) have **: "v c > 0" by auto
    with *[OF 2] obtain d where d: "Le (-d) = ?M' 0 (v c)" by auto
    with f 2 ** have "Le (- f (v c)) = Le (- d)" by simp
    then have "- f (v c) \<le> - d" by auto
    from dbm_entry_val.intros(2)[of ?u , OF this] d
    show ?case by auto
  next
    case (3 c)
    with A(2) have **: "v c > 0" by auto
    with *[OF 3] obtain d where d: "Le d = ?M' (v c) 0" by auto
    with f 3 ** have "Le (f (v c)) = Le d" by simp
    then have "f (v c) \<le> d" by auto
    from dbm_entry_val.intros(1)[of ?u, OF this] d
    show ?case by auto
  next
    case (4 c1 c2)
    with A(2) have **: "v c1 > 0" "v c2 > 0" by auto
    with *[OF 4(1)] obtain d1 where d1: "Le d1 = ?M' (v c1) 0" by auto
    with f 4 ** have "Le (f (v c1)) = Le d1" by simp
    then have d1': "f (v c1) = d1" by auto
    from *[OF 4(2)] ** obtain d2 where d2: "Le d2 = ?M' (v c2) 0" by auto
    with f 4 ** have "Le (f (v c2)) = Le d2" by simp
    then have d2': "f (v c2) = d2" by auto
    have "Le d1 \<le> ?M' (v c1) (v c2) + Le d2" using \<open>canonical ?M' n\<close> 4 d1 d2
    by (auto simp add: less_eq mult)
    then show ?case
    proof (cases "?M' (v c1) (v c2)", auto, goal_cases)
      case (1 d)
      from this(1) have "d1 \<le> d + d2" by (auto simp: mult less_eq le_dbm_le)
      then have "d1 - d2 \<le> d" by (simp add: diff_le_eq)
      then show ?case using d1' d2' by auto
    next
      case (2 d)
      from this(1) have "d1 < d + d2" by (auto simp: mult less_eq dbm_le_def elim: dbm_lt.cases)
      then have "d1 - d2 < d" using diff_less_eq by blast
      then show ?case using d1' d2' by auto
    qed
  qed
  from M'(1) FW_not_empty[OF this] obtain u where "DBM_val_bounded v u ?M n" by auto
  from FW_not_empty[OF this] show ?thesis by auto
qed

subsection \<open>Floyd-Warshall and Empty DBMs\<close>

theorem FW_detects_empty_zone:
  "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists>c. v c = k) \<Longrightarrow> \<forall> c. v c \<le> n \<longrightarrow> v c > 0
  \<Longrightarrow> [FW M n]\<^bsub>v,n\<^esub> = {} \<longleftrightarrow> (\<exists> i\<le>n. (FW M n) i i < Le 0)"
proof
  assume surj_on:"\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists>c. v c = k)" and "\<exists>i\<le>n. (FW M n) i i < Le 0"
  then obtain i where *: "len (FW M n) i i [] < \<one>" "i \<le>n" by (auto simp add: neutral)
  show "[FW M n]\<^bsub>v,n\<^esub> = {}"
  proof (rule ccontr, goal_cases)
    case 1
    then obtain u where "DBM_val_bounded v u (FW M n) n" unfolding DBM_zone_repr_def by auto
    from DBM_val_bounded_neg_cycle[OF this *(2) _ *(1) surj_on] show ?case by auto
  qed
next
  assume surj_on: "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists>c. v c = k)" and empty: "[FW M n]\<^bsub>v,n\<^esub> = {}"
  and    cn: "\<forall> c. v c \<le> n \<longrightarrow> v c > 0"
  show "\<exists> i\<le>n. (FW M n) i i < Le 0"
  proof (rule ccontr, goal_cases)
    case 1
    then have *:"\<forall>i\<le>n. FW M n i i \<ge> \<one>" by (auto simp add: neutral)
    have "cyc_free M n"
    proof (rule ccontr)
      assume "\<not> cyc_free M n"
      then have A: "\<not> cycle_free M n" using cycle_free_diag_equiv by auto
      from FW_neg_cycle_detect[OF A] * show False by auto
    qed
    from FW_cyc_free_preservation[OF this] have "cyc_free (FW M n) n" .
    from cyc_free_obtains_valuation[OF \<open>cyc_free (FW M n) n\<close> cn] empty
    obtain u where "DBM_val_bounded v u (FW M n) n" by blast
    with empty show ?case by (auto simp add: DBM_zone_repr_def)
  qed
qed

(* This definition is "internal" to the theorems for the correctness of the Floyd-Warshall algorithm
   and we want to reuse this as a variable name, so we hide it away *)
hide_const D

subsection \<open>Mixed Corollaries\<close>

lemma cyc_free_not_empty:
  assumes "cyc_free M n" "\<forall>c. v c \<le> n \<longrightarrow> 0 < v c"
  shows "[(M :: ('a :: time) DBM)]\<^bsub>v,n\<^esub> \<noteq> {}"
using cyc_free_obtains_valuation[OF assms(1,2)] unfolding DBM_zone_repr_def by auto

lemma empty_not_cyc_free:
  assumes "\<forall>c. v c \<le> n \<longrightarrow> 0 < v c" "[(M :: ('a :: time) DBM)]\<^bsub>v,n\<^esub> = {}"
  shows "\<not> cyc_free M n"
using assms by (meson cyc_free_not_empty)

lemma not_empty_cyc_free:
  assumes "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists> c. v c = k)" "[(M :: ('a :: time) DBM)]\<^bsub>v,n\<^esub> \<noteq> {}"
  shows "cyc_free M n" using DBM_val_bounded_neg_cycle[OF _ _ _ _ assms(1)] assms(2)
unfolding DBM_zone_repr_def by fastforce

lemma neg_cycle_empty:
  assumes "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists> c. v c = k)" "set xs \<subseteq> {0..n}" "i \<le> n" "len M i i xs < \<one>"
  shows "[(M :: ('a :: time) DBM)]\<^bsub>v,n\<^esub> = {}" using assms
by (metis leD not_empty_cyc_free)

abbreviation clock_numbering' :: "('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> bool"
where
  "clock_numbering' v n \<equiv> \<forall> c. v c > 0 \<and> (\<forall>x. \<forall>y. v x \<le> n \<and> v y \<le> n \<and> v x = v y \<longrightarrow> x = y)"

lemma non_empty_dbm_diag_set:
  "clock_numbering' v n \<Longrightarrow> [M]\<^bsub>v,n\<^esub> \<noteq> {} \<Longrightarrow> [M]\<^bsub>v,n\<^esub> = [(\<lambda> i j. if i = j then \<one> else M i j)]\<^bsub>v,n\<^esub>"
proof (auto simp: DBM_zone_repr_def, goal_cases)
  case 1
  { fix c assume A: "v c = 0"
    from 1 have "v c > 0" by auto
    with A have False by auto
  } note * = this
  from 1(1) have [simp]: "Le 0 \<preceq> M 0 0" by (auto simp: DBM_val_bounded_def)
  from 1 show ?case
    apply (auto simp add: DBM_val_bounded_def neutral)
         using * apply meson+
    apply (rename_tac c1 c2)
    apply (case_tac "c1 = c2")
     apply auto
  done
next
  case (2 x xa)
  note G = this
  { fix c assume A: "v c = 0"
    from 2 have "v c > 0" by auto
    with A have False by auto
  } note * = this
  { fix c assume A: "v c \<le> n" "M (v c) (v c) < \<one>"
    with 2(1) have False
      apply (auto simp: neutral DBM_val_bounded_def less)
      apply (cases rule: dbm_lt.cases)
    by fastforce+
  } note ** = this
  from 2(1) have [simp]: "Le 0 \<preceq> M 0 0" by (auto simp: DBM_val_bounded_def)
  from 2 show ?case
  proof (auto simp add: DBM_val_bounded_def neutral, goal_cases)
    case 1 with * show ?case by presburger
    case 2 with * show ?case by presburger
  next
    case (3 c1 c2)
    show ?case
    proof (cases "v c1 = v c2")
      case True
      with 3 have "c1 = c2" by auto
      moreover with **[OF 3(8)] not_less have "M (v c2) (v c2) \<ge> \<one>" by auto
      ultimately show "dbm_entry_val xa (Some c1) (Some c2) (M (v c1) (v c2))" unfolding neutral
      by (cases "M (v c1) (v c2)") (auto simp add: less_eq dbm_le_def, fastforce+)
    next
      case False
      with 3 show ?thesis by presburger
    qed
  qed
qed

lemma non_empty_cycle_free:
  assumes "[M]\<^bsub>v,n\<^esub> \<noteq> {}"
    and "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists>c. v c = k)"
  shows "cycle_free M n"
apply (rule ccontr)
apply (drule negative_cycle_dest_diag)
using DBM_val_bounded_neg_cycle assms unfolding DBM_zone_repr_def by blast

lemma neg_diag_empty:
  assumes "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists>c. v c = k)" "i \<le> n" "M i i < \<one>"
  shows "[M]\<^bsub>v,n\<^esub> = {}"
unfolding DBM_zone_repr_def using DBM_val_bounded_neg_cycle[of v _ M n i "[]"] assms by auto

lemma canonical_empty_zone:
  assumes "\<forall>k\<le>n. 0 < k \<longrightarrow> (\<exists>c. v c = k)" "\<forall>c. v c \<le> n \<longrightarrow> 0 < v c"
    and "canonical M n"
  shows "[M]\<^bsub>v,n\<^esub> = {} \<longleftrightarrow> (\<exists>i\<le>n. M i i < \<one>)"
using FW_detects_empty_zone[OF assms(1,2), of M] FW_canonical_id[OF assms(3)] unfolding neutral
by simp

end


theory Proof_1_2
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_1_2:
"VC2 inv1 s0 hands_value"
  apply(simp only: VC2_def inv1_def R1_def dryer_def)
  apply(rule impI; rule conjI)
proof -
  assume VC: "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands =
    ON"
  show " toEnvP
     (toEnv
       (setPstate
         (setVarBool (setVarAny s0 hands_value)
           (Suc (Suc 0)) ON)
         Ctrl drying)) \<and>
    (\<forall>s1 s2.
        substate s1 s2 \<and>
        substate s2
         (toEnv
           (setPstate
             (setVarBool (setVarAny s0 hands_value)
               (Suc (Suc 0)) ON)
             Ctrl drying)) \<and>
        toEnvP s1 \<and>
        toEnvP s2 \<and>
        toEnvNum s1 s2 = hands \<and>
        getVarBool s1 hands = OFF \<and>
        getVarBool s1 (Suc (Suc 0)) = OFF \<and>
        getVarBool s2 hands = ON \<longrightarrow>
        (\<exists>s4. toEnvP s4 \<and>
              substate s2 s4 \<and>
              substate s4
               (toEnv
                 (setPstate
                   (setVarBool
                     (setVarAny s0 hands_value)
                     (Suc (Suc 0)) ON)
                   Ctrl drying)) \<and>
              toEnvNum s2 s4 \<le> hands \<and>
              getVarBool s4 (Suc (Suc 0)) = ON \<and>
              (\<forall>s3. toEnvP s3 \<and>
                    substate s2 s3 \<and>
                    substate s3 s4 \<and>
                    s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 hands = ON)))"
    apply(rule conjI)
     apply(simp)
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: " substate s1 s2 \<and>
       substate s2
        (toEnv
          (setPstate
            (setVarBool (setVarAny s0 hands_value)
              (Suc (Suc 0)) ON)
            Ctrl drying)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       getVarBool s1 hands = OFF \<and>
       getVarBool s1 (Suc (Suc 0)) = OFF \<and>
       getVarBool s2 hands = ON "
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4
             (toEnv
               (setPstate
                 (setVarBool
                   (setVarAny s0 hands_value)
                   (Suc (Suc 0)) ON)
                 Ctrl drying)) \<and>
            toEnvNum s2 s4 \<le> hands \<and>
            getVarBool s4 (Suc (Suc 0)) = ON \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and>
                  s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 hands = ON)"
    proof cases
      assume 1: "s2 = (toEnv
                     (setPstate
                       (setVarBool
                         (setVarAny s0 hands_value)
                         (Suc (Suc 0)) ON)
                       Ctrl drying))"
      have " (toEnvP s2 \<and>
         substate s2 s2 \<and>
         substate s2
          (toEnv
            (setPstate
              (setVarBool (setVarAny s0 hands_value)
                (Suc (Suc 0)) ON)
              Ctrl drying)) \<and>
         toEnvNum s2 s2 \<le> hands \<and>
         getVarBool s2 (Suc (Suc 0)) = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and>
               s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 hands = ON)"
      proof
        from 1 show "toEnvP s2 \<and>
    substate s2 s2 \<and>
    substate s2
     (toEnv
       (setPstate
         (setVarBool (setVarAny s0 hands_value)
           (Suc (Suc 0)) ON)
         Ctrl drying)) \<and>
    toEnvNum s2 s2 \<le> hands \<and>
    getVarBool s2 (Suc (Suc 0)) = ON" by auto
      next
        from substate_asym show " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
         getVarBool s3 hands = ON"
          by auto
      qed
      thus ?thesis by blast
    next
       assume 1: "s2 \<noteq> (toEnv
                     (setPstate
                       (setVarBool
                         (setVarAny s0 hands_value)
                         (Suc (Suc 0)) ON)
                       Ctrl drying))"
       with req_prems have 2: "substate s2 s0"
         by (simp split: if_splits)
       from VC req_prems 2 obtain "\<exists>s4. toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)"by auto
       then obtain s4 where 3: "toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)" ..
       have "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4
       (toEnv
         (setPstate
           (setVarBool (setVarAny s0 hands_value)
             (Suc (Suc 0)) ON)
           Ctrl drying)) \<and>
      toEnvNum s2 s4 \<le> hands \<and>
      getVarBool s4 (Suc (Suc 0)) = ON \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 hands = ON)"
         using 3 by auto
       thus ?thesis ..
     qed
   qed
     next
assume VC: "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands =
    ON"
  with extra2 show " extraInv
     (toEnv
       (setPstate
         (setVarBool (setVarAny s0 hands_value)
           (Suc (Suc 0)) ON)
         Ctrl drying))"
    by (auto simp add: VC2_def dryer_def)
qed

end


section \<open>Nterm-Fail-Exception-State Monad\<close>
theory Monad
imports
  Basic_Imports ELenses
begin

  section \<open>Additions to Partial Function\<close>
  context partial_function_definitions
  begin
    lemma monotoneI:
      "(\<And>x. mono_body (\<lambda>f. F f x)) \<Longrightarrow> monotone le_fun le_fun F"
      by (auto simp: monotone_def fun_ord_def)

    lemma fp_unfold:
      assumes "f \<equiv> fixp_fun F"
      assumes "(\<And>x. mono_body (\<lambda>f. F f x))"
      shows "f x = F f x"
      using assms mono_body_fixp[of F] by auto

  end

  lemma fun_ordD: "fun_ord le f g \<Longrightarrow> le (f x) (g x)"
    by (auto simp: fun_ord_def)

  lemma fun_ord_mono_alt: "monotone le (fun_ord le') f \<longleftrightarrow> (\<forall>x. monotone le le' (\<lambda>y. f y x))"
    by (metis (mono_tags, lifting) fun_ord_def monotone_def)

  method_setup pf_mono_prover = \<open>Scan.succeed (SIMPLE_METHOD' o Subgoal.FOCUS_PREMS (fn {context=ctxt,...} => CHANGED (ALLGOALS (Partial_Function.mono_tac ctxt))))\<close>

  ML \<open>
    fun discharge_monos ctxt thm = let
      fun aux ctxt thm = let
        val prems = Thm.prems_of thm

        fun prove_simple tac t ctxt = Goal.prove ctxt [] [] t (fn {context=ctxt, ...} => ALLGOALS (tac ctxt))

        (*val mono_tac = Subgoal.FOCUS (fn {context=ctxt,...} => CHANGED (ALLGOALS (Partial_Function.mono_tac ctxt)))*)
        fun mono_tac ctxt = CHANGED o (Partial_Function.mono_tac ctxt)

        fun cinst (t as @{mpat "\<And>_. monotone (fun_ord _) _ _"}) = the_default asm_rl (try (prove_simple mono_tac t) ctxt)
          | cinst _ = asm_rl

        val insts = map cinst prems

        val thm = thm OF insts
      in
        thm
      end
    in
      (* Avoid surprises with schematic variables being instantiated *)
      singleton (Variable.trade (map o aux) ctxt) thm
    end

  \<close>

  attribute_setup discharge_monos
    = \<open>Scan.succeed (Thm.rule_attribute [] (discharge_monos o Context.proof_of))\<close>
    \<open>Try to discharge monotonicity premises\<close>

  section \<open>Monad Definition\<close>

  subsection \<open>Inner Type\<close>
  datatype (discs_sels) ('a,'e,'s,'f) mres = NTERM | FAIL (the_failure: 'f) | EXC 'e (the_state: 's) | SUCC 'a (the_state: 's)
  datatype ('a,'e,'s,'f) M = M (run: "'s \<Rightarrow> ('a,'e,'s,'f) mres")

  abbreviation "map_mres_state f \<equiv> map_mres id id f id"
  abbreviation "map_mres_fail f \<equiv> map_mres id id id f"

  lemma map_mres_state_invert[simp]:
    (*"map_mres_state f m = NTERM \<longleftrightarrow> m = NTERM"*)
    "map_mres_state f m = FAIL msg \<longleftrightarrow> m = FAIL msg"
    "map_mres_state f m = EXC e s \<longleftrightarrow> (\<exists>ss. s=f ss \<and> m = EXC e ss)"
    "map_mres_state f m = SUCC x s \<longleftrightarrow> (\<exists>ss. s=f ss \<and> m = SUCC x ss)"
    by (cases m; auto; fail)+

  lemma map_mres_fail_invert[simp]:
    (*"map_mres_state f m = NTERM \<longleftrightarrow> m = NTERM"*)
    "map_mres_fail f m = FAIL msg \<longleftrightarrow> (\<exists>msg'. msg = f msg' \<and> m = FAIL msg')"
    "map_mres_fail f m = EXC e s \<longleftrightarrow> m = EXC e s"
    "map_mres_fail f m = SUCC x s \<longleftrightarrow> m = SUCC x s"
    by (cases m; auto; fail)+

  lemma M_eqI[intro?]: "\<lbrakk> \<And>s. run m s = run m' s \<rbrakk> \<Longrightarrow> m=m'"
    by (cases m; cases m'; auto)

  subsection \<open>Ordering Structure\<close>
  abbreviation "mres_ord \<equiv> flat_ord NTERM"
  abbreviation "mres_lub \<equiv> flat_lub NTERM"
  abbreviation "mres_mono \<equiv> monotone (fun_ord mres_ord) mres_ord"
  abbreviation "M_ord \<equiv> img_ord run (fun_ord mres_ord)"
  abbreviation "M_lub \<equiv> img_lub run M (fun_lub mres_lub)"
  abbreviation "M_mono \<equiv> monotone (fun_ord M_ord) M_ord"

  interpretation M:
    partial_function_definitions "M_ord" "M_lub"
    apply (intro partial_function_image partial_function_lift flat_interpretation)
    by (auto simp: M.expand)

  subsection \<open>Basic Combinators\<close>

  definition REC where "REC \<equiv> M.fixp_fun"
  definition internal_nterm where "internal_nterm \<equiv> M (\<lambda>_. NTERM)"
  definition fail where "fail msg \<equiv> M (\<lambda>_. FAIL msg)"
  definition return where "return x \<equiv> M (SUCC x)"
  definition bind where "bind m f \<equiv> M (\<lambda>s. case run m s of SUCC x s \<Rightarrow> run (f x) s | NTERM \<Rightarrow> NTERM | FAIL msg \<Rightarrow> FAIL msg | EXC e s \<Rightarrow> EXC e s)"
  definition get where "get \<equiv> M (\<lambda>s. SUCC s s)"
  definition set where "set s \<equiv> M (\<lambda>_. SUCC () s)"
  definition raise where "raise e \<equiv> M (EXC e)"
  definition handle where "handle m h \<equiv> M (\<lambda>s. case run m s of EXC e s \<Rightarrow> run (h e) s | SUCC x s \<Rightarrow> SUCC x s | NTERM \<Rightarrow> NTERM | FAIL msg \<Rightarrow> FAIL msg)"

  definition mblock where "mblock begin end m \<equiv> M (map_mres_state end o run m o begin)"
  definition mfail where "mfail f m \<equiv> M (map_mres_fail f o run m)"

  text \<open>Derived, but required for some laws.\<close>
  definition "map_state f \<equiv> bind get (set o f)"

  section \<open>Syntax\<close>

  abbreviation (do_notation) bind_doI where "bind_doI \<equiv> bind"
  abbreviation (do_notation) then_doI where "then_doI m f \<equiv> bind_doI m (\<lambda>_. f)"

  notation bind_doI (infixr "\<bind>" 54)

  notation then_doI (infixr "\<then>" 54)

  nonterminal doI_binds and doI_bind
  syntax
    "_doI_block" :: "doI_binds \<Rightarrow> 'a" ("doM {//(2  _)//}" [12] 62)
    "_doI_bind"  :: "[pttrn, 'a] \<Rightarrow> doI_bind" ("(2_ \<leftarrow>/ _)" 13)
    "_doI_let" :: "[pttrn, 'a] \<Rightarrow> doI_bind" ("(2let _ =/ _)" [1000, 13] 13)
    "_doI_then" :: "'a \<Rightarrow> doI_bind" ("_" [14] 13)
    "_doI_final" :: "'a \<Rightarrow> doI_binds" ("_")
    "_doI_cons" :: "[doI_bind, doI_binds] \<Rightarrow> doI_binds" ("_;//_" [13, 12] 12)
    (*"_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr "\<then>" 54)*)

  syntax (ASCII)
    "_doI_bind" :: "[pttrn, 'a] \<Rightarrow> doI_bind" ("(2_ <-/ _)" 13)
    (*"_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr ">>" 54)*)

  translations
    "_doI_block (_doI_cons (_doI_then t) (_doI_final e))"
      \<rightleftharpoons> "CONST then_doI t e"

    "_doI_block (_doI_cons (_doI_bind p t) (_doI_final e))"
      \<rightleftharpoons> "CONST bind_doI t (\<lambda>p. e)"

    "_doI_block (_doI_cons (_doI_let p t) bs)"
      \<rightleftharpoons> "let p = t in _doI_block bs"

    "_doI_block (_doI_cons b (_doI_cons c cs))"
      \<rightleftharpoons> "_doI_block (_doI_cons b (_doI_final (_doI_block (_doI_cons c cs))))"

    "_doI_cons (_doI_let p t) (_doI_final s)"
      \<rightleftharpoons> "_doI_final (let p = t in s)"

    "_doI_block (_doI_final e)" \<rightharpoonup> "e"

  section \<open>Monad Laws\<close>

  lemma map_state_laws[simp]:
    "map_state (\<lambda>x. x) = return ()"
    "map_state id = return ()"
    "map_state (\<lambda>_. c) = set c"
    unfolding return_def bind_def map_state_def get_def set_def
    by (auto split: mres.splits)

  lemma bind_laws[simp]:
    "bind m return = m"
    "bind (return x) f = f x"
    "bind (bind m (\<lambda>x. f x)) g = bind m (\<lambda>x. bind (f x) g)"
    "bind (fail msg) f = fail msg"
    "bind (internal_nterm) f = internal_nterm"
    "bind (raise e) f = raise e"
    unfolding bind_def return_def fail_def raise_def internal_nterm_def
    by (cases m; auto split: mres.split)+

  lemma handle_laws[simp]:
    "handle (return x) h = return x"
    "handle (fail msg) h = fail msg"
    "handle (internal_nterm) h = internal_nterm"
    "handle (raise e) h = h e"
    "handle m raise = m"
    "handle (handle m (\<lambda>e. h e)) i = handle m (\<lambda>e. handle (h e) i)"
    unfolding handle_def return_def fail_def raise_def internal_nterm_def
    by ((auto split: mres.split | (cases m; auto split: mres.split)) [])+

  lemma state_laws[simp]:
    "bind get set = return ()"
    "bind get (\<lambda>s. bind (set s) (f s)) = bind get (\<lambda>s. f s ())" (* From Lars Hupel's HOL-Library.State_Monad *)
    "bind (set s) (\<lambda>_. set s') = set s'"
    "bind get (\<lambda>_. m) = m"
    "bind (set s) (\<lambda>_. get) = bind (set s) (\<lambda>_. return s)"

    "handle get h = get"
    "handle (set s) h = set s"
    unfolding handle_def return_def bind_def get_def set_def
    by (auto)

  lemma mblock_laws[simp]:
    "mblock begin end (return x) = doM {map_state (end o begin); return x}"
    "mblock begin end (raise e) = doM {map_state (end o begin); raise e}"
    "mblock begin end (fail msg) = fail msg"
    "mblock begin end (internal_nterm) = internal_nterm"
    "mblock begin end (get) = doM { s\<leftarrow>get; map_state (end o begin); return (begin s) }"
    "mblock begin end (set s) = set (end s)"
    unfolding return_def fail_def raise_def mblock_def bind_def map_state_def get_def set_def internal_nterm_def
    by (auto split: mres.splits del: ext intro!: ext)

  lemma mfail_laws[simp]:
    "mfail f (return x) = return x"
    "mfail f (raise e) = raise e"
    "mfail f (fail msg) = fail (f msg)"
    "mfail f (internal_nterm) = internal_nterm"
    "mfail f (get) = get"
    "mfail f (set s) = set s"
    unfolding return_def fail_def raise_def mfail_def bind_def map_state_def get_def set_def internal_nterm_def
    by (auto split: mres.splits del: ext intro!: ext)

  lemma m_injects[simp]:
    "return x = return x' \<longleftrightarrow> x=x'"
    "raise e = raise e' \<longleftrightarrow> e=e'"
    "fail msg = fail msg' \<longleftrightarrow> msg=msg'"
    unfolding return_def fail_def raise_def
    by (auto dest: fun_cong)

  section \<open>Recursion Setup\<close>

  subsection \<open>Fixed-Point Induction\<close>
  lemma M_admissible_aux:
    assumes "\<forall>x s. PQ x s NTERM"
    shows "M.admissible (\<lambda>f. \<forall>x s. PQ x s (run (f x) s))"
    apply (rule admissible_fun)
    apply unfold_locales
    apply (rule admissible_image)
    apply (rule partial_function_lift)
    apply (rule flat_interpretation)
    using assms
    apply (simp add: comp_def)
    apply (smt ccpo.admissibleI chain_fun flat_lub_in_chain fun_lub_def mem_Collect_eq)
    apply (auto simp: M.expand)
    done

  lemma M_lub_fun_empty[simp]: "M.lub_fun {} x = M (\<lambda>_. NTERM)"
    by (auto simp: img_lub_def fun_lub_def flat_lub_def)

  lemma REC_partial_rule:
    fixes PQ :: "'a \<Rightarrow> 'b \<Rightarrow> ('c, 'd, 'b,'f) mres \<Rightarrow> bool"
      and F :: "('a \<Rightarrow> ('c, 'd, 'b,'f) M) \<Rightarrow> 'a \<Rightarrow> ('c, 'd, 'b,'f) M"
    assumes "f \<equiv> REC F"
        and "\<And>x. M.mono_body (\<lambda>fa. F fa x)"
        and "\<And>x s. PQ x s NTERM"
        and "\<And>f x s. \<lbrakk>\<And>x' s'. PQ x' s' (run (f x') s')\<rbrakk> \<Longrightarrow> PQ x s (run (F f x) s)"
    shows "PQ x s (run (f x) s)"
    using ccpo.fixp_induct[OF M.ccpo M_admissible_aux M.monotoneI, simplified]
    using assms
    unfolding REC_def
    by blast

  declaration \<open>Partial_Function.init "ners" @{term M.fixp_fun}
    @{term M.mono_body} @{thm M.fixp_rule_uc} @{thm M.fixp_induct_uc}
    (NONE)\<close>

  subsection \<open>Well-Founded Induction\<close>
  lemma REC_total_rule:
    fixes PQ :: "'a \<Rightarrow> 'b \<Rightarrow> ('c, 'd, 'b,'f) mres \<Rightarrow> bool"
      and F :: "('a \<Rightarrow> ('c, 'd, 'b,'f) M) \<Rightarrow> 'a \<Rightarrow> ('c, 'd, 'b,'f) M"
    assumes DEF: "f \<equiv> REC F"
        and MONO: "\<And>x. M.mono_body (\<lambda>fa. F fa x)"
        and WF: "wf R"
        and STEP: "\<And>f x s. \<lbrakk>\<And>x' s'. ((x',s'),(x,s))\<in>R \<Longrightarrow> PQ x' s' (run (f x') s')\<rbrakk> \<Longrightarrow> PQ x s (run (F f x) s)"
    shows "PQ x s (run (f x) s)"
    using WF
    apply (induction "(x,s)" arbitrary: x s)
    by (metis DEF M.mono_body_fixp MONO REC_def STEP)

  subsection \<open>Monotonicity Reasoner Setup\<close>

  lemma M_bind_mono[partial_function_mono]:
    assumes mf: "M_mono B" and mg: "\<And>y. M_mono (\<lambda>f. C y f)"
    shows "M_mono (\<lambda>f. bind (B f) (\<lambda>y. C y f))"
    apply (rule monotoneI)
    using monotoneD[OF mf] monotoneD[OF mg]
    unfolding bind_def img_ord_def fun_ord_def
    apply (auto simp: flat_ord_def run_def split!: M.splits mres.splits)
    apply (smt M.collapse M.sel mres.distinct(1) run_def)
    apply (smt M.collapse M.sel mres.distinct(1) mres.inject(1) run_def)
    apply (smt M.collapse M.sel mres.distinct(1) mres.distinct(7) run_def)
    apply (smt M.collapse M.sel mres.distinct(1) mres.distinct(9) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) mres.distinct(7) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) mres.inject(2) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) mres.inject(2) run_def)
    apply (smt M.collapse M.sel mres.distinct(11) mres.distinct(3) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) mres.distinct(9) run_def)
    apply (smt M.collapse M.sel mres.distinct(11) mres.distinct(5) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) mres.inject(3) run_def)
    done

  lemma M_handle_mono[partial_function_mono]:
    assumes mf: "M_mono B" and mg: "\<And>y. M_mono (\<lambda>f. C y f)"
    shows "M_mono (\<lambda>f. handle (B f) (\<lambda>y. C y f))"
    apply (rule monotoneI)
    using monotoneD[OF mf] monotoneD[OF mg]
    unfolding handle_def img_ord_def fun_ord_def
    apply (auto simp: flat_ord_def run_def split!: M.splits mres.splits)
    apply (smt M.collapse M.sel mres.distinct(1) run_def)
    apply (smt M.collapse M.sel mres.distinct(1) mres.inject(1) run_def)
    apply (smt M.collapse M.sel mres.distinct(1) mres.distinct(7) run_def)
    apply (smt M.collapse M.sel mres.distinct(1) mres.distinct(9) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) mres.distinct(7) run_def)
    apply (smt M.collapse M.sel mres.distinct(3) mres.inject(2) run_def)
    apply (smt M.collapse M.sel mres.distinct(11) mres.distinct(3) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) mres.distinct(9) run_def)
    apply (smt M.collapse M.sel mres.distinct(11) mres.distinct(5) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) mres.inject(3) run_def)
    apply (smt M.collapse M.sel mres.distinct(5) mres.inject(3) run_def)
    done

  lemma mblock_mono[partial_function_mono]:
    assumes "M_mono (\<lambda>fa. m fa)"
    shows "M_mono (\<lambda>fa. mblock begin end (m fa))"
    apply (rule monotoneI)
    using monotoneD[OF assms]
    unfolding mblock_def
    unfolding flat_ord_def fun_ord_def img_ord_def
    by simp metis

  lemma mfail_mono[partial_function_mono]:
    assumes "M_mono (\<lambda>fa. m fa)"
    shows "M_mono (\<lambda>fa. mfail f (m fa))"
    apply (rule monotoneI)
    using monotoneD[OF assms]
    unfolding mfail_def
    unfolding flat_ord_def fun_ord_def img_ord_def
    by simp metis

  (*
    TODO: Make this proof generic, in partial_function_definitions or so.
  *)
  lemma REC_mono_aux:
    assumes MONO: "\<And>D. monotone M.le_fun M.le_fun (B D)"
    assumes 1: "monotone M.le_fun (fun_ord M.le_fun) B"
    shows "monotone M.le_fun M.le_fun (\<lambda>D. REC (B D))"
    unfolding REC_def
    apply (rule monotoneI)
    apply (rule ccpo.fixp_lowerbound[OF M.ccpo MONO])
    apply (subst (2) ccpo.fixp_unfold[OF M.ccpo MONO])
    supply R=fun_ordD[of M.le_fun "B x" "B y" for x y]
    apply (rule R)
    apply (rule monotoneD[OF 1])
    .

  lemma REC_mono[partial_function_mono]:
    assumes MONO: "\<And>D x. M.mono_body (\<lambda>E. B D E x)"
    assumes 1: "\<And>E x. M_mono (\<lambda>D. B D E x)"
    shows "M_mono (\<lambda>D. REC (B D) x)"
    using assms REC_mono_aux fun_ord_mono_alt by metis

section \<open>Reasoning Setup\<close>

  subsection \<open>Simplifier Based\<close>
  named_theorems run_simps

  definition "mwp m N F E S \<equiv> case_mres N F E S m"

  lemma mwp_simps[simp]:
    "mwp NTERM N F E S = N"
    "mwp (FAIL msg) N F E S = F msg"
    "mwp (EXC e s) N F E S = E e s"
    "mwp (SUCC x s) N F E S = S x s"
    by (auto simp: mwp_def)

  lemma mwp_cong[cong]: "m=m' \<Longrightarrow> mwp m N F E S = mwp m' N F E S" by simp

  lemma mwp_eq_cases:
    assumes "mwp m N F E S = r"
    assumes "m = NTERM \<Longrightarrow> r = N \<Longrightarrow> thesis"
    assumes "\<And>e. m = FAIL e \<Longrightarrow> r = F e \<Longrightarrow> thesis"
    assumes "\<And>e s. m = EXC e s \<Longrightarrow> r = E e s \<Longrightarrow> thesis"
    assumes "\<And>v s. m = SUCC v s \<Longrightarrow> r = S v s \<Longrightarrow> thesis"
    shows thesis
    using assms unfolding mwp_def by (auto split: mres.splits)

  lemma mwp_invert[simp]:
    "mwp (mwp m N F E S) N' F' E' S' =
      (mwp m
        (mwp N N' F' E' S')
        (\<lambda>x. mwp (F x) N' F' E' S')
        (\<lambda>e s. mwp (E e s) N' F' E' S')
        (\<lambda>x s. mwp (S x s) N' F' E' S')
      )"
    by (auto simp: mwp_def split: mres.splits)

  lemma mwp_eqI[intro!]:
    assumes "m=NTERM \<Longrightarrow> N=N'"
    assumes "\<And>f. m=FAIL f \<Longrightarrow> F f = F' f"
    assumes "\<And>e s. m=EXC e s \<Longrightarrow> E e s = E' e s"
    assumes "\<And>x s. m=SUCC x s \<Longrightarrow> S x s = S' x s"
    shows "mwp m N F E S = mwp m N' F' E' S'"
    using assms by (cases m) auto

  lemma mwp_cons:
    assumes "mwp r N' F' E' S'"
    assumes "N'\<Longrightarrow>N"
    assumes "\<And>msg. F' msg \<Longrightarrow> F msg"
    assumes "\<And>e s. E' e s \<Longrightarrow> E e s"
    assumes "\<And>x s. S' x s \<Longrightarrow> S x s"
    shows "mwp r N F E S"
    using assms by (auto simp: mwp_def split: mres.split)

  lemma mwp_map_mres_state[simp]: "mwp (map_mres_state f s) N F E S = mwp s N F (\<lambda>e s. E e (f s)) (\<lambda>r s. S r (f s))"
    by (cases s) auto

  lemma mwp_triv[simp]:
    "mwp m top top top top"
    "mwp m True (\<lambda>_. True) (\<lambda>_ _. True) (\<lambda>_ _. True)"
    by (cases m; auto; fail)+

  lemma mwp_trivI: "\<lbrakk>N; \<And>f. F f; \<And>e s. E e s; \<And>x s. S x s \<rbrakk> \<Longrightarrow> mwp m N F E S"
    by (cases m; auto)

  lemma flip_run_eq[simp]:
    "SUCC r s' = run c s \<longleftrightarrow> run c s = SUCC r s'"
    "EXC e s' = run c s \<longleftrightarrow> run c s = EXC e s'"
    by auto

  lemma flip_mwp_eq[simp]:
    "SUCC r s' = mwp m N F E S \<longleftrightarrow> mwp m N F E S = SUCC r s'"
    "EXC e s' = mwp m N F E S \<longleftrightarrow> mwp m N F E S = EXC e s'"
    by auto

  lemma basic_run_simps[run_simps]:
    "\<And>s. run (return x) s = SUCC x s"
    "\<And>s. run (fail msg) s = FAIL msg"
    "\<And>s. run (internal_nterm) s = NTERM"
    "\<And>s. run (raise e) s = EXC e s"
    "\<And>s. run (get) s = SUCC s s"
    "\<And>s. run (set s') s = SUCC () s'"
    by (auto simp: return_def fail_def raise_def get_def set_def internal_nterm_def)

  lemma run_Let[run_simps]: "run (let x=v in f x) s = run (f v) s" by auto

  lemma run_bind[run_simps]: "run (bind m f) s
    = (mwp (run m s) NTERM (\<lambda>x. FAIL x) (\<lambda>e s. EXC e s) (\<lambda>x s. run (f x) s))"
    unfolding bind_def mwp_def by simp

  lemma run_handle[run_simps]: "run (handle m h) s
    = (mwp (run m s) NTERM (\<lambda>msg. FAIL msg) (\<lambda>e s. run (h e) s) (\<lambda>x s. SUCC x s))"
    unfolding handle_def mwp_def by simp

  lemma run_mblock[run_simps]: "run (mblock b e m) s = map_mres_state e (run m (b s))"
    unfolding mblock_def by simp

  lemma run_mfail[run_simps]: "run (mfail f m) s = map_mres_fail f (run m s)"
    unfolding mfail_def by simp

  lemma run_map_state[run_simps]: "run (map_state f) s = SUCC () (f s)"
    unfolding map_state_def
    by (simp add: run_simps)

  lemma lrmwpe_REC_partial:
    assumes "f \<equiv> REC F"
        and "run (f x) s = r"
        and "\<And>x. M.mono_body (\<lambda>fa. F fa x)"
        and "\<And>x s. P x s NTERM"
        and "\<And>f x s r. \<lbrakk>\<And>x' s' r'. run (f x') s' = r' \<Longrightarrow> P x' s' r'; run (F f x) s = r \<rbrakk> \<Longrightarrow> P x s r"
    shows "P x s r"
  proof -
    note A = assms
    show ?thesis
      apply (rule REC_partial_rule[OF A(1,3), where PQ=P, of x s, unfolded A(2)])
      apply fact
      by (rule A(5)) auto
  qed

  lemma lrmwpe_REC_total:
    assumes "f \<equiv> REC F"
        and "run (f x) s = r"
        and "\<And>x. M.mono_body (\<lambda>fa. F fa x)"
        and "wf R"
        and "\<And>f x s r. \<lbrakk>\<And>x' s' r'. \<lbrakk>run (f x') s' = r'; ((x',s'), (x,s))\<in>R\<rbrakk> \<Longrightarrow> P x' s' r'; run (F f x) s = r \<rbrakk> \<Longrightarrow> P x s r"
    shows "P x s r"
  proof -
    note A = assms
    show ?thesis
      apply (rule REC_total_rule[OF A(1,3,4), where PQ=P, of x s, unfolded A(2)])
      by (rule A(5)) auto
  qed

  lemma mwp_inductI:
    assumes "\<And>r. run m s = r \<Longrightarrow> mwp r N F E S"
    shows "mwp (run m s) N F E S"
    using assms by auto

  subsection \<open>Simulation\<close>

  definition "sim m m' \<equiv> \<forall>s. mwp (run m s) top top (\<lambda>e s'. run m' s = EXC e s') (\<lambda>x s'. run m' s = SUCC x s')"

  named_theorems sim_rules

  lemma sim_refl[intro!,simp]: "sim m m"
    unfolding sim_def mwp_def by (auto split: mres.split)

  lemma sim_fail[sim_rules]: "sim (fail msg) m'"
    unfolding sim_def fail_def by auto

  lemma sim_internal_nterm[sim_rules]: "sim (internal_nterm) m'"
    unfolding sim_def internal_nterm_def by auto

  lemma sim_return[sim_rules]: "x=x' \<Longrightarrow> sim (return x) (return x')"
    by (auto simp: sim_def run_simps)

  lemma sim_get[sim_rules]: "sim get get"
    by (auto simp: sim_def run_simps)

  lemma sim_set[sim_rules]: "s=s' \<Longrightarrow> sim (set s) (set s')"
    by (auto simp: sim_def run_simps)

  lemma sim_REC:
    assumes DEF: "f \<equiv> REC F"
    assumes DEF': "f' \<equiv> REC F'"
    assumes MONO: "\<And>x. M.mono_body (\<lambda>f. F f x)" "\<And>x. M.mono_body (\<lambda>f. F' f x)"
    assumes SIM: "\<And>f f' x. (\<And>x. sim (f x) (f' x)) \<Longrightarrow> sim (F f x) (F' f' x)"
    shows "sim (f x) (f' x)"
    unfolding sim_def apply clarify
  proof (rule mwp_inductI)
    fix s r
    assume "run (f x) s = r"
    then show "mwp r top top (\<lambda>e s'. run (f' x) s = EXC e s') (\<lambda>xa s'. run (f' x) s = SUCC xa s')"
    proof (induction rule: lrmwpe_REC_partial[OF DEF _ MONO(1), consumes 1, case_names nterm step])
      case (nterm x s)
      then show ?case by simp
    next
      case (step f x s r)
      then show ?case
        apply (clarsimp)
        apply (subst REC_unfold[OF DEF' MONO(2)])
        apply (subst (2) REC_unfold[OF DEF' MONO(2)])
        using SIM[of f f' x]
        apply (auto simp: sim_def)
        done
    qed
  qed

  lemma sim_bind[sim_rules]:
    assumes "sim m m'" assumes "\<And>x. sim (f x) (f' x)"
    shows "sim (bind m f) (bind m' f')"
    using assms
    unfolding sim_def
    by (fastforce simp: run_simps mwp_def split: mres.splits)

  lemma sim_handle[sim_rules]:
    assumes "sim m m'" assumes "\<And>x. sim (h x) (h' x)"
    shows "sim (handle m h) (handle m' h')"
    using assms
    unfolding sim_def
    by (fastforce simp: run_simps mwp_def split: mres.splits)

  lemma sim_mblock[sim_rules]:
    "sim m m' \<Longrightarrow> sim (mblock begin end m) (mblock begin end m')"
    unfolding sim_def
    by (auto simp: run_simps mwp_def split: mres.splits)

  lemma sim_mfail[sim_rules]:
    "sim m m' \<Longrightarrow> sim (mfail fm m) (mfail fm m')"
    unfolding sim_def
    by (auto simp: run_simps mwp_def split: mres.splits)

section \<open>Integration of Lenses\<close>

subsection \<open>Monadic mblock\<close>
definition "mmblock begin end m \<equiv> doM {
  s' \<leftarrow> begin;
  s \<leftarrow> get;
  (x,s') \<leftarrow> handle (
    mblock (\<lambda>_. s') (\<lambda>_. s) (
      handle
        (doM { x\<leftarrow>m; s'\<leftarrow>get; return (x,s') })
        (\<lambda>e. doM { s'\<leftarrow>get; raise (e,s') })
    )
  ) (\<lambda>(e,s'). doM { end s'; raise e });

  end s';
  return x
}"

lemma run_mmblock[run_simps]:
  "run (mmblock begin end m) s = mwp (run begin s) NTERM FAIL EXC
    (\<lambda>s' s. mwp (run m s')
      NTERM
      FAIL
      (\<lambda>e s'. mwp (run (end s') s) NTERM FAIL EXC (\<lambda>_ s. EXC e s))
      (\<lambda>x s'. mwp (run (end s') s) NTERM FAIL EXC (\<lambda>_ s. SUCC x s))
    )"
  by (auto simp add: mmblock_def run_simps mwp_def cong del: mwp_cong split: prod.splits mres.splits)

lemma mmblock_mono[partial_function_mono]:
  "monotone M.le_fun M_ord m \<Longrightarrow> monotone M.le_fun M_ord (\<lambda>f. mmblock begin end (m f))"
  unfolding mmblock_def
  by pf_mono_prover

subsection \<open>Lifting from Sum-Type\<close>
definition "lift_sum m \<equiv> case m of Inl f \<Rightarrow> fail f | Inr x \<Rightarrow> return x"

lemma lift_sum_simps[simp]:
  "lift_sum (Inl f) = fail f"
  "lift_sum (Inr x) = return x"
  by (auto simp: lift_sum_def)

lemma run_lift_sum[run_simps]:
  "run (lift_sum m) s = (case m of Inl f \<Rightarrow> FAIL f | Inr x \<Rightarrow> SUCC x s)"
  by (auto simp: lift_sum_def run_simps split: sum.splits)

subsection \<open>Lifting Lenses\<close>

definition "mget L s \<equiv> lift_sum (eget L s)"
definition "mput L x s \<equiv> lift_sum (eput L x s)"

definition "use L \<equiv> doM { s\<leftarrow>get; mget L s }"
definition assign (infix "::=" 51) where "assign L x \<equiv> doM { s\<leftarrow>get; s\<leftarrow>mput L x s; set s }"

(*
definition "eget_cases L a f1 f2 \<equiv> case eget L a of Inr b \<Rightarrow> f1 b | Inl e \<Rightarrow> f2 e"

lemma eget_cases_split:
  "P (eget_cases L a f1 f2) \<longleftrightarrow> (epre_get L a \<longrightarrow> P (f1 (eget' L a))) \<and> (\<forall>e. eget L a = Inl e \<longrightarrow> P (f2 e))"
  unfolding eget_cases_def by (auto split: sum.split)

lemma eget_cases_split_asm:
  "P (eget_cases L a f1 f2) \<longleftrightarrow> \<not> ((epre_get L a \<and> \<not>P (f1 (eget' L a))) \<or> (\<exists>e. eget L a = Inl e \<and> \<not> P (f2 e)))"
  apply (subst eget_cases_split[of P]) by blast

definition "eput_cases L b a f1 f2 \<equiv> case eput L b a of Inr a \<Rightarrow> f1 a | Inl e \<Rightarrow> f2 e"

lemma eput_cases_split:
  "P (eput_cases L b a f1 f2) \<longleftrightarrow> (epre_put_single_point L b a \<longrightarrow> P (f1 (eput' L b a))) \<and> (\<forall>e. eput L b a = Inl e \<longrightarrow> P (f2 e))"
  unfolding eput_cases_def
  by (auto split: sum.split simp: eput_Inr_conv_sp)

lemma eput_cases_split_asm:
  "P (eput_cases L b a f1 f2) \<longleftrightarrow> \<not>((epre_put_single_point L b a \<and> \<not> P (f1 (eput' L b a))) \<or> (\<exists>e. eput L b a = Inl e \<and> \<not> P (f2 e)))"
  apply (subst eput_cases_split[of P]) by blast

lemmas epg_splits = eget_cases_split eget_cases_split_asm eput_cases_split eput_cases_split_asm
*)

abbreviation (input) "eget_cases L s f1 f2 \<equiv> case epre_get L s of None \<Rightarrow> f1 (eget' L s) | Some e \<Rightarrow> f2 e"
abbreviation (input) "eput_cases L x s f1 f2 \<equiv> case epre_put L x s of None \<Rightarrow> f1 (eput' L x s) | Some e \<Rightarrow> f2 e"

lemma run_mget[run_simps]:
  "run (mget L s) xx = (eget_cases L s (\<lambda>x. SUCC x xx) (FAIL))"
  by (auto simp: mget_def run_simps split: sum.splits option.splits)

lemma run_mput[run_simps]:
  "elens L \<Longrightarrow> run (mput L x s) xx = (eput_cases L x s (\<lambda>x. SUCC x xx) FAIL)"
  by (auto simp: mput_def run_simps split: sum.splits option.splits)

lemma run_use[run_simps]:
  "elens L \<Longrightarrow> run (use L) s = (eget_cases L s (\<lambda>x. SUCC x s) FAIL)"
  by (auto simp: use_def run_simps)

lemma run_assign[run_simps]:
  "elens L \<Longrightarrow> run (assign L x) s = eput_cases L x s (SUCC ()) FAIL"
  by (auto simp: assign_def run_simps split: option.splits)

definition "zoom L m \<equiv> mmblock (use L) (assign L) m"

lemma run_zoom[run_simps]:
  assumes [simp]: "elens L"
  shows
  "run (zoom L m) s = (
    eget_cases L s
      (\<lambda>ss. mwp (run m ss) NTERM FAIL (\<lambda>e ss. EXC e (eput' L ss s)) (\<lambda>x ss. SUCC x (eput' L ss s)))
      FAIL
    )"
  by (auto simp: zoom_def run_simps split: option.splits)

lemma zoom_mono[partial_function_mono]:
  "monotone M.le_fun M_ord m \<Longrightarrow> monotone M.le_fun M_ord (\<lambda>f. zoom L (m f))"
  unfolding zoom_def
  by pf_mono_prover

lemma zoom_get_is_use[simp]: "elens L \<Longrightarrow> zoom L get = use L"
  apply (rule)
  apply (auto simp: run_simps split: option.split)
  done

lemma zoom_set_is_assign[simp]: "ehlens L \<Longrightarrow> zoom L (set x) = (L ::= x)"
  apply (rule)
  apply (auto simp: run_simps split: option.split)
  done

lemma zoom_comp_eq[simp]: "\<lbrakk>elens L\<^sub>1; elens L\<^sub>2\<rbrakk> \<Longrightarrow> zoom (L\<^sub>1 \<bullet> L\<^sub>2) f = zoom L\<^sub>1 (zoom L\<^sub>2 f)"
  apply rule
  apply (auto simp: run_simps split: option.split)
  done

(* TODO: Move
   TODO/FIXME: Simplifier should derive this on its own! *)
lemma eget_put_pre: "elens L \<Longrightarrow> epre_put L x s = None \<Longrightarrow> epre_get L (eput' L x s) = None"
  by (metis (mono_tags, lifting) LENS_downstage(1) epre_get_def lens.simp_rls(4) lower_epre_put' lower_get_def lower_invert(1) lower_lens_def not_None_eq pre_eq_conv(2))

lemma zoom_return: "\<lbrakk>elens L\<rbrakk> \<Longrightarrow> zoom L (return x) = use L\<then>return x"
  apply (rule M_eqI)
  apply (auto simp: run_simps eget_put_pre split: option.split)
  done

lemma zoom_bind: "elens L \<Longrightarrow> zoom L (m\<bind>f) = zoom L m \<bind> zoom L o f"
  apply (rule M_eqI)
  apply (auto simp: run_simps eget_put_pre split: option.split)
  done

definition "ap_state f \<equiv> doM {s\<leftarrow>get; set (f s)}"
definition ap_lens (infix "%=" 51) where "ap_lens L f \<equiv> zoom L (ap_state f)"

lemma run_ap_state[run_simps]: "run (ap_state f) s = SUCC () (f s)"
  by (auto simp: ap_state_def run_simps)

lemma run_ap_lens[run_simps]: "elens L
  \<Longrightarrow> run (L%=f) s = (eget_cases L s (\<lambda>ss. SUCC () (eput' L (f ss) s)) FAIL)"
  by (auto simp: ap_lens_def run_simps split: option.splits)

definition "map_lens L f s \<equiv> doM {
  x \<leftarrow> mget L s;
  x \<leftarrow> f x;
  mput L x s
}"

thm run_simps

lemma run_map_lens[run_simps]:
  "elens L \<Longrightarrow> run (map_lens L f a) s = (
    eget_cases L a (\<lambda>b.
      mwp (run (f b) s) NTERM FAIL EXC (\<lambda>b s. SUCC (eput' L b a) s))
    ) FAIL"
  by (auto simp add: map_lens_def run_simps split: option.splits)

(* For presentation in paper *)

definition "noexc m \<equiv> \<forall>s. run m s \<noteq> NTERM \<and> \<not>is_EXC (run m s)"

lemma "elens L \<Longrightarrow> use L = zoom L get" by simp
lemma "ehlens L \<Longrightarrow> (L ::= x) = (zoom L (set x))" by simp

section \<open>Derived Constructs\<close>

subsection \<open>While\<close>

  definition "mwhile b f \<equiv> REC (\<lambda>mwhile \<sigma>. doM { ctd \<leftarrow> b \<sigma>; if ctd then doM {\<sigma>\<leftarrow>f \<sigma>; mwhile \<sigma> } else return \<sigma> })"
  abbreviation "mwhile' b f \<equiv> mwhile (\<lambda>_::unit. b) (\<lambda>_. f) ()"

  lemma sim_mwhile[sim_rules]:
    "\<lbrakk>\<And>\<sigma>. sim (b \<sigma>) (b' \<sigma>); \<And>\<sigma>. sim (f \<sigma>) (f' \<sigma>)\<rbrakk> \<Longrightarrow> sim (mwhile b f \<sigma>) (mwhile b' f' \<sigma>)"
    by (auto intro!: sim_rules sim_REC[OF mwhile_def mwhile_def, discharge_monos])

  lemma mwhile_mono[partial_function_mono]:
    assumes "\<And>x. M_mono (\<lambda>f. b f x)"
    assumes "\<And>x. M_mono (\<lambda>f. c f x)"
    shows "M_mono (\<lambda>D. mwhile (b D) (c D) \<sigma>)"
    supply assms[partial_function_mono]
    unfolding mwhile_def
    by pf_mono_prover

  lemma mwhile_invar_rule:
    assumes LR: "run (mwhile b f \<sigma>) s = r"
    assumes NTERM: "P NTERM"
    assumes INIT: "I \<sigma> s"
    assumes STEP: "\<And>\<sigma> s. \<lbrakk>I \<sigma> s\<rbrakk>
      \<Longrightarrow> mwp (run (b \<sigma>) s)
              True
              (\<lambda>msg. P (FAIL msg))
              (\<lambda>e s. P (EXC e s) )
              (\<lambda>ctd s. if ctd then (
                  mwp (run (f \<sigma>) s) True (\<lambda>msg. P (FAIL msg)) (\<lambda>e s. P (EXC e s)) I)
                else P (SUCC \<sigma> s) ) "
    shows "P r"
  proof -
    from LR INIT show ?thesis
    proof (induction rule: lrmwpe_REC_partial[OF mwhile_def, discharge_monos, consumes 1, case_names nterm step])
      case (nterm x s)
      then show ?case by (simp add: NTERM)
    next
      case (step while x s r)
      then show ?case
        using STEP[OF \<open>I x s\<close>]
        by (auto simp: run_simps mwp_def NTERM split: mres.splits)
    qed
  qed

  lemmas mwhile_unfold[code] = REC_unfold[OF mwhile_def, discharge_monos]

subsection \<open>Check\<close>
  definition "fcheck e \<phi> \<equiv> if \<phi> then return () else fail e"

  lemma fcheck_laws[simp]:
    "fcheck e True = return ()"
    "fcheck e False = fail e"
    by (auto simp: fcheck_def)

  lemma run_fcheck[run_simps]: "run (fcheck f \<Phi>) s = (if \<Phi> then SUCC () s else FAIL f)"
    by (auto simp: fcheck_def run_simps)

subsection \<open>Fold\<close>
  fun mfold where
    "mfold f [] s = return s"
  | "mfold f (x#xs) s = doM {
      s \<leftarrow> f x s;
      mfold f xs s
  }"

  abbreviation "mfold' f xs \<equiv> mfold (\<lambda>x _. f x) xs ()"

  lemma mfold_sim[sim_rules]:
    assumes [sim_rules]: "\<And>x s. sim (f x s) (f' x s)"
    shows "sim (mfold f xs s) (mfold f' xs s)"
    apply (induction xs arbitrary: s)
    apply (auto intro!: sim_rules)
    done

  lemma mfold_mono[partial_function_mono]:
    assumes [partial_function_mono]: "\<And>a \<sigma>. M_mono (\<lambda>fa. f fa a \<sigma>)"
    shows "M_mono (\<lambda>D. mfold (f D) l \<sigma>)"
  proof (induction l arbitrary: \<sigma>)
    case Nil
    then show ?case by simp pf_mono_prover
  next
    case [partial_function_mono]: (Cons a l)
    show ?case
      by simp pf_mono_prover
  qed

subsection \<open>Map\<close>

fun mmap where
  "mmap _ [] = return []"
| "mmap f (x#xs) = doM { x\<leftarrow>f x; xs\<leftarrow>mmap f xs; return (x#xs) }"

lemma mmap_sim[sim_rules]:
  assumes "\<And>x. x\<in>list.set xs \<Longrightarrow> sim (f x) (f' x)"
  shows "sim (mmap f xs) (mmap f' xs)"
  using assms
  apply (induction xs)
  by (auto intro!: sim_rules)

lemma mmap_mono[partial_function_mono]:
  assumes [partial_function_mono]: "\<And>a. M_mono (\<lambda>fa. f fa a)"
  shows "M_mono (\<lambda>D. mmap (f D) xs)"
proof (induction xs)
  case Nil
  then show ?case by simp pf_mono_prover
next
  case [partial_function_mono]: (Cons a xs)
  show ?case by simp pf_mono_prover
qed

lemma run_mmap_unit_state_idxD:
  assumes "run (mmap f xs) () = SUCC ys ()"
  assumes "i<length xs"
  shows "run (f (xs!i)) () = SUCC (ys!i) ()"
  using assms apply (induction xs arbitrary: i ys)
  by (auto simp: run_simps nth_Cons split: nat.splits elim!: mwp_eq_cases)

lemma run_mmap_length_eq:
  assumes "run (mmap f xs) s = SUCC ys s'"
  shows "length ys = length xs"
  using assms apply (induction xs arbitrary: ys s)
  by (auto simp: run_simps elim!: mwp_eq_cases)

lemma run_mmap_unit_state_elemD:
  assumes "run (mmap f xs) () = SUCC ys ()"
  assumes "x\<in>List.set xs"
  shows "\<exists>y\<in>List.set ys. run (f x) () = SUCC y ()"
  using assms
  by (auto simp: in_set_conv_nth Bex_def run_mmap_unit_state_idxD run_mmap_length_eq)

lemma run_mmap_append[run_simps]:
  "run (mmap f (xs@ys)) s = mwp (run (mmap f xs) s) NTERM FAIL EXC (\<lambda>rxs s.
  mwp (run (mmap f ys) s) NTERM FAIL EXC (\<lambda>rys s. SUCC (rxs@rys) s))"
  apply (induction xs arbitrary: s)
  apply (auto simp: run_simps mwp_def split: mres.splits)
  done

(* TODO: What are good rules for mmap ? *)

subsection \<open>Lookup\<close>

  definition "lookup f m s \<equiv> case m s of None \<Rightarrow> fail f | Some x \<Rightarrow> return x"

  lemma run_lookup[run_simps]:
    "run (lookup f m k) s = (case m k of None \<Rightarrow> FAIL f | Some v \<Rightarrow> SUCC v s)"
    by (auto simp: lookup_def run_simps split: option.splits)

  lemma lookup_sim[sim_rules]:
    assumes "\<pi> \<subseteq>\<^sub>m \<pi>'"
    shows "sim (lookup f \<pi> x2) (lookup f' \<pi>' x2)"
    using map_leD[OF assms]
    by (auto simp: sim_def run_simps split: option.split)

subsection \<open>Hiding too generic Names\<close>

hide_const (open) get set M.M

end