section \<open>\isaheader{Red-Black Tree based Maps}\<close>
theory Impl_RBT_Map
imports
  "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 \<open>Standard Setup\<close>

  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, goal_cases)
    case (1 s s' f f' t t') from this(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, goal_cases)
    case (1 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, goal_cases)
    case (1 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, goal_cases)
    case (1 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, goal_cases)
    case (1 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, goal_cases)
    case (1 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: prod.inject)+) []
    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]:
  "((=), (=))\<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' (<)"
  "(rbt_insert,\<lambda>k v m. m(k\<mapsto>v))
    \<in> Id \<rightarrow> Id \<rightarrow> rbt_map_rel' (<) \<rightarrow> rbt_map_rel' (<)"
  "(rbt_lookup,\<lambda>m k. m k) \<in> rbt_map_rel' (<) \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>option_rel"
  "(rbt_delete,\<lambda>k m. m|`(-{k})) \<in> Id \<rightarrow> rbt_map_rel' (<) \<rightarrow> rbt_map_rel' (<)"
  "(rbt_union,(++))
    \<in> rbt_map_rel' (<) \<rightarrow> rbt_map_rel' (<) \<rightarrow> rbt_map_rel' (<)"
  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_wrt_keys_true[simp]: "sorted_wrt (\<lambda>(_,_) (_,_). True) l"
  apply (induct l)
  apply auto
  done

(*
lemma (in linorder) rbt_it_linord_impl:
  "is_map_iterator_linord (rbt_map_rel' (<)) 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_wrt (\<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_wrt_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' (<)) 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_wrt (\<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_wrt_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' (<)) 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 (<)) (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 rev_subsetD)
    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 (<)) (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 rev_subsetD)
    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 (<)) (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 rev_subsetD)
    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 (<)"
  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,(<)) \<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 (<) \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (<)"
  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,(<)) \<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 (<) \<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,(<)) \<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 (<) \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (<)"
  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,(<)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(ord.rbt_union less_impl, (++)) \<in>
    \<langle>Rk,Rv\<rangle>rbt_map_rel (<) \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (<) \<rightarrow> \<langle>Rk,Rv\<rangle>rbt_map_rel (<)"
  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 \<open>A linear ordering on red-black trees\<close>

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 (<) \<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 \<open>Second Part: Binding\<close>
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),(++)) \<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')"
  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_wrt (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_wrt (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 (\<le>) (<), dflt_cmp (\<le>) (<))\<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 (<))"
  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 (\<le>) (<)))"

lemmas [autoref_post_simps] = dflt_cmp_inv2 dflt_cmp_2inv

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

lemma [autoref_post_simps]: "ord.rbt_lookup ((<)::_::linorder\<Rightarrow>_) = rbt_lookup"
  unfolding ord.rbt_lookup_def rbt_lookup_def ..

lemma [simp,autoref_post_simps]:
  "ord.rbt_insert_with_key (<) = rbt_insert_with_key"
  "ord.rbt_insert (<) = 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, (=)) \<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


header "Soundness"

theory Soundness imports Completeness begin

lemma permutation_validS: "fs <~~> gs --> (validS fs = validS gs)"
  apply(simp add: validS_def)
  apply(simp add: evalS_def)
  apply(simp add: perm_set_eq)
  done

lemma modelAssigns_vblcase: "phi \<in> modelAssigns M \<Longrightarrow>  x \<in> objects M \<Longrightarrow> vblcase x phi \<in> modelAssigns M"
  apply (simp add: modelAssigns_def, rule)
  apply(erule_tac rangeE)
  apply(case_tac xaa rule: vbl_casesE, auto)
  done

lemma tmp: "(!x : A. P x | Q) ==> (! x : A. P x) | Q " by blast

lemma soundnessFAll: "!!Gamma.
  [| u ~: freeVarsFL (FAll Pos A # Gamma);
  validS (instanceF u A # Gamma) |]
  ==> validS (FAll Pos A # Gamma)"
  apply (simp add: validS_def, rule)
  apply (drule_tac x=M in spec, rule)
  apply(simp add: evalF_instance)
  apply (rule tmp, rule)
  apply(drule_tac x="% y. if y = u then x else phi y" in bspec)
   apply(simp add: modelAssigns_def) apply force
  apply(erule disjE)
   apply (rule disjI1, simp)
   apply(subgoal_tac "evalF M (vblcase x (\<lambda>y. if y = u then x else phi y)) A = evalF M (vblcase x phi) A")
    apply force
   apply(rule evalF_equiv)
   apply(rule equalOn_vblcaseI)
    apply(rule,rule)
   apply(simp add: freeVarsFL_cons)
   apply (rule equalOnI, force)
  apply(rule disjI2)
  apply(subgoal_tac "evalS M (\<lambda>y. if y = u then x else phi y) Gamma = evalS M phi Gamma")
   apply force
  apply(rule evalS_equiv)
  apply(rule equalOnI)
  apply(force simp: freeVarsFL_cons)
  done

lemma soundnessFEx: "validS (instanceF x A # Gamma) ==> validS (FAll Neg A # Gamma)"
  apply(simp add: validS_def)
  apply (simp add: evalF_instance, rule, rule)
  apply(drule_tac x=M in spec)
  apply (drule_tac x=phi in bspec, assumption)
  apply(erule disjE)
  apply(rule disjI1)
  apply (rule_tac x="phi x" in bexI, assumption)
  apply(force dest: modelAssignsD subsetD)
  apply (rule disjI2, assumption)
  done

lemma soundnessFCut: "[| validS (C # Gamma); validS (FNot C # Delta) |] ==> validS (Gamma @ Delta)"
(*  apply(force simp: validS_def evalS_append evalS_cons evalF_FNot)*)
  apply (simp add: validS_def, rule, rule)
  apply(drule_tac x=M in spec)
  apply(drule_tac x=M in spec)
  apply(drule_tac x=phi in bspec) apply assumption
  apply(drule_tac x=phi in bspec) apply assumption
  apply (simp add: evalS_append evalF_FNot, blast)
  done

lemma completeness: "fs : deductions (PC) = validS fs"
  apply rule
   apply(rule soundness) apply assumption
  apply(subgoal_tac "fs : deductions CutFreePC")
   apply(rule subsetD) prefer 2 apply assumption
   apply(rule mono_deductions)
   apply(simp add: PC_def CutFreePC_def) apply blast
  apply(rule adequacy)
  by assumption

end


(*
 * Copyright 2014, NICTA
 *
 * 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.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   Miscellaneous library definitions and lemmas.
*)

(*chapter "Library"*)

theory Lib
imports Main
begin

lemma hd_map_simp:
  "b \<noteq> [] \<Longrightarrow> hd (map a b) = a (hd b)"
  by (rule hd_map)

lemma Collect_eq:
  "{x. P x} = {x. Q x} \<longleftrightarrow> (\<forall>x. P x = Q x)"
  by (rule iffI) auto

lemma iff_impI: "\<lbrakk>P \<Longrightarrow> Q = R\<rbrakk> \<Longrightarrow> (P \<longrightarrow> Q) = (P \<longrightarrow> R)" by blast

definition
  fun_app :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "$" 10) where
  "f $ x \<equiv> f x"

declare fun_app_def [iff]

lemma fun_app_cong[fundef_cong]:
  "\<lbrakk> f x = f' x' \<rbrakk> \<Longrightarrow> (f $ x) = (f' $ x')"
  by simp

lemma fun_app_apply_cong[fundef_cong]:
  "f x y = f' x' y' \<Longrightarrow> (f $ x) y = (f' $ x') y'"
  by simp

lemma if_apply_cong[fundef_cong]:
  "\<lbrakk> P = P'; x = x'; P' \<Longrightarrow> f x' = f' x'; \<not> P' \<Longrightarrow> g x' = g' x' \<rbrakk>
     \<Longrightarrow> (if P then f else g) x = (if P' then f' else g') x'"
  by simp

abbreviation (input) split :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" where
  "split \<equiv> case_prod"

lemma split_apply_cong[fundef_cong]:
  "\<lbrakk> f (fst p) (snd p) s = f' (fst p') (snd p') s' \<rbrakk> \<Longrightarrow> split f p s = split f' p' s'"
  by (simp add: split_def)

definition
  pred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "and" 35)
where
  "pred_conj P Q \<equiv> \<lambda>x. P x \<and> Q x"

definition
  pred_disj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "or" 30)
where
  "pred_disj P Q \<equiv> \<lambda>x. P x \<or> Q x"

definition
  pred_neg :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" ("not _" [40] 40)
where
  "pred_neg P \<equiv> \<lambda>x. \<not> P x"

definition "K \<equiv> \<lambda>x y. x"

definition
  zipWith :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
  "zipWith f xs ys \<equiv> map (split f) (zip xs ys)"

primrec
  delete :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "delete y [] = []"
| "delete y (x#xs) = (if y=x then xs else x # delete y xs)"

primrec
  find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option"
where
  "find f [] = None"
| "find f (x # xs) = (if f x then Some x else find f xs)"

definition
 "swp f \<equiv> \<lambda>x y. f y x"

primrec (nonexhaustive)
  theRight :: "'a + 'b \<Rightarrow> 'b" where
  "theRight (Inr x) = x"

primrec (nonexhaustive)
  theLeft :: "'a + 'b \<Rightarrow> 'a" where
  "theLeft (Inl x) = x"

definition
 "isLeft x \<equiv> (\<exists>y. x = Inl y)"

definition
 "isRight x \<equiv> (\<exists>y. x = Inr y)"

definition
 "const x \<equiv> \<lambda>y. x"

lemma tranclD2:
  "(x, y) \<in> R\<^sup>+ \<Longrightarrow> \<exists>z. (x, z) \<in> R\<^sup>* \<and> (z, y) \<in> R"
  by (erule tranclE) auto

lemma linorder_min_same1 [simp]:
  "(min y x = y) = (y \<le> (x::'a::linorder))"
  by (auto simp: min_def linorder_not_less)

lemma linorder_min_same2 [simp]:
  "(min x y = y) = (y \<le> (x::'a::linorder))"
  by (auto simp: min_def linorder_not_le)

text \<open>A combinator for pairing up well-formed relations.
        The divisor function splits the population in halves,
        with the True half greater than the False half, and
        the supplied relations control the order within the halves.\<close>

definition
  wf_sum :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
where
  "wf_sum divisor r r' \<equiv>
     ({(x, y). \<not> divisor x \<and> \<not> divisor y} \<inter> r')
   \<union>  {(x, y). \<not> divisor x \<and> divisor y}
   \<union> ({(x, y). divisor x \<and> divisor y} \<inter> r)"

lemma wf_sum_wf:
  "\<lbrakk> wf r; wf r' \<rbrakk> \<Longrightarrow> wf (wf_sum divisor r r')"
  apply (simp add: wf_sum_def)
  apply (rule wf_Un)+
      apply (erule wf_Int2)
     apply (rule wf_subset
             [where r="measure (\<lambda>x. If (divisor x) 1 0)"])
      apply simp
     apply clarsimp
    apply blast
   apply (erule wf_Int2)
  apply blast
  done

abbreviation(input)
 "option_map == map_option"

lemmas option_map_def = map_option_case

lemma False_implies_equals [simp]:
  "((False \<Longrightarrow> P) \<Longrightarrow> PROP Q) \<equiv> PROP Q"
  apply (rule equal_intr_rule)
   apply (erule meta_mp)
   apply simp
  apply simp
  done

lemma split_paired_Ball:
  "(\<forall>x \<in> A. P x) = (\<forall>x y. (x,y) \<in> A \<longrightarrow> P (x,y))"
  by auto

lemma split_paired_Bex:
  "(\<exists>x \<in> A. P x) = (\<exists>x y. (x,y) \<in> A \<and> P (x,y))"
  by auto

end


subsection \<open> Relational Abstraction \<close>

theory ITree_Relation
  imports ITree_Circus
begin

text \<open> The relational abstraction captures the possible return values associated with particular
  inputs to a Kleisli tree. It ignores any visible events and treats them as nondeterminism,
  if present. \<close>

definition itree_pred :: "('e, 'a, 'b) ktree \<Rightarrow> (bool, 'a \<times> 'b) expr" ("\<lbrakk>_\<rbrakk>\<^sub>p") where
"itree_pred P = (\<lambda> (s, s'). s' \<in> \<^bold>R (P s))"

definition itree_rel :: "('e, 'a, 'b) ktree \<Rightarrow> ('a \<times> 'b) set" where
"itree_rel P = Collect (itree_pred P)"

lemmas itree_rel_defs = itree_pred_def itree_rel_def

named_theorems itree_pred and itree_rel

definition spec :: "'s scene \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's rel" where
"spec a pre post = {(s, s'). s \<approx>\<^sub>S s' on (- a) \<and> pre s \<longrightarrow> post s'}"

lemma assume_rel [itree_rel]: "itree_rel (assume P) = {(s, s'). s' = s \<and> P s}"
  apply (auto simp add: itree_rel_defs retvals_def assume_def)
  apply (metis (full_types) Ret_trns diverge_no_Ret_trans itree.inject(1))
  using diverge_no_Ret_trans apply fastforce
  done

lemma test_rel [itree_rel]: "itree_rel (test P) = {(s, s'). s' = s \<and> P s}"
  apply (auto simp add: itree_rel_defs retvals_def test_def)
  apply (metis (full_types) empty_iff insert_iff retvals_Ret retvals_deadlock retvals_traceI)
  using nonterminates_iff apply force
  done

lemma Skip_rel [itree_rel]: "itree_rel Skip = Id"
  by (auto simp add: itree_rel_defs retvals_def Skip_def)

lemma assigns_pred [itree_pred]: "\<lbrakk>\<langle>\<sigma>\<rangle>\<^sub>a\<rbrakk>\<^sub>p (s, s') = (s' = \<sigma> s)"
  by (auto simp add: itree_rel_defs retvals_def assigns_def)

lemma assigns_rel [itree_rel]: "itree_rel \<langle>\<sigma>\<rangle>\<^sub>a = {(s, s'). s' = \<sigma> s}"
  by (simp add: itree_rel_def set_eq_iff assigns_pred)

lemma Div_rel [itree_rel]: "itree_rel Div = {}"
  by (simp add: itree_rel_defs)

lemma Stop_pred [itree_pred]: "\<lbrakk>Stop\<rbrakk>\<^sub>p (s, s') = False"
  by (auto simp add: itree_rel_defs)

lemma Stop_rel [itree_rel]: "itree_rel Stop = {}"
  by (simp add: itree_rel_def set_eq_iff Stop_pred)

lemma seq_pred [itree_pred]: "\<lbrakk>P ;; Q\<rbrakk>\<^sub>p (s, s') = (\<exists> s\<^sub>0.  \<lbrakk>P\<rbrakk>\<^sub>p (s, s\<^sub>0) \<and> \<lbrakk>Q\<rbrakk>\<^sub>p (s\<^sub>0, s'))"
  by (auto simp add: itree_rel_defs seq_itree_def kleisli_comp_def)

lemma seq_rel [itree_rel]: "itree_rel (P ;; Q) = itree_rel P O itree_rel Q"
  by (auto simp add: seq_itree_def kleisli_comp_def itree_rel_defs relcomp_unfold)

lemma cond_pred [itree_pred]:
  "\<lbrakk>cond_itree C\<^sub>1 B C\<^sub>2\<rbrakk>\<^sub>p (s, s') = (if B s then \<lbrakk>C\<^sub>1\<rbrakk>\<^sub>p (s, s') else \<lbrakk>C\<^sub>2\<rbrakk>\<^sub>p (s, s'))"
  by (auto simp add: cond_itree_def itree_rel_defs)

lemma cond_rel [itree_rel]:
  "itree_rel (if B then C\<^sub>1 else C\<^sub>2 fi)
    = {(s\<^sub>1, s\<^sub>2). if (B s\<^sub>1) then (s\<^sub>1, s\<^sub>2) \<in> itree_rel C\<^sub>1 else (s\<^sub>1, s\<^sub>2) \<in> itree_rel C\<^sub>2}"
  by (auto simp add: cond_itree_def itree_rel_defs)

lemma input_in_where_rel [itree_rel]:
  "wb_prism c \<Longrightarrow> itree_rel (input_in_where c A P) = {(s, s'). \<exists> v \<in> A s. fst (P v) s \<and> (s, s') \<in> itree_rel (snd (P v))}"
  by (auto simp add: input_in_where_def itree_rel_defs retvals_inp_in_where)

lemma input_in_pred [itree_pred]:
  "wb_prism c \<Longrightarrow> \<lbrakk>input_in c A P\<rbrakk>\<^sub>p (s, s') = (\<exists> v \<in> A s. \<lbrakk>P v\<rbrakk>\<^sub>p (s, s'))"
  by (auto simp add: input_in_where_def itree_rel_defs retvals_inp_in)

lemma input_in_rel [itree_rel]:
  "wb_prism c \<Longrightarrow> itree_rel (input_in c A P) = {(s, s'). \<exists> v \<in> A s. (s, s') \<in> itree_rel (P v)}"
  by (auto simp add: input_in_where_def itree_rel_defs retvals_inp_in)

lemma input_rel [itree_rel]: "wb_prism c \<Longrightarrow> itree_rel (input c P) = (\<Union> v. itree_rel (P v))"
  by (auto simp add: input_in_rel)

lemma input_in_lit_rel [itree_rel]: "wb_prism c \<Longrightarrow> itree_rel (input_in c (\<guillemotleft>A\<guillemotright>)\<^sub>e P) = (\<Union> v \<in> A. itree_rel (P v))"
  by (auto simp add: input_in_rel)

ML_file \<open>Lens_Rel_Utils.ML\<close>

method rename_rel_alpha_vars = tactic \<open> Lens_Rel_Utils.rename_rel_alpha_vars \<close>

method itree_pred uses add = (expr_simp add: prog_defs itree_pred add; ((rule allI)+)?; rename_rel_alpha_vars)

end


theory Word_Problem
  imports FreeGroupMain Generators Cancellation

begin

section \<open>Word Problem.\<close>

text\<open>reduce xs returns xs with the first instance of an element and its inverse
      occurring next to each other removed.\<close>

fun reduce :: "('a,'b) word \<Rightarrow> ('a,'b) word"
  where
"reduce [] = []"|
"reduce [x] = [x]"|
"reduce (x#y#xs) = (if (x = inverse y)
                           then xs
                           else (x#(reduce (y#xs))))"

text \<open>Some lemmas that required to show that
      if two words iterated by reduce by their length are equal
      then they are related by cancels eq\<close>

lemma cons_reduce:
  assumes "x \<noteq> inverse y"
  shows "reduce (x#y#xs) = (x#(reduce (y#xs)))"
  by (simp add: assms)

lemma cancel_at_cons:
  assumes "i\<ge>0"
      and "(1+i) < length xs"
      and "cancel_at i xs = ys"
    shows "cancel_at (1 + i) (z#xs) = (z#ys)"
proof-
  have "z#(take i xs) = take (1 + i) (z#xs)" using assms(1) assms(2) by auto
  moreover have "drop (i+2) xs = drop (1 + (i+2)) (z#xs)"using assms(1) assms(2) by simp
  ultimately show ?thesis unfolding cancel_at_def by (metis (no_types, lifting) add.commute append_Cons assms(3) cancel_at_def group_cancel.add2)
qed

lemma cancels_to_1_at_cons:
  assumes "i\<ge>0" "(1+i) < length xs"
      and "cancels_to_1_at i xs ys"
    shows "cancels_to_1_at (1 + i) (z#xs) (z#ys)"
  unfolding cancels_to_1_at_def
proof-
  have 1:"0 \<le> (1 + i)" using assms(1) by simp
  moreover have 2: "1 + (1 + i) < length (z # xs)" using assms(2) by auto
  have "(inverse (xs ! i)) = (xs ! (i+1))" using assms(3) by (metis add.commute cancels_to_1_at_def)
  moreover then have 3: "inverse ((z # xs) ! (1 + i)) = (z # xs) ! (1 + (1 + i))" by simp
  have "(ys = cancel_at i xs)" using assms(3)using cancels_to_1_at_def by auto
  moreover then have 4: "z # ys = cancel_at (1 + i) (z # xs)" using cancel_at_cons assms(1) assms(2) by metis
  ultimately show "0 \<le> 1 + i \<and>
    1 + (1 + i) < length (z # xs) \<and>
    inverse ((z # xs) ! (1 + i)) = (z # xs) ! (1 + (1 + i)) \<and>
    z # ys = cancel_at (1 + i) (z # xs)" using "2" "3" by blast
qed

lemma cancels_to_1_cons:
  assumes "cancels_to_1 xs ys"
  shows "cancels_to_1 (z#xs) (z#ys)"
  using assms
  unfolding cancels_to_1_def
proof-
  obtain i where 1:"cancels_to_1_at i xs ys" using assms cancels_to_1_def by auto
  then have "i\<ge>0 \<and> (1+i) < length xs" using cancels_to_1_at_def by auto
  then have "cancels_to_1_at (1 + i) (z#xs) (z#ys)" using 1 cancels_to_1_at_cons by blast
  then show "\<exists>i. cancels_to_1_at i (z # xs) (z # ys)" by auto
qed

lemma cons_cancel_at:
  "cancels_to xs ys \<longrightarrow> cancels_to (x#xs) (x#ys)"
  unfolding cancels_to_def
  apply(rule impI)
proof(induction rule: rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then have "cancels_to_1 b c" by simp
  then have "cancels_to_1 (x#b) (x#c)" by (simp add: cancels_to_1_cons)
  then show ?case using rtrancl_into_rtrancl.IH by auto
qed

lemma cancels_to_reduce:
  "cancels_to xs (reduce xs)"
proof(induction xs rule: reduce.induct)
  case 1
  then have "cancels_to [] []"  unfolding cancels_to_def by simp
  then show ?case by simp
next
  case (2 x)
  then have "cancels_to [x] [x]"  unfolding cancels_to_def by simp
  then show ?case by simp
next
  case (3 x y xs)
  then show ?case
  proof (cases "x = inverse y")
    case True
    have a: "(reduce (x # y # xs)) = xs" using True by simp
    then have 1: "reduce (x # y # xs) = cancel_at 0 (x # y # xs)" by (simp add: cancel_at_def)
    have 2: "(inverse ((x # y # xs) ! 0) = ((x # y # xs) ! (1 + 0)))" using True by (metis inverse_of_inverse nth_Cons_0 nth_Cons_Suc plus_1_eq_Suc)
    have "cancels_to_1_at 0 (x # y # xs) (reduce (x # y # xs))" using cancels_to_1_at_def using "1" "2" by fastforce
    then have "cancels_to_1 (x # y # xs) (reduce (x # y # xs))" using cancels_to_1_def by blast
    then show ?thesis by (simp add: cancels_to_def)
next
  case False
  then have "cancels_to (y # xs) (reduce (y # xs))" by (simp add: "3.IH")
  then have "cancels_to (x # y # xs) (x#(reduce (y # xs)))" by (simp add: cons_cancel_at)
    then show ?thesis using False by (simp add: cons_reduce)
    qed
  qed

lemma iter_cancels_to: "cancels_to xs ((reduce^^n) xs)"
proof(induction n)
  case 0
  have "((reduce^^0) xs) = xs" by simp
  then show ?case unfolding cancels_to_def by simp
next
  case (Suc n)
  then have 1: "cancels_to xs ((reduce^^n) xs)" by auto
  have "((reduce^^(Suc n)) xs) = reduce ((reduce^^n) xs)" by simp
  moreover have "cancels_to ((reduce^^n) xs) (reduce ((reduce^^n) xs))" using cancels_to_reduce by auto
  ultimately have "cancels_to ((reduce^^n) xs) ((reduce^^(Suc n)) xs)" by simp
  then show ?case using 1 unfolding cancels_to_def by auto
qed

lemma cons_reduced:
  assumes "x \<noteq> inverse y"
    shows "reduced (y # xs) \<Longrightarrow> reduced (x#y#xs)"
  using assms
proof-
  assume a: "reduced (y#xs)"
  have "reduced (x#y#xs) = reduced (y#xs)" using assms by simp
  then show ?thesis by (simp add: a)
qed

lemma cons_not_reduced:
  assumes "x \<noteq> inverse y"
    shows "\<not> reduced (x # y # xs) \<Longrightarrow> \<not> reduced (y # xs)"
  using assms
proof-
  assume a: "\<not> reduced (x # y # xs)"
  have "reduced (y # xs) \<Longrightarrow> reduced (x # y # xs)" using assms cons_reduced by simp
  then show ?thesis using a by blast
qed

lemma reduce_minus:
  assumes "\<not> (reduced xs)"
    shows "length (reduce xs) = (length xs) - 2"
  using assms
proof(induction xs rule: reduce.induct)
  case 1
then show ?case by simp
next
  case (2 x)
  then have a: "\<not> reduced [x]" by blast
  have "reduced [x]" by auto
  then show ?case using a by blast
next
case (3 x y xs)
  then show ?case
  proof(cases "x = inverse y")
    case True
    then have "reduce (x # y # xs) = xs" by simp
then show ?thesis by simp
next
  case False
  then have 1: "\<not> reduced (y # xs)" using cons_not_reduced "3.prems" by auto
  then have a: "length (reduce (y # xs)) = length (y # xs) - 2" using "3.IH" False by blast
  have b: "length (y # xs)  = length (x # y # xs) - 1" by auto
  have 2:"reduce (x # y # xs) = x#(reduce (y # xs))" using False by simp
  moreover have "length (x#(reduce (y # xs))) - 1 = length (reduce (y # xs))" by simp
  ultimately have c: "length (reduce (y # xs)) = length (reduce (x # y # xs)) - 1" by simp
  then have " length (reduce (x # y # xs)) - 1 = (length (x # y # xs) - 1) - 2" using a b c by argo
  then have "length (reduce (x # y # xs)) - 1 = length (x # y # xs) - 2 - 1" by simp
  then show ?thesis  by (smt (verit, ccfv_SIG) "1" "2" BNF_Greatest_Fixpoint.length_Cons Suc_1 diff_Suc_1 diff_Suc_eq_diff_pred reduced.elims(3))
  qed
qed

lemma reduced_reduce:
  assumes "reduced xs"
    shows "reduce xs = xs"
  using assms
proof(induction xs rule: reduce.induct)
  case 1
  then have "reduce [] = []" by simp
then show ?case by simp
next
  case (2 x)
  then have "reduce [x] = [x]" by simp
  then show ?case by simp
next
  case (3 x y xs)
  then have 1: "x \<noteq> inverse y" by auto
  then moreover have "reduced (y # xs)" using cons_reduced "3.prems" by simp
  ultimately have "reduce (y # xs) = (y # xs)" using "3.IH" by blast
  then have "x#(reduce (y # xs)) = (x # y # xs)" by simp
  moreover have "reduce (x # y # xs) = (x#reduce (y # xs))" using 1  by simp
  ultimately show ?case by simp
qed

lemma reduced_imp_reduce:
  "reduced xs \<Longrightarrow> reduced (reduce xs)"
proof-
  assume assms: "reduced xs"
  then have "reduce xs = xs" using reduced_reduce by auto
  then show ?thesis using assms by simp
qed

lemma length_reduce:
  "length (reduce xs) \<le> length xs"
proof(induction xs rule: reduce.induct)
case 1
  then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 x y xs)
  then show ?case
  proof(cases "x = inverse y")
    case True
    then show ?thesis using 3 by force
  next
    case False
    then show ?thesis using 3 by auto
 qed
qed

lemma length_reduce_iter:
  "length ((reduce^^n) xs) \<le> length xs"
proof(induction n)
  case 0
  then have "((reduce^^0) xs) = xs" by simp
  then show ?case by simp
next
  case (Suc n)
  have "reduce ((reduce^^n) xs) = ((reduce^^(Suc n)) xs)" by simp
  moreover have "length (reduce ((reduce^^n) xs)) \<le> length ((reduce^^n) xs)" using length_reduce by fast
 ultimately have "length (reduce ((reduce^^n) xs)) \<le> length ((reduce^^n) xs)" by simp
  then show ?case using Suc.IH by simp
qed

lemma reduce_iter_minus:
  assumes "\<not> reduced ((reduce^^n) xs)"
    shows "length ((reduce^^n) xs) = length xs - (2*n)"
  using assms
proof(induction n)
  case 0
  have 1: "length xs - 2 * 0 = length xs" by simp
  have 2: "((reduce^^0) xs) = xs" by simp
  then show ?case using 1 2 by simp
next
  case (Suc n)
  then have "\<not> reduced ((reduce^^(Suc n)) xs)" by simp
  moreover have b: "((reduce^^(Suc n)) xs) = reduce ((reduce^^n) xs)" by simp
  ultimately have a: "\<not> reduced ((reduce^^n) xs)" using reduced_imp_reduce by auto
  then have " length ((reduce^^n) xs) = length xs - (2 * n)" using Suc.IH by auto
  then have c: "length ((reduce^^n) xs) - 2 = length xs - (2 * n) - 2" by simp
  have "length ((reduce^^n) xs) - 2 = length ((reduce^^(Suc n)) xs)" using a b reduce_minus by (simp add: reduce_minus)
  moreover have "length xs - (2 * n) - 2 = length xs - (2 * Suc n)" by simp
  ultimately show ?case using c  by presburger
qed

lemma
  assumes "\<not> reduced xs"
    shows "length (reduce xs) < length xs"
  using assms
proof(induction xs rule:reduce.induct)
  case 1
  then have "reduced []" by simp
  then show ?case using "1.prems" by simp
next
  case (2 x)
  then have "reduced [x]" by simp
  then show ?case using "2.prems" by simp
next
  case (3 x y xs)
  have "length (x # y # xs) > 0" by simp
  then show ?case using reduce_minus "3.prems" by force
qed

lemma not_reduced_iter:
  assumes "reduced ((reduce^^n) xs)"
    shows "reduced ((reduce^^(n+1)) xs)"
  using assms
proof-
  have "((reduce^^(n+1)) xs) = reduce ((reduce^^n) xs)" by simp
  then show ?thesis by (simp add: reduced_imp_reduce assms)
qed

lemma reduced_iter_suc:
  assumes "reduced ((reduce^^n) xs)"
    shows "reduced ((reduce^^(n+k)) xs)"
  using assms
proof(induction k)
case 0
then show ?case by simp
next
  case (Suc k)
  then have "reduced ((reduce^^(n + k)) xs)" by simp
  then show ?case using  reduced_imp_reduce by auto
qed

lemma not_reduced_iter_suc:
  assumes "\<not> reduced ((reduce^^n) xs)" "(k::nat) \<le> n"
    shows "\<not> reduced ((reduce^^k) xs)"
proof-
  show ?thesis using reduced_iter_suc  using assms(1) assms(2) le_Suc_ex by blast
qed

lemma reduced_iter_length:
  "reduced ((reduce^^(length xs)) xs)"
proof(induction xs)
  case Nil
then have "((reduce^^(length [])) []) = []" by simp
  then show ?case by simp
next
  case (Cons a xs)
  have 2: "(((length (a#xs) div 2 + 1))* 2) \<ge> length (a#xs)" by (simp add: nonzero_mult_div_cancel_right)
  have "length (a # xs) > 0" by simp
  then have 1:"length (a # xs) div 2 + 1 \<le> length (a#xs)" by (meson discrete div_less_dividend one_less_numeral_iff semiring_norm(76))
  then show ?case
  proof(cases "\<not>reduced ((reduce^^(length (a # xs))) (a # xs))")
    case True
  then have a: "\<not>reduced ((reduce^^(length (a # xs))) (a # xs))" by simp
  then have cont:"\<not>reduced ((reduce^^(length (a # xs) div 2 + 1)) (a # xs))"
    using not_reduced_iter_suc 1 by blast
  then have "length ((reduce^^(length (a # xs) div 2 + 1)) (a # xs)) = length (a#xs) - (((length (a#xs) div 2 + 1))* 2)" using reduce_iter_minus by (metis mult.commute)
  then have "length ((reduce^^(length (a # xs) div 2 + 1)) (a # xs)) = 0" using "2" diff_is_0_eq by presburger
  then have "((reduce^^(length (a # xs) div 2 + 1)) (a # xs)) = []" by simp
  then have "reduced ((reduce^^(length (a # xs) div 2 + 1)) (a # xs))" by simp
   then show ?thesis using cont by blast
  next
    case False
    then show ?thesis by simp
  qed
qed

text \<open>Now we show that cancels eq xs ys is equivalent to applying reduce iteratively
      on xs and ys, and also relating them to equivalence relation.\<close>

lemma iter_imp_cancels:
  assumes "(reduce^^(length xs)) xs = (reduce^^(length ys)) ys"
    shows "cancels_eq xs ys"
proof-
  have "cancels_to xs ((reduce^^(length xs)) xs)" using iter_cancels_to by auto
  then have a: "cancels_eq  xs ((reduce^^(length xs)) xs)" unfolding cancels_eq_def by blast
  have "cancels_to ys ((reduce^^(length ys)) ys)" using iter_cancels_to by auto
  then have b: "cancels_eq ((reduce^^(length ys)) ys) ys" unfolding cancels_eq_def by blast
  then show ?thesis using a b unfolding cancels_eq_def using assms by auto
qed

lemma cancels_imp_iter:
  assumes "cancels_eq xs ys"
    shows "(reduce^^(length xs)) xs = (reduce^^(length ys)) ys"
proof-
  have "cancels_to xs ((reduce^^(length xs)) xs)" using iter_cancels_to by auto
  then have "cancels_eq  ((reduce^^(length xs)) xs) xs" unfolding cancels_eq_def by blast
  then have a: "cancels_eq ((reduce^^(length xs)) xs) ys" using assms unfolding cancels_eq_def by auto
  have "cancels_to ys ((reduce^^(length ys)) ys)" using iter_cancels_to by auto
  then have b: "cancels_eq ys ((reduce^^(length ys)) ys)" unfolding cancels_eq_def by blast
  have rel: "cancels_eq ((reduce^^(length xs)) xs)  ((reduce^^(length ys)) ys)"  using a b
    unfolding cancels_eq_def by auto
  have x: "reduced ((reduce^^(length xs)) xs)" using reduced_iter_length by blast
  have y:  "reduced ((reduce^^(length ys)) ys)" using reduced_iter_length by blast
  then show ?thesis using rel x y reduced_cancel_eq by blast
qed

lemma cancels_eq_imp_reln:
  "cancels_eq xs ys \<Longrightarrow> xs ~ ys"
  unfolding cancels_eq_def
  using cancels_imp_iter[of "xs" "ys"] iter_cancels_to[of "xs" "length xs"] cancels_imp_rel[of "xs" "ys"]
  by (metis cancels_eq_def cancels_imp_rel iter_cancels_to reln.sym reln.trans)

text\<open>Here, we prove some lemmas about reln and free group elements needed to
     give a solution to the word problem.\<close>

lemma word_problem_not_eq:
  assumes "xs \<in> \<langle>S\<rangle>"
      and "ys \<in> \<langle>S\<rangle>"
      and "\<not> (xs ~ ys)"
    shows "reln_tuple \<langle>S\<rangle> `` {xs} \<noteq> reln_tuple \<langle>S\<rangle> `` {ys} "
  using assms unfolding reln_tuple_def by blast

lemma word_problem_not_eq_id:
  assumes "xs \<in> \<langle>S\<rangle>"
    and "\<not> (xs ~ [])"
  shows "reln_tuple \<langle>S\<rangle> `` {xs} \<noteq> \<one>\<^bsub>(freegroup S)\<^esub> "
  using assms word_problem_not_eq[of "xs" ]
  by (metis freegroup_def freewords_on_def monoid.select_convs(2) words_on.intros(1))

lemma
  assumes "xs \<in> \<langle>S\<rangle>" "ys \<in> \<langle>S\<rangle>"
    shows "reln_tuple \<langle>S\<rangle> `` {xs @ ys} = reln_tuple \<langle>S\<rangle> `` {xs} \<otimes>\<^bsub>freegroup S\<^esub> reln_tuple \<langle>S\<rangle> `` {ys}"
  using assms proj_append_wd[OF assms]
  by (simp add: freegroup_def)

lemma reln_tuple_eq:
  assumes "xs \<in> \<langle>S\<rangle>"
  shows "reln_tuple \<langle>S\<rangle> `` {xs} = monoid.m_concat (freegroup S)  (map (\<lambda>ys. (reln_tuple \<langle>S\<rangle> `` {[ys]})) xs)"
  using assms
proof(induction xs)
  case (Cons a xs)
  let ?l =  "monoid.m_concat (freegroup S)  (map (\<lambda>ys. (reln_tuple \<langle>S\<rangle> `` {[ys]})) (xs))"
  have "[a] \<in> \<langle>S\<rangle>"
    using cons_span Cons freewords_on_def by blast
  have " (\<lambda>ys. (reln_tuple \<langle>S\<rangle> `` {[ys]})) a = reln_tuple \<langle>S\<rangle> `` {[a]}" by simp
  have "monoid.m_concat (freegroup S)  (map (\<lambda>ys. (reln_tuple \<langle>S\<rangle> `` {[ys]})) (a#xs))
            =   reln_tuple \<langle>S\<rangle> `` {[a]} \<otimes>\<^bsub>freegroup S\<^esub> ?l"
    by simp
  moreover have "reln_tuple \<langle>S\<rangle> `` {xs} = ?l" using Cons
    using freewords_on_def span_cons by blast
  ultimately have 1:"monoid.m_concat (freegroup S)  (map (\<lambda>ys. (reln_tuple \<langle>S\<rangle> `` {[ys]})) (a#xs))
          = (reln_tuple \<langle>S\<rangle> `` {[a]}) \<otimes>\<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {xs})"
    by argo
  hence 2:"... =  (reln_tuple \<langle>S\<rangle> `` {[a]@xs})" using proj_append_wd Cons freegroup_def
    by (metis \<open>[a] \<in> \<langle>S\<rangle>\<close> freewords_on_def monoid.select_convs(1) span_cons)
  hence 3:"... = (reln_tuple \<langle>S\<rangle> `` {a#xs})" by auto
  then show ?case using 1 2 by argo
qed(simp add: freegroup_def)

text\<open>We use the lemmas equating the different relations
      and those shown above to give a solution to the word problem. The following
lemma is a formal statement of the word problem\<close>

theorem word_problem_eq:
  assumes "xs \<in> \<langle>S\<rangle>" "ys \<in> \<langle>S\<rangle>"
    shows "(reln_tuple \<langle>S\<rangle> `` {xs}) = (reln_tuple \<langle>S\<rangle> `` {ys})
          \<longleftrightarrow> (reduce^^(length xs)) xs = (reduce^^(length ys)) ys"
proof
  assume "reln_tuple \<langle>S\<rangle> `` {xs} = reln_tuple \<langle>S\<rangle> `` {ys}"
  hence "xs ~ ys" using assms
    by (meson word_problem_not_eq)
  hence "cancels_eq xs ys" using assms reln_imp_cancels by blast
  thus "(reduce^^(length xs)) xs = (reduce^^(length ys)) ys" using cancels_imp_iter[of xs ys] by argo
next
  assume "(reduce^^(length xs)) xs = (reduce^^(length ys)) ys"
  hence "cancels_eq xs ys" using iter_imp_cancels[of xs ys] by argo
  hence "xs ~ ys" using assms
    by (simp add: cancels_eq_imp_reln)
  thus "(reln_tuple \<langle>S\<rangle> `` {xs}) = (reln_tuple \<langle>S\<rangle> `` {ys})" using assms
    by (metis (mono_tags, lifting) case_prodI equiv_class_eq mem_Collect_eq reln_equiv reln_tuple_def)
qed

text \<open>Some of the trivial consequences of the word problem are below \<close>

lemma word_problem_neq:
  assumes "xs \<in> \<langle>S\<rangle>"
      and "(reln_tuple \<langle>S\<rangle> `` {xs}) \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
    shows "(reduce^^(length xs)) xs \<noteq> []"
  using word_problem_eq assms freegroup_def freewords_on_def
  by (metis bot.extremum_uniqueI le0 length_greater_0_conv length_reduce_iter list.size(3) monoid.select_convs(2) words_on.empty)

lemma word_problem_notrel:
  assumes "xs \<in> \<langle>S\<rangle>"
      and "(reln_tuple \<langle>S\<rangle> `` {xs}) \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
    shows "\<not> ((reduce^^(length xs)) xs ~ [])"
  using  assms word_problem_neq
    reduced.simps(1) reduced_cancel_eq reduced_iter_length reln_imp_cancels by metis

lemma "xs ~ (reduce^^(length xs)) xs"
  by (simp add: cancels_imp_rel iter_cancels_to)

definition normal_form::"('a,'b) word \<Rightarrow> ('a,'b) word"
  where
"normal_form xs = ((reduce^^(length xs)) xs)"

export_code normal_form in Haskell
module_name WP file_prefix Wp

end


(*  Title:      ZF/Constructible/AC_in_L.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {* The Axiom of Choice Holds in L! *}

theory AC_in_L imports Formula Separation begin

subsection{*Extending a Wellordering over a List -- Lexicographic Power*}

text{*This could be moved into a library.*}

consts
  rlist   :: "[i,i]=>i"

inductive
  domains "rlist(A,r)" \<subseteq> "list(A) * list(A)"
  intros
    shorterI:
      "[| length(l') < length(l); l' \<in> list(A); l \<in> list(A) |]
       ==> <l', l> \<in> rlist(A,r)"

    sameI:
      "[| <l',l> \<in> rlist(A,r); a \<in> A |]
       ==> <Cons(a,l'), Cons(a,l)> \<in> rlist(A,r)"

    diffI:
      "[| length(l') = length(l); <a',a> \<in> r;
          l' \<in> list(A); l \<in> list(A); a' \<in> A; a \<in> A |]
       ==> <Cons(a',l'), Cons(a,l)> \<in> rlist(A,r)"
  type_intros list.intros

subsubsection{*Type checking*}

lemmas rlist_type = rlist.dom_subset

lemmas field_rlist = rlist_type [THEN field_rel_subset]

subsubsection{*Linearity*}

lemma rlist_Nil_Cons [intro]:
    "[|a \<in> A; l \<in> list(A)|] ==> <[], Cons(a,l)> \<in> rlist(A, r)"
by (simp add: shorterI)

lemma linear_rlist:
  assumes r: "linear(A,r)" shows "linear(list(A),rlist(A,r))"
proof -
  { fix xs ys
    have "xs \<in> list(A) \<Longrightarrow> ys \<in> list(A) \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> rlist(A,r) \<or> xs = ys \<or> \<langle>ys,xs\<rangle> \<in> rlist(A, r) "
    proof (induct xs arbitrary: ys rule: list.induct)
      case Nil
      thus ?case by (induct ys rule: list.induct) (auto simp add: shorterI)
    next
      case (Cons x xs)
      { fix y ys
        assume "y \<in> A" and "ys \<in> list(A)"
        with Cons
        have "\<langle>Cons(x,xs),Cons(y,ys)\<rangle> \<in> rlist(A,r) \<or> x=y & xs = ys \<or> \<langle>Cons(y,ys), Cons(x,xs)\<rangle> \<in> rlist(A,r)"
          apply (rule_tac i = "length(xs)" and j = "length(ys)" in Ord_linear_lt)
          apply (simp_all add: shorterI)
          apply (rule linearE [OF r, of x y])
          apply (auto simp add: diffI intro: sameI)
          done
      }
      note yConsCase = this
      show ?case using `ys \<in> list(A)`
        by (cases rule: list.cases) (simp_all add: Cons rlist_Nil_Cons yConsCase)
    qed
  }
  thus ?thesis by (simp add: linear_def)
qed

subsubsection{*Well-foundedness*}

text{*Nothing preceeds Nil in this ordering.*}
inductive_cases rlist_NilE: " <l,[]> \<in> rlist(A,r)"

inductive_cases rlist_ConsE: " <l', Cons(x,l)> \<in> rlist(A,r)"

lemma not_rlist_Nil [simp]: " <l,[]> \<notin> rlist(A,r)"
by (blast intro: elim: rlist_NilE)

lemma rlist_imp_length_le: "<l',l> \<in> rlist(A,r) ==> length(l') \<le> length(l)"
apply (erule rlist.induct)
apply (simp_all add: leI)
done

lemma wf_on_rlist_n:
  "[| n \<in> nat; wf[A](r) |] ==> wf[{l \<in> list(A). length(l) = n}](rlist(A,r))"
apply (induct_tac n)
 apply (rule wf_onI2, simp)
apply (rule wf_onI2, clarify)
apply (erule_tac a=y in list.cases, clarify)
 apply (simp (no_asm_use))
apply clarify
apply (simp (no_asm_use))
apply (subgoal_tac "\<forall>l2 \<in> list(A). length(l2) = x \<longrightarrow> Cons(a,l2) \<in> B", blast)
apply (erule_tac a=a in wf_on_induct, assumption)
apply (rule ballI)
apply (rule impI)
apply (erule_tac a=l2 in wf_on_induct, blast, clarify)
apply (rename_tac a' l2 l')
apply (drule_tac x="Cons(a',l')" in bspec, typecheck)
apply simp
apply (erule mp, clarify)
apply (erule rlist_ConsE, auto)
done

lemma list_eq_UN_length: "list(A) = (\<Union>n\<in>nat. {l \<in> list(A). length(l) = n})"
by (blast intro: length_type)

lemma wf_on_rlist: "wf[A](r) ==> wf[list(A)](rlist(A,r))"
apply (subst list_eq_UN_length)
apply (rule wf_on_Union)
  apply (rule wf_imp_wf_on [OF wf_Memrel [of nat]])
 apply (simp add: wf_on_rlist_n)
apply (frule rlist_type [THEN subsetD])
apply (simp add: length_type)
apply (drule rlist_imp_length_le)
apply (erule leE)
apply (simp_all add: lt_def)
done

lemma wf_rlist: "wf(r) ==> wf(rlist(field(r),r))"
apply (simp add: wf_iff_wf_on_field)
apply (rule wf_on_subset_A [OF _ field_rlist])
apply (blast intro: wf_on_rlist)
done

lemma well_ord_rlist:
     "well_ord(A,r) ==> well_ord(list(A), rlist(A,r))"
apply (rule well_ordI)
apply (simp add: well_ord_def wf_on_rlist)
apply (simp add: well_ord_def tot_ord_def linear_rlist)
done

subsection{*An Injection from Formulas into the Natural Numbers*}

text{*There is a well-known bijection between @{term "nat*nat"} and @{term
nat} given by the expression f(m,n) = triangle(m+n) + m, where triangle(k)
enumerates the triangular numbers and can be defined by triangle(0)=0,
triangle(succ(k)) = succ(k + triangle(k)).  Some small amount of effort is
needed to show that f is a bijection.  We already know that such a bijection exists by the theorem @{text well_ord_InfCard_square_eq}:
@{thm[display] well_ord_InfCard_square_eq[no_vars]}

However, this result merely states that there is a bijection between the two
sets.  It provides no means of naming a specific bijection.  Therefore, we
conduct the proofs under the assumption that a bijection exists.  The simplest
way to organize this is to use a locale.*}

text{*Locale for any arbitrary injection between @{term "nat*nat"}
      and @{term nat}*}
locale Nat_Times_Nat =
  fixes fn
  assumes fn_inj: "fn \<in> inj(nat*nat, nat)"

consts   enum :: "[i,i]=>i"
primrec
  "enum(f, Member(x,y)) = f ` <0, f ` <x,y>>"
  "enum(f, Equal(x,y)) = f ` <1, f ` <x,y>>"
  "enum(f, Nand(p,q)) = f ` <2, f ` <enum(f,p), enum(f,q)>>"
  "enum(f, Forall(p)) = f ` <succ(2), enum(f,p)>"

lemma (in Nat_Times_Nat) fn_type [TC,simp]:
    "[|x \<in> nat; y \<in> nat|] ==> fn`<x,y> \<in> nat"
by (blast intro: inj_is_fun [OF fn_inj] apply_funtype)

lemma (in Nat_Times_Nat) fn_iff:
    "[|x \<in> nat; y \<in> nat; u \<in> nat; v \<in> nat|]
     ==> (fn`<x,y> = fn`<u,v>) \<longleftrightarrow> (x=u & y=v)"
by (blast dest: inj_apply_equality [OF fn_inj])

lemma (in Nat_Times_Nat) enum_type [TC,simp]:
    "p \<in> formula ==> enum(fn,p) \<in> nat"
by (induct_tac p, simp_all)

lemma (in Nat_Times_Nat) enum_inject [rule_format]:
    "p \<in> formula ==> \<forall>q\<in>formula. enum(fn,p) = enum(fn,q) \<longrightarrow> p=q"
apply (induct_tac p, simp_all)
   apply (rule ballI)
   apply (erule formula.cases)
   apply (simp_all add: fn_iff)
  apply (rule ballI)
  apply (erule formula.cases)
  apply (simp_all add: fn_iff)
 apply (rule ballI)
 apply (erule_tac a=qa in formula.cases)
 apply (simp_all add: fn_iff)
 apply blast
apply (rule ballI)
apply (erule_tac a=q in formula.cases)
apply (simp_all add: fn_iff, blast)
done

lemma (in Nat_Times_Nat) inj_formula_nat:
    "(\<lambda>p \<in> formula. enum(fn,p)) \<in> inj(formula, nat)"
apply (simp add: inj_def lam_type)
apply (blast intro: enum_inject)
done

lemma (in Nat_Times_Nat) well_ord_formula:
    "well_ord(formula, measure(formula, enum(fn)))"
apply (rule well_ord_measure, simp)
apply (blast intro: enum_inject)
done

lemmas nat_times_nat_lepoll_nat =
    InfCard_nat [THEN InfCard_square_eqpoll, THEN eqpoll_imp_lepoll]

text{*Not needed--but interesting?*}
theorem formula_lepoll_nat: "formula \<lesssim> nat"
apply (insert nat_times_nat_lepoll_nat)
apply (unfold lepoll_def)
apply (blast intro: Nat_Times_Nat.inj_formula_nat Nat_Times_Nat.intro)
done

subsection{*Defining the Wellordering on @{term "DPow(A)"}*}

text{*The objective is to build a wellordering on @{term "DPow(A)"} from a
given one on @{term A}.  We first introduce wellorderings for environments,
which are lists built over @{term "A"}.  We combine it with the enumeration of
formulas.  The order type of the resulting wellordering gives us a map from
(environment, formula) pairs into the ordinals.  For each member of @{term
"DPow(A)"}, we take the minimum such ordinal.*}

definition
  env_form_r :: "[i,i,i]=>i" where
    --{*wellordering on (environment, formula) pairs*}
   "env_form_r(f,r,A) ==
      rmult(list(A), rlist(A, r),
            formula, measure(formula, enum(f)))"

definition
  env_form_map :: "[i,i,i,i]=>i" where
    --{*map from (environment, formula) pairs to ordinals*}
   "env_form_map(f,r,A,z)
      == ordermap(list(A) * formula, env_form_r(f,r,A)) ` z"

definition
  DPow_ord :: "[i,i,i,i,i]=>o" where
    --{*predicate that holds if @{term k} is a valid index for @{term X}*}
   "DPow_ord(f,r,A,X,k) ==
           \<exists>env \<in> list(A). \<exists>p \<in> formula.
             arity(p) \<le> succ(length(env)) &
             X = {x\<in>A. sats(A, p, Cons(x,env))} &
             env_form_map(f,r,A,<env,p>) = k"

definition
  DPow_least :: "[i,i,i,i]=>i" where
    --{*function yielding the smallest index for @{term X}*}
   "DPow_least(f,r,A,X) == \<mu> k. DPow_ord(f,r,A,X,k)"

definition
  DPow_r :: "[i,i,i]=>i" where
    --{*a wellordering on @{term "DPow(A)"}*}
   "DPow_r(f,r,A) == measure(DPow(A), DPow_least(f,r,A))"

lemma (in Nat_Times_Nat) well_ord_env_form_r:
    "well_ord(A,r)
     ==> well_ord(list(A) * formula, env_form_r(fn,r,A))"
by (simp add: env_form_r_def well_ord_rmult well_ord_rlist well_ord_formula)

lemma (in Nat_Times_Nat) Ord_env_form_map:
    "[|well_ord(A,r); z \<in> list(A) * formula|]
     ==> Ord(env_form_map(fn,r,A,z))"
by (simp add: env_form_map_def Ord_ordermap well_ord_env_form_r)

lemma DPow_imp_ex_DPow_ord:
    "X \<in> DPow(A) ==> \<exists>k. DPow_ord(fn,r,A,X,k)"
apply (simp add: DPow_ord_def)
apply (blast dest!: DPowD)
done

lemma (in Nat_Times_Nat) DPow_ord_imp_Ord:
     "[|DPow_ord(fn,r,A,X,k); well_ord(A,r)|] ==> Ord(k)"
apply (simp add: DPow_ord_def, clarify)
apply (simp add: Ord_env_form_map)
done

lemma (in Nat_Times_Nat) DPow_imp_DPow_least:
    "[|X \<in> DPow(A); well_ord(A,r)|]
     ==> DPow_ord(fn, r, A, X, DPow_least(fn,r,A,X))"
apply (simp add: DPow_least_def)
apply (blast dest: DPow_imp_ex_DPow_ord intro: DPow_ord_imp_Ord LeastI)
done

lemma (in Nat_Times_Nat) env_form_map_inject:
    "[|env_form_map(fn,r,A,u) = env_form_map(fn,r,A,v); well_ord(A,r);
       u \<in> list(A) * formula;  v \<in> list(A) * formula|]
     ==> u=v"
apply (simp add: env_form_map_def)
apply (rule inj_apply_equality [OF bij_is_inj, OF ordermap_bij,
                                OF well_ord_env_form_r], assumption+)
done

lemma (in Nat_Times_Nat) DPow_ord_unique:
    "[|DPow_ord(fn,r,A,X,k); DPow_ord(fn,r,A,Y,k); well_ord(A,r)|]
     ==> X=Y"
apply (simp add: DPow_ord_def, clarify)
apply (drule env_form_map_inject, auto)
done

lemma (in Nat_Times_Nat) well_ord_DPow_r:
    "well_ord(A,r) ==> well_ord(DPow(A), DPow_r(fn,r,A))"
apply (simp add: DPow_r_def)
apply (rule well_ord_measure)
 apply (simp add: DPow_least_def Ord_Least)
apply (drule DPow_imp_DPow_least, assumption)+
apply simp
apply (blast intro: DPow_ord_unique)
done

lemma (in Nat_Times_Nat) DPow_r_type:
    "DPow_r(fn,r,A) \<subseteq> DPow(A) * DPow(A)"
by (simp add: DPow_r_def measure_def, blast)

subsection{*Limit Construction for Well-Orderings*}

text{*Now we work towards the transfinite definition of wellorderings for
@{term "Lset(i)"}.  We assume as an inductive hypothesis that there is a family
of wellorderings for smaller ordinals.*}

definition
  rlimit :: "[i,i=>i]=>i" where
  --{*Expresses the wellordering at limit ordinals.  The conditional
      lets us remove the premise @{term "Limit(i)"} from some theorems.*}
    "rlimit(i,r) ==
       if Limit(i) then
         {z: Lset(i) * Lset(i).
          \<exists>x' x. z = <x',x> &
                 (lrank(x') < lrank(x) |
                  (lrank(x') = lrank(x) & <x',x> \<in> r(succ(lrank(x)))))}
       else 0"

definition
  Lset_new :: "i=>i" where
  --{*This constant denotes the set of elements introduced at level
      @{term "succ(i)"}*}
    "Lset_new(i) == {x \<in> Lset(succ(i)). lrank(x) = i}"

lemma Limit_Lset_eq2:
    "Limit(i) ==> Lset(i) = (\<Union>j\<in>i. Lset_new(j))"
apply (simp add: Limit_Lset_eq)
apply (rule equalityI)
 apply safe
 apply (subgoal_tac "Ord(y)")
  prefer 2 apply (blast intro: Ord_in_Ord Limit_is_Ord)
 apply (simp_all add: Limit_is_Ord Lset_iff_lrank_lt Lset_new_def
                      Ord_mem_iff_lt)
 apply (blast intro: lt_trans)
apply (rule_tac x = "succ(lrank(x))" in bexI)
 apply (simp add: Lset_succ_lrank_iff)
apply (blast intro: Limit_has_succ ltD)
done

lemma wf_on_Lset:
    "wf[Lset(succ(j))](r(succ(j))) ==> wf[Lset_new(j)](rlimit(i,r))"
apply (simp add: wf_on_def Lset_new_def)
apply (erule wf_subset)
apply (simp add: rlimit_def, force)
done

lemma wf_on_rlimit:
    "(\<forall>j<i. wf[Lset(j)](r(j))) ==> wf[Lset(i)](rlimit(i,r))"
apply (case_tac "Limit(i)")
 prefer 2
 apply (simp add: rlimit_def wf_on_any_0)
apply (simp add: Limit_Lset_eq2)
apply (rule wf_on_Union)
  apply (rule wf_imp_wf_on [OF wf_Memrel [of i]])
 apply (blast intro: wf_on_Lset Limit_has_succ Limit_is_Ord ltI)
apply (force simp add: rlimit_def Limit_is_Ord Lset_iff_lrank_lt Lset_new_def
                       Ord_mem_iff_lt)
done

lemma linear_rlimit:
    "[|Limit(i); \<forall>j<i. linear(Lset(j), r(j)) |]
     ==> linear(Lset(i), rlimit(i,r))"
apply (frule Limit_is_Ord)
apply (simp add: Limit_Lset_eq2 Lset_new_def)
apply (simp add: linear_def rlimit_def Ball_def lt_Ord Lset_iff_lrank_lt)
apply (simp add: ltI, clarify)
apply (rename_tac u v)
apply (rule_tac i="lrank(u)" and j="lrank(v)" in Ord_linear_lt, simp_all)
apply (drule_tac x="succ(lrank(u) \<union> lrank(v))" in ospec)
 apply (simp add: ltI)
apply (drule_tac x=u in spec, simp)
apply (drule_tac x=v in spec, simp)
done

lemma well_ord_rlimit:
    "[|Limit(i); \<forall>j<i. well_ord(Lset(j), r(j)) |]
     ==> well_ord(Lset(i), rlimit(i,r))"
by (blast intro: well_ordI wf_on_rlimit well_ord_is_wf
                           linear_rlimit well_ord_is_linear)

lemma rlimit_cong:
     "(!!j. j<i ==> r'(j) = r(j)) ==> rlimit(i,r) = rlimit(i,r')"
apply (simp add: rlimit_def, clarify)
apply (rule refl iff_refl Collect_cong ex_cong conj_cong)+
apply (simp add: Limit_is_Ord Lset_lrank_lt)
done

subsection{*Transfinite Definition of the Wellordering on @{term "L"}*}

definition
  L_r :: "[i, i] => i" where
  "L_r(f) == %i.
      transrec3(i, 0, \<lambda>x r. DPow_r(f, r, Lset(x)),
                \<lambda>x r. rlimit(x, \<lambda>y. r`y))"

subsubsection{*The Corresponding Recursion Equations*}

lemma [simp]: "L_r(f, succ(i)) = DPow_r(f, L_r(f,i), Lset(i))"
by (simp add: L_r_def)

text{*The limit case is non-trivial because of the distinction between
object-level and meta-level abstraction.*}
lemma [simp]: "Limit(i) ==> L_r(f,i) = rlimit(i, L_r(f))"
by (simp cong: rlimit_cong add: transrec3_Limit L_r_def ltD)

lemma (in Nat_Times_Nat) L_r_type:
    "Ord(i) ==> L_r(fn,i) \<subseteq> Lset(i) * Lset(i)"
apply (induct i rule: trans_induct3)
  apply (simp_all add: Lset_succ DPow_r_type well_ord_DPow_r rlimit_def
                       Transset_subset_DPow [OF Transset_Lset], blast)
done

lemma (in Nat_Times_Nat) well_ord_L_r:
    "Ord(i) ==> well_ord(Lset(i), L_r(fn,i))"
apply (induct i rule: trans_induct3)
apply (simp_all add: well_ord0 Lset_succ L_r_type well_ord_DPow_r
                     well_ord_rlimit ltD)
done

lemma well_ord_L_r:
    "Ord(i) ==> \<exists>r. well_ord(Lset(i), r)"
apply (insert nat_times_nat_lepoll_nat)
apply (unfold lepoll_def)
apply (blast intro: Nat_Times_Nat.well_ord_L_r Nat_Times_Nat.intro)
done

text{*Every constructible set is well-ordered! Therefore the Wellordering Theorem and
      the Axiom of Choice hold in @{term L}!!*}
theorem L_implies_AC: assumes x: "L(x)" shows "\<exists>r. well_ord(x,r)"
  using Transset_Lset x
apply (simp add: Transset_def L_def)
apply (blast dest!: well_ord_L_r intro: well_ord_subset)
done

interpretation L?: M_basic L by (rule M_basic_L)

theorem "\<forall>x[L]. \<exists>r. wellordered(L,x,r)"
proof
  fix x
  assume "L(x)"
  then obtain r where "well_ord(x,r)"
    by (blast dest: L_implies_AC)
  thus "\<exists>r. wellordered(L,x,r)"
    by (blast intro: well_ord_imp_relativized)
qed

text{*In order to prove @{term" \<exists>r[L]. wellordered(L,x,r)"}, it's necessary to know
that @{term r} is actually constructible. It follows from the assumption ``@{term V} equals @{term L''},
but this reasoning doesn't appear to work in Isabelle.*}

end