header {* \isaheader{Red-Black Tree based Maps} *}
theory Impl_RBT_Map
imports
  "~~/src/HOL/Library/RBT_Impl"
  "../../Lib/RBT_add"
  "../../../Automatic_Refinement/Automatic_Refinement"
  "../../Iterator/Iterator"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

(* TODO: Move to common/RBT_add (replace) *)

subsection {* Standard Setup *}

  inductive_set color_rel where
    "(color.R,color.R) \<in> color_rel"
   | "(color.B,color.B) \<in> color_rel"

  inductive_cases color_rel_elims:
    "(x,color.R) \<in> color_rel"
    "(x,color.B) \<in> color_rel"
    "(color.R,y) \<in> color_rel"
    "(color.B,y) \<in> color_rel"

  thm color_rel_elims

  lemma param_color[param]:
    "(color.R,color.R)\<in>color_rel"
    "(color.B,color.B)\<in>color_rel"
    "(case_color,case_color)\<in>R \<rightarrow> R \<rightarrow> color_rel \<rightarrow> R"
    by (auto
      intro: color_rel.intros
      elim: color_rel.cases
      split: color.split)

  inductive_set rbt_rel_aux for Ra Rb where
    "(rbt.Empty,rbt.Empty)\<in>rbt_rel_aux Ra Rb"
  | "\<lbrakk> (c,c')\<in>color_rel;
       (l,l')\<in>rbt_rel_aux Ra Rb; (a,a')\<in>Ra; (b,b')\<in>Rb;
       (r,r')\<in>rbt_rel_aux Ra Rb \<rbrakk>
    \<Longrightarrow> (rbt.Branch c l a b r, rbt.Branch c' l' a' b' r')\<in>rbt_rel_aux Ra Rb"

  inductive_cases rbt_rel_aux_elims:  (* Argh! This seems to use
    the default simpset to simplify the result. If relators are in this
    simpset, we get an undesired result! *)
    "(x,rbt.Empty)\<in>rbt_rel_aux Ra Rb"
    "(rbt.Empty,x')\<in>rbt_rel_aux Ra Rb"
    "(rbt.Branch c l a b r,x')\<in>rbt_rel_aux Ra Rb"
    "(x,rbt.Branch c' l' a' b' r')\<in>rbt_rel_aux Ra Rb"

  definition "rbt_rel \<equiv> rbt_rel_aux"
  lemma rbt_rel_aux_fold: "rbt_rel_aux Ra Rb \<equiv> \<langle>Ra,Rb\<rangle>rbt_rel"
    by (simp add: rbt_rel_def relAPP_def)

  lemmas rbt_rel_intros = rbt_rel_aux.intros[unfolded rbt_rel_aux_fold]
  lemmas rbt_rel_cases = rbt_rel_aux.cases[unfolded rbt_rel_aux_fold]
  lemmas rbt_rel_induct[induct set]
    = rbt_rel_aux.induct[unfolded rbt_rel_aux_fold]
  lemmas rbt_rel_elims = rbt_rel_aux_elims[unfolded rbt_rel_aux_fold]

  lemma param_rbt1[param]:
    "(rbt.Empty,rbt.Empty) \<in> \<langle>Ra,Rb\<rangle>rbt_rel"
    "(rbt.Branch,rbt.Branch) \<in>
      color_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    by (auto intro: rbt_rel_intros)

  lemma param_case_rbt[param]:
    "(case_rbt,case_rbt) \<in>
      Ra \<rightarrow> (color_rel \<rightarrow> \<langle>Rb,Rc\<rangle>rbt_rel \<rightarrow> Rb \<rightarrow> Rc \<rightarrow> \<langle>Rb,Rc\<rangle>rbt_rel \<rightarrow> Ra)
        \<rightarrow> \<langle>Rb,Rc\<rangle>rbt_rel \<rightarrow> Ra"
    apply clarsimp
    apply (erule rbt_rel_cases)
    apply simp
    apply simp
    apply parametricity
    done

  lemma param_rec_rbt[param]: "(rec_rbt, rec_rbt) \<in>
    Ra \<rightarrow> (color_rel \<rightarrow> \<langle>Rb,Rc\<rangle>rbt_rel \<rightarrow> Rb \<rightarrow> Rc \<rightarrow> \<langle>Rb,Rc\<rangle>rbt_rel
     \<rightarrow> Ra \<rightarrow> Ra \<rightarrow> Ra) \<rightarrow> \<langle>Rb,Rc\<rangle>rbt_rel \<rightarrow> Ra"
  proof (intro fun_relI)
    case (goal1 s s' f f' t t') from goal1(3,1,2) show ?case
      apply (induct arbitrary: s s')
      apply simp
      apply simp
      apply parametricity
      done
  qed

  lemma param_paint[param]:
    "(paint,paint)\<in>color_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    unfolding paint_def
    by parametricity

  lemma param_balance[param]:
    shows "(balance,balance) \<in>
      \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
  proof (intro fun_relI)
    case (goal1 t1 t1' a a' b b' t2 t2')
    thus ?case
      apply (induct t1' a' b' t2' arbitrary: t1 a b t2 rule: balance.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: balance.simps)
      apply (parametricity)+
      done
  qed

  lemma param_rbt_ins[param]:
    fixes less
    assumes param_less[param]: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows "(ord.rbt_ins less,ord.rbt_ins less') \<in>
             (Ra\<rightarrow>Rb\<rightarrow>Rb\<rightarrow>Rb) \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
  proof (intro fun_relI)
    case (goal1 f f' a a' b b' t t')
    thus ?case
      apply (induct f' a' b' t' arbitrary: f a b t rule: ord.rbt_ins.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: ord.rbt_ins.simps rbt_ins.simps)
      apply parametricity+
      done
  qed

  term rbt_insert
  lemma param_rbt_insert[param]:
    fixes less
    assumes param_less[param]: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows "(ord.rbt_insert less,ord.rbt_insert less') \<in>
      Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    unfolding rbt_insert_def ord.rbt_insert_def
    unfolding rbt_insert_with_key_def[abs_def]
      ord.rbt_insert_with_key_def[abs_def]
    by parametricity

  lemma param_rbt_lookup[param]:
    fixes less
    assumes param_less[param]: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows "(ord.rbt_lookup less,ord.rbt_lookup less') \<in>
             \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> \<langle>Rb\<rangle>option_rel"
    unfolding rbt_lookup_def ord.rbt_lookup_def
    by parametricity

  term balance_left
  lemma param_balance_left[param]:
    "(balance_left, balance_left) \<in>
      \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
  proof (intro fun_relI)
    case (goal1 l l' a a' b b' r r')
    thus ?case
      apply (induct l a b r arbitrary: l' a' b' r' rule: balance_left.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: balance_left.simps)
      apply parametricity+
      done
  qed

  term balance_right
  lemma param_balance_right[param]:
    "(balance_right, balance_right) \<in>
      \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
  proof (intro fun_relI)
    case (goal1 l l' a a' b b' r r')
    thus ?case
      apply (induct l a b r arbitrary: l' a' b' r' rule: balance_right.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: balance_right.simps)
      apply parametricity+
      done
  qed

  lemma param_combine[param]:
    "(combine,combine)\<in>\<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
  proof (intro fun_relI)
    case (goal1 t1 t1' t2 t2')
    thus ?case
      apply (induct t1 t2 arbitrary: t1' t2' rule: combine.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: combine.simps)
      apply parametricity+
      done
  qed

  lemma ih_aux1: "\<lbrakk> (a',b)\<in>R; a'=a \<rbrakk> \<Longrightarrow> (a,b)\<in>R" by auto
  lemma is_eq: "a=b \<Longrightarrow> a=b" .

  lemma param_rbt_del_aux:
    fixes br
    fixes less
    assumes param_less[param]: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows
    "\<lbrakk> (ak1,ak1')\<in>Ra; (al,al')\<in>\<langle>Ra,Rb\<rangle>rbt_rel; (ak,ak')\<in>Ra;
      (av,av')\<in>Rb; (ar,ar')\<in>\<langle>Ra,Rb\<rangle>rbt_rel
    \<rbrakk> \<Longrightarrow> (ord.rbt_del_from_left less ak1 al ak av ar,
      ord.rbt_del_from_left less' ak1' al' ak' av' ar')
    \<in> \<langle>Ra,Rb\<rangle>rbt_rel"
    "\<lbrakk> (bk1,bk1')\<in>Ra; (bl,bl')\<in>\<langle>Ra,Rb\<rangle>rbt_rel; (bk,bk')\<in>Ra;
      (bv,bv')\<in>Rb; (br,br')\<in>\<langle>Ra,Rb\<rangle>rbt_rel
    \<rbrakk> \<Longrightarrow> (ord.rbt_del_from_right less bk1 bl bk bv br,
      ord.rbt_del_from_right less' bk1' bl' bk' bv' br')
    \<in> \<langle>Ra,Rb\<rangle>rbt_rel"
    "\<lbrakk> (ck,ck')\<in>Ra; (ct,ct')\<in>\<langle>Ra,Rb\<rangle>rbt_rel \<rbrakk>
      \<Longrightarrow> (ord.rbt_del less ck ct, ord.rbt_del less' ck' ct') \<in> \<langle>Ra,Rb\<rangle>rbt_rel"
    apply (induct
      ak1' al' ak' av' ar' and bk1' bl' bk' bv' br' and ck' ct'
      arbitrary: ak1 al ak av ar and bk1 bl bk bv br and ck ct
      rule: ord.rbt_del_from_left_rbt_del_from_right_rbt_del.induct)
    (* TODO/FIXME: We do not have 'deep' elimination rules, thus
      we have to do some ughly hack to apply the rbt_rel-elimination inside
      the induction hypothesis. *)
    apply (assumption
      | elim rbt_rel_elims color_rel_elims
      | simp (no_asm_use) only: rbt_del.simps ord.rbt_del.simps
          rbt_del_from_left.simps ord.rbt_del_from_left.simps
          rbt_del_from_right.simps ord.rbt_del_from_right.simps
      | parametricity
      | rule rbt_rel_intros
      | hypsubst
      | (simp, rule ih_aux1, rprems)
      | (rule is_eq, simp)
    ) +
    done

  lemma param_rbt_del[param]:
    fixes less
    assumes param_less: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows
    "(ord.rbt_del_from_left less, ord.rbt_del_from_left less') \<in>
      Ra \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    "(ord.rbt_del_from_right less, ord.rbt_del_from_right less') \<in>
      Ra \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    "(ord.rbt_del less,ord.rbt_del less') \<in>
      Ra \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    by (intro fun_relI, blast intro: param_rbt_del_aux[OF param_less])+

  lemma param_rbt_delete[param]:
    fixes less
    assumes param_less[param]: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows "(ord.rbt_delete less, ord.rbt_delete less')
      \<in> Ra \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    unfolding rbt_delete_def[abs_def] ord.rbt_delete_def[abs_def]
    by parametricity

  term ord.rbt_insert_with_key

  abbreviation compare_rel :: "(RBT_Impl.compare \<times> _) set"
    where "compare_rel \<equiv> Id"

  lemma param_rbtreeify_aux[param]:
    "\<lbrakk>n\<le>length kvs; (n,n')\<in>nat_rel; (kvs,kvs')\<in>\<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel\<rbrakk>
    \<Longrightarrow> (rbtreeify_f n kvs,rbtreeify_f n' kvs')
      \<in> \<langle>\<langle>Ra,Rb\<rangle>rbt_rel, \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel\<rangle>prod_rel"
    "\<lbrakk>n\<le>Suc (length kvs); (n,n')\<in>nat_rel; (kvs,kvs')\<in>\<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel\<rbrakk>
    \<Longrightarrow> (rbtreeify_g n kvs,rbtreeify_g n' kvs')
      \<in> \<langle>\<langle>Ra,Rb\<rangle>rbt_rel, \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel\<rangle>prod_rel"
    apply (induct n kvs and n kvs
      arbitrary: n' kvs' and n' kvs'
      rule: rbtreeify_induct)

    (* TODO: Still requires some manual proof! *)
    apply (simp only: pair_in_Id_conv)
    apply (simp (no_asm_use) only: rbtreeify_f_simps rbtreeify_g_simps)
    apply parametricity

    apply (elim list_relE prod_relE)
    apply (simp only: pair_in_Id_conv)
    apply hypsubst
    apply (simp (no_asm_use) only: rbtreeify_f_simps rbtreeify_g_simps)
    apply parametricity

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a)
      \<in> \<langle>\<langle>Ra, Rb\<rangle>rbt_rel, \<langle>\<langle>Ra, Rb\<rangle>prod_rel\<rangle>list_rel\<rangle>prod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply rprems
    apply (rule refl)
    apply assumption

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a)
      \<in> \<langle>\<langle>Ra, Rb\<rangle>rbt_rel, \<langle>\<langle>Ra, Rb\<rangle>prod_rel\<rangle>list_rel\<rangle>prod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply rprems
    apply (rule refl)
    apply assumption

    apply simp
    apply parametricity

    apply clarsimp
    apply parametricity

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_g n kvs, rbtreeify_g n kvs'a)
      \<in> \<langle>\<langle>Ra, Rb\<rangle>rbt_rel, \<langle>\<langle>Ra, Rb\<rangle>prod_rel\<rangle>list_rel\<rangle>prod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply parametricity
    apply (rule refl)

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a)
      \<in> \<langle>\<langle>Ra, Rb\<rangle>rbt_rel, \<langle>\<langle>Ra, Rb\<rangle>prod_rel\<rangle>list_rel\<rangle>prod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply parametricity
    apply (rule refl)
    done

  lemma param_rbtreeify[param]:
    "(rbtreeify, rbtreeify) \<in> \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    unfolding rbtreeify_def[abs_def]
    apply parametricity
    by simp

  lemma param_sunion_with[param]:
    fixes less
    shows "\<lbrakk> (less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id;
      (f,f')\<in>(Ra\<rightarrow>Rb\<rightarrow>Rb\<rightarrow>Rb); (a,a')\<in>\<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel;
      (b,b')\<in>\<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel \<rbrakk>
    \<Longrightarrow> (ord.sunion_with less f a b, ord.sunion_with less' f' a' b') \<in>
      \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel"
    apply (induct f' a' b' arbitrary: f a b
      rule: ord.sunion_with.induct[of less'])
    apply (elim_all list_relE prod_relE)
    apply (simp_all only: ord.sunion_with.simps)
    apply parametricity
    apply simp_all
    done

  lemma skip_red_alt:
    "RBT_Impl.skip_red t = (case t of
      (Branch color.R l k v r) \<Rightarrow> l
    | _ \<Rightarrow> t)"
    by (auto split: rbt.split color.split)

  function compare_height ::
    "('a, 'b) RBT_Impl.rbt \<Rightarrow> ('a, 'b) RBT_Impl.rbt \<Rightarrow> ('a, 'b) RBT_Impl.rbt \<Rightarrow> ('a, 'b) RBT_Impl.rbt \<Rightarrow> RBT_Impl.compare"
    where
    "compare_height sx s t tx =
  (case (RBT_Impl.skip_red sx, RBT_Impl.skip_red s, RBT_Impl.skip_red t, RBT_Impl.skip_red tx) of
     (Branch _ sx' _ _ _, Branch _ s' _ _ _, Branch _ t' _ _ _, Branch _ tx' _ _ _) \<Rightarrow>
       compare_height (RBT_Impl.skip_black sx') s' t' (RBT_Impl.skip_black tx')
   | (_, rbt.Empty, _, Branch _ _ _ _ _) \<Rightarrow> RBT_Impl.LT
   | (Branch _ _ _ _ _, _, rbt.Empty, _) \<Rightarrow> RBT_Impl.GT
   | (Branch _ sx' _ _ _, Branch _ s' _ _ _, Branch _ t' _ _ _, rbt.Empty) \<Rightarrow>
       compare_height (RBT_Impl.skip_black sx') s' t' rbt.Empty
   | (rbt.Empty, Branch _ s' _ _ _, Branch _ t' _ _ _, Branch _ tx' _ _ _) \<Rightarrow>
       compare_height rbt.Empty s' t' (RBT_Impl.skip_black tx')
   | _ \<Rightarrow> RBT_Impl.EQ)"
    by pat_completeness auto

  lemma skip_red_size: "size (RBT_Impl.skip_red b) \<le> size b"
    by (auto simp add: skip_red_alt split: rbt.split color.split)

  lemma skip_black_size: "size (RBT_Impl.skip_black b) \<le> size b"
    unfolding RBT_Impl.skip_black_def
    apply (auto
      simp add: Let_def
      split: rbt.split color.split
    )
    using skip_red_size[of b]
    apply auto
    done

  termination
  proof -
    {
      fix s t x
      assume A: "s = RBT_Impl.skip_red t"
        and B: "x < size s"
      note B
      also note A
      also note skip_red_size
      finally have "x < size t" .
    } note AUX=this

    show "All compare_height_dom"
      apply (relation
        "measure (\<lambda>(a, b, c, d). size a + size b + size c + size d)")
      apply rule

      (* FIXME: This is solved by
        apply (smt rbt.size(4) skip_black_size skip_red_size)+
        which is, however, not allowed for afp.
        *)

      apply (clarsimp simp: Let_def split: rbt.splits color.splits)
      apply (intro add_less_mono trans_less_add2
        order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []

      apply (clarsimp simp: Let_def split: rbt.splits color.splits)
      apply (rule trans_less_add1)
      apply (intro add_less_mono trans_less_add2
        order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []

      apply (clarsimp simp: Let_def split: rbt.splits color.splits)
      apply (intro add_less_mono trans_less_add2
        order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []
      done
  qed

  lemmas [simp del] = compare_height.simps

  lemma compare_height_alt:
    "RBT_Impl.compare_height sx s t tx = compare_height sx s t tx"
    apply (induct sx s t tx rule: compare_height.induct)
    apply (subst RBT_Impl.compare_height.simps)
    apply (subst compare_height.simps)
    apply (auto split: rbt.split)
    done

  term RBT_Impl.skip_red
  lemma param_skip_red[param]: "(RBT_Impl.skip_red,RBT_Impl.skip_red)
    \<in> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel"
    unfolding skip_red_alt[abs_def] by parametricity

  lemma param_skip_black[param]: "(RBT_Impl.skip_black,RBT_Impl.skip_black)
    \<in> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel"
    unfolding RBT_Impl.skip_black_def[abs_def] by parametricity

  term case_rbt
  lemma param_case_rbt':
    assumes "(t,t')\<in>\<langle>Rk,Rv\<rangle>rbt_rel"
    assumes "\<lbrakk>t=rbt.Empty; t'=rbt.Empty\<rbrakk> \<Longrightarrow> (fl,fl')\<in>R"
    assumes "\<And>c l k v r c' l' k' v' r'. \<lbrakk>
      t = Branch c l k v r; t' = Branch c' l' k' v' r';
      (c,c')\<in>color_rel;
      (l,l')\<in>\<langle>Rk,Rv\<rangle>rbt_rel; (k,k')\<in>Rk; (v,v')\<in>Rv; (r,r')\<in>\<langle>Rk,Rv\<rangle>rbt_rel
    \<rbrakk> \<Longrightarrow> (fb c l k v r, fb' c' l' k' v' r') \<in> R"
    shows "(case_rbt fl fb t, case_rbt fl' fb' t') \<in> R"
    using assms by (auto split: rbt.split elim: rbt_rel_elims)

  lemma compare_height_param_aux[param]:
    "\<lbrakk> (sx,sx')\<in>\<langle>Rk,Rv\<rangle>rbt_rel; (s,s')\<in>\<langle>Rk,Rv\<rangle>rbt_rel;
       (t,t')\<in>\<langle>Rk,Rv\<rangle>rbt_rel; (tx,tx')\<in>\<langle>Rk,Rv\<rangle>rbt_rel \<rbrakk>
    \<Longrightarrow> (compare_height sx s t tx, compare_height sx' s' t' tx') \<in> compare_rel"
    apply (induct sx' s' t' tx' arbitrary: sx s t tx
      rule: compare_height.induct)
    apply (subst (2) compare_height.simps)
    apply (subst compare_height.simps)
    apply (parametricity add: param_case_prod' param_case_rbt', (simp only: Pair_eq)+) []
    done

  lemma compare_height_param[param]:
    "(RBT_Impl.compare_height,RBT_Impl.compare_height) \<in>
      \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel
      \<rightarrow> compare_rel"
    unfolding compare_height_alt[abs_def]
    by parametricity

  lemma param_rbt_union[param]:
    fixes less
    assumes param_less[param]: "(less,less') \<in> Ra \<rightarrow> Ra \<rightarrow> Id"
    shows "(ord.rbt_union less, ord.rbt_union less')
      \<in> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> \<langle>Ra,Rb\<rangle>rbt_rel"
    unfolding ord.rbt_union_def[abs_def] ord.rbt_union_with_key_def[abs_def]
      ord.rbt_insert_with_key_def[abs_def]
    unfolding RBT_Impl.fold_def RBT_Impl.entries_def
    by parametricity

term rm_iterateoi
lemma param_rm_iterateoi[param]: "(rm_iterateoi,rm_iterateoi)
  \<in> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> (Rc\<rightarrow>Id) \<rightarrow> (\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rc \<rightarrow> Rc) \<rightarrow> Rc \<rightarrow> Rc"
  unfolding rm_iterateoi_def
  by (parametricity)

lemma param_rm_reverse_iterateoi[param]:
  "(rm_reverse_iterateoi,rm_reverse_iterateoi)
    \<in> \<langle>Ra,Rb\<rangle>rbt_rel \<rightarrow> (Rc\<rightarrow>Id) \<rightarrow> (\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rc \<rightarrow> Rc) \<rightarrow> Rc \<rightarrow> Rc"
  unfolding rm_reverse_iterateoi_def
  by (parametricity)

lemma param_color_eq[param]:
  "(op =, op =)\<in>color_rel\<rightarrow>color_rel\<rightarrow>Id"
  by (auto elim: color_rel.cases)

term bheight
lemma param_bheight[param]:
  "(bheight,bheight)\<in>\<langle>Rk,Rv\<rangle>rbt_rel\<rightarrow>Id"
  unfolding bheight_def
  by (parametricity)

lemma inv1_param[param]: "(inv1,inv1)\<in>\<langle>Rk,Rv\<rangle>rbt_rel\<rightarrow>Id"
  unfolding inv1_def
  by (parametricity)

lemma inv2_param[param]: "(inv2,inv2)\<in>\<langle>Rk,Rv\<rangle>rbt_rel\<rightarrow>Id"
  unfolding inv2_def
  by (parametricity)

term ord.rbt_less
lemma rbt_less_param[param]: "(ord.rbt_less,ord.rbt_less) \<in>
  (Rk\<rightarrow>Rk\<rightarrow>Id) \<rightarrow> Rk \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> Id"
  unfolding ord.rbt_less_prop[abs_def]
  apply (parametricity add: param_list_ball)
  unfolding RBT_Impl.keys_def RBT_Impl.entries_def
  apply (parametricity)
  done

term ord.rbt_greater
lemma rbt_greater_param[param]: "(ord.rbt_greater,ord.rbt_greater) \<in>
  (Rk\<rightarrow>Rk\<rightarrow>Id) \<rightarrow> Rk \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> Id"
  unfolding ord.rbt_greater_prop[abs_def]
  apply (parametricity add: param_list_ball)
  unfolding RBT_Impl.keys_def RBT_Impl.entries_def
  apply (parametricity)
  done

lemma rbt_sorted_param[param]:
  "(ord.rbt_sorted,ord.rbt_sorted)\<in>(Rk\<rightarrow>Rk\<rightarrow>Id)\<rightarrow>\<langle>Rk,Rv\<rangle>rbt_rel\<rightarrow>Id"
  unfolding ord.rbt_sorted_def[abs_def]
  by (parametricity)

lemma is_rbt_param[param]: "(ord.is_rbt,ord.is_rbt) \<in>
  (Rk\<rightarrow>Rk\<rightarrow>Id) \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_rel \<rightarrow> Id"
  unfolding ord.is_rbt_def[abs_def]
  by (parametricity)

definition "rbt_map_rel' lt = br (ord.rbt_lookup lt) (ord.is_rbt lt)"

lemma (in linorder) rbt_map_impl:
  "(rbt.Empty,Map.empty) \<in> rbt_map_rel' op <"
  "(rbt_insert,\<lambda>k v m. m(k\<mapsto>v))
    \<in> Id \<rightarrow> Id \<rightarrow> rbt_map_rel' op < \<rightarrow> rbt_map_rel' op <"
  "(rbt_lookup,\<lambda>m k. m k) \<in> rbt_map_rel' op < \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>option_rel"
  "(rbt_delete,\<lambda>k m. m|`(-{k})) \<in> Id \<rightarrow> rbt_map_rel' op < \<rightarrow> rbt_map_rel' op <"
  "(rbt_union,op ++)
    \<in> rbt_map_rel' op < \<rightarrow> rbt_map_rel' op < \<rightarrow> rbt_map_rel' op <"
  by (auto simp add:
    rbt_lookup_rbt_insert rbt_lookup_rbt_delete rbt_lookup_rbt_union
    rbt_union_is_rbt
    rbt_map_rel'_def br_def)

lemma sorted_by_rel_keys_true[simp]: "sorted_by_rel (\<lambda>(_,_) (_,_). True) l"
  apply (induct l)
  apply auto
  done

(*
lemma (in linorder) rbt_it_linord_impl:
  "is_map_iterator_linord (rbt_map_rel' op <) Id Id Id
    (rm_iterateoi::_ \<Rightarrow> ('a,'v,'s) map_iterator)"
  unfolding is_map_iterator_genord_def is_map_iterator_linord_def
    gen_map_iterator_genord_def[abs_def]
  apply (intro fun_relI)
  apply (clarsimp intro!: chooseR.intros[OF _ IdI])
proof -
  case (goal1 t s' c f s)
  hence "is_rbt t" and [simp]: "s'=(rbt_lookup t)"
    unfolding rbt_map_rel'_def br_def by simp_all
  hence RSORTED: "rbt_sorted t" by (simp add: is_rbt_def)

  thm rm_iterateoi_correct
  from rm_iterateoi_correct[OF RSORTED,
    unfolded set_iterator_map_linord_def
      set_iterator_genord_def
  ] obtain l where
      "distinct l"
      and "map_to_set (rbt_lookup t) = set l"
      and "sorted_by_rel (\<lambda>(k,_) (k',_). k \<le> k') l"
      and "(rm_iterateoi t::('a,'v,'s) map_iterator) = foldli l"
    by blast
  thus ?case
    apply (rule_tac exI[where x=l])
    apply (simp add: sorted_by_rel_keys_map_fst)
    by (metis iterate_to_list_foldli map_iterator_foldli_conv rev_rev_ident
      set_iterator_foldli_correct)
qed

lemma (in linorder) rbt_it_rev_linord_impl:
  "is_map_iterator_rev_linord (rbt_map_rel' op <) Id Id Id
    (rm_reverse_iterateoi::_ \<Rightarrow> ('a,'v,'s) map_iterator)"
  unfolding is_map_iterator_genord_def is_map_iterator_rev_linord_def
    gen_map_iterator_genord_def[abs_def]
  apply (intro fun_relI)
  apply (clarsimp intro!: chooseR.intros[OF _ IdI])
proof -
  case (goal1 t s' c f s)
  hence "is_rbt t" and [simp]: "s'=(rbt_lookup t)"
    unfolding rbt_map_rel'_def br_def by simp_all
  hence RSORTED: "rbt_sorted t" by (simp add: is_rbt_def)

  from rm_reverse_iterateoi_correct[unfolded
    set_iterator_map_rev_linord_def
    set_iterator_genord_def,
    OF RSORTED
  ] obtain l where
      "distinct l"
      and "map_to_set (rbt_lookup t) = set l"
      and "sorted_by_rel (\<lambda>(k,_) (k',_). k \<ge> k') l"
      and "(rm_reverse_iterateoi t::('a,'v,'s) map_iterator) = foldli l"
    by blast
  thus ?case
    apply (rule_tac exI[where x=l])
    apply (simp add: sorted_by_rel_keys_map_fst)
    by (metis iterate_to_list_foldli map_iterator_foldli_conv rev_rev_ident
      set_iterator_foldli_correct)
qed

lemma (in linorder) rbt_it_impl:
  "is_map_iterator (rbt_map_rel' op <) Id Id Id rm_iterateoi"
  unfolding is_map_iterator_def
  apply (rule is_map_iterator_genord_weaken)
  apply (rule rbt_it_linord_impl[unfolded is_map_iterator_linord_def])
  ..

*)

definition rbt_map_rel_def_internal:
  "rbt_map_rel lt Rk Rv \<equiv> \<langle>Rk,Rv\<rangle>rbt_rel O rbt_map_rel' lt"

lemma rbt_map_rel_def:
  "\<langle>Rk,Rv\<rangle>rbt_map_rel lt \<equiv> \<langle>Rk,Rv\<rangle>rbt_rel O rbt_map_rel' lt"
  by (simp add: rbt_map_rel_def_internal relAPP_def)

(*
lemma (in linorder) autoref_gen_rbt_iterate_linord:
  "is_map_iterator_linord
    (\<langle>Rk,Rv\<rangle>rbt_map_rel op <) (Rk::(_\<times>'a) set) Rv R\<sigma> rm_iterateoi"
proof -
  note param_rm_iterateoi[of Rk Rv R\<sigma>]
  also note rbt_it_linord_impl[
    unfolded is_map_iterator_linord_def is_map_iterator_genord_def]
  finally (relcompI) show ?thesis
    unfolding is_map_iterator_linord_def is_map_iterator_genord_def
    apply -
    apply (erule set_rev_mp)
    apply (simp add: rbt_map_rel_def rbt_map_rel'_def)
    apply (
      rule Orderings.order_trans[OF fun_rel_comp_dist] fun_rel_mono subset_refl
      | simp
    )+
    done
qed

lemma (in linorder) autoref_gen_rbt_iterate_rev_linord:
  "is_map_iterator_rev_linord
    (\<langle>Rk,Rv\<rangle>rbt_map_rel op <) (Rk::(_\<times>'a) set) Rv R\<sigma> rm_reverse_iterateoi"
proof -
  note param_rm_reverse_iterateoi[of Rk Rv R\<sigma>]
  also note rbt_it_rev_linord_impl[
    unfolded is_map_iterator_rev_linord_def is_map_iterator_genord_def]
  finally (relcompI) show ?thesis
    unfolding is_map_iterator_rev_linord_def is_map_iterator_genord_def
    apply -
    apply (erule set_rev_mp)
    apply (simp add: rbt_map_rel_def rbt_map_rel'_def)
    apply (
      rule Orderings.order_trans[OF fun_rel_comp_dist] fun_rel_mono subset_refl
      | simp
    )+
    done
qed

lemma (in linorder) autoref_gen_rbt_iterate:
  "is_map_iterator
    (\<langle>Rk,Rv\<rangle>rbt_map_rel op <) (Rk::(_\<times>'a) set) Rv R\<sigma> rm_iterateoi"
proof -
  note param_rm_iterateoi[of Rk Rv R\<sigma>]
  also note rbt_it_impl[
    unfolded is_map_iterator_def is_map_iterator_genord_def]
  finally (relcompI) show ?thesis
    unfolding is_map_iterator_def is_map_iterator_genord_def
    apply -
    apply (erule set_rev_mp)
    apply (simp add: rbt_map_rel_def rbt_map_rel'_def)
    apply (
      rule Orderings.order_trans[OF fun_rel_comp_dist] fun_rel_mono subset_refl
      | simp
    )+
    done
qed
*)

lemma (in linorder) autoref_gen_rbt_empty:
  "(rbt.Empty,Map.empty) \<in> \<langle>Rk,Rv\<rangle>rbt_map_rel op <"
  by (auto simp: rbt_map_rel_def
    intro!: rbt_map_impl rbt_rel_intros)

lemma (in linorder) autoref_gen_rbt_insert:
  fixes less_impl
  assumes param_less: "(less_impl,op <) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(ord.rbt_insert less_impl,\<lambda>k v m. m(k\<mapsto>v)) \<in>
    Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel op < \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel op <"
  apply (intro fun_relI)
  unfolding rbt_map_rel_def
  apply (auto intro!: relcomp.intros)
  apply (rule param_rbt_insert[OF param_less, param_fo])
  apply assumption+
  apply (rule rbt_map_impl[param_fo])
  apply (rule IdI | assumption)+
  done

lemma (in linorder) autoref_gen_rbt_lookup:
  fixes less_impl
  assumes param_less: "(less_impl,op <) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(ord.rbt_lookup less_impl, \<lambda>m k. m k) \<in>
    \<langle>Rk,Rv\<rangle>rbt_map_rel op < \<rightarrow> Rk \<rightarrow> \<langle>Rv\<rangle>option_rel"
  unfolding rbt_map_rel_def
  apply (intro fun_relI)
  apply (elim relcomp.cases)
  apply hypsubst
  apply (subst R_O_Id[symmetric])
  apply (rule relcompI)
  apply (rule param_rbt_lookup[OF param_less, param_fo])
  apply assumption+
  apply (subst option_rel_id_simp[symmetric])
  apply (rule rbt_map_impl[param_fo])
  apply assumption
  apply (rule IdI)
  done

lemma (in linorder) autoref_gen_rbt_delete:
  fixes less_impl
  assumes param_less: "(less_impl,op <) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(ord.rbt_delete less_impl, \<lambda>k m. m |`(-{k})) \<in>
    Rk \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel op < \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel op <"
  unfolding rbt_map_rel_def
  apply (intro fun_relI)
  apply (elim relcomp.cases)
  apply hypsubst
  apply (rule relcompI)
  apply (rule param_rbt_delete[OF param_less, param_fo])
  apply assumption+
  apply (rule rbt_map_impl[param_fo])
  apply (rule IdI)
  apply assumption
  done

lemma (in linorder) autoref_gen_rbt_union:
  fixes less_impl
  assumes param_less: "(less_impl,op <) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(ord.rbt_union less_impl, op ++) \<in>
    \<langle>Rk,Rv\<rangle>rbt_map_rel op < \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel op < \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel op <"
  unfolding rbt_map_rel_def
  apply (intro fun_relI)
  apply (elim relcomp.cases)
  apply hypsubst
  apply (rule relcompI)
  apply (rule param_rbt_union[OF param_less, param_fo])
  apply assumption+
  apply (rule rbt_map_impl[param_fo])
  apply assumption+
  done

subsection {* A linear ordering on red-black trees *}

abbreviation "rbt_to_list t \<equiv> it_to_list rm_iterateoi t"

lemma (in linorder) rbt_to_list_correct:
  assumes SORTED: "rbt_sorted t"
  shows "rbt_to_list t = sorted_list_of_map (rbt_lookup t)" (is "?tl = _")
proof -
  from map_it_to_list_linord_correct[where it=rm_iterateoi, OF
    rm_iterateoi_correct[OF SORTED]
  ] have
      M: "map_of ?tl = rbt_lookup t"
      and D: "distinct (map fst ?tl)"
      and S: "sorted (map fst ?tl)"
    by (simp_all)

  from the_sorted_list_of_map[OF D S] M show ?thesis
    by simp
qed

definition
  "cmp_rbt cmpk cmpv \<equiv> cmp_img rbt_to_list (cmp_lex (cmp_prod cmpk cmpv))"

lemma (in linorder) param_rbt_sorted_list_of_map[param]:
  shows "(rbt_to_list, sorted_list_of_map) \<in>
  \<langle>Rk, Rv\<rangle>rbt_map_rel op < \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
  apply (auto simp: rbt_map_rel_def rbt_map_rel'_def br_def
    rbt_to_list_correct[symmetric]
  )
  by (parametricity)

lemma param_rbt_sorted_list_of_map'[param]:
  assumes ELO: "eq_linorder cmp'"
  shows "(rbt_to_list,linorder.sorted_list_of_map (comp2le cmp')) \<in>
    \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp') \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    by parametricity
qed

lemma rbt_linorder_impl:
  assumes ELO: "eq_linorder cmp'"
  assumes [param]: "(cmp,cmp')\<in>Rk\<rightarrow>Rk\<rightarrow>Id"
  shows
  "(cmp_rbt cmp, cmp_map cmp') \<in>
    (Rv\<rightarrow>Rv\<rightarrow>Id)
    \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')
    \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp') \<rightarrow> Id"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    unfolding cmp_map_def[abs_def] cmp_rbt_def[abs_def]
    apply (parametricity add: param_cmp_extend param_cmp_img)
    unfolding rbt_map_rel_def[abs_def] rbt_map_rel'_def br_def
    by auto
qed

lemma color_rel_sv[relator_props]: "single_valued color_rel"
  by (auto intro!: single_valuedI elim: color_rel.cases)

lemma rbt_rel_sv_aux:
  assumes SK: "single_valued Rk"
  assumes SV: "single_valued Rv"
  assumes I1: "(a,b)\<in>(\<langle>Rk, Rv\<rangle>rbt_rel)"
  assumes I2: "(a,c)\<in>(\<langle>Rk, Rv\<rangle>rbt_rel)"
  shows "b=c"
  using I1 I2
  apply (induct arbitrary: c)
  apply (elim rbt_rel_elims)
  apply simp
  apply (elim rbt_rel_elims)
  apply (simp add: single_valuedD[OF color_rel_sv]
    single_valuedD[OF SK] single_valuedD[OF SV])
  done

lemma rbt_rel_sv[relator_props]:
  assumes SK: "single_valued Rk"
  assumes SV: "single_valued Rv"
  shows "single_valued (\<langle>Rk, Rv\<rangle>rbt_rel)"
  by (auto intro: single_valuedI rbt_rel_sv_aux[OF SK SV])

lemma rbt_map_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rk; single_valued Rv\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rk,Rv\<rangle>rbt_map_rel lt)"
  apply (auto simp: rbt_map_rel_def rbt_map_rel'_def)
  apply (rule single_valued_relcomp)
  apply (rule rbt_rel_sv, assumption+)
  apply (rule br_sv)
  done

lemmas [autoref_rel_intf] = REL_INTFI[of "rbt_map_rel x" i_map] for x

subsection {* Second Part: Binding *}
lemma autoref_rbt_empty[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(rbt.Empty,op_map_empty) \<in>
    \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    by (simp) (rule autoref_gen_rbt_empty)
qed

lemma autoref_rbt_update[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(ord.rbt_insert (comp2lt cmp),op_map_update) \<in>
    Rk\<rightarrow>Rv\<rightarrow>\<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')
    \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    unfolding op_map_update_def[abs_def]
    apply (rule autoref_gen_rbt_insert)
    unfolding comp2lt_def[abs_def]
    by (parametricity)
qed

lemma autoref_rbt_lookup[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(\<lambda>k t. ord.rbt_lookup (comp2lt cmp) t k, op_map_lookup) \<in>
    Rk \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp') \<rightarrow> \<langle>Rv\<rangle>option_rel"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    unfolding op_map_lookup_def[abs_def]
    apply (intro fun_relI)
    apply (rule autoref_gen_rbt_lookup[param_fo])
    apply (unfold comp2lt_def[abs_def]) []
    apply (parametricity)
    apply assumption+
    done
qed

lemma autoref_rbt_delete[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(ord.rbt_delete (comp2lt cmp),op_map_delete) \<in>
    Rk \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')
       \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    unfolding op_map_delete_def[abs_def]
    apply (intro fun_relI)
    apply (rule autoref_gen_rbt_delete[param_fo])
    apply (unfold comp2lt_def[abs_def]) []
    apply (parametricity)
    apply assumption+
    done
qed

lemma autoref_rbt_union[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(ord.rbt_union (comp2lt cmp),op ++) \<in>
    \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp') \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')
       \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    apply (intro fun_relI)
    apply (rule autoref_gen_rbt_union[param_fo])
    apply (unfold comp2lt_def[abs_def]) []
    apply (parametricity)
    apply assumption+
    done
qed

lemma autoref_rbt_is_iterator[autoref_ga_rules]:
  assumes ELO: "GEN_ALGO_tag (eq_linorder cmp')"
  (*assumes [relator_props]: "single_valued Rk"   "single_valued Rv"*)
  shows "is_map_to_sorted_list (comp2le cmp') Rk Rv (rbt_map_rel (comp2lt cmp'))
    rbt_to_list"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply auto
  proof -
    fix r m'
    assume "(r, m') \<in> \<langle>Rk, Rv\<rangle>rbt_map_rel (comp2lt cmp')"
    then obtain r' where R1: "(r,r')\<in>\<langle>Rk,Rv\<rangle>rbt_rel"
      and R2: "(r',m') \<in> rbt_map_rel' (comp2lt cmp')"
      unfolding rbt_map_rel_def by blast

    from R2 have "is_rbt r'" and M': "m' = rbt_lookup r'"
      unfolding rbt_map_rel'_def
      by (simp_all add: br_def)
    hence SORTED: "rbt_sorted r'"
      by (simp add: is_rbt_def)

    from map_it_to_list_linord_correct[where it = rm_iterateoi, OF
      rm_iterateoi_correct[OF SORTED]
    ] have
        M: "map_of (rbt_to_list r') = rbt_lookup r'"
        and D: "distinct (map fst (rbt_to_list r'))"
        and S: "sorted (map fst (rbt_to_list r'))"
      by (simp_all)

    show "\<exists>l'. (rbt_to_list r, l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<and>
            distinct l' \<and>
            map_to_set m' = set l' \<and>
            sorted_by_rel (key_rel (comp2le cmp')) l'"
    proof (intro exI conjI)
      from D show "distinct (rbt_to_list r')" by (rule distinct_mapI)
      from S show "sorted_by_rel (key_rel (comp2le cmp')) (rbt_to_list r')"
        unfolding key_rel_def[abs_def]
        by simp
      show "(rbt_to_list r, rbt_to_list r') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
        by (parametricity add: R1)
      from M show "map_to_set m' = set (rbt_to_list r')"
        by (simp add: M' map_of_map_to_set[OF D])
    qed
  qed
qed

(* TODO: Reverse iterator *)

lemmas [autoref_ga_rules] = class_to_eq_linorder

lemma (in linorder) dflt_cmp_id:
  "(dflt_cmp op \<le> op <, dflt_cmp op \<le> op <)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

lemmas [autoref_rules] = dflt_cmp_id

lemma rbt_linorder_autoref[autoref_rules]:
  assumes "SIDE_GEN_ALGO (eq_linorder cmpk')"
  assumes "SIDE_GEN_ALGO (eq_linorder cmpv')"
  assumes "GEN_OP cmpk cmpk' (Rk\<rightarrow>Rk\<rightarrow>Id)"
  assumes "GEN_OP cmpv cmpv' (Rv\<rightarrow>Rv\<rightarrow>Id)"
  shows
  "(cmp_rbt cmpk cmpv, cmp_map cmpk' cmpv') \<in>
       \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmpk')
    \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmpk') \<rightarrow> Id"
  apply (intro fun_relI)
  apply (rule rbt_linorder_impl[param_fo])
  using assms
  apply simp_all
  done

(* TODO: Move. This belongs to generic algorithms for orders *)
lemma map_linorder_impl[autoref_ga_rules]:
  assumes "GEN_ALGO_tag (eq_linorder cmpk)"
  assumes "GEN_ALGO_tag (eq_linorder cmpv)"
  shows "eq_linorder (cmp_map cmpk cmpv)"
  using assms apply simp_all
  using map_ord_eq_linorder .

lemma set_linorder_impl[autoref_ga_rules]:
  assumes "GEN_ALGO_tag (eq_linorder cmpk)"
  shows "eq_linorder (cmp_set cmpk)"
  using assms apply simp_all
  using set_ord_eq_linorder .

lemma (in linorder) rbt_map_rel_finite_aux:
  "finite_map_rel (\<langle>Rk,Rv\<rangle>rbt_map_rel op <)"
  unfolding finite_map_rel_def
  by (auto simp: rbt_map_rel_def rbt_map_rel'_def br_def)

lemma rbt_map_rel_finite[relator_props]:
  assumes ELO: "GEN_ALGO_tag (eq_linorder cmpk)"
  shows "finite_map_rel (\<langle>Rk,Rv\<rangle>rbt_map_rel (comp2lt cmpk))"
proof -
  interpret linorder "comp2le cmpk" "comp2lt cmpk"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    using rbt_map_rel_finite_aux .
qed

abbreviation
  "dflt_rm_rel \<equiv> rbt_map_rel (comp2lt (dflt_cmp op \<le> op <))"

lemmas [autoref_post_simps] = dflt_cmp_inv2 dflt_cmp_2inv

lemma [simp,autoref_post_simps]: "ord.rbt_ins op < = rbt_ins"
proof (intro ext)
  case goal1 thus ?case
    apply (induct x xa xb xc rule: rbt_ins.induct)
    apply (simp_all add: ord.rbt_ins.simps)
    done
qed

lemma [simp,autoref_post_simps]:
  "ord.rbt_insert_with_key op < = rbt_insert_with_key"
  "ord.rbt_insert op < = rbt_insert"
  unfolding
    ord.rbt_insert_with_key_def[abs_def] rbt_insert_with_key_def[abs_def]
    ord.rbt_insert_def[abs_def] rbt_insert_def[abs_def]
  by simp_all

(* TODO: Move, probably to some orderings setup theory *)
lemma autoref_comp2eq[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes ELC: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (R\<rightarrow>R\<rightarrow>Id)"
  shows "(comp2eq cmp, op =) \<in> R\<rightarrow>R\<rightarrow>Id"
proof -
  from ELC have 1: "eq_linorder cmp'" by simp
  show ?thesis
    apply (subst eq_linorder_comp2eq_eq[OF 1,symmetric])
    by parametricity
qed

lemma pi'_rm[icf_proper_iteratorI]:
  "proper_it' rm_iterateoi rm_iterateoi"
  "proper_it' rm_reverse_iterateoi rm_reverse_iterateoi"
  apply (rule proper_it'I)
  apply (rule pi_rm)
  apply (rule proper_it'I)
  apply (rule pi_rm_rev)
  done

declare pi'_rm[proper_it]

lemmas autoref_rbt_rules =
  autoref_rbt_empty
  autoref_rbt_lookup
  autoref_rbt_update
  autoref_rbt_delete
  autoref_rbt_union

lemmas autoref_rbt_rules_linorder[autoref_rules_raw] =
  autoref_rbt_rules[where Rk="Rk"] for Rk :: "(_\<times>_::linorder) set"

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Dflipflop
  imports VHDL_Hoare_Complete
begin

text \<open>datatype for all signals\<close>

datatype sig = D | CLK | OUT

definition dflipflop :: "sig conc_stmt" where
  "dflipflop \<equiv> process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull"

text \<open>The following positive edge is only defined for a scalar signal.\<close>

abbreviation is_posedge :: "'signal worldline \<Rightarrow> 'signal \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "is_posedge w s j i \<equiv> (  j \<le> i \<and> w s (j - 1)  = Bv False \<and> w s j = Bv True \<comment> \<open>change of signal from low to high at j\<close>
                      \<and> (\<forall>j' \<le> i.  w s (j' - 1) = Bv False \<and> w s j' = Bv True \<longrightarrow> j' \<le> j) \<comment> \<open>largest of positive edge\<close>)"

lemma is_posedge_strictly_positive:
  "is_posedge w s j i \<Longrightarrow> 0 < j"
  using gr_zeroI  by force

lemma is_posedge_unique:
  assumes "is_posedge w s j1 i" and "is_posedge w s j2 i"
  shows "j1 = j2"
  using assms by (simp add: dual_order.antisym)

definition inv :: "sig assn2" where
  "inv tw \<equiv> (\<forall>i < fst tw.                                   \<comment> \<open>at all ``times''\<close>
            (\<forall>j \<le> i. is_posedge (wline_of tw) CLK j i \<longrightarrow>   \<comment> \<open>if there is positive edge namely j\<close>
                wline_of tw OUT (i + 1) = wline_of tw D j)  \<comment> \<open>the output at i + 1 equals to D at j\<close>)"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> disjnt {CLK} (event_of tw) \<or> wline_of tw CLK (fst tw) = (Bv False) \<longrightarrow> \<comment> \<open>if there is no positive edge in CLK\<close>
             (\<forall>i \<ge> fst tw. wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)) \<comment> \<open>the value stays the same\<close>"

lemma wline_of_diff:
  assumes "wline_of tw sig t \<noteq> wline_of tw sig (t - 1)"
  assumes "wline_of tw sig t = (Bv bool)"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "wline_of tw sig (t - 1) = (Bv (\<not> bool))"
proof -
  have "type_of (wline_of tw sig t) = Bty"
    using assms(2) by auto
  hence "type_of (wline_of tw sig (t - 1)) = Bty"
    using assms(3) unfolding wityping_def wtyping_def by auto
  thus ?thesis
    using assms(1-2)  by (metis (mono_tags) ty.distinct(1) type_of.elims val.inject(1))
qed

lemma inv_time_seq_next_time:
  assumes "inv tw" and "\<not> disjnt {CLK} (event_of tw)" and "beval_world_raw2 tw (Bsig CLK) (Bv True)"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 wline_of tw D (fst tw)]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "\<forall>k \<in> {fst tw' <.. next_time_world tw'}. inv (k, snd tw')"
  unfolding inv_def
proof (rule)+
  fix i j k
  assume "k \<in> {fst tw' <.. next_time_world tw'}"
  assume "i < fst (k, snd tw')"
  hence "i < k"
    by auto
  assume "j \<le> i"
  assume "is_posedge (wline_of (k, snd tw')) CLK j i "
  hence  "is_posedge (wline_of tw') CLK j i"
    by auto
  have "i < fst tw \<or> fst tw \<le> i \<and> i < k - 1 \<or> i = k - 1"
    using \<open>i < k\<close> by linarith
  moreover
  { assume "i < fst tw"
    hence "is_posedge (wline_of tw) CLK j i"
      using \<open>is_posedge (wline_of tw') CLK j i\<close> by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
    have "wline_of tw' OUT (i + 1) = wline_of tw OUT (i + 1)"
      by (metis \<open>i < get_time tw\<close> add_mono1 tw'_def worldline_upd2_before_dly)
    also have "... = wline_of tw D j"
      using \<open>j \<le> i\<close> \<open>is_posedge (wline_of tw') CLK j i\<close> assms(1) \<open>i < fst tw\<close> \<open>is_posedge (wline_of tw) CLK j i\<close>
      unfolding inv_def by auto
    also have "... = wline_of tw' D j"
      by (metis (no_types, lifting) One_nat_def \<open>i < get_time tw\<close> \<open>j \<le> i\<close> add.right_neutral
      add_Suc_right add_mono1 le_imp_less_Suc less_trans tw'_def worldline_upd2_before_dly)
    finally have "wline_of tw' OUT (i + 1) = wline_of tw' D j"
      by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < k - 1"
    hence "is_posedge (wline_of tw) CLK j i"
      using \<open>is_posedge (wline_of tw') CLK j i\<close>
      by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
    have "wline_of tw' OUT (i + 1) = wline_of tw' OUT (fst tw + 1)"
      by (smt \<open>get_time tw \<le> i \<and> i < k - 1\<close> add_diff_cancel_right' comp_def less_diff_conv not_le
      sndI tw'_def worldline_upd2_at_dly worldline_upd2_def worldline_upd_def)
    also have "... = wline_of tw D (fst tw)"
      unfolding tw'_def  by (meson beval_world_raw2_Bsig worldline_upd2_at_dly)
    also have "... = wline_of tw D j"
    proof -
      have "0 < j"
        using is_posedge_strictly_positive \<open>is_posedge (wline_of tw') CLK j i\<close>  by fastforce
      hence "0 < i"
        using \<open>j \<le> i\<close> by auto
      hence "0 < fst tw"
        by (smt \<open>i < k\<close> \<open>is_posedge (wline_of tw') CLK j i\<close> \<open>k \<in> {get_time tw'<..next_time_world
        tw'}\<close> assms(4) diff_le_self fst_conv gr0I greaterThanAtMost_iff le_less_trans
        less_imp_le_nat less_le_trans unchanged_until_next_time_world val.inject(1)
        worldline_upd2_def)
      have "wline_of tw CLK (fst tw) \<noteq> wline_of tw CLK (fst tw - 1)"
        using assms(2) \<open>0 < fst tw\<close> unfolding event_of_alt_def
        by simp
      hence "wline_of tw CLK (fst tw) = Bv True"
        using assms(3) by (metis beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)
      have "wline_of tw CLK (fst tw - 1) = Bv False"
      proof -
        have "type_of (wline_of tw CLK (fst tw)) = Bty"
          using \<open>wline_of tw CLK (fst tw) = Bv True\<close> by auto
        hence "type_of (wline_of tw CLK (fst tw - 1)) = Bty"
          using \<open>wityping \<Gamma> (snd tw)\<close> unfolding wityping_def wtyping_def  by auto
        hence "wline_of tw CLK (fst tw - 1) = (Bv False) \<or> wline_of tw CLK (fst tw - 1) = (Bv True)"
          by (metis ty.distinct(1) type_of.elims)
        thus ?thesis
          using \<open>wline_of tw CLK (get_time tw) = Bv True\<close> \<open>wline_of tw CLK (get_time tw) \<noteq> wline_of tw CLK (get_time tw - 1)\<close> by auto
      qed
      moreover have "\<forall>j' \<le> i. wline_of tw CLK (j' - 1) = (Bv False) \<and> wline_of tw CLK j' = (Bv True) \<longrightarrow> j' \<le> fst tw"
        by (smt Suc_diff_1 \<open>0 < j\<close> \<open>get_time tw \<le> i \<and> i < k - 1\<close> \<open>is_posedge (wline_of tw') CLK j i\<close>
        \<open>is_posedge (wline_of tw) CLK j i\<close> \<open>k \<in> {get_time tw'<..next_time_world tw'}\<close> \<open>wline_of tw
        CLK (get_time tw) = Bv True\<close> \<open>wline_of tw CLK (get_time tw) \<noteq> wline_of tw CLK (get_time tw -
        1)\<close> calculation diff_le_self dual_order.strict_trans1 fst_conv greaterThanAtMost_iff
        le_less_trans less_Suc_eq_le not_le_imp_less tw'_def unchanged_until_next_time_world
        worldline_upd2_def)
      ultimately have "fst tw = j"
        using \<open>is_posedge (wline_of tw) CLK j i\<close>
        by (meson \<open>get_time tw \<le> i \<and> i < k - 1\<close> \<open>wline_of tw CLK (get_time tw) = Bv True\<close> eq_iff)
      thus ?thesis
        using \<open>is_posedge (wline_of tw) CLK j i\<close> by blast
    qed
    also have "... = wline_of tw' D j"
      by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
    finally have "wline_of tw' OUT (i + 1) = wline_of tw' D j"
      by auto }
  moreover
  { assume "i = k - 1"
    hence "is_posedge (wline_of tw) CLK j i"
      using \<open>is_posedge (wline_of tw') CLK j i\<close> by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
    have "wline_of tw' OUT (i + 1) = wline_of tw' OUT (k)"
      by (metis Suc_diff_1 Suc_eq_plus1 \<open>i < k\<close> \<open>i = k - 1\<close>
      add.right_neutral le_add2 nat_less_le not_le)
    also have "... = wline_of tw' OUT (fst tw + 1)"
      unfolding tw'_def
      by (smt Suc_eq_plus1 Suc_leI \<open>k \<in> {get_time tw'<..next_time_world tw'}\<close> comp_apply fst_conv
      greaterThanAtMost_iff nat_less_le not_less_iff_gr_or_eq sndI tw'_def worldline_upd2_def
      worldline_upd_def)
    also have "... = wline_of tw D (fst tw)"
      unfolding tw'_def  by (meson beval_world_raw2_Bsig worldline_upd2_at_dly)
    also have "... = wline_of tw D j"
    proof -
      have *: "wline_of tw CLK (fst tw) \<noteq> wline_of tw CLK (fst tw - 1)"
        using assms(2) unfolding event_of_alt_def
        by (smt \<open>i < k\<close> \<open>is_posedge (wline_of tw') CLK j i\<close> \<open>k \<in> {get_time tw'<..next_time_world
        tw'}\<close> diff_is_0_eq' diff_le_self disjnt_iff fst_conv greaterThanAtMost_iff le_less_trans
        mem_Collect_eq not_less singletonD tw'_def unchanged_until_next_time_world val.inject(1)
        worldline_upd2_def)
      have "wline_of tw CLK (fst tw) = Bv True"
        by (metis assms(3) beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)
      hence "wline_of tw CLK (fst tw - 1) = Bv False"
        using wline_of_diff[OF * _ assms(5)] by auto
      moreover have "\<forall>j' \<le> i. wline_of tw CLK (j' - 1) = Bv False \<and> wline_of tw CLK j' = Bv True \<longrightarrow> j' \<le> fst tw"
        by (smt "*" One_nat_def \<open>i = k - 1\<close> \<open>is_posedge (wline_of tw') CLK j i\<close> \<open>is_posedge
        (wline_of tw) CLK j i\<close> \<open>k \<in> {get_time tw'<..next_time_world tw'}\<close> \<open>wline_of tw CLK (get_time
        tw) = Bv True\<close> calculation dual_order.strict_trans1 fst_conv greaterThanAtMost_iff le_Suc_eq
        le_imp_less_Suc le_zero_eq less_imp_le_nat linordered_semidom_class.add_diff_inverse
        not_less_iff_gr_or_eq plus_1_eq_Suc tw'_def unchanged_until_next_time_world
        worldline_upd2_def)
      ultimately have "fst tw = j"
        using \<open>is_posedge (wline_of tw) CLK j i\<close>
        by (metis One_nat_def \<open>i = k - 1\<close> \<open>k \<in> {get_time tw'<..next_time_world tw'}\<close> \<open>wline_of tw
        CLK (get_time tw) = Bv True\<close> dual_order.antisym fstI gr_implies_not_zero
        greaterThanAtMost_iff less_Suc0 less_Suc_eq_le linordered_semidom_class.add_diff_inverse
        plus_1_eq_Suc tw'_def worldline_upd2_def)
      thus ?thesis
        using \<open>is_posedge (wline_of tw) CLK j i\<close> by blast
    qed
    also have "... = wline_of tw' D j"
      by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
    finally have "wline_of tw' OUT (i + 1) = wline_of tw' D j"
      by auto }
  ultimately have "wline_of tw' OUT (i + 1) = wline_of tw' D j"
    by auto
  thus "wline_of (k, snd tw') OUT (i + 1) = wline_of (k, snd tw') D j"
    by auto
qed

lemma dflipflop_seq_inv:
  "\<turnstile> [\<lambda>tw. (((inv tw \<and> inv2 tw) \<and> \<not> disjnt {CLK} (event_of tw)) \<and> beval_world_raw2 tw (Bsig CLK) (Bv True)) \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans OUT (Bsig D) 1
     [\<lambda>tw. \<forall>k \<in> {fst tw <.. next_time_world tw}. inv (k, snd tw)]"
  apply (rule Assign2_altI)
  using inv_time_seq_next_time
  by (metis beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)

lemma inv2_seq_next_time:
  assumes "inv tw" and "inv2 tw" and "\<not> disjnt {CLK} (event_of tw)" and "beval_world_raw2 tw (Bsig CLK) (Bv True)"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 wline_of tw D (fst tw)]"
  shows "\<forall>k \<in> {fst tw' <.. next_time_world tw'}. inv2 (k, snd tw')"
  unfolding inv2_def
proof (rule)+
  fix i k
  assume "k \<in> {fst tw' <.. next_time_world tw'}"
  assume "   disjnt {CLK} (event_of (k, snd tw'))  \<or> wline_of (k, snd tw') CLK (get_time (k, snd tw')) = (Bv False)"
  hence  "   disjnt {CLK} (event_of (k, snd tw'))  \<or> wline_of tw' CLK (k) = (Bv False)"
    by auto
  assume "get_time (k, snd tw') \<le> i"
  hence "k \<le> i"
    by auto
  moreover have "fst tw < k"
    using next_time_world_at_least
    by (metis Pair_inject \<open>k \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff
    prod.collapse tw'_def worldline_upd2_def)
  ultimately have "fst tw < i"
    by auto
  have "wline_of tw' OUT (i + 1) = wline_of tw' OUT (k)"
    unfolding tw'_def using \<open>fst tw < k\<close> \<open>fst tw < i\<close>
    by (smt Suc_eq_plus1 Suc_leI add_diff_cancel_right' comp_apply diff_is_0_eq' less_diff_conv
    not_less_iff_gr_or_eq snd_conv tw'_def worldline_upd2_def worldline_upd_def zero_less_diff)
  thus " wline_of (k, snd tw') OUT (i + 1) =
         wline_of (k, snd tw') OUT (get_time (k, snd tw'))"
    by auto
qed

lemma dflipflop_seq_inv2:
  "\<turnstile> [\<lambda>tw. ((inv tw \<and> inv2 tw) \<and> \<not> disjnt {CLK} (event_of tw)) \<and> beval_world_raw2 tw (Bsig CLK) (Bv True)]
        Bassign_trans OUT (Bsig D) 1
     [\<lambda>tw. \<forall>k \<in> {fst tw <.. next_time_world tw}. inv2 (k, snd tw)]"
  apply (rule Assign2_altI)
  using inv2_seq_next_time
  by (metis beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)

lemma dflipflop_inv_if:
  "\<turnstile> [\<lambda>tw. (((inv tw \<and> inv2 tw) \<and> \<not> disjnt {CLK} (event_of tw)) \<and> beval_world_raw2 tw (Bsig CLK) (Bv True)) \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans OUT (Bsig D) 1
     [\<lambda>tw. \<forall>k \<in> {fst tw <.. next_time_world tw}. inv (k, snd tw) \<and> inv2 (k, snd tw)]"
  apply (rule Conj_univ_qtfd)
   apply (rule dflipflop_seq_inv)
  apply (rule strengthen_precondition)
  apply (rule dflipflop_seq_inv2)
  done

lemma inv_next_time_null:
  assumes "inv tw" and "inv2 tw" and "\<not> disjnt {CLK} (event_of tw)" and "beval_world_raw2 tw (Bsig CLK) (Bv False)"
  shows "\<forall>k \<in> {fst tw <.. next_time_world tw}. inv (k, snd tw)"
  unfolding inv_def
proof (rule)+
  fix i j k :: nat
  assume "j \<le> i"
  assume "k \<in> {fst tw <.. next_time_world tw}"
  assume "is_posedge (wline_of (k, snd tw)) CLK j i"
  hence  "is_posedge (wline_of tw) CLK j i"
    by auto
  hence "0 < j"
    using is_posedge_strictly_positive by metis
  have *: "\<forall>i\<ge>get_time tw. wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
    using assms(2) assms(4) unfolding inv2_def
    by (metis Suc_eq_plus1 beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)
  assume "i < fst (k, snd tw)"
  hence "i < k"
    by auto
  hence "i < fst tw \<or> fst tw \<le> i \<and> i \<le> k - 1"
    by linarith
  moreover
  { assume "i < fst tw"
    hence "wline_of tw OUT (i + 1) = wline_of tw D j"
      using Dflipflop.inv_def \<open>is_posedge (wline_of (k, snd tw)) CLK j i\<close> \<open>j \<le> i\<close>
      assms(1) by auto }
  moreover
  { assume "fst tw \<le> i \<and> i \<le> k - 1"
    hence "wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
      using \<open>inv2 tw\<close> assms(3-4) * unfolding inv2_def by blast
    have "fst tw = 0 \<or> 0 < fst tw"
      by auto
    moreover
    { assume "0 < fst tw"
      hence "fst tw - 1 < fst tw"
        by auto
      have "j \<noteq> fst tw"
      proof (rule ccontr)
        assume "\<not> j \<noteq> fst tw"
        hence "j = fst tw"
          by auto
        hence "wline_of tw CLK j = Bv True"
          using `is_posedge (wline_of tw) CLK j i` by auto
        with \<open>beval_world_raw2 tw (Bsig CLK) (Bv False)\<close> show False
          by (smt \<open>j = get_time tw\<close> beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic val.inject(1))
      qed
      hence "j < fst tw \<or> j > fst tw"
        by auto
      moreover have "j > fst tw \<Longrightarrow> False"
      proof -
        assume "j > fst tw"
        have "j < next_time_world tw - 1"
          using \<open>j \<le> i\<close> `fst tw \<le> i \<and> i \<le> k - 1`
          by (smt Suc_diff_1 \<open>get_time tw < j\<close> \<open>i < k\<close> \<open>is_posedge (wline_of tw) CLK j i\<close> \<open>k \<in>
          {get_time tw<..next_time_world tw}\<close> diff_is_0_eq' greaterThanAtMost_iff le_less_trans
          less_SucE less_imp_diff_less less_imp_le_nat less_le_trans unchanged_until_next_time_world
          val.inject(1))
        hence "wline_of tw CLK (j - 1) = wline_of tw CLK j"
          using `fst tw < j` unchanged_until_next_time_world
          by (metis Suc_diff_1 cancel_comm_monoid_add_class.diff_cancel less_Suc_eq_le
          less_imp_diff_less less_imp_le_nat next_time_world_at_least)
        with \<open>is_posedge (wline_of tw) CLK j i\<close> show False
          by simp
      qed
      ultimately have "j \<le> fst tw - 1"
        by auto
      moreover have "is_posedge (wline_of tw) CLK j (fst tw - 1)"
        using \<open>get_time tw \<le> i \<and> i \<le> k - 1\<close> \<open>is_posedge (wline_of tw) CLK j i\<close>
        less_imp_diff_less  using calculation by auto
      ultimately have "wline_of tw OUT (fst tw)= wline_of tw D j"
        using \<open>inv tw\<close> `fst tw - 1 < fst tw` unfolding inv_def  by auto
      with \<open>wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)\<close> have "wline_of tw OUT (i + 1) = wline_of tw D j"
        by auto }
    moreover
    { assume "fst tw = 0"
      with `inv2 tw` have "wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
        unfolding inv2_def  using \<open>beval_world_raw2 tw (Bsig CLK) (Bv False)\<close>
        \<open>wline_of tw OUT (i + 1) = wline_of tw OUT (get_time tw)\<close> by blast
      have "is_posedge (wline_of tw) CLK j (fst tw)"
        using \<open>get_time tw = 0\<close> \<open>is_posedge (wline_of tw) CLK j i\<close>
        by (metis (no_types, lifting) \<open>i < k\<close> \<open>k \<in> {get_time tw<..next_time_world tw}\<close> diff_le_self
        dual_order.strict_trans1 greaterThanAtMost_iff le0 le_less_trans
        unchanged_until_next_time_world val.inject(1))
      hence "wline_of tw CLK (fst tw - 1) \<noteq> wline_of tw CLK (fst tw)"
        using \<open>get_time tw = 0\<close> by auto
      with \<open>fst tw = 0\<close> have "False"
        by simp
      hence "wline_of tw OUT (i + 1) = wline_of tw D j"
        by auto }
    ultimately have "wline_of tw OUT (i + 1) = wline_of tw D j"
      by auto }
  ultimately have "wline_of tw OUT (i + 1) = wline_of tw D j"
    by auto
  thus "wline_of (k, snd tw) OUT (i + 1) = wline_of (k, snd tw) D j"
    by auto
qed

lemma inv2_next_time_null:
  assumes "inv tw" and "inv2 tw" and "\<not> disjnt {CLK} (event_of tw)" and "beval_world_raw2 tw (Bsig CLK) (Bv False)"
  shows "\<forall>k \<in> {fst tw <.. next_time_world tw}. inv2 (k, snd tw)"
  unfolding inv2_def
proof (rule)+
  fix i k
  assume "k \<in> {fst tw <.. next_time_world tw}"
  assume "   disjnt {CLK} (event_of (k, snd tw))
         \<or>   wline_of (k, snd tw) CLK (get_time (k, snd tw)) = Bv False"
  assume " get_time (k, snd tw) \<le> i"
  hence "k \<le> i"
    by auto
  hence "fst tw \<le> i"
    using next_time_world_at_least dual_order.strict_trans less_Suc_eq_le
    using \<open>k \<in> {get_time tw<..next_time_world tw}\<close> by auto
  moreover have "\<forall>i \<ge> fst tw. wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
    using assms(2) assms(4) unfolding inv2_def
    by (metis beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)
  ultimately have "wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
    by auto
  also have "... = wline_of tw OUT (k - 1)"
    using unchanged_until_next_time_world
    by (smt Suc_diff_1 \<open>k \<in> {get_time tw<..next_time_world tw}\<close> diff_is_0_eq' diff_le_self diff_less
    dual_order.strict_iff_order greaterThanAtMost_iff le_Suc_eq less_le_trans zero_less_one)
  also have "... = wline_of tw OUT (k)"
    using assms(3) unfolding event_of_alt_def
    by (smt \<open>\<forall>i\<ge>get_time tw. wline_of tw OUT (i + 1) = wline_of tw OUT (get_time tw)\<close> \<open>k \<in> {get_time
    tw<..next_time_world tw}\<close> add_diff_cancel_left' diff_add diff_add_zero greaterThanAtMost_iff
    le_Suc_eq le_add1 le_add_diff_inverse less_le plus_1_eq_Suc)
  finally have "wline_of tw OUT (i + 1) = wline_of tw OUT (k)"
    by auto
  thus "wline_of (k, snd tw) OUT (i + 1) =
        wline_of (k, snd tw) OUT (get_time (k, snd tw))"
    by auto
qed

lemma dflipflop_inv_else:
  "\<turnstile> [\<lambda>tw. ((inv tw \<and> inv2 tw) \<and> \<not> disjnt {CLK} (event_of tw)) \<and> beval_world_raw2 tw (Bsig CLK) (Bv False)]
        Bnull
     [\<lambda>tw. \<forall>k \<in> {fst tw <.. next_time_world tw}. inv (k, snd tw) \<and> inv2 (k, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>k \<in> {fst tw <.. next_time_world tw}. inv (k, snd tw) \<and> inv2 (k, snd tw)", rotated 1])
    apply (rule Null2)
   apply simp
  using inv_next_time_null inv2_next_time_null by auto

lemma dflipflop_seq_both_inv:
  "\<turnstile> [\<lambda>tw. (inv tw \<and> inv2 tw) \<and> \<not> disjnt {CLK} (event_of tw) \<and> wityping \<Gamma> (snd tw)] \<comment> \<open>precondition\<close>
        Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull \<comment> \<open>program\<close>
     [\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw) \<and> inv2 (j, snd tw)]" \<comment> \<open>postcondition\<close>
  apply (rule If2)
   apply (rule Conseq2)
     prefer 2
     apply (rule dflipflop_inv_if)
    apply blast+
  apply (rule Conseq2)
    prefer 2
    apply (rule dflipflop_inv_else)
   apply blast+
  done

lemma inv_next_time_disjnt:
  assumes "inv tw" and "inv2 tw" and "disjnt {CLK} (event_of tw)"
  shows "\<forall>k \<in> {fst tw <.. next_time_world tw}. inv (k, snd tw)"
  unfolding inv_def
proof (rule)+
  fix i j k :: nat
  assume "k \<in> {fst tw <.. next_time_world tw}"
  assume "j \<le> i"
  assume "is_posedge (wline_of (k, snd tw)) CLK j i"
  hence "is_posedge (wline_of tw) CLK j i"
    by auto
  hence "0 < j"
    using is_posedge_strictly_positive by metis
  have *: "\<forall>i\<ge>get_time tw. wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
    using assms(2) assms(3) unfolding inv2_def by auto
  assume "i < fst (k, snd tw)"
  hence "i < k"
    by auto
  hence "i < fst tw \<or> fst tw \<le> i \<and> i \<le> k - 1"
    by linarith
  moreover
  { assume "i < fst tw"
    hence "wline_of tw OUT (i + 1) = wline_of tw D j"
      using Dflipflop.inv_def \<open>is_posedge (wline_of (k, snd tw)) CLK j i\<close> \<open>j \<le> i\<close>
      assms(1) by auto }
  moreover
  { assume "fst tw \<le> i \<and> i \<le> k - 1"
    have "fst tw = 0 \<or> 0 < fst tw"
      by auto
    moreover
    { assume "0 < fst tw"
      hence "fst tw - 1 < fst tw"
        by auto
      have "j \<noteq> fst tw"
      proof (rule ccontr)
        assume "\<not> j \<noteq> fst tw"
        hence "j = fst tw"
          by auto
        hence "wline_of tw CLK (fst tw - 1) \<noteq> wline_of tw CLK (fst tw)"
          using \<open>is_posedge (wline_of tw) CLK j i\<close> by simp
        hence "\<not> disjnt {CLK} (event_of tw)"
          unfolding event_of_alt_def using \<open>0 < fst tw\<close>  by auto
        with \<open>disjnt {CLK} (event_of tw)\<close> show False
          by auto
      qed
      hence "j < fst tw \<or> j > fst tw"
        by auto
      moreover have "j > fst tw \<Longrightarrow> False"
      proof -
        assume "j > fst tw"
        have "j < next_time_world tw - 1"
          using \<open>j \<le> i\<close> `fst tw \<le> i \<and> i \<le> k - 1`
          by (smt \<open>get_time tw < j\<close> \<open>is_posedge (wline_of tw) CLK j i\<close> \<open>k \<in> {get_time
          tw<..next_time_world tw}\<close> diff_is_0_eq' diff_less_Suc greaterThanAtMost_iff less_SucE
          less_imp_le_nat less_le_trans linordered_semidom_class.add_diff_inverse not_less
          plus_1_eq_Suc unchanged_until_next_time_world val.inject(1))
        hence "wline_of tw CLK (j - 1) = wline_of tw CLK j"
          using `fst tw < j` unchanged_until_next_time_world
          by (smt add_le_imp_le_diff diff_le_self discrete dual_order.strict_trans1
          le_eq_less_or_eq)
        with \<open>is_posedge (wline_of tw) CLK j i\<close> show False
          by simp
      qed
      ultimately have "j \<le> fst tw - 1"
        by auto
      moreover have "is_posedge (wline_of tw) CLK j (fst tw - 1)"
        using  \<open>is_posedge (wline_of tw) CLK j i\<close>
        less_imp_diff_less calculation \<open>get_time tw \<le> i \<and> i \<le> k - 1\<close> by auto
      ultimately have "wline_of tw OUT (fst tw)= wline_of tw D j"
        using \<open>inv tw\<close> `fst tw - 1 < fst tw` unfolding inv_def  by auto
      with * have "wline_of tw OUT (i + 1) = wline_of tw D j"
        using \<open>get_time tw \<le> i \<and> i \<le> k - 1\<close>  by simp }
    moreover
    { assume "fst tw = 0"
      have "wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
        using *  by (simp add: \<open>get_time tw = 0\<close>)
      have "is_posedge (wline_of tw) CLK j (fst tw)"
        using \<open>get_time tw = 0\<close> \<open>is_posedge (wline_of tw) CLK j i\<close>
        by (metis (no_types, lifting) \<open>i < get_time (k, snd tw)\<close> \<open>k \<in> {get_time tw<..next_time_world
        tw}\<close> diff_le_self dual_order.strict_trans1 fst_conv greaterThanAtMost_iff le0 le_less_trans
        unchanged_until_next_time_world val.inject(1))
      hence "wline_of tw CLK (fst tw - 1) \<noteq> wline_of tw CLK (fst tw)"
        using \<open>get_time tw = 0\<close> by auto
      with \<open>fst tw = 0\<close> have "False"
        by simp
      hence "wline_of tw OUT (i + 1) = wline_of tw D j"
        by auto }
    ultimately have "wline_of tw OUT (i + 1) = wline_of tw D j"
      by auto }
  ultimately have "wline_of tw OUT (i + 1) = wline_of tw D j"
    by auto
  thus "wline_of (k, snd tw) OUT (i + 1) = wline_of (k, snd tw) D j"
    by auto
qed

lemma inv2_next_time_disjnt:
  assumes "inv tw" and "inv2 tw" and "disjnt {CLK} (event_of tw)"
  shows "\<forall>k \<in> {fst tw <.. next_time_world tw}. inv2 (k, snd tw)"
  unfolding inv2_def
proof rule+
  fix i k
  assume "k \<in> {get_time tw<..next_time_world tw}"
  assume "   disjnt {CLK} (event_of (k, snd tw))
         \<or>   wline_of (k, snd tw) CLK (get_time (k, snd tw)) = Bv False"
  assume " get_time (k, snd tw) \<le> i"
  hence "k \<le> i"
    by auto
  hence "fst tw \<le> i"
    using next_time_world_at_least dual_order.strict_trans less_Suc_eq_le
    using \<open>k \<in> {get_time tw<..next_time_world tw}\<close> by auto
  moreover have "\<forall>i \<ge> fst tw. wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
    using assms(2-3) unfolding inv2_def  by (simp add: beval_world_raw2_Bsig)
  ultimately have "wline_of tw OUT (i + 1) = wline_of tw OUT (fst tw)"
    by auto
  also have "... = wline_of tw OUT (k - 1)"
    using unchanged_until_next_time_world
    by (smt Suc_diff_1 \<open>k \<in> {get_time tw<..next_time_world tw}\<close> diff_is_0_eq' diff_le_self diff_less
    dual_order.strict_iff_order greaterThanAtMost_iff le_Suc_eq less_le_trans zero_less_one)
  also have "... = wline_of tw OUT (k)"
    using assms(3) unfolding event_of_alt_def
    by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 \<open>\<forall>i\<ge>get_time tw. wline_of tw OUT (i + 1)
    = wline_of tw OUT (get_time tw)\<close> \<open>k \<in> {get_time tw<..next_time_world tw}\<close> \<open>wline_of tw OUT
    (get_time tw) = wline_of tw OUT (k - 1)\<close> gr_implies_not0 greaterThanAtMost_iff le_Suc_eq
    less_Suc0 less_or_eq_imp_le linordered_semidom_class.add_diff_inverse plus_1_eq_Suc)
  finally have "wline_of tw OUT (i + 1) = wline_of tw OUT (k)"
    by auto
  thus "wline_of (k, snd tw) OUT (i + 1) =
        wline_of (k, snd tw) OUT (get_time (k, snd tw))"
    by auto
qed

lemma dflipflop_conc_both_inv:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>  \<comment> \<open>precondition\<close>
        process {CLK} : Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull \<comment> \<open>program\<close>
     \<lbrace>\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw) \<and> inv2 (j, snd tw)\<rbrace>" \<comment> \<open>postcondition\<close>
  apply (rule Single)
   apply (rule Conseq2)
     prefer 2
     apply (rule dflipflop_seq_both_inv)
    apply blast+
  using inv_next_time_disjnt inv2_next_time_disjnt
  by auto

theorem simulation_comb:
  assumes "conc_wt \<Gamma> dflipflop"
  shows "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and>  wityping \<Gamma> (snd tw)\<rbrace> dflipflop \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  unfolding dflipflop_def
  apply (rule While)
  apply (rule Conj2_univ_qtfd)
   apply (rule dflipflop_conc_both_inv)
  apply (rule Conseq'[rotated])
    apply (rule single_conc_stmt_preserve_wityping_hoare[where \<Gamma>="\<Gamma>"])
    apply (metis assms conc_wt_cases(1) dflipflop_def)
  by auto

corollary simulation_inv:
  assumes "conc_wt \<Gamma> dflipflop"
  shows "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw \<and> wityping \<Gamma> (snd tw)\<rbrace> dflipflop \<lbrace>\<lambda>tw. inv tw\<rbrace>"
  using simulation_comb[OF assms]  Conseq_sim   by fastforce

subsection \<open>Initialisation satisfies @{term "inv"} and @{term "inv2"}\<close>

lemma inv_time_seq_next_time0:
  assumes "fst tw = 0"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 wline_of tw D (fst tw)]"
  shows "inv (next_time_world tw', snd tw')"
  unfolding inv_def
proof (rule, rule, rule, rule, rule)
  fix i j
  assume "i < get_time (next_time_world tw', snd tw')"
  hence "i < next_time_world tw'"
    by auto
  assume "j \<le> i"
  hence "j < next_time_world tw'"
    using `i < next_time_world tw'` by auto
  assume "is_posedge (wline_of (next_time_world tw', snd tw')) CLK j i"
  hence "is_posedge (wline_of tw') CLK j i"
    by auto
  hence "wline_of tw' CLK (j - 1) \<noteq> wline_of tw' CLK j"
    by simp
  moreover have "(\<forall>s. wline_of tw' s j = wline_of tw' s (fst tw'))"
    using unchanged_until_next_time_world `fst tw = 0` `j < next_time_world tw'`
    by (metis fst_conv less_eq_nat.simps(1) tw'_def worldline_upd2_def)
  ultimately have "False"
    by (metis \<open>j < next_time_world tw'\<close> assms(1) fst_conv less_imp_diff_less tw'_def
    unchanged_until_next_time_world worldline_upd2_def zero_le)
  thus "wline_of (next_time_world tw', snd tw') OUT (i + 1) = wline_of (next_time_world tw', snd tw') D j"
    by auto
qed

lemma init0:
  "\<turnstile> [\<lambda>tw. get_time tw = 0 \<and> beval_world_raw2 tw (Bsig CLK) (Bv True)]
        Bassign_trans OUT (Bsig D) 1
     [\<lambda>tw. inv (next_time_world tw, snd tw)]"
  apply (rule Assign2_altI)
  using inv_time_seq_next_time0
  by (metis beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)

lemma inv_time_seq_next_time0':
  assumes "fst tw = 0"
  shows   "inv (next_time_world tw, snd tw)"
  unfolding inv_def
proof (rule, rule, rule, rule, rule)
  fix i j
  assume "i < fst (next_time_world tw, snd tw)"
  hence "i < next_time_world tw"
    by auto
  assume "j \<le> i"
  hence "j < next_time_world tw"
    using `i < next_time_world tw` by auto
  assume " is_posedge (wline_of (next_time_world tw, snd tw)) CLK j i"
  hence "is_posedge (wline_of tw) CLK j i"
    by auto
  hence "wline_of tw CLK (j - 1) \<noteq> wline_of tw CLK j"
    by simp
  moreover have "(\<forall>s. wline_of tw s j = wline_of tw s (fst tw))"
    using unchanged_until_next_time_world `fst tw = 0` `j < next_time_world tw`
    by (metis less_eq_nat.simps(1))
  ultimately have "False"
    by (metis \<open>j < next_time_world tw\<close> assms le0 less_imp_diff_less unchanged_until_next_time_world)
  thus "wline_of (next_time_world tw, snd tw) OUT (i + 1) = wline_of (next_time_world tw, snd tw) D j"
    by auto
qed

lemma init1:
  "\<turnstile> [\<lambda>tw. get_time tw = 0 \<and> beval_world_raw2 tw (Bsig CLK) (Bv False)]
        Bnull
     [\<lambda>tw. inv (next_time_world tw, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_time_world tw, snd tw)", rotated 1])
    apply (rule Null2)
   apply simp
  using inv_time_seq_next_time0' by auto

lemma init2:
  " \<turnstile> [\<lambda>tw. get_time tw = 0]
        Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull
      [\<lambda>tw. Dflipflop.inv (next_time_world tw, snd tw)]"
  apply (rule If2)
   apply (rule init0)
  apply (rule init1)
  done

lemma init3:
  "init_sim_hoare (\<lambda>tw. get_time tw = 0) dflipflop inv"
  unfolding dflipflop_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule init2)
  done

lemma inv2_holds_initially_assigned:
  assumes "fst tw = 0"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 wline_of tw D (fst tw)]"
  shows "inv2 (next_time_world tw', snd tw')"
  unfolding inv2_def
proof (rule, rule, rule)
  fix i
  assume *: "disjnt {CLK} (event_of (next_time_world tw', snd tw'))
         \<or>  wline_of (next_time_world tw', snd tw') CLK (get_time (next_time_world tw', snd tw')) = Bv False"
  assume "get_time (next_time_world tw', snd tw') \<le> i"
  hence "next_time_world tw' \<le> i"
    by auto
  have "fst tw' < next_time_world tw'"
    using next_time_world_at_least by metis
  hence "0 < next_time_world tw'"
    by linarith
  have "wline_of tw' OUT (i + 1) = wline_of tw D (fst tw)"
    unfolding tw'_def
    by (simp add: assms(1) beval_world_raw2_Bsig worldline_upd2_def worldline_upd_def)
  also have "... = wline_of tw' OUT (fst tw + 1)"
    unfolding tw'_def by (metis worldline_upd2_at_dly)
  also have "... = wline_of tw' OUT (fst tw' + 1)"
    by (simp add: tw'_def worldline_upd2_def)
  finally have **: "wline_of tw' OUT (i + 1) = wline_of tw' OUT (fst tw' + 1)"
    by auto
  have "disjnt {CLK} (event_of (next_time_world tw', snd tw'))  \<or> wline_of tw' CLK (next_time_world tw') = (Bv False)"
    using * by auto
  hence "wline_of tw' OUT (fst tw' + 1) = wline_of tw' OUT (next_time_world tw')"
    by (smt One_nat_def Suc_diff_1 Suc_eq_plus1 \<open>0 < next_time_world tw'\<close> assms(1) diff_add_zero
    less_numeral_extra(3) o_apply plus_1_eq_Suc snd_conv tw'_def worldline_upd2_def
    worldline_upd_def zero_less_diff)
  hence "wline_of tw' OUT (i + 1) = wline_of tw' OUT (next_time_world tw')"
    using ** by auto
  thus "wline_of (next_time_world tw', snd tw') OUT (i + 1) =
        wline_of (next_time_world tw', snd tw') OUT (get_time (next_time_world tw', snd tw'))"
    by auto
qed

lemma init4:
  " \<turnstile> [\<lambda>tw. (get_time tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (get_time tw))) \<and> beval_world_raw2 tw (Bsig CLK) (Bv True)]
        Bassign_trans OUT (Bsig D) 1
      [\<lambda>tw. inv2 (next_time_world tw, snd tw)]"
  apply (rule Assign2_altI)
  using inv2_holds_initially_assigned
  by (metis beval_world_raw2_Bsig beval_world_raw2_def beval_world_raw_deterministic)

lemma inv2_holds_initially:
  assumes "fst tw = 0" and "(\<forall>i. wline_of tw OUT i = wline_of tw OUT (get_time tw))" and "beval_world_raw2 tw (Bsig CLK) (Bv False)"
  shows "inv2 (next_time_world tw, snd tw)"
proof -
  have "inv tw"
    using assms(1) unfolding inv_def by auto
  moreover have "inv2 tw"
    using assms(2)  using inv2_def by blast
  ultimately show ?thesis
    using inv2_next_time_disjnt inv2_next_time_null assms(3)
    by (meson greaterThanAtMost_iff next_time_world_at_least order_refl)
qed

lemma init5:
  " \<turnstile> [\<lambda>tw. (get_time tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (get_time tw))) \<and> beval_world_raw2 tw (Bsig CLK) (Bv False)]
        Bnull
      [\<lambda>tw. inv2 (next_time_world tw, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv2 (next_time_world tw, snd tw)", rotated 1])
    apply (rule Null2)
   apply simp
  using inv2_holds_initially by auto

lemma init6:
  "\<turnstile> [\<lambda>tw. get_time tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (get_time tw))]
        Bguarded (Bsig CLK) (Bassign_trans OUT (Bsig D) 1) Bnull
     [\<lambda>tw. inv2 (next_time_world tw, snd tw)]"
  apply (rule If2)
   apply (rule init4)
  apply (rule init5)
  done

lemma init7:
  "init_sim_hoare (\<lambda>tw. get_time tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (get_time tw))) dflipflop inv2"
  unfolding dflipflop_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule init6)
  done

theorem init8:
  "init_sim_hoare
    (\<lambda>tw. fst tw = 0 \<comment> \<open>initially the time is zero\<close>
        \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (fst tw))) \<comment> \<open>initially no signal shall be posted in the internal signal\<close>
      dflipflop
    (\<lambda>tw. inv tw \<and> inv2 tw)"
  apply (rule ConjI_sim)
   apply (rule ConseqI_sim[where Q="inv" and P="\<lambda>tw. fst tw = 0"])
     apply simp
    apply (rule init3)
   apply simp
  apply (rule init7)
  done

lemma init_sim_hoare_well_typed:
  assumes "conc_wt \<Gamma> dflipflop"
  shows "init_sim_hoare (\<lambda>tw. wityping \<Gamma> (snd tw)) dflipflop (\<lambda>tw. wityping \<Gamma> (snd tw))"
  unfolding dflipflop_def
  apply (rule AssignI)
  apply (rule SingleI)
  unfolding snd_conv
  by (metis assms conc_stmt.distinct(1) conc_stmt.inject(2) conc_wt.cases dflipflop_def
      seq_stmt_preserve_wityping_hoare)

theorem init_sim_hoare_inv_and_well_typed:
  assumes "conc_wt \<Gamma> dflipflop"
  shows
  "init_sim_hoare
    (\<lambda>tw. fst tw = 0 \<comment> \<open>initially the time is zero\<close>
        \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (fst tw)) \<comment> \<open>initially no signal shall be posted in the internal signal\<close>
        \<and> wityping \<Gamma> (snd tw))
      dflipflop
    (\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw))"
  apply (rule ConjI_sim)
   apply (rule strengthen_precondition_init_sim_hoare)
  prefer 2
    apply (rule init8)
   apply blast
  apply (rule ConseqI_sim)
  prefer 2
  apply (rule init_sim_hoare_well_typed[OF assms])
  by blast+

lemma
  assumes "sim_fin w (i + 1) dflipflop tw'"
  assumes "\<forall>i. snd w OUT i = snd w OUT 0"
  assumes " conc_wt \<Gamma> dflipflop" and "wityping \<Gamma> w"
  shows "(\<forall>j \<le> i. is_posedge (wline_of tw') CLK j i \<longrightarrow>  wline_of tw' OUT (i + 1) = wline_of tw' D j)"
proof -
  obtain tw where "init_sim (0, w) dflipflop tw" and  "tw, i + 1, dflipflop \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf dflipflop"
    unfolding conc_stmt_wf_def dflipflop_def by auto
  moreover have "nonneg_delay_conc dflipflop"
    unfolding dflipflop_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> (\<forall>i. wline_of tw OUT i = wline_of tw OUT (fst tw)) \<and> wityping \<Gamma> (snd tw)) dflipflop (\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw))"
    using init_sim_hoare_soundness[OF init_sim_hoare_inv_and_well_typed[OF assms(3)]] by auto
  hence "(inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)"
    using \<open>init_sim (0, w) dflipflop tw\<close> fst_conv assms(2) assms(4) unfolding init_sim_valid_def
    by (metis (mono_tags) comp_apply snd_conv)
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw \<and> wityping \<Gamma> (snd tw)\<rbrace> dflipflop \<lbrace>inv\<rbrace>"
    using conc_sim_soundness[OF simulation_inv] \<open>conc_stmt_wf dflipflop\<close> \<open>nonneg_delay_conc dflipflop\<close>
    assms(3) by blast
  ultimately have "inv tw'"
    using \<open>tw, i + 1, dflipflop \<Rightarrow>\<^sub>S tw'\<close>  unfolding sim_hoare_valid_def
    by blast
  hence "\<forall>i<get_time tw'. \<forall>j\<le>i. is_posedge (wline_of tw') CLK j i \<longrightarrow> wline_of tw' OUT (i + 1) = wline_of tw' D j"
    unfolding inv_def by auto
  with \<open>i + 1 = fst tw'\<close> show ?thesis
    by (smt less_add_one)
qed

end


(*  Title:      ZF/AC/Cardinal_aux.thy
    Author:     Krzysztof Grabczewski

Auxiliary lemmas concerning cardinalities.
*)

theory Cardinal_aux imports AC_Equiv begin

lemma Diff_lepoll: "[| A \<lesssim> succ(m); B \<subseteq> A; B\<noteq>0 |] ==> A-B \<lesssim> m"
apply (rule not_emptyE, assumption)
apply (blast intro: lepoll_trans [OF subset_imp_lepoll Diff_sing_lepoll])
done

(* ********************************************************************** *)
(* Lemmas involving ordinals and cardinalities used in the proofs         *)
(* concerning AC16 and DC                                                 *)
(* ********************************************************************** *)

(* j=|A| *)
lemma lepoll_imp_ex_le_eqpoll:
     "[| A \<lesssim> i; Ord(i) |] ==> \<exists>j. j \<le> i & A \<approx> j"
by (blast intro!: lepoll_cardinal_le well_ord_Memrel
                  well_ord_cardinal_eqpoll [THEN eqpoll_sym]
          dest: lepoll_well_ord)

(* j=|A| *)
lemma lesspoll_imp_ex_lt_eqpoll:
     "[| A \<prec> i; Ord(i) |] ==> \<exists>j. j<i & A \<approx> j"
by (unfold lesspoll_def, blast dest!: lepoll_imp_ex_le_eqpoll elim!: leE)

lemma Un_eqpoll_Inf_Ord:
  assumes A: "A \<approx> i" and B: "B \<approx> i" and NFI: "\<not> Finite(i)" and i: "Ord(i)"
  shows "A \<union> B \<approx> i"
proof (rule eqpollI)
  have AB: "A \<approx> B" using A B by (blast intro: eqpoll_sym eqpoll_trans)
  have "2 \<lesssim> nat"
    by (rule subset_imp_lepoll) (rule OrdmemD [OF nat_2I Ord_nat])
  also have "... \<lesssim> i"
    by (simp add: nat_le_infinite_Ord le_imp_lepoll NFI i)+
  also have "... \<approx> A" by (blast intro: eqpoll_sym A)
  finally have "2 \<lesssim> A" .
  have ICI: "InfCard(|i|)"
    by (simp add: Inf_Card_is_InfCard Finite_cardinal_iff NFI i)
  have "A \<union> B \<lesssim> A + B" by (rule Un_lepoll_sum)
  also have "... \<lesssim> A \<times> B"
    by (rule lepoll_imp_sum_lepoll_prod [OF AB [THEN eqpoll_imp_lepoll] \<open>2 \<lesssim> A\<close>])
  also have "... \<approx> i \<times> i"
    by (blast intro: prod_eqpoll_cong eqpoll_imp_lepoll A B)
  also have "... \<approx> i"
    by (blast intro: well_ord_InfCard_square_eq well_ord_Memrel ICI i)
  finally show "A \<union> B \<lesssim> i" .
next
  have "i \<approx> A" by (blast intro: A eqpoll_sym)
  also have "... \<lesssim> A \<union> B" by (blast intro: subset_imp_lepoll)
  finally show "i \<lesssim> A \<union> B" .
qed

schematic_goal paired_bij: "?f \<in> bij({{y,z}. y \<in> x}, x)"
apply (rule RepFun_bijective)
apply (simp add: doubleton_eq_iff, blast)
done

lemma paired_eqpoll: "{{y,z}. y \<in> x} \<approx> x"
by (unfold eqpoll_def, fast intro!: paired_bij)

lemma ex_eqpoll_disjoint: "\<exists>B. B \<approx> A & B \<inter> C = 0"
by (fast intro!: paired_eqpoll equals0I elim: mem_asym)

(*Finally we reach this result.  Surely there's a simpler proof?*)
lemma Un_lepoll_Inf_Ord:
     "[| A \<lesssim> i; B \<lesssim> i; ~Finite(i); Ord(i) |] ==> A \<union> B \<lesssim> i"
apply (rule_tac A1 = i and C1 = i in ex_eqpoll_disjoint [THEN exE])
apply (erule conjE)
apply (drule lepoll_trans)
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll])
apply (rule Un_lepoll_Un [THEN lepoll_trans], (assumption+))
apply (blast intro: eqpoll_refl Un_eqpoll_Inf_Ord eqpoll_imp_lepoll)
done

lemma Least_in_Ord: "[| P(i); i \<in> j; Ord(j) |] ==> (\<mu> i. P(i)) \<in> j"
apply (erule Least_le [THEN leE])
apply (erule Ord_in_Ord, assumption)
apply (erule ltE)
apply (fast dest: OrdmemD)
apply (erule subst_elem, assumption)
done

lemma Diff_first_lepoll:
     "[| well_ord(x,r); y \<subseteq> x; y \<lesssim> succ(n); n \<in> nat |]
      ==> y - {THE b. first(b,y,r)} \<lesssim> n"
apply (case_tac "y=0", simp add: empty_lepollI)
apply (fast intro!: Diff_sing_lepoll the_first_in)
done

lemma UN_subset_split:
     "(\<Union>x \<in> X. P(x)) \<subseteq> (\<Union>x \<in> X. P(x)-Q(x)) \<union> (\<Union>x \<in> X. Q(x))"
by blast

lemma UN_sing_lepoll: "Ord(a) ==> (\<Union>x \<in> a. {P(x)}) \<lesssim> a"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>z \<in> (\<Union>x \<in> a. {P (x) }) . (\<mu> i. P (i) =z) " in exI)
apply (rule_tac d = "%z. P (z) " in lam_injective)
apply (fast intro!: Least_in_Ord)
apply (fast intro: LeastI elim!: Ord_in_Ord)
done

lemma UN_fun_lepoll_lemma [rule_format]:
     "[| well_ord(T, R); ~Finite(a); Ord(a); n \<in> nat |]
      ==> \<forall>f. (\<forall>b \<in> a. f`b \<lesssim> n & f`b \<subseteq> T) \<longrightarrow> (\<Union>b \<in> a. f`b) \<lesssim> a"
apply (induct_tac "n")
apply (rule allI)
apply (rule impI)
apply (rule_tac b = "\<Union>b \<in> a. f`b" in subst)
apply (rule_tac [2] empty_lepollI)
apply (rule equals0I [symmetric], clarify)
apply (fast dest: lepoll_0_is_0 [THEN subst])
apply (rule allI)
apply (rule impI)
apply (erule_tac x = "\<lambda>x \<in> a. f`x - {THE b. first (b,f`x,R) }" in allE)
apply (erule impE, simp)
apply (fast intro!: Diff_first_lepoll, simp)
apply (rule UN_subset_split [THEN subset_imp_lepoll, THEN lepoll_trans])
apply (fast intro: Un_lepoll_Inf_Ord UN_sing_lepoll)
done

lemma UN_fun_lepoll:
     "[| \<forall>b \<in> a. f`b \<lesssim> n & f`b \<subseteq> T; well_ord(T, R);
         ~Finite(a); Ord(a); n \<in> nat |] ==> (\<Union>b \<in> a. f`b) \<lesssim> a"
by (blast intro: UN_fun_lepoll_lemma)

lemma UN_lepoll:
     "[| \<forall>b \<in> a. F(b) \<lesssim> n & F(b) \<subseteq> T; well_ord(T, R);
         ~Finite(a); Ord(a); n \<in> nat |]
      ==> (\<Union>b \<in> a. F(b)) \<lesssim> a"
apply (rule rev_mp)
apply (rule_tac f="\<lambda>b \<in> a. F (b)" in UN_fun_lepoll)
apply auto
done

lemma UN_eq_UN_Diffs:
     "Ord(a) ==> (\<Union>b \<in> a. F(b)) = (\<Union>b \<in> a. F(b) - (\<Union>c \<in> b. F(c)))"
apply (rule equalityI)
 prefer 2 apply fast
apply (rule subsetI)
apply (erule UN_E)
apply (rule UN_I)
 apply (rule_tac P = "%z. x \<in> F (z) " in Least_in_Ord, (assumption+))
apply (rule DiffI, best intro: Ord_in_Ord LeastI, clarify)
apply (erule_tac P = "%z. x \<in> F (z) " and i = c in less_LeastE)
apply (blast intro: Ord_Least ltI)
done

lemma lepoll_imp_eqpoll_subset:
     "a \<lesssim> X ==> \<exists>Y. Y \<subseteq> X & a \<approx> Y"
apply (unfold lepoll_def eqpoll_def, clarify)
apply (blast intro: restrict_bij
             dest: inj_is_fun [THEN fun_is_rel, THEN image_subset])
done

(* ********************************************************************** *)
(* Diff_lesspoll_eqpoll_Card                                              *)
(* ********************************************************************** *)

lemma Diff_lesspoll_eqpoll_Card_lemma:
     "[| A\<approx>a; ~Finite(a); Card(a); B \<prec> a; A-B \<prec> a |] ==> P"
apply (elim lesspoll_imp_ex_lt_eqpoll [THEN exE] Card_is_Ord conjE)
apply (frule_tac j=xa in Un_upper1_le [OF lt_Ord lt_Ord], assumption)
apply (frule_tac j=xa in Un_upper2_le [OF lt_Ord lt_Ord], assumption)
apply (drule Un_least_lt, assumption)
apply (drule eqpoll_imp_lepoll [THEN lepoll_trans],
       rule le_imp_lepoll, assumption)+
apply (case_tac "Finite(x \<union> xa)")
txt\<open>finite case\<close>
 apply (drule Finite_Un [OF lepoll_Finite lepoll_Finite], assumption+)
 apply (drule subset_Un_Diff [THEN subset_imp_lepoll, THEN lepoll_Finite])
 apply (fast dest: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_Finite])
txt\<open>infinite case\<close>
apply (drule Un_lepoll_Inf_Ord, (assumption+))
apply (blast intro: le_Ord2)
apply (drule lesspoll_trans1
             [OF subset_Un_Diff [THEN subset_imp_lepoll, THEN lepoll_trans]
                 lt_Card_imp_lesspoll], assumption+)
apply (simp add: lesspoll_def)
done

lemma Diff_lesspoll_eqpoll_Card:
     "[| A \<approx> a; ~Finite(a); Card(a); B \<prec> a |] ==> A - B \<approx> a"
apply (rule ccontr)
apply (rule Diff_lesspoll_eqpoll_Card_lemma, (assumption+))
apply (blast intro: lesspoll_def [THEN def_imp_iff, THEN iffD2]
                    subset_imp_lepoll eqpoll_imp_lepoll lepoll_trans)
done

end