(*  Author:     Gertrud Bauer, Tobias Nipkow
*)

header {* Properties of Lower Bound Machinery *}

theory ScoreProps
imports ListSum TameEnum PlaneProps TameProps
begin

lemma deleteAround_empty[simp]: "deleteAround g a [] = []"
by (simp add: deleteAround_def)

lemma deleteAroundCons:
  "deleteAround g a (p#ps) =
    (if fst p \<in> {v. \<exists>f \<in> set (facesAt g a).
               (length (vertices f) = 4) \<and> v \<in> {f \<bullet> a, f \<bullet> (f \<bullet> a)}
             \<or> (length (vertices f) \<noteq> 4) \<and> (v = f \<bullet> a)}
     then deleteAround g a ps
     else p#deleteAround g a ps)"
by (fastforce simp: nextV2 deleteAround_def)

lemma deleteAround_subset: "set (deleteAround g a ps) \<subseteq> set ps"
by (simp add: deleteAround_def)

lemma distinct_deleteAround: "distinct (map fst ps) \<Longrightarrow>
    distinct (map fst (deleteAround g (fst (a, b)) ps))"
proof (induct ps)
  case Nil then show ?case by simp
next
  case (Cons p ps)
  then have "fst p \<notin> fst ` set ps" by simp
  moreover have "set (deleteAround g a ps) \<subseteq> set ps"
    by (rule deleteAround_subset)
  ultimately have "fst p \<notin> fst ` set (deleteAround g a ps)" by auto

  moreover from Cons have "distinct (map fst ps)" by simp
  then have "distinct (map fst (deleteAround g (fst (a, b)) ps))"
    by (rule Cons)
  ultimately show ?case by (simp add: deleteAroundCons)
qed

definition deleteAround' :: "graph \<Rightarrow> vertex \<Rightarrow> (vertex \<times> nat) list \<Rightarrow>
    (vertex \<times> nat) list" where
  "deleteAround' g v ps \<equiv>
      let fs = facesAt g v;
      vs = (\<lambda>f. let n1 = f \<bullet> v;
                n2 = f \<bullet> n1 in
                if length (vertices f) = 4 then [n1, n2] else [n1]);
      ws = concat (map vs fs) in
      removeKeyList ws ps"

lemma deleteAround_eq: "deleteAround g v ps = deleteAround' g v ps"
apply (auto simp add: deleteAround_def deleteAround'_def split: split_if_asm)
apply (unfold nextV2[THEN eq_reflection], simp)
done

lemma deleteAround_nextVertex:
  "f \<in> set (facesAt g a) \<Longrightarrow>
  (f \<bullet> a, b) \<notin> set (deleteAround g a ps)"
by (auto simp add: deleteAround_eq deleteAround'_def removeKeyList_eq)

lemma deleteAround_nextVertex_nextVertex:
  "f \<in> set (facesAt g a) \<Longrightarrow> |vertices f| = 4 \<Longrightarrow>
  (f \<bullet> (f \<bullet> a), b) \<notin> set (deleteAround g a ps)"
by (auto simp add: deleteAround_eq deleteAround'_def removeKeyList_eq)

lemma deleteAround_prevVertex:
  "minGraphProps g \<Longrightarrow> a : \<V> g \<Longrightarrow> f \<in> set (facesAt g a) \<Longrightarrow>
  (f\<^bsup>-1\<^esup> \<bullet> a, b) \<notin> set (deleteAround g a ps)"
proof -
  assume a: "minGraphProps g" "a : \<V> g" "f \<in> set (facesAt g a)"
  have "(f\<^bsup>-1\<^esup> \<bullet> a, a) \<in> \<E> f" using a
    by(blast intro:prevVertex_in_edges minGraphProps)
  then obtain f' :: face where f': "f' \<in> set(facesAt g a)"
    and e: "(a, f\<^bsup>-1\<^esup> \<bullet> a) \<in> \<E> f'"
    using a by(blast dest:mgp_edge_face_ex)
  have "(f' \<bullet> a, b) \<notin> set (deleteAround g a ps)" using f'
    by (auto simp add: deleteAround_eq deleteAround'_def removeKeyList_eq)
  moreover have "f' \<bullet> a = f\<^bsup>-1\<^esup> \<bullet> a"
    using e by (simp add:edges_face_eq)
  ultimately show ?thesis by simp
qed

lemma deleteAround_separated:
assumes mgp: "minGraphProps g" and fin: "final g" and ag: "a : \<V> g" and 4: "|vertices f| \<le> 4"
and f: "f \<in> set(facesAt g a)"
shows "\<V> f \<inter> set [fst p. p \<leftarrow> deleteAround g a ps] \<subseteq> {a}" (is "?A")
proof -
  note MGP = mgp ag f
  have af: "a \<in> \<V> f" using MGP by(blast intro:minGraphProps)
  have "2 < |vertices f|" using MGP by(blast intro:minGraphProps)
  with 4 have "|vertices f| = 3 \<or> |vertices f| = 4" by arith
  then show "?A"
  proof
    assume 3: "|vertices f| = 3"
    show "?A"
    proof (rule ccontr)
      assume "\<not> ?A"
      then obtain b where b1: "b \<noteq> a" "b \<in> \<V> f"
        "b \<in> set (map fst (deleteAround g a ps))" by auto
      from MGP have d: "distinct (vertices f)"
        by(blast intro:minGraphProps)
      with af 3 have "\<V> f = {a, f \<bullet> a, f \<bullet> (f \<bullet> a)}"
          by (rule_tac vertices_triangle)
      also from d af 3 have
        "f \<bullet> (f \<bullet> a) = f\<^bsup>-1\<^esup> \<bullet> a"
        by (simp add: triangle_nextVertex_prevVertex)
      finally have
        "b \<in> {f \<bullet> a, f\<^bsup>-1\<^esup> \<bullet> a}"
        using b1 by simp
      with MGP have "b \<notin> set (map fst (deleteAround g a ps))"
      using deleteAround_nextVertex deleteAround_prevVertex by auto
      then show False by contradiction (rule b1)
    qed
  next
    assume 4: "|vertices f| = 4"
    show "?A"
    proof (rule ccontr)
      assume "\<not> ?A"
      then obtain b where b1: "b \<noteq> a" "b \<in> \<V> f"
        "b \<in> set (map fst (deleteAround g a ps))" by auto
      from MGP have d: "distinct (vertices f)" by(blast intro:minGraphProps)
      with af 4 have "\<V> f = {a, f \<bullet> a, f \<bullet> (f \<bullet> a), f \<bullet> (f \<bullet> (f \<bullet> a))}"
        by (rule_tac vertices_quad)
      also from d af 4 have "f \<bullet> (f \<bullet> (f \<bullet> a)) = f\<^bsup>-1\<^esup> \<bullet> a"
        by (simp add: quad_nextVertex_prevVertex)
      finally have "b \<in> {f \<bullet> a, f \<bullet> (f \<bullet> a), f\<^bsup>-1\<^esup> \<bullet> a}"
      using b1 by simp
      with MGP 4 have "b \<notin> set (map fst (deleteAround g a ps))"
      using deleteAround_nextVertex deleteAround_prevVertex
           deleteAround_nextVertex_nextVertex by auto
      then show False by contradiction (rule b1)
    qed
  qed
qed
(*
deleteAround g y loescht nextVertex f a,
nextVertex f (nextVertex f a),
prevVertex f a wird mit nachbarflaeche geloescht.
*)

lemma separated_insert:
assumes mgp: "minGraphProps g" and a: "a \<in> \<V> g"
  and Vg: "V <= \<V> g"
  and ps: "separated g V"
  and s2: "(\<And>f. f \<in> set (facesAt g a) \<Longrightarrow> f \<bullet> a \<notin> V)"
  and s3: "(\<And>f. f \<in> set (facesAt g a) \<Longrightarrow>
      |vertices f| \<le> 4 \<Longrightarrow> \<V> f \<inter> V \<subseteq> {a})"
  shows "separated g (insert a V)"
proof (simp add: separated_def separated\<^sub>2_def separated\<^sub>3_def,
 intro conjI ballI impI)
  fix f assume f: "f \<in> set (facesAt g a)"
  then show "f \<bullet> a \<noteq> a" by (rule mgp_facesAt_no_loop[OF mgp a])
  from f show "f \<bullet> a \<notin> V" by (rule s2)
next
  fix f v assume v: "f \<in> set (facesAt g v)" and vV: "v \<in> V"
  have "v : \<V> g" using vV Vg by blast
  show "f \<bullet> v \<noteq> a"
  proof
    assume f: "f \<bullet> v = a"
    then obtain f' where f': "f' \<in> set(facesAt g a)" and v: "f' \<bullet> a = v"
      using mgp_nextVertex_face_ex2[OF mgp `v : \<V> g` v] by blast
    have "f' \<bullet> a \<in> V" using v vV by simp
    with f' s2 show False by blast
  qed
  from ps v vV show "f \<bullet> v \<notin> V"
    by (simp add: separated_def separated\<^sub>2_def)
next
  fix f assume f:  "f \<in> set (facesAt g a)" "|vertices f| \<le> 4"
  then have "\<V> f \<inter> V \<subseteq> {a}" by (rule s3)
  moreover from mgp a f have "a \<in> \<V> f" by(blast intro:minGraphProps)
  ultimately show "\<V> f \<inter> insert a V = {a}" by auto
next
  fix v f
  assume a: "v \<in> V" "f \<in> set (facesAt g v)"
    "|vertices f| \<le> 4"
  with ps have v: "\<V> f \<inter> V = {v}"
    by (simp add: separated_def separated\<^sub>3_def)
  have "v : \<V> g" using a Vg by blast
  show  "\<V> f \<inter> insert a V = {v}"
  proof cases
    assume "a = v"
    with v mgp a show ?thesis by(blast intro:minGraphProps)
  next
    assume n: "a \<noteq> v"
    have  "a \<notin> \<V> f"
    proof
      assume a2: "a \<in> \<V> f"
      with mgp a `v : \<V> g` have "f \<in> \<F> g" by(blast intro:minGraphProps)
      with mgp a2 have "f \<in> set (facesAt g a)" by(blast intro:minGraphProps)
      with a have "\<V> f \<inter> V \<subseteq> {a}" by (simp add: s3)
      with v have "a = v" by auto
      with n show False by auto
    qed
    with a  v show "\<V> f \<inter> insert a V = {v}" by blast
  qed
qed

function ExcessNotAtRecList :: "(vertex, nat) table \<Rightarrow> graph \<Rightarrow> vertex list" where
  "ExcessNotAtRecList [] = (%g. [])"
  | "ExcessNotAtRecList ((x, y) # ps) = (%g.
      let l1 = ExcessNotAtRecList ps g;
      l2 = ExcessNotAtRecList (deleteAround g x ps) g in
      if ExcessNotAtRec ps g
       \<le> y + ExcessNotAtRec (deleteAround g x ps) g
      then x # l2 else l1)"
by pat_completeness auto
termination by (relation "measure size")
  (auto simp add: less_Suc_eq_le length_deleteAround)

lemma isTable_deleteAround:
  "isTable E vs ((a,b)#ps) \<Longrightarrow> isTable E vs (deleteAround g a ps)"
by (rule isTable_subset, rule deleteAround_subset,
    rule isTable_Cons)

lemma ListSum_ExcessNotAtRecList:
 "isTable E vs ps \<Longrightarrow> ExcessNotAtRec ps g
  = (\<Sum>\<^bsub>p \<in> ExcessNotAtRecList ps g\<^esub> E p)" (is "?T ps \<Longrightarrow> ?P ps")
proof (induct ps rule: ExcessNotAtRecList.induct)
  case 1 show ?case by simp
next
  case (2 a b ps)
  from 2 have prem: "?T ((a,b)#ps)" by blast
  then have E: "b = E a" by (simp add: isTable_eq)
  from 2 have hyp1: "?T (deleteAround g a ps) \<Longrightarrow>
   ?P (deleteAround g a ps)" by blast
  from 2 have hyp2:  "?T ps \<Longrightarrow> ?P ps" by blast
  have H1: "?P (deleteAround g a ps)"
    by (rule hyp1, rule isTable_deleteAround) (rule prem)
  have H2: "?P ps" by (rule hyp2, rule isTable_Cons, rule prem)
  show "?P ((a,b)#ps)"
  proof cases
    assume
    "ExcessNotAtRec ps g
    \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    with H1 E show ?thesis
      by (simp add: max_def split: split_if_asm)
  next
    assume "\<not> ExcessNotAtRec ps g
       \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    with H2 E show ?thesis
      by (simp add: max_def split: split_if_asm)
  qed
qed

lemma ExcessNotAtRecList_subset:
  "set (ExcessNotAtRecList ps g) \<subseteq> set [fst p. p \<leftarrow> ps]" (is "?P ps")
proof (induct ps rule: ExcessNotAtRecList.induct)
  case 1 show ?case by simp
next
  case (2 a b ps)
  presume H1: "?P (deleteAround g a ps)"
  presume H2: "?P ps"
  show "?P ((a, b) # ps)"
  proof cases
    assume a: "ExcessNotAtRec ps g
      \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    have "set (deleteAround g a ps) \<subseteq> set ps"
      by (simp add: deleteAround_subset)
    then have
    "fst ` set (deleteAround g a ps) \<subseteq> insert a (fst ` set ps)"
      by blast
    with a H1 show ?thesis by (simp)
  next
    assume "\<not> ExcessNotAtRec ps g
      \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
    with H2 show ?thesis by (auto)
  qed
qed simp

lemma separated_ExcessNotAtRecList:
 "minGraphProps g \<Longrightarrow> final g \<Longrightarrow> isTable E (vertices g) ps \<Longrightarrow>
  separated g (set (ExcessNotAtRecList ps g))"
proof -
  assume fin: "final g" and mgp: "minGraphProps g"
  show
   "isTable E (vertices g) ps \<Longrightarrow> separated g (set (ExcessNotAtRecList ps g))"
   (is "?T ps \<Longrightarrow> ?P ps")
  proof (induct rule: ExcessNotAtRec.induct)
    case 1 show ?case by simp
  next
    case (2 a b ps)
    from 2 have prem: "?T ((a,b)#ps)" by blast
    then have E: "b = E a" by (simp add: isTable_eq)
    have "a :\<V> g" using prem by(auto simp: isTable_def)
    from 2 have hyp1: "?T (deleteAround g a ps) \<Longrightarrow>
      ?P (deleteAround g a ps)" by blast
    from 2 have hyp2:  "?T ps \<Longrightarrow> ?P ps" by blast
    have H1: "?P (deleteAround g a ps)"
      by (rule hyp1, rule isTable_deleteAround) (rule prem)
    have H2: "?P ps" by (rule hyp2, rule isTable_Cons) (rule prem)

    show "?P ((a,b)#ps)"
    proof cases
      assume c: "ExcessNotAtRec ps g
        \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
      have "separated g
       (insert a (set (ExcessNotAtRecList (deleteAround g a ps) g)))"
      proof (rule separated_insert[OF mgp])
        from prem show "a \<in> set (vertices g)" by (auto simp add: isTable_def)

        show "set (ExcessNotAtRecList (deleteAround g a ps) g) \<subseteq> \<V> g"
        proof-
          have "set (ExcessNotAtRecList (deleteAround g a ps) g) <=
                set (map fst (deleteAround g a ps))"
            by(rule ExcessNotAtRecList_subset[simplified concat_map_singleton])
          also have "\<dots> <= set (map fst ps)"
            using deleteAround_subset by fastforce
          finally show ?thesis using prem by(auto simp: isTable_def)
        qed
        from H1
        show pS: "separated g
            (set (ExcessNotAtRecList (deleteAround g a ps) g))"
          by simp

        fix f assume f: "f \<in> set (facesAt g a)"
        then have
        "f \<bullet> a \<notin> set [fst p. p \<leftarrow> deleteAround g a ps]"
          by (auto simp add: facesAt_def deleteAround_eq deleteAround'_def
            removeKeyList_eq split: split_if_asm)
        moreover
        have "set (ExcessNotAtRecList (deleteAround g a ps) g)
          \<subseteq> set [fst p. p \<leftarrow> deleteAround g a ps]"
          by (rule ExcessNotAtRecList_subset)
        ultimately
        show "f \<bullet> a
          \<notin> set (ExcessNotAtRecList (deleteAround g a ps) g)"
          by auto
        assume "|vertices f| \<le> 4"
        from this f have "set (vertices f)
          \<inter> set [fst p. p \<leftarrow> deleteAround g a ps] \<subseteq> {a}"
          by (rule deleteAround_separated[OF mgp fin `a : \<V> g`])
        moreover
        have "set (ExcessNotAtRecList (deleteAround g a ps) g)
          \<subseteq> set [fst p. p \<leftarrow> deleteAround g a ps]"
           by (rule ExcessNotAtRecList_subset)
        ultimately
        show "set (vertices f)
           \<inter> set (ExcessNotAtRecList (deleteAround g a ps) g) \<subseteq> {a}"
          by blast
      qed
      with H1 E c show ?thesis by (simp)
    next
      assume "\<not> ExcessNotAtRec ps g
        \<le> b + ExcessNotAtRec (deleteAround g a ps) g"
      with H2 E show ?thesis by simp
    qed
  qed
qed

lemma isTable_ExcessTable:
  "isTable (\<lambda>v. ExcessAt g v) vs (ExcessTable g vs)"
by (auto simp add: isTable_def ExcessTable_def ExcessAt_def)

lemma ExcessTable_subset:
  "set (map fst (ExcessTable g vs)) \<subseteq> set vs"
by (induct vs) (auto simp add: ExcessTable_def)

lemma distinct_ExcessNotAtRecList:
  "distinct (map fst ps) \<Longrightarrow> distinct (ExcessNotAtRecList ps g)"
    (is "?T ps \<Longrightarrow> ?P ps")
proof (induct rule: ExcessNotAtRec.induct)
  case 1 show ?case by simp
next
  case (2 a b ps)
  from 2 have prem: "?T ((a,b)#ps)" by blast
  then have a: "a \<notin> set (map fst ps)" by simp
  from 2 have hyp1: "?T (deleteAround g a ps) \<Longrightarrow>
    ?P (deleteAround g a ps)" by blast
  from 2 have hyp2:  "?T ps \<Longrightarrow> ?P ps" by blast
  from 2 have "?T ps" by simp
  then have H1: "?P (deleteAround g a ps)"
   by (rule_tac hyp1) (rule distinct_deleteAround [simplified])
  from prem have H2: "?P ps"
    by (rule_tac hyp2) simp

  have "a \<notin> set (ExcessNotAtRecList (deleteAround g a ps) g)"(* auto ?? *)
  proof
    assume "a \<in> set (ExcessNotAtRecList (deleteAround g a ps) g)"
    also have "set (ExcessNotAtRecList (deleteAround g a ps) g)
      \<subseteq> set [fst p. p \<leftarrow> deleteAround g a ps]"
     by (rule ExcessNotAtRecList_subset)
    also have "set (deleteAround g a ps) \<subseteq> set ps"
      by (rule deleteAround_subset)
    then have "set [fst p. p \<leftarrow> deleteAround g a ps]
      \<subseteq> set [fst p. p \<leftarrow> ps]" by auto
    finally have "a \<in> set (map fst ps)" by simp
    with a show False by contradiction
  qed
  with H1 H2 show "?P ((a,b)#ps)"
    by ( simp add: ExcessNotAtRecList_subset)
qed

(* alternative definition *)
primrec ExcessTable_cont ::
  "(vertex \<Rightarrow> nat) \<Rightarrow> vertex list \<Rightarrow> (vertex \<times> nat) list"
where
  "ExcessTable_cont ExcessAtPG [] = []" |
  "ExcessTable_cont ExcessAtPG (v#vs) =
   (let vi = ExcessAtPG v in
     if 0 < vi
     then (v, vi)#ExcessTable_cont ExcessAtPG vs
     else ExcessTable_cont ExcessAtPG vs)"

definition ExcessTable' :: "graph \<Rightarrow> vertex list \<Rightarrow> (vertex \<times> nat) list" where
  "ExcessTable' g \<equiv> ExcessTable_cont (ExcessAt g)"

lemma distinct_ExcessTable_cont:
  "distinct vs \<Longrightarrow>
  distinct (map fst (ExcessTable_cont (ExcessAt g) vs))"
proof (induct vs)
  case Nil then show ?case by (simp add: ExcessTable_def)
next
  case (Cons v vs)
  from Cons have v: "v \<notin> set vs" by simp
  from Cons have "distinct vs" by simp
  with Cons have IH:
    "distinct (map fst (ExcessTable_cont (ExcessAt g) vs))"
    by simp
  moreover have
    "v \<notin> fst ` set (ExcessTable_cont (ExcessAt g) vs)"
  proof
    assume "v \<in> fst ` set (ExcessTable_cont (ExcessAt g) vs)"
    also have "fst ` set (ExcessTable_cont (ExcessAt g) vs) \<subseteq> set vs"
      by (induct vs) auto
    finally have " v \<in> set vs" .
    with v show False by contradiction
  qed
  ultimately show ?case by (simp add: ExcessTable_def)
qed

lemma ExcessTable_cont_eq:
 "ExcessTable_cont E vs =
  [(v, E v). v \<leftarrow> [v\<leftarrow>vs . 0 < E v]]"
by (induct vs) (simp_all)

lemma ExcessTable_eq: "ExcessTable = ExcessTable'"
proof (rule ext, rule ext)
  fix p g vs show "ExcessTable g vs = ExcessTable' g vs"
  by (simp add: ExcessTable_def ExcessTable'_def ExcessTable_cont_eq)
qed

lemma distinct_ExcessTable:
   "distinct vs \<Longrightarrow> distinct [fst p. p \<leftarrow> ExcessTable g vs]"
by (simp_all add: ExcessTable_eq ExcessTable'_def distinct_ExcessTable_cont)

lemma ExcessNotAt_eq:
  "minGraphProps g \<Longrightarrow> final g \<Longrightarrow>
  \<exists>V. ExcessNotAt g None
      = (\<Sum>\<^bsub>v \<in> V\<^esub> ExcessAt g v)
   \<and> separated g (set V) \<and> set V \<subseteq> set (vertices g)
   \<and> distinct V"
proof (intro exI conjI)
  assume mgp: "minGraphProps g" and fin: "final g"
  let ?ps = "ExcessTable g (vertices g)"
  let ?V = "ExcessNotAtRecList ?ps g"
  let ?vs = "vertices g"
  let ?E = "\<lambda>v. ExcessAt g v"
  have t: "isTable ?E ?vs ?ps" by (rule isTable_ExcessTable)
  with this show "ExcessNotAt g None = (\<Sum>\<^bsub>v \<in> ?V\<^esub> ?E v)"
    by (simp add: ListSum_ExcessNotAtRecList ExcessNotAt_def)

  show "separated g (set ?V)"
    by(rule separated_ExcessNotAtRecList[OF mgp fin t])

  have "set (ExcessNotAtRecList ?ps g) \<subseteq> set (map fst ?ps)"
    by (rule ExcessNotAtRecList_subset[simplified concat_map_singleton])
  also have "\<dots> \<subseteq> set (vertices g)" by (rule ExcessTable_subset)
  finally show "set ?V \<subseteq> set (vertices g)" .

  show "distinct ?V"
    by (simp add: distinct_ExcessNotAtRecList distinct_ExcessTable[simplified concat_map_singleton])
qed

lemma excess_eq:
  assumes 7: "t + q \<le> 7"
  shows "excessAtType t q 0 + t * \<d> 3 + q * \<d> 4 = \<b> t q"
proof -
  note simps = excessAtType_def squanderVertex_def squanderFace_def
    nat_minus_add_max squanderTarget_def
  from 7 have "q=0 \<or> q=1 \<or> q=2 \<or> q=3 \<or> q=4 \<or> q=5 \<or> q=6 \<or> q=7" by arith
  then show ?thesis
  proof (elim disjE)
    assume q: "q = 0" (* 16 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 1" (* 29 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 2" (* 16 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 3" (* 16 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 4" (* 6 subgoals *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 5" (* 1 subgoal *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 6" (* 1 subgoal *)
    with 7 show ?thesis by (simp add: simps)
  next
    assume q: "q = 7" (* 1 subgoal *)
    with 7 show ?thesis by (simp add: simps)
  qed
qed

lemma excess_eq1:
  "\<lbrakk> inv g; final g; tame g; except g v = 0; v \<in> set(vertices g) \<rbrakk> \<Longrightarrow>
   ExcessAt g v + (tri g v) * \<d> 3 + (quad g v) * \<d>  4
   = \<b> (tri g v) (quad g v)"
apply(subgoal_tac "finalVertex g v")
apply(simp add: ExcessAt_def excess_eq faceCountMax_bound)
apply(auto simp:finalVertex_def plane_final_facesAt)
done

text {* separating *}

definition separating :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> bool" where
  "separating V F \<equiv>
   (\<forall>v1 \<in> V. \<forall>v2 \<in> V. v1 \<noteq> v2 \<longrightarrow>  F v1 \<inter> F v2 = {})"

lemma separating_insert1:
  "separating (insert a V) F \<Longrightarrow> separating V F"
  by (simp add: separating_def)

lemma separating_insert2:
  "separating (insert a V) F \<Longrightarrow> a \<notin> V \<Longrightarrow>  v \<in> V \<Longrightarrow>
  F a \<inter> F v = {}"
  by (auto simp add: separating_def)

lemma setsum_disj_Union:
 "finite V \<Longrightarrow>
  (\<And>f. finite (F f)) \<Longrightarrow>
  separating V F \<Longrightarrow>
  (\<Sum>v\<in>V. \<Sum>f\<in>(F v). (w f::nat)) = (\<Sum>f\<in>(\<Union>v\<in>V. F v). w f)"
proof (induct  rule: finite_induct)
  case empty then show ?case by simp
next
  case (insert a V)
  then have s: "separating (insert a V) F" by simp
  then have "separating V F" by (rule_tac separating_insert1)
  with insert
  have IH: "(\<Sum>v\<in>V. \<Sum>f\<in>(F v). w f) = (\<Sum>f\<in>(\<Union>v\<in>V. F v). w f)"
    by simp

  moreover have fin: "finite V" "a \<notin> V" "\<And>f. finite (F f)" by fact+

  moreover from s have "\<And>v. a \<notin> V \<Longrightarrow> v \<in> V \<Longrightarrow> F a \<inter> F v = {}"
   by (simp add: separating_insert2)
  with fin have "(F a) \<inter> (\<Union>v\<in>V. F v) = {}" by auto

  ultimately show ?case by (simp add: setsum.union_disjoint)
qed

lemma separated_separating:
assumes Vg: "set V <= \<V> g"
and pS: "separated g (set V)"
and noex: "ALL f:P. |vertices f| <= 4"
shows "separating (set V) (\<lambda>v. set (facesAt g v) Int P)"
proof -
  from pS have i: "\<forall>v\<in>set V. \<forall>f\<in>set (facesAt g v).
    |vertices f| \<le> 4 \<longrightarrow> set (vertices f) \<inter> set V = {v}"
    by (simp add: separated_def separated\<^sub>3_def)
  show "separating (set V) (\<lambda>v. set (facesAt g v) Int P)"
  proof (simp add: separating_def, intro ballI impI)
    fix v1 v2 assume v: "v1 \<in> set V" "v2 \<in> set V" "v1 \<noteq> v2"
    hence "v1 : \<V> g" using Vg by blast
    show "(set (facesAt g v1) \<inter> P) \<inter> (set (facesAt g v2) \<inter> P) = {}" (is "?P")
    proof (rule ccontr)
      assume "\<not> ?P"
      then obtain f where f1: "f \<in> set (facesAt g v1)"
        and f2: "f \<in> set (facesAt g v2)" and "f : P" by auto
      with noex have l: "|vertices f| \<le> 4" by blast
      from v f1 l i have "set (vertices f) \<inter> set V = {v1}" by simp
      also from v f2 l i
      have "set (vertices f) \<inter> set V = {v2}" by simp
      finally have "v1 = v2" by auto
      then show False by contradiction (rule v)
    qed
  qed
qed

lemma ListSum_V_F_eq_ListSum_F:
assumes pl: "inv g"
and pS: "separated g (set V)" and dist: "distinct V"
and V_subset: "set V \<subseteq> set (vertices g)"
and noex: "ALL f : Collect P. |vertices f| <= 4"
shows "(\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> filter P (facesAt g v)\<^esub> (w::face \<Rightarrow> nat) f)
       = (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g . \<exists>v \<in> set V. f \<in> set (facesAt g v) Int Collect P]\<^esub> w f)"
proof -
  have s: "separating (set V) (\<lambda>v. set (facesAt g v) Int Collect P)"
    by (rule separated_separating[OF V_subset pS noex])
  moreover note dist
  moreover from pl V_subset
  have "\<And>v. v \<in> set V \<Longrightarrow> distinct (facesAt g v)"
    by(blast intro:mgp_dist_facesAt[OF inv_mgp])
  hence v: "\<And>v. v \<in> set V \<Longrightarrow> distinct (filter P (facesAt g v))"
    by simp
  moreover
  have "distinct [f\<leftarrow>faces g . \<exists>v \<in> set V. f \<in> set (facesAt g v) Int Collect P]"
    by (intro distinct_filter minGraphProps11'[OF inv_mgp[OF pl]])
  moreover from pl have "{x. x \<in> \<F> g \<and> (\<exists>v \<in> set V. x \<in> set (facesAt g v) \<and> P x)} =
      (\<Union>v\<in>set V. set (facesAt g v) Int Collect P)" using V_subset
    by (blast intro:minGraphProps inv_mgp)
  moreover from v have "(\<Sum>v\<in>set V. ListSum (filter P (facesAt g v)) w) = (\<Sum>v\<in>set V. setsum w (set(facesAt g v) Int Collect P))"
    by (auto simp add: ListSum_conv_setsum Int_def)
  ultimately show ?thesis
    by (simp add: ListSum_conv_setsum setsum_disj_Union)
qed

lemma separated_disj_Union2:
assumes pl: "inv g" and fin: "final g" and ne: "noExceptionals g (set V)"
and pS: "separated g (set V)" and dist: "distinct V"
and V_subset: "set V \<subseteq> set (vertices g)"
shows "(\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> (w::face \<Rightarrow> nat) f)
       = (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g . \<exists>v \<in> set V. f \<in> set (facesAt g v)]\<^esub> w f)"
proof -
  let ?P = "\<lambda>f. |vertices f| <= 4"
  have "ALL v : set V. ALL f : set (facesAt g v). |vertices f| <= 4"
    using V_subset ne
    by (auto simp: noExceptionals_def
      intro: minGraphProps5[OF inv_mgp[OF pl]] not_exceptional[OF pl fin])
  thus ?thesis
    using ListSum_V_F_eq_ListSum_F[where P = ?P, OF pl pS dist V_subset]
    by (simp add: Int_def cong: conj_cong)
qed

lemma squanderFace_distr2: "inv g \<Longrightarrow> final g \<Longrightarrow> noExceptionals g (set V) \<Longrightarrow>
  separated g (set V) \<Longrightarrow> distinct V \<Longrightarrow> set V \<subseteq> set (vertices g) \<Longrightarrow>
     (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g. \<exists>v \<in> set V. f \<in> set (facesAt g v)]\<^esub>
         \<d> |vertices f| )
   = (\<Sum>\<^bsub>v \<in> V\<^esub> ((tri g v) * \<d> 3
         + (quad g v) * \<d> 4))"
proof -
  assume pl: "inv g"
  assume fin: "final g"
  assume ne: "noExceptionals g (set V)"
  assume "separated g (set V)"  "distinct V" and V_subset: "set V \<subseteq> set (vertices g)"
  with pl ne fin have
    "(\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g. \<exists>v\<in>set V. f\<in>set (facesAt g v)]\<^esub> \<d> |vertices f| )
   = (\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| )"
    by (simp add: separated_disj_Union2)
  also have "\<And>v. v \<in> set V \<Longrightarrow>
    (\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| )
  = (tri g v) * \<d> 3 + (quad g v) * \<d> 4"
  proof -
    fix v assume v1: "v \<in> set V"
    with V_subset have v: "v \<in> set (vertices g)" by auto

    with ne have d:
      "\<And>f. f \<in> set (facesAt g v) \<Longrightarrow>
      |vertices f| = 3 \<or> |vertices f| = 4"
    proof -
      fix f assume f: "f \<in> set (facesAt g v)"
      then have ff: "f \<in> set (faces g)" by (rule minGraphProps5[OF inv_mgp[OF pl] v])
      with ne f v1 pl fin v have "|vertices f| \<le> 4"
        by (auto simp add: noExceptionals_def not_exceptional)
      moreover from pl ff have "3 \<le> |vertices f|" by(rule planeN4)
      ultimately show "?thesis f" by arith
    qed

    from d pl v have
      "(\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| )
    = (\<Sum>\<^bsub>f\<in>[f \<leftarrow> facesAt g v. |vertices f| = 3]\<^esub> \<d> |vertices f| )
    + (\<Sum>\<^bsub>f\<in>[f \<leftarrow> facesAt g v. |vertices f| = 4]\<^esub> \<d> |vertices f| )"
      apply (rule_tac ListSum_disj_union)
      apply (rule distinct_filter) apply simp
      apply (rule distinct_filter) apply simp
      apply simp
      apply force
      apply force
      done
    also have "\<dots> = tri g v * \<d> 3 + quad g v * \<d> 4"
    proof -
      from pl fin v have "\<And>A.[f \<leftarrow> facesAt g v. final f \<and> A f]
        = [f \<leftarrow> facesAt g v. A f]"
        by (rule_tac filter_eqI) (auto simp:plane_final_facesAt)
      with fin show ?thesis  by (auto simp add: tri_def quad_def)
    qed
    finally show "(\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| ) = tri g v * \<d> 3 + quad g v * \<d> 4" .
  qed
  then have "(\<Sum>\<^bsub>v \<in> V\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> \<d> |vertices f| ) =
         (\<Sum>\<^bsub>v \<in> V\<^esub> (tri g v * \<d> 3 + quad g v * \<d> 4))"
     by (rule ListSum_eq)
  finally show ?thesis .
qed

lemma separated_subset: (* separated *)
   "V1 \<subseteq> V2 \<Longrightarrow> separated g V2 \<Longrightarrow> separated g V1"
proof (simp add:  separated_def separated\<^sub>3_def separated\<^sub>2_def,
  elim conjE, intro allI impI ballI conjI)
  fix v f
  assume a: "v \<in> V1" "V1 \<subseteq> V2" "f \<in> set (facesAt g v)"
    "|vertices f| \<le> 4"
    "\<forall>v\<in>V2. \<forall>f\<in>set (facesAt g v). |vertices f| \<le> 4 \<longrightarrow>
      set (vertices f) \<inter> V2 = {v}"
  then show "set (vertices f) \<inter> V1 = {v}" by auto
next
  fix v f
  assume a: "v \<in> V1" "V1 \<subseteq> V2" "f \<in> set (facesAt g v)"
    "\<forall>v\<in>V2. \<forall>f\<in>set (facesAt g v). f \<bullet> v \<notin> V2"
  then have "v \<in> V2" by auto
  with a have "f \<bullet> v \<notin> V2" by auto
  with a show "f \<bullet> v \<notin> V1" by auto
qed

end


(*  Title:      HOL/Proofs/Lambda/Standardization.thy
    Author:     Stefan Berghofer
    Copyright   2005 TU Muenchen
*)

section \<open>Standardization\<close>

theory Standardization
imports NormalForm
begin

text \<open>
Based on lecture notes by Ralph Matthes \<^cite>\<open>"Matthes-ESSLLI2000"\<close>,
original proof idea due to Ralph Loader \<^cite>\<open>Loader1998\<close>.
\<close>

subsection \<open>Standard reduction relation\<close>

declare listrel_mono [mono_set]

inductive
  sred :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>s" 50)
  and sredlist :: "dB list \<Rightarrow> dB list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>s]" 50)
where
  "s [\<rightarrow>\<^sub>s] t \<equiv> listrelp (\<rightarrow>\<^sub>s) s t"
| Var: "rs [\<rightarrow>\<^sub>s] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>s r' \<Longrightarrow> ss [\<rightarrow>\<^sub>s] ss' \<Longrightarrow> Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> ss'"
| Beta: "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>s t \<Longrightarrow> Abs r \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"

lemma refl_listrelp: "\<forall>x\<in>set xs. R x x \<Longrightarrow> listrelp R xs xs"
  by (induct xs) (auto intro: listrelp.intros)

lemma refl_sred: "t \<rightarrow>\<^sub>s t"
  by (induct t rule: Apps_dB_induct) (auto intro: refl_listrelp sred.intros)

lemma refl_sreds: "ts [\<rightarrow>\<^sub>s] ts"
  by (simp add: refl_sred refl_listrelp)

lemma listrelp_conj1: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp R x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_conj2: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp S x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_app:
  assumes xsys: "listrelp R xs ys"
  shows "listrelp R xs' ys' \<Longrightarrow> listrelp R (xs @ xs') (ys @ ys')" using xsys
  by (induct arbitrary: xs' ys') (auto intro: listrelp.intros)

lemma lemma1:
  assumes r: "r \<rightarrow>\<^sub>s r'" and s: "s \<rightarrow>\<^sub>s s'"
  shows "r \<degree> s \<rightarrow>\<^sub>s r' \<degree> s'" using r
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "rs @ [s] [\<rightarrow>\<^sub>s] rs' @ [s']" by (rule listrelp_app)
  hence "Var x \<degree>\<degree> (rs @ [s]) \<rightarrow>\<^sub>s Var x \<degree>\<degree> (rs' @ [s'])" by (rule sred.Var)
  thus ?case by (simp only: app_last)
next
  case (Abs r r' ss ss')
  from Abs(3) have "ss [\<rightarrow>\<^sub>s] ss'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "ss @ [s] [\<rightarrow>\<^sub>s] ss' @ [s']" by (rule listrelp_app)
  with \<open>r \<rightarrow>\<^sub>s r'\<close> have "Abs r \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> (ss' @ [s'])"
    by (rule sred.Abs)
  thus ?case by (simp only: app_last)
next
  case (Beta r u ss t)
  hence "r[u/0] \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (simp only: app_last)
  hence "Abs r \<degree> u \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (rule sred.Beta)
  thus ?case by (simp only: app_last)
qed

lemma lemma1':
  assumes ts: "ts [\<rightarrow>\<^sub>s] ts'"
  shows "r \<rightarrow>\<^sub>s r' \<Longrightarrow> r \<degree>\<degree> ts \<rightarrow>\<^sub>s r' \<degree>\<degree> ts'" using ts
  by (induct arbitrary: r r') (auto intro: lemma1)

lemma lemma2_1:
  assumes beta: "t \<rightarrow>\<^sub>\<beta> u"
  shows "t \<rightarrow>\<^sub>s u" using beta
proof induct
  case (beta s t)
  have "Abs s \<degree> t \<degree>\<degree> [] \<rightarrow>\<^sub>s s[t/0] \<degree>\<degree> []" by (iprover intro: sred.Beta refl_sred)
  thus ?case by simp
next
  case (appL s t u)
  thus ?case by (iprover intro: lemma1 refl_sred)
next
  case (appR s t u)
  thus ?case by (iprover intro: lemma1 refl_sred)
next
  case (abs s t)
  hence "Abs s \<degree>\<degree> [] \<rightarrow>\<^sub>s Abs t \<degree>\<degree> []" by (iprover intro: sred.Abs listrelp.Nil)
  thus ?case by simp
qed

lemma listrelp_betas:
  assumes ts: "listrelp (\<rightarrow>\<^sub>\<beta>\<^sup>*) ts ts'"
  shows "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<degree>\<degree> ts'" using ts
  by induct auto

lemma lemma2_2:
  assumes t: "t \<rightarrow>\<^sub>s u"
  shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using t
  by induct (auto dest: listrelp_conj2
    intro: listrelp_betas apps_preserves_beta converse_rtranclp_into_rtranclp)

lemma sred_lift:
  assumes s: "s \<rightarrow>\<^sub>s t"
  shows "lift s i \<rightarrow>\<^sub>s lift t i" using s
proof (induct arbitrary: i)
  case (Var rs rs' x)
  hence "map (\<lambda>t. lift t i) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. lift t i) rs'"
    by induct (auto intro: listrelp.intros)
  thus ?case by (cases "x < i") (auto intro: sred.Var)
next
  case (Abs r r' ss ss')
  from Abs(3) have "map (\<lambda>t. lift t i) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. lift t i) ss'"
    by induct (auto intro: listrelp.intros)
  thus ?case by (auto intro: sred.Abs Abs)
next
  case (Beta r s ss t)
  thus ?case by (auto intro: sred.Beta)
qed

lemma lemma3:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "s \<rightarrow>\<^sub>s s' \<Longrightarrow> r[s/x] \<rightarrow>\<^sub>s r'[s'/x]" using r
proof (induct arbitrary: s s' x)
  case (Var rs rs' y)
  hence "map (\<lambda>t. t[s/x]) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. t[s'/x]) rs'"
    by induct (auto intro: listrelp.intros Var)
  moreover have "Var y[s/x] \<rightarrow>\<^sub>s Var y[s'/x]"
  proof (cases "y < x")
    case True thus ?thesis by simp (rule refl_sred)
  next
    case False
    thus ?thesis
      by (cases "y = x") (auto simp add: Var intro: refl_sred)
  qed
  ultimately show ?case by simp (rule lemma1')
next
  case (Abs r r' ss ss')
  from Abs(4) have "lift s 0 \<rightarrow>\<^sub>s lift s' 0" by (rule sred_lift)
  hence "r[lift s 0/Suc x] \<rightarrow>\<^sub>s r'[lift s' 0/Suc x]" by (fast intro: Abs.hyps)
  moreover from Abs(3) have "map (\<lambda>t. t[s/x]) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. t[s'/x]) ss'"
    by induct (auto intro: listrelp.intros Abs)
  ultimately show ?case by simp (rule sred.Abs)
next
  case (Beta r u ss t)
  thus ?case by (auto simp add: subst_subst intro: sred.Beta)
qed

lemma lemma4_aux:
  assumes rs: "listrelp (\<lambda>t u. t \<rightarrow>\<^sub>s u \<and> (\<forall>r. u \<rightarrow>\<^sub>\<beta> r \<longrightarrow> t \<rightarrow>\<^sub>s r)) rs rs'"
  shows "rs' => ss \<Longrightarrow> rs [\<rightarrow>\<^sub>s] ss" using rs
proof (induct arbitrary: ss)
  case Nil
  thus ?case by cases (auto intro: listrelp.Nil)
next
  case (Cons x y xs ys)
  note Cons' = Cons
  show ?case
  proof (cases ss)
    case Nil with Cons show ?thesis by simp
  next
    case (Cons y' ys')
    hence ss: "ss = y' # ys'" by simp
    from Cons Cons' have "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys \<or> y' = y \<and> ys => ys'" by simp
    hence "x # xs [\<rightarrow>\<^sub>s] y' # ys'"
    proof
      assume H: "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from Cons' have "xs [\<rightarrow>\<^sub>s] ys" by (iprover dest: listrelp_conj1)
      ultimately have "x # xs [\<rightarrow>\<^sub>s] y' # ys" by (rule listrelp.Cons)
      with H show ?thesis by simp
    next
      assume H: "y' = y \<and> ys => ys'"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from H have "xs [\<rightarrow>\<^sub>s] ys'" by (blast intro: Cons')
      ultimately show ?thesis by (rule listrelp.Cons)
    qed
    with ss show ?thesis by simp
  qed
qed

lemma lemma4:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "r' \<rightarrow>\<^sub>\<beta> r'' \<Longrightarrow> r \<rightarrow>\<^sub>s r''" using r
proof (induct arbitrary: r'')
  case (Var rs rs' x)
  then obtain ss where rs: "rs' => ss" and r'': "r'' = Var x \<degree>\<degree> ss"
    by (blast dest: head_Var_reduction)
  from Var(1) rs have "rs [\<rightarrow>\<^sub>s] ss" by (rule lemma4_aux)
  hence "Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> ss" by (rule sred.Var)
  with r'' show ?case by simp
next
  case (Abs r r' ss ss')
  from \<open>Abs r' \<degree>\<degree> ss' \<rightarrow>\<^sub>\<beta> r''\<close> show ?case
  proof
    fix s
    assume r'': "r'' = s \<degree>\<degree> ss'"
    assume "Abs r' \<rightarrow>\<^sub>\<beta> s"
    then obtain r''' where s: "s = Abs r'''" and r''': "r' \<rightarrow>\<^sub>\<beta> r'''" by cases auto
    from r''' have "r \<rightarrow>\<^sub>s r'''" by (blast intro: Abs)
    moreover from Abs have "ss [\<rightarrow>\<^sub>s] ss'" by (iprover dest: listrelp_conj1)
    ultimately have "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r''' \<degree>\<degree> ss'" by (rule sred.Abs)
    with r'' s show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    fix rs'
    assume "ss' => rs'"
    with Abs(3) have "ss [\<rightarrow>\<^sub>s] rs'" by (rule lemma4_aux)
    with \<open>r \<rightarrow>\<^sub>s r'\<close> have "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> rs'" by (rule sred.Abs)
    moreover assume "r'' = Abs r' \<degree>\<degree> rs'"
    ultimately show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    fix t u' us'
    assume "ss' = u' # us'"
    with Abs(3) obtain u us where
      ss: "ss = u # us" and u: "u \<rightarrow>\<^sub>s u'" and us: "us [\<rightarrow>\<^sub>s] us'"
      by cases (auto dest!: listrelp_conj1)
    have "r[u/0] \<rightarrow>\<^sub>s r'[u'/0]" using Abs(1) and u by (rule lemma3)
    with us have "r[u/0] \<degree>\<degree> us \<rightarrow>\<^sub>s r'[u'/0] \<degree>\<degree> us'" by (rule lemma1')
    hence "Abs r \<degree> u \<degree>\<degree> us \<rightarrow>\<^sub>s r'[u'/0] \<degree>\<degree> us'" by (rule sred.Beta)
    moreover assume "Abs r' = Abs t" and "r'' = t[u'/0] \<degree>\<degree> us'"
    ultimately show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" using ss by simp
  qed
next
  case (Beta r s ss t)
  show ?case
    by (rule sred.Beta) (rule Beta)+
qed

lemma rtrancl_beta_sred:
  assumes r: "r \<rightarrow>\<^sub>\<beta>\<^sup>* r'"
  shows "r \<rightarrow>\<^sub>s r'" using r
  by induct (iprover intro: refl_sred lemma4)+

subsection \<open>Leftmost reduction and weakly normalizing terms\<close>

inductive
  lred :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>l" 50)
  and lredlist :: "dB list \<Rightarrow> dB list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>l]" 50)
where
  "s [\<rightarrow>\<^sub>l] t \<equiv> listrelp (\<rightarrow>\<^sub>l) s t"
| Var: "rs [\<rightarrow>\<^sub>l] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>l Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>l r' \<Longrightarrow> Abs r \<rightarrow>\<^sub>l Abs r'"
| Beta: "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>l t \<Longrightarrow> Abs r \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>l t"

lemma lred_imp_sred:
  assumes lred: "s \<rightarrow>\<^sub>l t"
  shows "s \<rightarrow>\<^sub>s t" using lred
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (rule sred.Var)
next
  case (Abs r r')
  from \<open>r \<rightarrow>\<^sub>s r'\<close>
  have "Abs r \<degree>\<degree> [] \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> []" using listrelp.Nil
    by (rule sred.Abs)
  then show ?case by simp
next
  case (Beta r s ss t)
  from \<open>r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>s t\<close>
  show ?case by (rule sred.Beta)
qed

inductive WN :: "dB => bool"
  where
    Var: "listsp WN rs \<Longrightarrow> WN (Var n \<degree>\<degree> rs)"
  | Lambda: "WN r \<Longrightarrow> WN (Abs r)"
  | Beta: "WN ((r[s/0]) \<degree>\<degree> ss) \<Longrightarrow> WN ((Abs r \<degree> s) \<degree>\<degree> ss)"

lemma listrelp_imp_listsp1:
  assumes H: "listrelp (\<lambda>x y. P x) xs ys"
  shows "listsp P xs" using H
  by induct auto

lemma listrelp_imp_listsp2:
  assumes H: "listrelp (\<lambda>x y. P y) xs ys"
  shows "listsp P ys" using H
  by induct auto

lemma lemma5:
  assumes lred: "r \<rightarrow>\<^sub>l r'"
  shows "WN r" and "NF r'" using lred
  by induct
    (iprover dest: listrelp_conj1 listrelp_conj2
     listrelp_imp_listsp1 listrelp_imp_listsp2 intro: WN.intros
     NF.intros [simplified listall_listsp_eq])+

lemma lemma6:
  assumes wn: "WN r"
  shows "\<exists>r'. r \<rightarrow>\<^sub>l r'" using wn
proof induct
  case (Var rs n)
  then have "\<exists>rs'. rs [\<rightarrow>\<^sub>l] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (iprover intro: lred.Var)
qed (iprover intro: lred.intros)+

lemma lemma7:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "NF r' \<Longrightarrow> r \<rightarrow>\<^sub>l r'" using r
proof induct
  case (Var rs rs' x)
  from \<open>NF (Var x \<degree>\<degree> rs')\<close> have "listall NF rs'"
    by cases simp_all
  with Var(1) have "rs [\<rightarrow>\<^sub>l] rs'"
  proof induct
    case Nil
    show ?case by (rule listrelp.Nil)
  next
    case (Cons x y xs ys)
    hence "x \<rightarrow>\<^sub>l y" and "xs [\<rightarrow>\<^sub>l] ys" by simp_all
    thus ?case by (rule listrelp.Cons)
  qed
  thus ?case by (rule lred.Var)
next
  case (Abs r r' ss ss')
  from \<open>NF (Abs r' \<degree>\<degree> ss')\<close>
  have ss': "ss' = []" by (rule Abs_NF)
  from Abs(3) have ss: "ss = []" using ss'
    by cases simp_all
  from ss' Abs have "NF (Abs r')" by simp
  hence "NF r'" by cases simp_all
  with Abs have "r \<rightarrow>\<^sub>l r'" by simp
  hence "Abs r \<rightarrow>\<^sub>l Abs r'" by (rule lred.Abs)
  with ss ss' show ?case by simp
next
  case (Beta r s ss t)
  hence "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>l t" by simp
  thus ?case by (rule lred.Beta)
qed

lemma WN_eq: "WN t = (\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
proof
  assume "WN t"
  then have "\<exists>t'. t \<rightarrow>\<^sub>l t'" by (rule lemma6)
  then obtain t' where t': "t \<rightarrow>\<^sub>l t'" ..
  then have NF: "NF t'" by (rule lemma5)
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule lred_imp_sred)
  then have "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" by (rule lemma2_2)
  with NF show "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by iprover
next
  assume "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  then obtain t' where t': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and NF: "NF t'"
    by iprover
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule rtrancl_beta_sred)
  then have "t \<rightarrow>\<^sub>l t'" using NF by (rule lemma7)
  then show "WN t" by (rule lemma5)
qed

end


section \<open> Productive Reactive Designs \<close>

theory utp_rdes_productive
  imports utp_rdes_parallel
begin

subsection \<open> Healthiness condition \<close>

text \<open> A reactive design is productive if it strictly increases the trace, whenever it terminates.
  If it does not terminate, it is also classed as productive. \<close>

definition Productive :: "('s, 't::trace, '\<alpha>) hrel_rsp \<Rightarrow> ('s, 't, '\<alpha>) hrel_rsp" where
[upred_defs]: "Productive(P) = P \<parallel>\<^sub>R \<^bold>R\<^sub>s(true \<turnstile> true \<diamondop> ($tr <\<^sub>u $tr\<acute>))"

lemma Productive_alt_def:
  "Productive(P) = P \<parallel>\<^sub>R \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> true\<^sub>r \<diamondop> ($tr <\<^sub>u $tr\<acute>))"
  by (rel_auto)

lemma Productive_RHS_design_form:
  assumes "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q" "$ok\<acute> \<sharp> R"
  shows "Productive(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) = \<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> (R \<and> $tr <\<^sub>u $tr\<acute>))"
  using assms by (simp add: Productive_def RHS_tri_design_par unrest rpred)

text \<open> We use the @{term R4} healthiness condition to characterise that the postcondition must
  extend the trace for a reactive design to be productive. \<close>

lemma Productive_RHS_R4_design_form:
  assumes "P is RR" "Q is RR" "R is RR"
  shows "Productive(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) = \<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R4(R))"
  by (simp add: Productive_RHS_design_form closure assms unrest R4_def)

lemma Productive_form:
  "Productive(SRD(P)) = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>))"
proof -
  have "Productive(SRD(P)) = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) \<parallel>\<^sub>R \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> true\<^sub>r \<diamondop> ($tr <\<^sub>u $tr\<acute>))"
    by (simp add: Productive_alt_def SRD_as_reactive_tri_design)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>))"
    by (simp add: RHS_tri_design_par unrest rpred, rel_auto)
  finally show ?thesis .
qed

text \<open> A reactive design is productive provided that the postcondition, under the precondition,
  strictly increases the trace. \<close>

lemma Productive_intro:
  assumes "P is SRD" "($tr <\<^sub>u $tr\<acute>) \<sqsubseteq> (pre\<^sub>R(P) \<and> post\<^sub>R(P))" "$wait\<acute> \<sharp> pre\<^sub>R(P)"
  shows "P is Productive"
proof -
  have P:"\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)) = P"
  proof -
    have "\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> (pre\<^sub>R(P) \<and> peri\<^sub>R(P)) \<diamondop> (pre\<^sub>R(P) \<and> post\<^sub>R(P)))"
      by (metis (no_types, opaque_lifting) design_export_pre wait'_cond_conj_exchange wait'_cond_idem)
    also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> (pre\<^sub>R(P) \<and> peri\<^sub>R(P)) \<diamondop> (pre\<^sub>R(P) \<and> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
      by (metis assms(2) utp_pred_laws.inf.absorb1 utp_pred_laws.inf.assoc)
    also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>))"
      by (metis (no_types, opaque_lifting) design_export_pre wait'_cond_conj_exchange wait'_cond_idem)
    finally show ?thesis
      by (simp add: SRD_reactive_tri_design assms(1))
  qed
  thus ?thesis
    by (metis Healthy_def Productive_form assms(1))
qed

lemma Productive_post_refines_tr_increase:
  assumes "P is SRD" "P is Productive" "$wait\<acute> \<sharp> pre\<^sub>R(P)"
  shows "($tr <\<^sub>u $tr\<acute>) \<sqsubseteq> (pre\<^sub>R(P) \<and> post\<^sub>R(P))"
proof -
  have "post\<^sub>R(P) = post\<^sub>R(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
    by (metis Healthy_def Productive_form assms(1) assms(2))
  also have "... = R1(R2c(pre\<^sub>R(P) \<Rightarrow> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
    by (simp add: rea_post_RHS_design unrest usubst assms, rel_auto)
  also have "... = R1((pre\<^sub>R(P) \<Rightarrow> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
    by (simp add: R2c_impl R2c_preR R2c_postR R2c_and R2c_tr_less_tr' assms)
  also have "($tr <\<^sub>u $tr\<acute>) \<sqsubseteq> (pre\<^sub>R(P) \<and> ...)"
    by (rel_auto)
  finally show ?thesis .
qed

lemma Continuous_Productive [closure]: "Continuous Productive"
  by (simp add: Continuous_def Productive_def, rel_auto)

subsection \<open> Reactive design calculations \<close>

lemma preR_Productive [rdes]:
  assumes "P is SRD"
  shows "pre\<^sub>R(Productive(P)) = pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(Productive(P)) = pre\<^sub>R(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
    by (metis Healthy_def Productive_form assms)
  thus ?thesis
    by (simp add: rea_pre_RHS_design usubst unrest R2c_not R2c_preR R1_preR Healthy_if assms)
qed

lemma periR_Productive [rdes]:
  assumes "P is NSRD"
  shows "peri\<^sub>R(Productive(P)) = peri\<^sub>R(P)"
proof -
  have "peri\<^sub>R(Productive(P)) = peri\<^sub>R(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
    by (metis Healthy_def NSRD_is_SRD Productive_form assms)
  also have "... = R1 (R2c (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P))"
    by (simp add: rea_peri_RHS_design usubst unrest R2c_not assms closure)
  also have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P)"
    by (simp add: R1_rea_impl R2c_rea_impl R2c_preR R2c_peri_SRD
                  R1_peri_SRD assms closure R1_tr_less_tr' R2c_tr_less_tr')
  finally show ?thesis
    by (simp add: SRD_peri_under_pre assms unrest closure)
qed

lemma postR_Productive [rdes]:
  assumes "P is NSRD"
  shows "post\<^sub>R(Productive(P)) = (pre\<^sub>R(P) \<Rightarrow>\<^sub>r post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)"
proof -
  have "post\<^sub>R(Productive(P)) = post\<^sub>R(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))"
    by (metis Healthy_def NSRD_is_SRD Productive_form assms)
  also have "... = R1 (R2c (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr))"
    by (simp add: rea_post_RHS_design usubst unrest assms closure)
  also have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr)"
    by (simp add: R1_rea_impl R2c_rea_impl R2c_preR R2c_and R1_extend_conj' R2c_post_SRD
             R1_post_SRD assms closure R1_tr_less_tr' R2c_tr_less_tr')
  finally show ?thesis .
qed

lemma preR_frame_seq_export:
  assumes "P is NSRD" "P is Productive" "Q is NSRD"
  shows "(pre\<^sub>R P \<and> (pre\<^sub>R P \<and> post\<^sub>R P) ;; Q) = (pre\<^sub>R P \<and> (post\<^sub>R P ;; Q))"
proof -
  have "(pre\<^sub>R P \<and> (post\<^sub>R P ;; Q)) = (pre\<^sub>R P \<and> ((pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P) ;; Q))"
    by (simp add: SRD_post_under_pre assms closure unrest)
  also have "... = (pre\<^sub>R P \<and> (((\<not>\<^sub>r pre\<^sub>R P) ;; Q \<or> (pre\<^sub>R P \<Rightarrow>\<^sub>r R1(post\<^sub>R P)) ;; Q)))"
    by (simp add: NSRD_is_SRD R1_post_SRD assms(1) rea_impl_def seqr_or_distl R1_preR Healthy_if)
  also have "... = (pre\<^sub>R P \<and> (((\<not>\<^sub>r pre\<^sub>R P) ;; Q \<or> (pre\<^sub>R P \<and> post\<^sub>R P) ;; Q)))"
  proof -
    have "(pre\<^sub>R P \<or> \<not>\<^sub>r pre\<^sub>R P) = R1 true"
      by (simp add: R1_preR rea_not_or)
    then show ?thesis
      by (metis (no_types, lifting) R1_def conj_comm disj_comm disj_conj_distr rea_impl_def seqr_or_distl utp_pred_laws.inf_top_left utp_pred_laws.sup.left_idem)
  qed
  also have "... = (pre\<^sub>R P \<and> (((\<not>\<^sub>r pre\<^sub>R P) \<or> (pre\<^sub>R P \<and> post\<^sub>R P) ;; Q)))"
    by (simp add: NSRD_neg_pre_left_zero assms closure SRD_healths)
  also have "... = (pre\<^sub>R P \<and> (pre\<^sub>R P \<and> post\<^sub>R P) ;; Q)"
    by (rel_blast)
  finally show ?thesis ..
qed

subsection \<open> Closure laws \<close>

lemma Productive_rdes_intro:
  assumes "($tr <\<^sub>u $tr\<acute>) \<sqsubseteq> R" "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q" "$ok\<acute> \<sharp> R" "$wait \<sharp> P" "$wait\<acute> \<sharp> P"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) is Productive"
proof (rule Productive_intro)
  show "\<^bold>R\<^sub>s (P \<turnstile> Q \<diamondop> R) is SRD"
    by (simp add: RHS_tri_design_is_SRD assms)

  from assms(1) show "($tr\<acute> >\<^sub>u $tr) \<sqsubseteq> (pre\<^sub>R (\<^bold>R\<^sub>s (P \<turnstile> Q \<diamondop> R)) \<and> post\<^sub>R (\<^bold>R\<^sub>s (P \<turnstile> Q \<diamondop> R)))"
    apply (simp add: rea_pre_RHS_design rea_post_RHS_design usubst assms unrest)
    using assms(1) apply (rel_auto)
    apply fastforce
    done

  show "$wait\<acute> \<sharp> pre\<^sub>R (\<^bold>R\<^sub>s (P \<turnstile> Q \<diamondop> R))"
    by (simp add: rea_pre_RHS_design rea_post_RHS_design usubst R1_def R2c_def R2s_def assms unrest)
qed

lemma Productive_rdes_RR_intro [closure]:
  assumes "P is RR" "Q is RR" "R is RR" "R is R4"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) is Productive"
  using assms by (simp add: Productive_rdes_intro R4_iff_refine unrest)

lemma Productive_Miracle [closure]: "Miracle is Productive"
  unfolding Miracle_tri_def Healthy_def
  by (subst Productive_RHS_design_form, simp_all add: unrest closure)

lemma Productive_Chaos [closure]: "Chaos is Productive"
  unfolding Chaos_tri_def Healthy_def
  by (subst Productive_RHS_design_form, simp_all add: unrest closure)

lemma Productive_intChoice [closure]:
  assumes "P is SRD" "P is Productive" "Q is SRD" "Q is Productive"
  shows "P \<sqinter> Q is Productive"
proof -
  have "P \<sqinter> Q =
        \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)) \<sqinter> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> peri\<^sub>R(Q) \<diamondop> (post\<^sub>R(Q) \<and> $tr <\<^sub>u $tr\<acute>))"
    by (metis Healthy_if Productive_form assms)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> peri\<^sub>R Q) \<diamondop> ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) \<or> (post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr)))"
    by (simp add: RHS_tri_design_choice)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> peri\<^sub>R Q) \<diamondop> (((post\<^sub>R P) \<or> (post\<^sub>R Q)) \<and> $tr\<acute> >\<^sub>u $tr))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... is Productive"
    by (metis Healthy_def Productive_form assms(1) assms(3) calculation periR_inf postR_inf preR_inf srdes_theory.meet_is_healthy)
  finally show ?thesis .
qed

lemma cond_R1_closure [closure]: "\<lbrakk> P is R1; Q is R1 \<rbrakk> \<Longrightarrow> P \<triangleleft> b \<triangleright>\<^sub>R Q is R1"
  by (rel_auto)

lemma Productive_cond_rea [closure]:
  assumes "P is SRD" "P is Productive" "Q is SRD" "Q is Productive"
  shows "P \<triangleleft> b \<triangleright>\<^sub>R Q is Productive"
proof -
  have "P \<triangleleft> b \<triangleright>\<^sub>R Q =
        \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)) \<triangleleft> b \<triangleright>\<^sub>R \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> peri\<^sub>R(Q) \<diamondop> (post\<^sub>R(Q) \<and> $tr <\<^sub>u $tr\<acute>))"
    by (metis Healthy_if Productive_form assms)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<triangleleft> b \<triangleright>\<^sub>R pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<triangleleft> b \<triangleright>\<^sub>R peri\<^sub>R Q) \<diamondop> ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) \<triangleleft> b \<triangleright>\<^sub>R (post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr)))"
    by (simp add: cond_srea_form)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<triangleleft> b \<triangleright>\<^sub>R pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<triangleleft> b \<triangleright>\<^sub>R peri\<^sub>R Q) \<diamondop> (((post\<^sub>R P) \<triangleleft> b \<triangleright>\<^sub>R (post\<^sub>R Q)) \<and> $tr\<acute> >\<^sub>u $tr))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... is Productive"
    by (simp add: Healthy_def, simp add: Productive_RHS_design_form closure unrest assms)
  finally show ?thesis .
qed

lemma Productive_seq_1 [closure]:
  assumes "P is NSRD" "P is Productive" "Q is NSRD"
  shows "P ;; Q is Productive"
proof -
  have "P ;; Q = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)) ;; \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> peri\<^sub>R(Q) \<diamondop> (post\<^sub>R(Q)))"
    by (metis Healthy_def NSRD_is_SRD SRD_reactive_tri_design Productive_form assms(1) assms(2) assms(3))
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> (post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) wp\<^sub>r pre\<^sub>R Q) \<turnstile>
                       (peri\<^sub>R P \<or> ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; peri\<^sub>R Q)) \<diamondop> ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; post\<^sub>R Q))"
    by (simp add: RHS_tri_design_composition_wp rpred unrest closure assms wp NSRD_neg_pre_left_zero  SRD_healths ex_unrest wp_rea_def disj_upred_def)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> (post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) wp\<^sub>r pre\<^sub>R Q) \<turnstile>
                       (peri\<^sub>R P \<or> ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; peri\<^sub>R Q)) \<diamondop> ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr))"
  proof -
    have "((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; R1(post\<^sub>R Q)) = ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; R1(post\<^sub>R Q) \<and> $tr\<acute> >\<^sub>u $tr)"
      by (rel_auto)
    thus ?thesis
      by (simp add: NSRD_is_SRD R1_post_SRD assms)
  qed
  also have "... is Productive"
    by (rule Productive_rdes_intro, simp_all add: unrest assms closure wp_rea_def)
  finally show ?thesis .
qed

lemma Productive_seq_2 [closure]:
  assumes "P is NSRD" "Q is NSRD" "Q is Productive"
  shows "P ;; Q is Productive"
proof -
  have "P ;; Q = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P))) ;; \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> peri\<^sub>R(Q) \<diamondop> (post\<^sub>R(Q) \<and> $tr <\<^sub>u $tr\<acute>))"
    by (metis Healthy_def NSRD_is_SRD SRD_reactive_tri_design Productive_form assms)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)) \<diamondop> (post\<^sub>R P ;; (post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr)))"
    by (simp add: RHS_tri_design_composition_wp rpred unrest closure assms wp NSRD_neg_pre_left_zero  SRD_healths ex_unrest wp_rea_def disj_upred_def)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)) \<diamondop> (post\<^sub>R P ;; (post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr) \<and> $tr\<acute> >\<^sub>u $tr))"
  proof -
    have "(R1(post\<^sub>R P) ;; (post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr) \<and> $tr\<acute> >\<^sub>u $tr) = (R1(post\<^sub>R P) ;; (post\<^sub>R Q \<and> $tr\<acute> >\<^sub>u $tr))"
      by (rel_auto)
    thus ?thesis
      by (simp add: NSRD_is_SRD R1_post_SRD assms)
  qed
  also have "... is Productive"
    by (rule Productive_rdes_intro, simp_all add: unrest assms closure wp_rea_def)
  finally show ?thesis .
qed

end