(*  Title:       BDD
    Author:      Veronika Ortner and Norbert Schirmer, 2004
    Maintainer:  Norbert Schirmer,  norbert.schirmer at web de
    License:     LGPL
*)

(*
LevellistProof.thy

Copyright (C) 2004-2008 Veronika Ortner and Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>Proof of Procedure Levellist\<close>
theory LevellistProof imports ProcedureSpecs Simpl.HeapList begin

hide_const (open) DistinctTreeProver.set_of tree.Node tree.Tip

(*a well formed levellist is a list that contains all nodes with variable
i on position i
because the elements of levellist can contain old elements before the call of Levellist,
subdag_eq t pt can not be postulated for all elements of the sublists. One has to make
shure that the initial call of Levellist is parameterized with a levellist with empty sublists.
Otherwise some problems could arise in the call of Reduce!
(\<exists> ptt. (Dag pt low high ptt \<and> subdag_eq (Node lt p rt) ptt \<and> pt\<rightarrow>var = i))
consts wf_levellist :: "dag \<Rightarrow> ref list list \<Rightarrow> ref list list \<Rightarrow>
                        (ref \<Rightarrow> nat) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool"
defs wf_levellist_def: "wf_levellist t levellist_old levellist_new var low high \<equiv>
case t of Tip \<Rightarrow> levellist_old = levellist_new
| (Node lt p rt) \<Rightarrow>
  (\<forall> q. q \<in> set_of t \<longrightarrow> q \<in> set (levellist_new ! (q\<rightarrow>var))) \<and>
  (\<forall> i \<le> p\<rightarrow>var. (\<exists> prx. (levellist_new ! i) = prx@(levellist_old ! i)
                       \<and> (\<forall> pt \<in> set prx. pt \<in> set_of t \<and> pt\<rightarrow>var = i))) \<and>
  (\<forall> i. (p\<rightarrow>var) < i \<longrightarrow> (levellist_new ! i) = (levellist_old ! i)) \<and>
  (length levellist_new = length levellist_old)"
*)

lemma all_stop_cong: "(\<forall>x. P x) = (\<forall>x. P x)"
  by simp

lemma Dag_RefD:
  "\<lbrakk>Dag p l r t; p\<noteq>Null\<rbrakk> \<Longrightarrow>
    \<exists>lt rt. t=Node lt p rt \<and> Dag (l p) l r lt \<and> Dag (r p) l r rt"
  by simp

lemma Dag_unique_ex_conjI:
  "\<lbrakk>Dag p l r t;   P t\<rbrakk> \<Longrightarrow> (\<exists>t. Dag p l r t \<and> P t)"
  by simp

(* FIXME: To BinDag *)
lemma dag_Null [simp]: "dag Null l r = Tip"
  by (simp add: dag_def)

definition first:: "ref list \<Rightarrow> ref" where
"first ps = (case ps of [] \<Rightarrow> Null | (p#rs) \<Rightarrow> p)"

lemma first_simps [simp]:
 "first [] = Null"
 "first (r#rs) = r"
by (simp_all add: first_def)

definition Levellist:: "ref list \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> (ref list list) \<Rightarrow> bool" where
"Levellist hds next ll \<longleftrightarrow> (map first ll = hds) \<and>
                         (\<forall>i < length hds. List (hds ! i) next (ll!i))"

lemma Levellist_unique:
  assumes ll: "Levellist hds next ll"
  assumes ll': "Levellist hds next ll'"
  shows "ll=ll'"
proof -
  from ll have "length ll = length hds"
    by (clarsimp simp add: Levellist_def)
  moreover
  from ll' have "length ll' = length hds"
    by (clarsimp simp add: Levellist_def)
  ultimately have leq: "length ll = length ll'" by simp
  show ?thesis
  proof (rule nth_equalityI [OF leq, rule_format])
    fix i
    assume "i < length ll"
    with ll ll'
    show "ll!i = ll'!i"
      apply (clarsimp simp add: Levellist_def)
      apply (erule_tac x=i in allE)
      apply (erule_tac x=i in allE)
      apply simp
      by (erule List_unique)
  qed
qed

lemma Levellist_unique_ex_conj_simp [simp]:
"Levellist hds next ll \<Longrightarrow> (\<exists>ll. Levellist hds next ll \<and> P ll) = P ll"
by (auto dest: Levellist_unique)

lemma in_set_concat_idx:
  "x \<in> set (concat xss) \<Longrightarrow> \<exists>i < length xss. x \<in> set (xss!i)"
apply (induct xss)
apply  simp
apply clarsimp
apply (erule disjE)
apply  (rule_tac x=0 in exI)
apply  simp
apply auto
done

definition wf_levellist :: "dag \<Rightarrow> ref list list \<Rightarrow> ref list list \<Rightarrow>
                       (ref \<Rightarrow> nat) \<Rightarrow> bool" where
"wf_levellist t levellist_old levellist_new var =
(case t of Tip \<Rightarrow> levellist_old = levellist_new
| (Node lt p rt) \<Rightarrow>
  (\<forall> q. q \<in> set_of t \<longrightarrow> q \<in> set (levellist_new ! (var q))) \<and>
  (\<forall> i \<le> var p. (\<exists> prx. (levellist_new ! i) = prx@(levellist_old ! i)
                       \<and> (\<forall> pt \<in> set prx. pt \<in> set_of t \<and> var pt = i))) \<and>
  (\<forall> i. (var p) < i \<longrightarrow> (levellist_new ! i) = (levellist_old ! i)) \<and>
  (length levellist_new = length levellist_old))"

lemma wf_levellist_subset:
  assumes wf_ll: "wf_levellist t ll ll' var"
  shows "set (concat ll') \<subseteq>  set (concat ll) \<union> set_of t"
proof (cases t)
  case Tip with wf_ll show ?thesis by (simp add: wf_levellist_def)
next
  case (Node lt p rt)
  show ?thesis
  proof -
    {
      fix n
      assume "n \<in> set (concat ll')"
      from in_set_concat_idx [OF this]
      obtain i where i_bound: "i < length ll'" and n_in: "n \<in> set (ll' ! i)"
        by blast
      have "n \<in> set (concat ll) \<union> set_of t"
      proof (cases "i \<le> var p")
        case True
        with wf_ll obtain prx where
          ll'_ll: "ll' ! i = prx @ ll ! i" and
          prx: "\<forall>pt \<in> set prx. pt \<in> set_of t"  and
          leq: "length ll' = length ll"
          apply (clarsimp simp add: wf_levellist_def Node)
          apply (erule_tac x="i" in allE)
          apply clarsimp
          done
        show ?thesis
        proof (cases "n \<in> set prx")
          case True
          with prx have "n \<in> set_of t"
            by simp
          thus ?thesis by simp
        next
          case False
          with n_in ll'_ll
          have "n \<in> set (ll ! i)"
            by simp
          with i_bound leq
          have "n \<in> set (concat ll)"
            by auto
          thus ?thesis by simp
        qed
      next
        case False
        with wf_ll obtain "ll'!i = ll!i" "length ll' = length ll"
          by (auto simp add: wf_levellist_def Node)
        with n_in i_bound
        have "n \<in> set (concat ll)"
          by auto
        thus ?thesis by simp
      qed
    }
    thus ?thesis by auto
  qed
qed
(*
  next
    show "set (concat ll) \<union> set_of t \<subseteq> set (concat ll')"
    proof -
      {
        fix n
        assume "n \<in> set (concat ll)"
        from in_set_concat_idx [OF this]
        obtain i where i_bound: "i < length ll" and n_in: "n \<in> set (ll ! i)"
          by blast
        with wf_ll
        obtain "n \<in> set (ll' ! i)" "length ll = length ll'"
          apply (clarsimp simp add: wf_levellist_def Node)
          apply (case_tac "i \<le> var p")
          apply  fastforce
          apply fastforce
          done
        with i_bound have "n \<in> set (concat ll')"
          by auto
      }
      moreover
      {
        fix n
        assume "n \<in> set_of t"
        with wf_ll obtain "n \<in> set (ll' ! var n)" "length ll' = length ll"
          by (auto simp add: wf_levellist_def Node)
        with root

            next

          proof (cases prx)
            case Nil
            with ll'_ll i_bound leq n_in
            have "n \<in> set (concat ll)"
              by auto
            thus ?thesis by simp
          next
            case (Cons p prx')
            show ?thesis

              apply auto
        *)

(*
consts wf_levellist :: "dag \<Rightarrow> ref list \<Rightarrow> ref list \<Rightarrow>
                        (ref \<Rightarrow> ref) \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow>
                       (ref \<Rightarrow> nat) \<Rightarrow> bool"
defs wf_levellist_def:
"wf_levellist t levellist_old levellist_new next_old next_new var  \<equiv>
case t of Tip \<Rightarrow> levellist_old = levellist_new
| (Node lt p rt) \<Rightarrow>
  (\<forall> q. q \<in> set_of t \<longrightarrow> (\<exists>ns. List (levellist_new ! (var q)) next_new ns \<and>
                                q \<in> set ns)) \<and>
  (\<forall> i \<le> var p. (\<exists>ns_new ns_old.
                  List (levellist_new ! i) next_new ns_new \<and>
                  List (levellist_old ! i) next_old ns_old \<and>
                 (\<exists> prx. ns_new = prx@ns_old
                       \<and> (\<forall> pt \<in> set prx. pt \<in> set_of t \<and> var pt = i)))) \<and>
  (\<forall> i. (var p) < i \<longrightarrow> (\<exists>ns_new ns_old.
                          List (levellist_new ! i) next_new ns_new \<and>
                          List (levellist_old ! i) next_old ns_old \<and>
                          ns_new = ns_old)) \<and>
  (length levellist_new = length levellist_old)"
*)

lemma Levellist_ext_to_all: "((\<exists>ll. Levellist hds next ll \<and> P ll) \<longrightarrow> Q)
       =
       (\<forall>ll. Levellist hds next ll \<and> P ll \<longrightarrow> Q)"
apply blast
done

lemma Levellist_length: "Levellist hds p ll \<Longrightarrow> length ll = length hds"
  by (auto simp add: Levellist_def)

lemma map_update:
  "\<And>i. i < length xss \<Longrightarrow> map f (xss[i := xs]) = (map f xss) [i := f xs]"
apply (induct xss)
apply  simp
apply (case_tac i)
apply  simp
apply simp
done

lemma (in Levellist_impl) Levellist_spec_total':
shows "\<forall>ll \<sigma> t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t
        \<lbrace>\<sigma>. Dag \<acute>p \<acute>low \<acute>high t \<and> (\<acute>p \<noteq> Null \<longrightarrow> (\<acute>p\<rightarrow>\<acute>var) < length \<acute>levellist) \<and>
             ordered t \<acute>var \<and> Levellist \<acute>levellist \<acute>next ll \<and>
             (\<forall>n \<in> set_of t.
              (if \<acute>mark n = \<acute>m
               then n \<in> set (ll ! \<acute>var n) \<and>
                    (\<forall>nt p. Dag n \<acute>low \<acute>high nt \<and> p \<in> set_of nt
                     \<longrightarrow> \<acute>mark p = \<acute>m)
               else n \<notin> set (concat ll)))\<rbrace>
          \<acute>levellist :== PROC Levellist (\<acute>p, \<acute>m, \<acute>levellist)
       \<lbrace>\<exists>ll'. Levellist \<acute>levellist \<acute>next ll' \<and> wf_levellist t ll ll' \<^bsup>\<sigma>\<^esup>var \<and>
        wf_marking t  \<^bsup>\<sigma>\<^esup>mark \<acute>mark \<^bsup>\<sigma>\<^esup>m \<and>
        (\<forall>p. p \<notin> set_of t \<longrightarrow> \<^bsup>\<sigma>\<^esup>next p = \<acute>next p)
        \<rbrace>"
apply (hoare_rule HoareTotal.ProcRec1
           [where r="measure (\<lambda>(s,p). size (dag \<^bsup>s\<^esup>p \<^bsup>s\<^esup>low \<^bsup>s\<^esup>high))"])
apply vcg
apply (rule conjI)
apply  clarify
apply  (rule conjI)
apply   clarify
apply   (clarsimp simp del: BinDag.set_of.simps split del: if_split)
defer
apply   (rule impI)
apply   (clarsimp simp del: BinDag.set_of.simps split del: if_split)
defer
apply   (clarsimp simp add: wf_levellist_def wf_marking_def) (* p=Null*)
apply (simp only: Levellist_ext_to_all )
proof -
  fix ll var low high mark "next" nexta p levellist m lt rt
  assume pnN: "p \<noteq> Null"
  assume mark_p: "mark p = (\<not> m)"
  assume lt: "Dag (low p) low high lt"
  assume rt: "Dag (high p) low high rt"
  from pnN lt rt have Dag_p: "Dag p low high (Node lt p rt)" by simp
  from Dag_p rt
  have size_rt_dec: "size (dag (high p) low high) < size (dag p low high)"
    by (simp only: Dag_dag) simp
  from Dag_p lt
  have size_lt_dec: "size (dag (low p) low high) < size (dag p low high)"
    by (simp only: Dag_dag) simp
  assume ll: "Levellist levellist next ll"

  assume marked_child_ll:
    "\<forall>n \<in> set_of (Node lt p rt).
        if mark n = m
        then n \<in> set (ll ! var n) \<and>
             (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> mark p = m)
        else n \<notin> set (concat ll)"
  with mark_p have p_notin_ll: "p \<notin> set (concat ll)"
    by auto
  assume varsll': "var p < length levellist"
  with ll have varsll: "var p < length ll"
    by (simp add: Levellist_length)
  assume orderedt: "ordered (Node lt p rt) var"
  show "(low p \<noteq> Null \<longrightarrow> var (low p) < length levellist) \<and>
          ordered lt var \<and>
          (\<forall>n \<in> set_of lt.
              if mark n = m
              then n \<in> set (ll ! var n) \<and>
                   (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> mark p = m)
              else n \<notin> set (concat ll)) \<and>
          size (dag (low p) low high) < size (dag p low high) \<and>
          (\<forall>marka nexta levellist lla.
              Levellist levellist nexta lla \<and>
              wf_levellist lt ll lla var \<and> wf_marking lt mark marka m \<and>
              (\<forall>p. p \<notin> set_of lt \<longrightarrow> next p = nexta p)\<longrightarrow>
              (high p \<noteq> Null \<longrightarrow> var (high p) < length levellist) \<and>
              ordered rt var \<and>
              (\<exists>lla. Levellist levellist nexta lla \<and>
                     (\<forall>n \<in> set_of rt.
                        if marka n = m
                        then n \<in> set (lla ! var n) \<and>
                             (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow>
                                    marka p = m)
                        else n \<notin> set (concat lla)) \<and>
                     size (dag (high p) low high) < size (dag p low high) \<and>
                     (\<forall>markb nextb levellist llb.
                         Levellist levellist nextb llb \<and>
                         wf_levellist rt lla llb var \<and>
                         wf_marking rt marka markb m \<and>
                         (\<forall>p. p \<notin> set_of rt \<longrightarrow> nexta p = nextb p) \<longrightarrow>
                         (\<exists>ll'. Levellist (levellist[var p := p])
                                 (nextb(p := levellist ! var p)) ll' \<and>
                                wf_levellist (Node lt p rt) ll ll' var \<and>
                                wf_marking (Node lt p rt) mark (markb(p := m)) m \<and>
                                (\<forall>pa. pa \<notin> set_of (Node lt p rt) \<longrightarrow>
                                      next pa =
                                      (if pa = p then levellist ! var p
                                       else nextb pa))))))"
  proof (cases "lt")
    case Tip
    note lt_Tip = this
    show ?thesis
    proof (cases "rt")
      case Tip
      show ?thesis
        using size_rt_dec Tip lt_Tip Tip lt rt
        apply clarsimp
        subgoal premises prems for marka nexta levellista lla markb nextb levellistb llb
        proof -
          have lla: "Levellist levellista nexta lla" by fact
          have llb: "Levellist levellistb nextb llb" by fact
          have wfll_lt: "wf_levellist Tip ll lla var"
                        "wf_marking Tip mark marka m" by fact+

          then have ll_lla: "ll = lla"
            by (simp add: wf_levellist_def)

          moreover
          with wfll_lt lt_Tip lt have "marka = mark"
            by (simp add: wf_marking_def)
          moreover
          have wfll_rt:"wf_levellist Tip lla llb var"
                       "wf_marking Tip marka markb m" by fact+
          then have lla_llb: "lla = llb"
            by (simp add: wf_levellist_def)
          moreover
          with wfll_rt Tip rt have "markb = marka"
            by (simp add: wf_marking_def)
          moreover
          from varsll llb ll_lla lla_llb
          obtain "var p < length levellistb" "var p < length llb"
            by (simp add: Levellist_length)
          with llb pnN
          have llc: "Levellist (levellistb[var p := p]) (nextb(p := levellistb ! var p))
                      (llb[var p := p # llb ! var p])"
            apply (clarsimp simp add: Levellist_def map_update)
            apply (erule_tac x=i in allE)
            apply clarsimp
            apply (subgoal_tac "p \<notin> set (llb ! i) ")
            prefer 2
            using  p_notin_ll ll_lla lla_llb
            apply  simp
            apply (case_tac "i=var p")
            apply  simp
            apply simp
            done
          ultimately
          show ?thesis
            using lt_Tip Tip varsll
            apply (clarsimp simp add: wf_levellist_def wf_marking_def)
          proof -
            fix i
            assume varsllb: "var p < length llb"
            assume "i \<le> var p"
            show "\<exists>prx. llb[var p := p#llb!var p]!i = prx @ llb!i \<and>
                      (\<forall>pt\<in>set prx. pt = p \<and> var pt = i)"
            proof (cases "i = var p")
              case True
              with pnN lt rt varsllb lt_Tip Tip show ?thesis
                apply -
                apply (rule_tac x="[p]" in exI)
                apply (simp add: subdag_eq_def)
                done
            next
              assume "i \<noteq> var p"
              with varsllb show ?thesis
                apply -
                apply (rule_tac x="[]" in exI)
                apply (simp add: subdag_eq_def)
                done
            qed
          qed
        qed
      done
    next
      case (Node dag1 a dag2)
      have rt_node: "rt = Node dag1 a dag2" by fact
      with rt have high_p: "high p = a"
        by simp
      have s: "\<And>nexta. (\<forall>p. next p = nexta p) = (next = nexta)"
        by auto
      show ?thesis
        using size_rt_dec size_lt_dec rt_node lt_Tip Tip lt rt
        apply (clarsimp simp del: set_of_Node split del: if_split simp add: s)
        subgoal premises prems for marka levellista lla
        proof -
          have lla: "Levellist levellista next lla" by fact
          have wfll_lt:"wf_levellist Tip ll lla var"
                       "wf_marking Tip mark marka m" by fact+
          from this have ll_lla: "ll = lla"
            by (simp add: wf_levellist_def)
          moreover
          from wfll_lt lt_Tip lt have marklrec: "marka = mark"
            by (simp add: wf_marking_def)
          from orderedt varsll lla ll_lla rt_node lt_Tip high_p
          have var_highp_bound: "var (high p) < length levellista"
            by (auto simp add: Levellist_length)
          from orderedt high_p rt_node lt_Tip
          have ordered_rt: "ordered (Node dag1 (high p) dag2) var"
            by simp
          from high_p marklrec marked_child_ll lt rt lt_Tip rt_node ll_lla
          have mark_rt: "(\<forall>n\<in>set_of (Node dag1 (high p) dag2).
                if marka n = m
                then n \<in> set (lla ! var n) \<and>
                     (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> marka p = m)
                else n \<notin> set (concat lla))"
            apply (simp only: BinDag.set_of.simps)
            apply clarify
            apply (drule_tac x=n in bspec)
            apply  blast
            apply assumption
            done
          show ?thesis
            apply (rule conjI)
            apply  (rule var_highp_bound)
            apply (rule conjI)
            apply  (rule ordered_rt)
            apply (rule conjI)
            apply  (rule mark_rt)
            apply clarify
            apply clarsimp
            subgoal premises prems for markb nextb levellistb llb
            proof -
              have llb: "Levellist levellistb nextb llb" by fact
              have wfll_rt: "wf_levellist (Node dag1 (high p) dag2) lla llb var" by fact
              have wfmarking_rt: "wf_marking (Node dag1 (high p) dag2) marka markb m" by fact
              from wfll_rt varsll llb ll_lla
              obtain var_p_bounds: "var p < length levellistb" "var p < length llb"
                by (simp add: Levellist_length wf_levellist_def)
              with p_notin_ll ll_lla wfll_rt
              have p_notin_llb: "\<forall>i < length llb. p \<notin> set (llb ! i)"
                apply -
                apply (intro allI impI)
                apply (clarsimp simp add: wf_levellist_def)
                apply (case_tac "i \<le> var (high p)")
                apply  (drule_tac x=i in spec)
                using  orderedt rt_node lt_Tip high_p
                apply  clarsimp
                apply (drule_tac x=i in spec)
                apply (drule_tac x=i in spec)
                apply clarsimp
                done
              with llb pnN var_p_bounds
              have llc: "Levellist (levellistb[var p := p])
                            (nextb(p := levellistb ! var p))
                            (llb[var p := p # llb ! var p])"
                apply (clarsimp simp add: Levellist_def map_update)
                apply (erule_tac x=i in allE)
                apply (erule_tac x=i in allE)
                apply clarsimp
                apply (case_tac "i=var p")
                apply  simp
                apply simp
                done
              then show ?thesis
                apply simp
                using wfll_rt wfmarking_rt
                      lt_Tip rt_node varsll orderedt lt rt pnN ll_lla marklrec
                apply (clarsimp simp add: wf_levellist_def wf_marking_def)
                apply (intro conjI)
                apply  (rule allI)
                apply  (rule conjI)
                apply   (erule_tac x="q" in allE)
                apply   (case_tac "var p = var q")
                apply    fastforce
                apply   fastforce
                apply  (case_tac "var p = var q")
                apply   hypsubst_thin
                apply   fastforce
                apply  fastforce
                apply (rule allI)
                apply (rotate_tac 4)
                apply (erule_tac x="i" in allE)
                apply (case_tac "i=var p")
                apply  simp
                apply (case_tac "var (high p) < i")
                apply  simp
                apply simp
                apply (erule exE)
                apply (rule_tac x="prx" in exI)
                apply (intro conjI)
                apply  simp
                apply clarify
                apply (rotate_tac 15)
                apply (erule_tac x="pt" in ballE)
                apply  fastforce
                apply fastforce
                done
            qed
          done
        qed
      done
    qed
  next
    case (Node llt l rlt)
    have lt_Node: "lt = Node llt l rlt" by fact
    from orderedt lt varsll' lt_Node
    obtain ordered_lt:
      "ordered lt var" "(low p \<noteq> Null \<longrightarrow> var (low p) < length levellist)"
      by (cases rt) auto
    from lt lt_Node marked_child_ll
    have mark_lt: "\<forall>n\<in>set_of lt.
     if mark n = m
     then n \<in> set (ll ! var n) \<and>
          (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> mark p = m)
     else n \<notin> set (concat ll)"
      apply (simp only: BinDag.set_of.simps)
      apply clarify
      apply (drule_tac x=n in bspec)
      apply  blast
      apply assumption
      done
    show ?thesis
      apply (intro conjI ordered_lt mark_lt size_lt_dec)
      apply (clarify)
      apply (simp add: size_rt_dec split del: if_split)
      apply (simp only: Levellist_ext_to_all)
      subgoal premises prems for marka nexta levellista lla
      proof -
        have lla: "Levellist levellista nexta lla" by fact
        have wfll_lt: "wf_levellist lt ll lla var"  by fact
        have wfmarking_lt:"wf_marking lt mark marka m" by fact
        from wfll_lt lt_Node
        have lla_eq_ll: "length lla = length ll"
          by (simp add: wf_levellist_def)
        with ll lla have lla_eq_ll': "length levellista = length levellist"
          by (simp add: Levellist_length)
        with orderedt rt lt_Node lt varsll'
        obtain ordered_rt:
          "ordered rt var" "(high p \<noteq> Null \<longrightarrow> var (high p) < length levellista)"
          by (cases rt) auto
        from wfll_lt lt_Node
        have nodes_in_lla: "\<forall> q. q \<in> set_of lt \<longrightarrow> q \<in> set (lla ! (q\<rightarrow>var))"
          by (simp add: wf_levellist_def)
        from wfll_lt lt_Node lt
        have lla_st: "(\<forall>i \<le> (low p)\<rightarrow>var.
                        (\<exists>prx. (lla ! i) = prx@(ll ! i) \<and>
                               (\<forall>pt \<in> set prx. pt \<in> set_of lt \<and> pt\<rightarrow>var = i)))"
          by (simp add: wf_levellist_def)
        from wfll_lt lt_Node lt
        have lla_nc: "\<forall>i. ((low p)\<rightarrow>var) < i \<longrightarrow> (lla ! i) = (ll ! i)"
          by (simp add: wf_levellist_def)
        from wfmarking_lt lt_Node lt
        have mot_nc: "\<forall> n. n \<notin> set_of lt \<longrightarrow> mark n = marka n"
          by (simp add: wf_marking_def)
        from wfmarking_lt lt_Node lt
        have mit_marked: "\<forall>n. n \<in> set_of lt \<longrightarrow> marka n = m"
          by (simp add: wf_marking_def)
        from marked_child_ll nodes_in_lla mot_nc mit_marked lla_st
        have mark_rt: "\<forall>n\<in>set_of rt.
               if marka n = m
               then n \<in> set (lla ! var n) \<and>
                   (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> marka p = m)
               else n \<notin> set (concat lla)"
          apply -
          apply (rule ballI)
          apply (drule_tac x="n" in bspec)
          apply (simp)
        proof -
          fix n

          assume nodes_in_lla: "\<forall>q. q \<in> set_of lt \<longrightarrow> q \<in> set (lla ! var q)"
          assume mot_nc: "\<forall>n. n \<notin> set_of lt \<longrightarrow> mark n = marka n"
          assume mit_marked: "\<forall>n. n \<in> set_of lt \<longrightarrow> marka n = m"
          assume marked_child_ll: "if mark n = m
           then n \<in> set (ll ! var n) \<and>
                (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> mark p = m)
           else n \<notin> set (concat ll)"

          assume lla_st: "\<forall>i\<le>var (low p).
                               \<exists>prx. lla ! i = prx @ ll ! i \<and>
                               (\<forall>pt\<in>set prx. pt \<in> set_of lt \<and> var pt = i)"

          assume n_in_rt: " n \<in> set_of rt"
          show n_in_lla_marked: "if marka n = m
             then n \<in> set (lla ! var n) \<and>
                  (\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> marka p = m)
             else n \<notin> set (concat lla)"
          proof (cases "n \<in> set_of lt")
            case True
            from True nodes_in_lla have n_in_ll: "n \<in> set (lla ! var n)"
              by simp
            moreover
            from True wfmarking_lt
            have "marka n = m"
              apply (cases lt)
              apply (auto simp add: wf_marking_def)
              done
            moreover
            {
              fix nt p
              assume "Dag n low high nt"
              with lt True have subset_nt_lt: "set_of nt \<subseteq> set_of lt"
                by (rule dag_setof_subsetD)
              moreover assume " p \<in> set_of nt"
              ultimately have "p \<in> set_of lt"
                by blast
              with mit_marked have " marka p = m"
                by simp
            }
            ultimately show ?thesis
              using n_in_rt
              apply clarsimp
              done
          next
            assume n_notin_lt: "n \<notin> set_of lt"
            show ?thesis
            proof (cases "marka n = m")
              case True
              from n_notin_lt mot_nc have marka_eq_mark: "mark n = marka n"
                by simp
              from marka_eq_mark True have n_marked: "mark n = m"
                by simp
              from rt n_in_rt have nnN: "n \<noteq> Null"
                apply -
                apply (rule set_of_nn [rule_format])
                apply fastforce
                apply assumption
                done
              from marked_child_ll n_in_rt marka_eq_mark nnN n_marked
              have n_in_ll: "n \<in> set (ll ! var n)"
                by fastforce
              from marked_child_ll n_in_rt marka_eq_mark nnN n_marked lt rt
              have nt_mark: "\<forall>nt p. Dag n low high nt \<and> p \<in> set_of nt \<longrightarrow> mark p = m"
                by simp
              from nodes_in_lla n_in_ll lla_st
              have n_in_lla: "n \<in> set (lla ! var n)"
              proof (cases "var (low p) < (var n)")
                case True
                with lla_nc have "(lla ! var n) = (ll ! var n)"
                  by fastforce
                with n_in_ll show ?thesis
                  by fastforce
              next
                assume varnslp: " \<not> var (low p) < var n"
                with lla_st
                have ll_in_lla: "\<exists>prx. lla ! (var n) = prx @ ll ! (var n)"
                  apply -
                  apply (erule_tac x="var n" in allE)
                  apply fastforce
                  done
                with n_in_ll show ?thesis
                  by fastforce
              qed
              {
                fix nt pt
                assume nt_Dag: "Dag n low high nt"
                assume pt_in_nt: "pt \<in> set_of nt"
                have " marka pt = m"
                proof (cases "pt \<in> set_of lt")
                  case True
                  with mit_marked show ?thesis
                    by fastforce
                next
                  assume pt_notin_lt: " pt \<notin> set_of lt"
                  with mot_nc have "mark pt = marka pt"
                    by fastforce
                  with nt_mark nt_Dag pt_in_nt show ?thesis
                    by fastforce
                qed
              }
              then have nt_marka:
                "\<forall>nt pt. Dag n low high nt \<and> pt \<in> set_of nt \<longrightarrow> marka pt = m"
                by fastforce
              with n_in_lla nt_marka True show ?thesis
                by fastforce
            next
              case False
              note n_not_marka = this
              with wfmarking_lt n_notin_lt
              have "mark n \<noteq> m"
                by (simp add: wf_marking_def lt_Node)
              with marked_child_ll
              have n_notin_ll: "n \<notin> set (concat ll)"
                by simp
              show ?thesis
              proof (cases "n \<in> set (concat lla)")
                case False with n_not_marka show ?thesis by simp
              next
                case True
                with wf_levellist_subset [OF wfll_lt] n_notin_ll
                have "n \<in> set_of lt"
                  by blast
                with n_notin_lt have False by simp
                thus ?thesis ..
              qed
            qed
          qed
        qed
        show ?thesis
          apply (intro conjI ordered_rt mark_rt)
          apply clarify
          subgoal premises prems for markb nextb levellistb llb
          proof -
            have llb: "Levellist levellistb nextb llb" by fact
            have wfll_rt: "wf_levellist rt lla llb var" by fact
            have wfmarking_rt: "wf_marking rt marka markb m" by fact
            show ?thesis
            proof (cases rt)
              case Tip
              from wfll_rt Tip have lla_llb: "lla = llb"
                by (simp add: wf_levellist_def)
              moreover
              from wfmarking_rt Tip rt have "markb = marka"
                by (simp add: wf_marking_def)
              moreover
              from wfll_lt varsll llb lla_llb
              obtain var_p_bounds: "var p < length levellistb" "var p < length llb"
                by (simp add: Levellist_length wf_levellist_def lt_Node Tip)
              with p_notin_ll lla_llb wfll_lt
              have p_notin_llb: "\<forall>i < length llb. p \<notin> set (llb ! i)"
                apply -
                apply (intro allI impI)
                apply (clarsimp simp add: wf_levellist_def lt_Node)
                apply (case_tac "i \<le> var l")
                apply  (drule_tac x=i in spec)
                using  orderedt Tip lt_Node
                apply  clarsimp
                apply (drule_tac x=i in spec)
                apply (drule_tac x=i in spec)
                apply clarsimp
                done
              with llb pnN var_p_bounds
              have llc: "Levellist (levellistb[var p := p])
                            (nextb(p := levellistb ! var p))
                            (llb[var p := p # llb ! var p])"
                apply (clarsimp simp add: Levellist_def map_update)
                apply (erule_tac x=i in allE)
                apply (erule_tac x=i in allE)
                apply clarsimp
                apply (case_tac "i=var p")
                apply  simp
                apply simp
                done
              ultimately show ?thesis
                using Tip lt_Node varsll orderedt lt rt pnN wfll_lt wfmarking_lt
                apply (clarsimp simp add: wf_levellist_def wf_marking_def)
                apply (intro conjI)
                apply  (rule allI)
                apply  (rule conjI)
                apply   (erule_tac x="q" in allE)
                apply   (case_tac "var p = var q")
                apply    fastforce
                apply   fastforce
                apply  (case_tac "var p = var q")
                apply   hypsubst_thin
                apply   fastforce
                apply  fastforce
                apply (rule allI)
                apply (rotate_tac 4)
                apply (erule_tac x="i" in allE)
                apply (case_tac "i=var p")
                apply  simp
                apply (case_tac "var (low p) < i")
                apply  simp
                apply simp
                apply (erule exE)
                apply (rule_tac x="prx" in exI)
                apply (intro conjI)
                apply  simp
                apply clarify
                apply (rotate_tac 15)
                apply (erule_tac x="pt" in ballE)
                apply  fastforce
                apply fastforce
                done
            next
              case (Node lrt r rrt)
              have rt_Node: "rt = Node lrt r rrt" by fact
              from wfll_rt rt_Node
              have llb_eq_lla: "length llb = length lla"
                by (simp add: wf_levellist_def)
              with llb lla
              have llb_eq_lla': "length levellistb = length levellista"
                by (simp add: Levellist_length)
              from wfll_rt rt_Node
              have nodes_in_llb: "\<forall>q. q \<in> set_of rt \<longrightarrow> q \<in> set (llb ! (q\<rightarrow>var))"
                by (simp add: wf_levellist_def)
              from wfll_rt rt_Node rt
              have llb_st: "(\<forall> i \<le> (high p)\<rightarrow>var.
                             (\<exists> prx. (llb ! i) = prx@(lla ! i) \<and>
                             (\<forall>pt \<in> set prx. pt \<in> set_of rt \<and> pt\<rightarrow>var = i)))"
                by (simp add: wf_levellist_def)
              from wfll_rt rt_Node rt
              have llb_nc:
                "\<forall>i. ((high p)\<rightarrow>var) < i \<longrightarrow> (llb ! i) = (lla ! i)"
                by (simp add: wf_levellist_def)
              from wfmarking_rt rt_Node rt
              have mort_nc: "\<forall>n. n \<notin> set_of rt \<longrightarrow> marka n = markb n"
                by (simp add: wf_marking_def)
              from wfmarking_rt rt_Node rt
              have mirt_marked: "\<forall>n. n \<in> set_of rt \<longrightarrow> markb n = m"
                by (simp add: wf_marking_def)
              with p_notin_ll wfll_rt wfll_lt
              have p_notin_llb: "\<forall>i < length llb. p \<notin> set (llb ! i)"
                apply -
                apply (intro allI impI)
                apply (clarsimp simp add: wf_levellist_def lt_Node rt_Node)
                apply (case_tac "i \<le> var r")
                apply  (drule_tac x=i in spec)
                using  orderedt rt_Node lt_Node
                apply  clarsimp
                apply  (erule disjE)
                apply   clarsimp
                apply  (case_tac "i \<le> var l")
                apply   (drule_tac x=i in spec)
                apply   clarsimp
                apply  clarsimp
                apply (subgoal_tac "llb ! i = lla ! i")
                prefer 2
                apply  clarsimp
                apply (case_tac "i \<le> var l")
                apply  (drule_tac x=i in spec, erule impE, assumption)
                apply  clarsimp
                using  orderedt rt_Node lt_Node
                apply  clarsimp
                apply clarsimp
                done
              from wfll_lt wfll_rt varsll lla llb
              obtain var_p_bounds: "var p < length levellistb" "var p < length llb"
                by (simp add: Levellist_length wf_levellist_def lt_Node rt_Node)
              with p_notin_llb llb pnN var_p_bounds
              have llc: "Levellist (levellistb[var p := p])
                            (nextb(p := levellistb ! var p))
                            (llb[var p := p # llb ! var p])"
                apply (clarsimp simp add: Levellist_def map_update)
                apply (erule_tac x=i in allE)
                apply (erule_tac x=i in allE)
                apply clarsimp
                apply (case_tac "i=var p")
                apply  simp
                apply simp
                done
              then show ?thesis
              proof (clarsimp)
                show "wf_levellist (Node lt p rt) ll (llb[var p := p#llb ! var p]) var \<and>
                      wf_marking (Node lt p rt) mark (markb(p := m)) m"
                proof -
                  have nodes_in_upllb: "\<forall> q. q \<in> set_of (Node lt p rt)
                    \<longrightarrow> q \<in> set (llb[var p :=p # llb ! var p] ! (var q))"
                    apply -
                    apply (rule allI)
                    apply (rule impI)
                  proof -
                    fix q
                    assume q_in_t: "q \<in> set_of (Node lt p rt)"
                    show q_in_upllb:
                      "q \<in> set (llb[var p :=p # llb ! var p] ! (var q))"
                    proof (cases "q \<in> set_of rt")
                      case True
                      with nodes_in_llb have q_in_llb: "q \<in> set (llb ! (var q))"
                        by fastforce
                      from orderedt rt_Node lt_Node lt rt
                      have ordered_rt: "ordered rt var"
                        by fastforce
                      from True rt ordered_rt rt_Node lt lt_Node have "var q \<le> var r"
                        apply -
                        apply (drule subnodes_ordered)
                        apply fastforce
                        apply fastforce
                        apply fastforce
                        done
                      with orderedt rt lt rt_Node lt_Node have "var q < var p"
                        by fastforce
                      then have
                        "llb[var p :=p#llb ! var p] ! var q =
                         llb ! var q"
                        by fastforce
                      with q_in_llb show ?thesis
                        by fastforce
                    next
                      assume q_notin_rt: "q \<notin> set_of rt"
                      show "q \<in> set (llb[var p :=p # llb ! var p] ! var q)"
                      proof (cases "q \<in> set_of lt")
                        case True
                        assume q_in_lt: "q \<in> set_of lt"
                        with nodes_in_lla have q_in_lla: "q \<in> set (lla ! (var q))"
                          by fastforce
                        from orderedt rt_Node lt_Node lt rt
                        have ordered_lt: "ordered lt var"
                          by fastforce
                        from q_in_lt lt ordered_lt rt_Node rt lt_Node
                        have "var q \<le> var l"
                          apply -
                          apply (drule subnodes_ordered)
                          apply fastforce
                          apply fastforce
                          apply fastforce
                          done
                        with orderedt rt lt rt_Node lt_Node have qsp: "var q < var p"
                          by fastforce
                        then show ?thesis
                        proof (cases "var q \<le> var (high p)")
                          case True
                          with llb_st
                          have "\<exists>prx. (llb ! (var q)) = prx@(lla ! (var q))"
                            by fastforce
                          with nodes_in_lla q_in_lla
                          have q_in_llb: "q \<in> set (llb ! (var q))"
                            by fastforce
                          from qsp
                          have "llb[var p :=p#llb ! var p]!var q =
                                   llb ! (var q)"
                            by fastforce
                          with q_in_llb show ?thesis
                            by fastforce
                        next
                          assume "\<not> var q \<le> var (high p)"
                          with llb_nc have "llb ! (var q) = lla ! (var q)"
                            by fastforce
                          with q_in_lla have q_in_llb: "q \<in> set (llb ! (var q))"
                            by fastforce
                          from qsp have
                            "llb[var p :=p # llb ! var p] ! var q = llb ! (var q)"
                            by fastforce
                          with q_in_llb show ?thesis
                            by fastforce
                        qed
                      next
                        assume q_notin_lt: "q \<notin> set_of lt"
                        with q_notin_rt rt lt rt_Node lt_Node q_in_t have qp: "q = p"
                          by fastforce
                        with varsll lla_eq_ll llb_eq_lla have "var p < length llb"
                          by fastforce
                        with qp show ?thesis
                          by simp
                      qed
                    qed
                  qed
                  have prx_ll_st: "\<forall>i \<le> var p.
                   (\<exists>prx. llb[var p :=p#llb!var p]!i = prx@(ll!i) \<and>
                         (\<forall>pt \<in> set prx. pt \<in> set_of (Node lt p rt) \<and> var pt = i))"
                    apply -
                    apply (rule allI)
                    apply (rule impI)
                  proof -
                    fix i
                    assume isep: "i \<le> var p"
                    show "\<exists>prx. llb[var p :=p#llb!var p]!i = prx@ll!i \<and>
                      (\<forall>pt\<in>set prx. pt \<in> set_of (Node lt p rt) \<and> var pt = i)"
                    proof (cases "i = var p")
                      case True
                      with orderedt lt lt_Node rt rt_Node
                      have lpsp: "var (low p) < var p"
                        by fastforce
                      with orderedt lt lt_Node rt rt_Node
                      have hpsp: "var (high p) < var p"
                        by fastforce
                      with lpsp lla_nc
                      have llall: "lla ! var p = ll ! var p"
                        by fastforce
                      with hpsp llb_nc have "llb ! var p = ll ! var p"
                        by fastforce
                      with llb_eq_lla lla_eq_ll isep True varsll lt rt show ?thesis
                        apply -
                        apply (rule_tac x="[p]" in exI)
                        apply (rule conjI)
                        apply simp
                        apply (rule ballI)
                        apply fastforce
                        done
                    next
                      assume inp: " i \<noteq> var p"
                      show ?thesis
                      proof (cases "var (low p) < i")
                        case True
                        with lla_nc have llall: "lla ! i = ll ! i"
                          by fastforce
                        assume vpsi: "var (low p) < i"
                        show ?thesis
                        proof (cases "var (high p) < i")
                          case True
                          with llall llb_nc have "llb ! i = ll ! i"
                            by fastforce
                          with inp True vpsi varsll lt rt show ?thesis
                            apply -
                            apply (rule_tac x="[]" in exI)
                            apply (rule conjI)
                            apply simp
                            apply (rule ballI)
                            apply fastforce
                            done
                        next
                          assume isehp: " \<not> var (high p) < i"
                          with vpsi lla_nc have lla_ll: "lla ! i = ll ! i"
                            by fastforce
                          with isehp llb_st
                          have prx_lla: "\<exists>prx. llb ! i = prx @ lla ! i \<and>
                            (\<forall>pt\<in>set prx. pt \<in> set_of rt \<and> var pt = i)"
                            apply -
                            apply (erule_tac x="i" in allE)
                            apply simp
                            done
                          with lla_ll inp rt show ?thesis
                            apply -
                            apply (erule exE)
                            apply (rule_tac x="prx" in exI)
                            apply simp
                            done
                        qed
                      next
                        assume iselp: "\<not> var (low p) < i"
                        show ?thesis
                        proof (cases "var (high p) < i")
                          case True
                          with llb_nc have llb_ll: "llb ! i = lla ! i"
                            by fastforce
                          with iselp lla_st
                          have prx_ll: "\<exists>prx. lla ! i = prx @ ll ! i \<and>
                            (\<forall>pt\<in>set prx. pt \<in> set_of lt \<and> var pt = i)"
                            apply -
                            apply (erule_tac x="i" in allE)
                            apply simp
                            done
                          with llb_ll inp lt show ?thesis
                            apply -
                            apply (erule exE)
                            apply (rule_tac x="prx" in exI)
                            apply simp
                            done
                        next
                          assume isehp: " \<not> var (high p) < i"
                          from iselp lla_st
                          have prxl: "\<exists>prx. lla ! i = prx @ ll ! i \<and>
                            (\<forall>pt\<in>set prx. pt \<in> set_of lt \<and> var pt = i)"
                            by fastforce
                          from isehp llb_st
                          have prxh: "\<exists>prx. llb ! i = prx @ lla ! i \<and>
                            (\<forall>pt\<in>set prx. pt \<in> set_of rt \<and> var pt = i)"
                            by fastforce
                          with prxl inp lt pnN rt show ?thesis
                            apply -
                            apply (elim exE)
                            apply (rule_tac x="prxa @ prx" in exI)
                            apply simp
                            apply (elim conjE)
                            apply fastforce
                            done
                        qed
                      qed
                    qed
                  qed
                  have big_Nodes_nc: "\<forall>i. (p->var) < i
                    \<longrightarrow> (llb[var p :=p # llb ! var p]) ! i = ll ! i"
                    apply -
                    apply (rule allI)
                    apply (rule impI)
                  proof -
                    fix i
                    assume psi: "var p < i"
                    with orderedt lt rt lt_Node rt_Node have lpsi: "var (low p) < i"
                      by fastforce
                    with lla_nc have lla_ll: "lla ! i = ll ! i"
                      by fastforce
                    from psi orderedt lt rt lt_Node rt_Node have hpsi: "var (high p) < i"
                      by fastforce
                    with llb_nc have llb_lla: "llb ! i = lla ! i"
                      by fastforce
                    from psi
                    have upllb_llb: "llb[var p :=p#llb!var p]!i = llb!i"
                      by fastforce
                    from upllb_llb llb_lla lla_ll
                    show "llb[var p :=p # llb ! var p] ! i = ll ! i"
                      by fastforce
                  qed
                  from lla_eq_ll llb_eq_lla
                  have length_eq: "length (llb[var p :=p # llb ! var p]) = length ll"
                    by fastforce
                  from length_eq big_Nodes_nc prx_ll_st nodes_in_upllb
                  have wf_ll_upllb:
                    "wf_levellist (Node lt p rt) ll (llb[var p :=p # llb ! var p]) var"
                    by (simp add: wf_levellist_def)
                  have mark_nc:
                    "\<forall> n. n \<notin> set_of (Node lt p rt) \<longrightarrow> (markb(p:=m)) n = mark n"
                    apply -
                    apply (rule allI)
                    apply (rule impI)
                  proof -
                    fix n
                    assume nnit: "n \<notin> set_of (Node lt p rt)"
                    with lt rt have nnilt: " n \<notin> set_of lt"
                      by fastforce
                    from nnit lt rt have nnirt: " n \<notin> set_of rt"
                      by fastforce
                    with nnilt mot_nc mort_nc have mb_eq_m: "markb n = mark n"
                      by fastforce
                    from nnit have "n\<noteq>p"
                      by fastforce
                    then have upmarkb_markb: "(markb(p :=m)) n = markb n"
                      by fastforce
                    with mb_eq_m show "(markb(p :=m)) n = mark n"
                      by fastforce
                  qed
                  have mark_c: "\<forall> n. n \<in> set_of (Node lt p rt) \<longrightarrow> (markb(p :=m)) n = m"
                    apply -
                    apply (intro allI)
                    apply (rule impI)
                  proof -
                    fix n
                    assume nint: " n \<in> set_of (Node lt p rt)"
                    show "(markb(p :=m)) n = m"
                    proof (cases "n=p")
                      case True
                      then show ?thesis
                        by fastforce
                    next
                      assume nnp: " n \<noteq> p"
                      show ?thesis
                      proof (cases "n \<in> set_of rt")
                        case True
                        with mirt_marked have "markb n = m"
                          by fastforce
                        with nnp show ?thesis
                          by fastforce
                      next
                        assume nninrt: " n \<notin> set_of rt"
                        with nint nnp have ninlt: "n \<in> set_of lt"
                          by fastforce
                        with mit_marked have marka_m: "marka n = m"
                          by fastforce
                        from mort_nc nninrt have "marka n = markb n"
                          by fastforce
                        with marka_m have "markb n = m"
                          by fastforce
                        with nnp show ?thesis
                          by fastforce
                      qed
                    qed
                  qed
                  from mark_c mark_nc
                  have wf_mark: "wf_marking (Node lt p rt) mark (markb(p :=m)) m"
                    by (simp add: wf_marking_def)
                  with wf_ll_upllb show ?thesis
                    by fastforce
                qed
              qed
            qed
          qed
        done
      qed
    done
  qed
next
  fix var low high p lt rt and levellist and
    ll::"ref list list" and mark::"ref \<Rightarrow> bool" and "next"
  assume pnN: "p \<noteq> Null"
  assume ll: "Levellist levellist next ll"
  assume vpsll: "var p < length levellist"
  assume orderedt: "ordered (Node lt p rt) var"
  assume marked_child_ll: "\<forall>n\<in>set_of (Node lt p rt).
           if mark n = mark p
           then n \<in> set (ll ! var n) \<and>
                (\<forall>nt pa. Dag n low high nt \<and> pa \<in> set_of nt \<longrightarrow> mark pa = mark p)
           else n \<notin> set (concat ll)"
  assume lt: "Dag (low p) low high lt"
  assume rt: "Dag (high p) low high rt"
  show "wf_levellist (Node lt p rt) ll ll var \<and>
        wf_marking (Node lt p rt) mark mark (mark p)"
  proof -
    from marked_child_ll pnN lt rt have marked_st:
      "(\<forall>pa. pa \<in> set_of (Node lt p rt) \<longrightarrow> mark pa = mark p)"
      apply -
      apply (drule_tac x="p" in bspec)
      apply  simp
      apply (clarsimp)
      apply (erule_tac x="(Node lt p rt)" in allE)
      apply simp
      done
    have nodest_in_ll:
      "\<forall>q. q \<in> set_of (Node lt p rt) \<longrightarrow> q \<in> set (ll ! var q)"
    proof -
      from marked_child_ll pnN have pinll: "p \<in> set (ll ! var p)"
        apply -
        apply (drule_tac x="p" in bspec)
        apply  simp
        apply fastforce
        done
      from marked_st marked_child_ll lt rt show ?thesis
        apply -
        apply (rule allI)
        apply (erule_tac x="q" in allE)
        apply (rule impI)
        apply (erule impE)
        apply  assumption
        apply (drule_tac x="q" in bspec)
        apply  simp
        apply fastforce
        done
    qed
    have levellist_nc: "\<forall> i \<le> var p. (\<exists> prx. ll ! i = prx@(ll ! i) \<and>
      (\<forall> pt \<in> set prx. pt \<in> set_of (Node lt p rt) \<and> var pt = i))"
      apply -
      apply (rule allI)
      apply (rule impI)
      apply (rule_tac x="[]" in exI)
      apply fastforce
      done
    have ll_nc: "\<forall> i. (var p) < i \<longrightarrow> ll ! i = ll ! i"
      by fastforce
    have length_ll: "length ll = length ll"
      by fastforce
    with ll_nc levellist_nc nodest_in_ll
    have wf: "wf_levellist (Node lt p rt) ll ll var"
      by (simp add: wf_levellist_def)
    have m_nc: "\<forall> n. n \<notin> set_of (Node lt p rt) \<longrightarrow> mark n = mark n"
      by fastforce
    from marked_st have "\<forall> n. n \<in> set_of (Node lt p rt) \<longrightarrow> mark n = mark p"
      by fastforce
    with m_nc have " wf_marking (Node lt p rt) mark mark (mark p)"
      by (simp add: wf_marking_def)
    with wf show ?thesis
      by fastforce
  qed
qed

lemma allD: "\<forall>ll. P ll \<Longrightarrow> P ll"
  by blast

lemma replicate_spec: "\<lbrakk>\<forall>i < n. xs ! i = x; n=length xs\<rbrakk>
  \<Longrightarrow> replicate (length xs) x = xs"
apply hypsubst_thin
apply (induct xs)
apply  simp
apply force
done

lemma (in Levellist_impl) Levellist_spec_total:
shows "\<forall>\<sigma> t. \<Gamma>,\<Theta>\<turnstile>\<^sub>t
        \<lbrace>\<sigma>. Dag \<acute>p \<acute>low \<acute>high t \<and> (\<forall>i < length \<acute>levellist. \<acute>levellist ! i = Null) \<and>
             length \<acute>levellist  = \<acute>p \<rightarrow> \<acute>var + 1 \<and>
             ordered t \<acute>var \<and> (\<forall>n \<in> set_of t. \<acute>mark n = (\<not> \<acute>m) )\<rbrace>
          \<acute>levellist :== PROC Levellist (\<acute>p, \<acute>m, \<acute>levellist)
       \<lbrace>\<exists>ll. Levellist \<acute>levellist \<acute>next ll \<and> wf_ll t ll \<^bsup>\<sigma>\<^esup>var  \<and>
         length \<acute>levellist = \<^bsup>\<sigma>\<^esup>p \<rightarrow> \<^bsup>\<sigma>\<^esup>var + 1 \<and>
         wf_marking t \<^bsup>\<sigma>\<^esup>mark \<acute>mark \<^bsup>\<sigma>\<^esup>m \<and>
         (\<forall>p. p \<notin> set_of t \<longrightarrow> \<^bsup>\<sigma>\<^esup>next p = \<acute>next p)\<rbrace>"
apply (hoare_rule HoareTotal.conseq)
apply  (rule_tac ll="replicate (\<^bsup>\<sigma>\<^esup>p\<rightarrow>\<^bsup>\<sigma>\<^esup>var + 1) []" in allD [OF Levellist_spec_total'])
apply (intro allI impI)
apply (rule_tac x=\<sigma> in exI)
apply (rule_tac x=t in exI)
apply (rule conjI)
apply  (clarsimp split:if_split_asm simp del: concat_replicate_trivial)
apply  (frule replicate_spec [symmetric])
apply   (simp)
apply  (clarsimp simp add: Levellist_def )
apply  (case_tac i)
apply   simp
apply  simp
apply (simp add: Collect_conv_if split:if_split_asm)
apply vcg_step
apply (elim exE conjE)
apply (rule_tac x=ll' in exI)
apply simp
apply (thin_tac "\<forall>p. p \<notin> set_of t \<longrightarrow> next p = nexta p")
apply (simp add: wf_levellist_def wf_ll_def)
apply (case_tac "t = Tip")
apply  simp
apply  (rule conjI)
apply   clarsimp
apply   (case_tac k)
apply    simp
apply   simp
apply  (subgoal_tac "length ll'=Suc (var Null)")
apply   (simp add: Levellist_length)
apply  fastforce
apply (split dag.splits)
apply  simp
apply (elim conjE)
apply (intro conjI)
apply   (rule allI)
apply   (erule_tac x="pa" in allE)
apply   clarify
prefer 2
apply  (simp add: Levellist_length)
apply (rule allI)
apply (rule impI)
apply (rule ballI)
apply (rotate_tac 11)
apply (erule_tac x="k" in allE)
apply (rename_tac dag1 ref dag2 k pa)
apply (subgoal_tac "k <= var ref")
prefer 2
apply  (subgoal_tac "ref = p")
apply   simp
apply  clarify
apply  (erule_tac ?P = "Dag p low high (Node dag1 ref dag2)" in rev_mp)
apply  (simp (no_asm))
apply (rotate_tac 14)
apply (erule_tac x=k in allE)
apply clarify
apply (erule_tac x=k in allE)
apply clarify
apply (case_tac k)
apply  simp
apply simp
done

end


(* Title: CTR/CTR.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Infrastructure for the synthesis of the transfer rules and relativized
constants.
*)

section\<open>\<open>CTR\<close>\<close>
theory CTR
  imports
    "../UD/UD"
    "HOL-Library.Conditional_Parametricity"
  keywords "ctr_relator" :: thy_defn
    and "ctr" :: thy_defn
    and "trp"
    and "synthesis"
    and "relativization"
    and "hybrid"
    and "parametricity"
begin

subsection\<open>Import\<close>

ML_file "CTR_Relators.ML"
ML_file "CTR_Foundations.ML"
ML_file "CTR_Algorithm.ML"
ML_file "CTR_Conversions.ML"
ML_file "CTR_Relativization.ML"
ML_file "CTR_Parametricity.ML"
ML_file "CTR_Postprocessing.ML"
ML_file "CTR.ML"

subsection\<open>Rewriting\<close>

named_theorems ctr_blank
named_theorems ctr_simps

lemma ctr_simps_pred_fun_top_eq_range[ctr_simps]:
  "pred_fun top (\<lambda>x. x \<in> R) f = (range f \<subseteq> R)"
  by auto
lemma ctr_simps_pred_prod_eq_cart[ctr_simps]:
  "pred_prod (\<lambda>x. x \<in> A) (\<lambda>x. x \<in> B) = (\<lambda>x. x \<in> A \<times> B)"
  by auto
lemma ctr_simps_pred_fun_eq_image[ctr_simps]:
  "pred_fun (\<lambda>x. x \<in> D) (\<lambda>x. x \<in> R) f \<longleftrightarrow> (f ` D \<subseteq> R)"
  by auto
lemma ctr_simps_in_iff[ctr_simps]: "(\<forall>x\<in>A. x \<in> U) \<longleftrightarrow> A \<subseteq> U" by auto
lemma ctr_simps_subset_pow_iff[ctr_simps]: "(\<forall>A\<in>S. A \<subseteq> U) \<longleftrightarrow> S \<subseteq> Pow U"
  by auto
lemma ctr_simps_subset_pow_iff'[ctr_simps]:
  "(\<forall>A. A \<in> S \<longrightarrow> A \<subseteq> U) \<longleftrightarrow> S \<subseteq> Pow U"
  by auto
lemma ctr_simps_subset_pow_iff''[ctr_simps]: "(S \<subseteq> {S. S \<subseteq> U}) \<longleftrightarrow> S \<subseteq> Pow U"
  by (simp add: subset_eq)
lemma ctr_simps_range_ss_iff[ctr_simps]: "(\<forall>x. f x \<in> U) \<longleftrightarrow> range f \<subseteq> U"
  by auto
lemma ctr_simps_range_pow_ss_iff[ctr_simps]: "(\<forall>x. f x \<subseteq> U) \<longleftrightarrow> range f \<subseteq> Pow U"
  by auto
lemma ctr_simps_Ball_def'[ctr_simps]: "(\<forall>x. x \<in> A \<longrightarrow> P x) \<longleftrightarrow> (\<forall>x \<in> A. P x)"
  by auto
lemma ctr_simps_True_imp[ctr_simps]: "(True \<longrightarrow> A) \<longleftrightarrow> A" by simp
lemma ctr_simps_True_conj[ctr_simps]: "(True \<and> A) \<longleftrightarrow> A" by simp
lemma ctr_simps_conj_True[ctr_simps]: "(A \<and> True) \<longleftrightarrow> A" by simp
lemma ctr_simps_top_True[ctr_simps]: "top A \<longleftrightarrow> True" by auto
lemma ctr_simps_Ball_True[ctr_simps]: "(\<forall>x\<in>U. True) \<longleftrightarrow> True" by auto
lemma ctr_simps_Ball_UNIV[ctr_simps]: "(\<forall>n\<in>UNIV. A n) \<longleftrightarrow> (\<forall>n. A n)" by simp
lemma ctr_simps_Bex_UNIV[ctr_simps]: "(\<exists>n\<in>UNIV. A n) \<longleftrightarrow> (\<exists>n. A n)" by simp
lemma ctr_simps_subset_Pow[ctr_simps]: "{A. A \<subseteq> U} = Pow U" by blast
lemma ctr_simps_mem_Collect_eq[ctr_simps]: "(a \<in> Collect P) = P a"
  by (rule mem_Collect_eq)
lemma ctr_simps_relation_top_empty_eq[ctr_simps]: "(\<lambda>x. x \<in> UNIV) = top"
  by auto
lemma ctr_simps_pred_fun_eq[ctr_simps]:
  "pred_fun A B = (\<lambda>f. \<forall>x. A x \<longrightarrow> B (f x))"
  by simp
lemma ctr_simps_subset_eq_sym[ctr_simps]: "(\<forall>x\<in>A. x \<in> B) \<longleftrightarrow> (A \<subseteq> B)" by auto
lemma ctr_simps_UNIV_I[ctr_simps]: "x \<in> UNIV" by simp
lemma ctr_simps_UNIV_def[ctr_simps]: "{x. True} = UNIV" by simp
lemma ctr_simps_conj_commute[ctr_simps]: "(P \<and> Q) \<longleftrightarrow> (Q \<and> P)" by auto
lemma ctr_simps_conj_absorb[ctr_simps]: "(A \<and> A) \<longleftrightarrow> A" by simp
lemma ctr_simps_conj_left_absorb[ctr_simps]: "(A \<and> A \<and> B) \<longleftrightarrow> (A \<and> B)" by simp
lemma ctr_simps_inf_idem[ctr_simps]: "inf a a = (a::'a::semilattice_inf)"
  by simp
lemma ctr_simps_sup_idem[ctr_simps]: "sup a a = (a::'a::semilattice_sup)"
  by simp
lemma ctr_simps_inf_assoc[ctr_simps]:
  "inf (inf a b) c = inf (a::'a::semilattice_inf) (inf b c)"
  by (auto simp: semilattice_inf_class.inf.assoc)
lemma ctr_simps_sup_assoc[ctr_simps]:
  "sup (sup a b) c = sup (a::'a::semilattice_sup) (sup b c)"
  by (auto simp: semilattice_sup_class.sup.assoc)
lemma ctr_simps_Collect_mem_eq[ctr_simps]: "{x. x \<in> U} = U" by simp

subsection\<open>tts relators\<close>

ctr_relator rel_set
ctr_relator rel_filter

end


theory ContractGeneration
imports Contracts
begin

fun map_of_eqs :: "form \<Rightarrow> (var \<rightharpoonup> expr)" where
  "map_of_eqs ((f_eq (VarE v) e)\<^emph>f) = (map_of_eqs f)(v\<mapsto>e)"
| "map_of_eqs _ = Map.empty"

fun update_var_eq_after :: "form \<Rightarrow> (expr\<rightharpoonup>expr) \<Rightarrow> form" where
  "update_var_eq_after (f_eq x y) arg_to_new_expr =
    (case arg_to_new_expr x of Some a \<Rightarrow> f_eq x a | None \<Rightarrow> f_eq x y)"
| "update_var_eq_after ((f_eq x y)\<^emph>rest) arg_to_new_expr =
    ((case arg_to_new_expr x of Some a \<Rightarrow> f_eq x a | None \<Rightarrow> f_eq x y)
    \<^emph>(update_var_eq_after rest arg_to_new_expr))"
| "update_var_eq_after f _ = f"

definition (in sound_separation_logic) bap :: "var set \<Rightarrow> var set \<Rightarrow> form \<Rightarrow> form \<Rightarrow> form \<Rightarrow> form \<Rightarrow> form \<Rightarrow> bool" where
  "bap args Uq Qfree Qeq C M F \<equiv> entails (Qfree\<^emph>M) (add_prenex (sorted_list_of_set ((free_vars C \<union> free_vars F)
    -(free_vars Qfree \<union> free_vars Qeq \<union> free_vars M))) (C\<^emph>F))
  \<and> quantifree_symb_heap M \<and> quantifree_symb_heap F
  \<and> free_vars M \<subseteq> UNIV - args - Uq \<and> free_vars F \<inter> args = {}"

locale generation_ctxt = program_logic +
  fixes bap_solver :: "var set \<Rightarrow> var set \<Rightarrow> form \<Rightarrow> form \<Rightarrow> form \<Rightarrow> (form\<times>form)" and pvars :: "var list"
  assumes bap_solution: "\<forall>Uq Qf Qeq C M F. bap_solver (set pvars) Uq Qf Qeq C = (M,F)
    \<longleftrightarrow> bap (set pvars) Uq Qf Qeq C M F"
begin

text \<open>This is what's called biabduct(P,Q,g(a1,...,an),C,D) but with slightly different argument order.\<close>
definition biabduction_step :: "(contract\<times>(var list)) \<Rightarrow> (form\<times>form) \<Rightarrow> (form\<times>form) option" where
  "biabduction_step func_call PQ = (case PQ of (P,Q) \<Rightarrow>
    (case func_call of (contr, call_args) \<Rightarrow>
    (case raw_contract contr of ([(C,[D])],f) \<Rightarrow>
    (case strip_prenex Q of (Uq, Qf\<^emph>Qeq) \<Rightarrow>
    \<comment> \<open>Rename logical variables\<close>
    (let (C1,vs) = rename_vars C (free_vars P - (set pvars)) VarE in
    (let (D',_) = rename_vars D (free_vars P - (set (pvars))) vs in
    (case strip_prenex D' of (_, Df\<^emph>Deq) \<Rightarrow>
    \<comment> \<open>Substitute the arguments for the parameters\<close>
    (let (C2,_) = rename_vars_option C1 {} ((map_of_eqs Qeq) \<circ>\<^sub>m (map_of (zip (snd f) call_args))) in
    \<comment> \<open>Do biabduction and construct the next intermediate contract\<close>
    (let (M,F) = bap_solver (set pvars) Uq Qf Qeq C2 in
    (let P_after = M \<^emph> P in
    (let Qf' = F \<^emph> Df in
    (let Qeq' = update_var_eq_after Qeq ((map_of_eqs Deq) \<circ>\<^sub>m (map_of (zip (map VarE call_args) (snd f)))) in
    (let Uq_after = (free_vars Qf' \<union> free_vars Qeq') - (set pvars) - free_vars P_after in
    (let Q_after = add_prenex (sorted_list_of_set Uq_after) (Qf'\<^emph>Qeq') in
    Some (P_after,Q_after))))))))
  | _ \<Rightarrow> None))) | _ \<Rightarrow> None) | _ \<Rightarrow> None)))"
end

text \<open>As in 6.3.1 we assume a function body as a sequence of calls to functions for which we already
  have the (conjunctive) contracts.\<close>
locale sequential = generation_ctxt +
  fixes func_body :: "(contract\<times>(var list)) list"
  assumes non_empty: "func_body \<noteq> []" and conj: "list_all (conjunctive \<circ> fst) func_body"
  and simple: "list_all (\<lambda>c. (\<exists>c'. fst (raw_contract (fst c)) = [c'])) func_body"
  and well_formed: "list_all (\<lambda>c. set (snd c) \<subseteq> set (pvars) \<and> distinct (snd c)) func_body"
begin
fun symbolic_execution :: "(contract\<times>(var list)) list \<Rightarrow> (form\<times>form) \<Rightarrow> (form\<times>form) option" where
  "symbolic_execution [] (P,Q) = Some (P,Q)"
| "symbolic_execution (func_call#rest) (P,Q) = (case biabduction_step func_call (P,Q)
    of Some (P_after,Q_after) \<Rightarrow> symbolic_execution rest (P_after,Q_after) | _ \<Rightarrow> None)"

fun build_initial :: "var list \<Rightarrow> var set \<Rightarrow> form" where
  "build_initial [] _ = Emp"
| "build_initial (x#vs) used = (let X = fresh used in (f_eq x X)\<^emph>(build_initial vs (insert X used)))"

definition initialP :: form where
  "initialP \<equiv> simplify_emp_sepconj (build_initial pvars (set pvars))"

text \<open>This is Theorem 3, but I won't prove it yet. This would be way to much work for now.\<close>
lemma "symbolic_execution func_body (initialP, initialP) = Some (P,Q) \<Longrightarrow>
  sound (Contract ([(P,[Q])], (f,pvars)))"
  sorry
end

type_synonym symb_map = "CFG_node \<Rightarrow> (form\<times>form) list"
axiomatization P_init Q_init :: form

abbreviation add_prenex_wo_pvars :: "var set \<Rightarrow> form \<Rightarrow> form" where
  "add_prenex_wo_pvars pvars P \<equiv> add_prenex (sorted_list_of_set (free_vars P - pvars)) P"

definition (in sound_separation_logic) covers :: "var set \<Rightarrow> form \<Rightarrow> form \<Rightarrow> form \<Rightarrow> form \<Rightarrow> bool" where
  "covers pvars P Q P' Q' \<equiv>
    entails (add_prenex_wo_pvars pvars P) (add_prenex_wo_pvars pvars P') \<and>
    entails (add_prenex_wo_pvars pvars Q') (add_prenex_wo_pvars pvars Q)"

locale loops_allowed = generation_ctxt +
  fixes func_body :: "(CFG_node \<times> string \<times> var list \<times> CFG_node) set" and contracts :: "string \<Rightarrow> contract"
  and cut_points :: "CFG_node set" and widening :: "form \<Rightarrow> form"
  assumes sound_contracts: "\<forall>f. sound (contracts f)"
begin

definition init_symb :: symb_map where "init_symb \<equiv> (\<lambda>_. [])(entry := [(P_init,Q_init)])"

text \<open>Given a worklist of nodes and the symb_maps, relate them to the next worklist and the updated
  symb maps.\<close>
inductive symbolic_execution :: "CFG_node set \<Rightarrow> symb_map \<Rightarrow> CFG_node set \<Rightarrow> symb_map \<Rightarrow> bool" where
  "\<lbrakk>v\<in>worklist; sm v = (P,Q)#sm_v; \<forall>f f_args v'. (v,f,f_args,v') \<in> func_body \<longrightarrow>
    insert v' (ws-{v}) \<subseteq> worklist_after \<and>
    (\<forall>(C,Ds) \<in> set (fst (raw_contract (contracts f))).
    (\<forall>D\<in>set Ds.
    (\<forall>P_after Q_after. Some (P_after,Q_after) =
      biabduction_step (Contract ([(C,[D])],snd (raw_contract (contracts f))), f_args) (P,Q) \<longrightarrow>
    (v'\<notin>cut_points \<longrightarrow> (sm_after v = sm_v \<and> sm_after v' = (sm v')@[(P_after,Q_after)])) \<and>
    (v\<in>cut_points \<and> (\<exists>P' Q'. ((P',Q')\<in> set (sm v') \<and> covers (set pvars) P_after Q_after P' Q')
      \<longrightarrow> (sm_after v = sm_v \<and> sm_after v' = sm v')) \<and>
    (\<nexists>P' Q'. ((P',Q')\<in> set (sm v') \<and> covers (set pvars) P_after Q_after P' Q')
      \<longrightarrow> (sm_after v = sm_v \<and> sm_after v' = sm v'@[(widening P_after, widening Q_after)]))))))\<rbrakk>
    \<Longrightarrow> symbolic_execution worklist sm worklist_after sm_after"
end
end