theory SolverP3
  imports SolverP2 InferVar
begin

fun lbound_perm where
  "lbound_perm (SVar r) = UsePerm"
| "lbound_perm (SPerm p) = p"

fun lbound_permx where
  "lbound_permx (XPerm p) = lbound_perm p"
| "lbound_permx (XType a) = NoPerm"
| "lbound_permx (XComp px qx) = union_perm (lbound_permx px) (lbound_permx qx)"
| "lbound_permx (XLift px q) = (if lbound_perm q = OwnPerm \<and> lbound_permx px \<noteq> NoPerm then OwnPerm else lbound_permx px)"
| "lbound_permx (XIfZero px qx) = (if lbound_permx px = NoPerm then NoPerm else lbound_permx qx)"

fun owner_crn where
  "owner_crn (LeqCrn2 px q) = (lbound_permx px = OwnPerm)"
| "owner_crn (DisjCrn2 px qx) = False"
| "owner_crn (MiniDisjCrn2 px qx) = False"

definition use_semi_env where
  "use_semi_env = (\<lambda> x. UsePerm)"

function complete_sol_calc_f where
  "complete_sol_calc_f c_list = (case select_list owner_crn c_list of
    None \<Rightarrow> Some use_semi_env
    | Some (c, c_t) \<Rightarrow> (case c of
      LeqCrn2 px q \<Rightarrow> (case q of
        SPerm p \<Rightarrow> if p = OwnPerm then complete_sol_calc_f c_t else None
        | SVar r \<Rightarrow> (case complete_sol_calc_f (sub1_crn_list c_t r) of
          None \<Rightarrow> None
          | Some o_sub \<Rightarrow> Some (\<lambda> r'. if r' = r then OwnPerm else o_sub r')
        )
      )
      | other \<Rightarrow> None
    )
  )" by auto
termination
  apply (relation "measure length")
   apply (auto)
   apply (rule_tac select_less_length)
   apply (auto)
  apply (rule_tac t="length (sub1_crn_list b x2a)" and s="length b" in subst)
   apply (rule_tac sub1_same_length)
  apply (rule_tac select_less_length)
  apply (auto)
  done

definition complete_sol_calc where
  "complete_sol_calc c_list = complete_sol_calc_f c_list"

lemma select_sol_sat_crn: "\<lbrakk> sol_sat2 p_sub c_list; select_list f c_list = Some (c, c_t) \<rbrakk> \<Longrightarrow> sol_sat_crn2 p_sub c"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

lemma select_sol_sat: "\<lbrakk> sol_sat2 p_sub c_list; select_list f c_list = Some (c, c_t) \<rbrakk> \<Longrightarrow> sol_sat2 p_sub c_t"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

lemma select_sol_sat_split: "\<lbrakk> select_list f c_list = Some (c, c_t); sol_sat_crn2 p_sub c; sol_sat2 p_sub c_t \<rbrakk> \<Longrightarrow> sol_sat2 p_sub c_list"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
   apply (case_tac "f a")
    apply (auto)
   apply (case_tac "select_list f c_list")
    apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

    (*
definition nz_sub where
  "nz_sub p_sub px = (\<forall> x. x \<in> pvar_set px \<longrightarrow> p_sub x \<noteq> NoPerm)"
    *)

definition nz_sub where
  "nz_sub p_sub ds = (\<forall> x. x \<in> ds \<longrightarrow> p_sub x \<noteq> NoPerm)"

lemma lbound_eval_perm: "\<lbrakk> nz_sub p_sub (pvar_set_perm p) \<rbrakk> \<Longrightarrow> leq_perm (lbound_perm p) (eval_perm p_sub p)"
  apply (case_tac p)
   apply (auto)
   apply (case_tac x1)
     apply (auto)
  apply (simp add: nz_sub_def)
  apply (case_tac "p_sub x2")
    apply (auto)
  done

lemma lbound_eval_permx: "\<lbrakk> nz_sub p_sub (pvar_set px) \<rbrakk> \<Longrightarrow> leq_perm (lbound_permx px) (eval_permx p_sub px)"
  apply (induct px)
      apply (auto)
    (* perm case *)
         apply (rule_tac lbound_eval_perm)
         apply (simp)
    (* comp case *)
        apply (rule_tac dist_union_leq_perm)
         apply (rule_tac union_leq_perm1)
         apply (simp add: nz_sub_def)
        apply (rule_tac union_leq_perm2)
        apply (simp add: nz_sub_def)
    (* lift cases 1-4 *)
       apply (case_tac x2a)
        apply (auto)
      apply (simp add: nz_sub_def)
      apply (case_tac "lbound_permx px")
        apply (auto)
     apply (simp add: nz_sub_def)
    apply (simp add: nz_sub_def)
    (* if zero cases 1-2 *)
   apply (case_tac "\<not> nz_sub p_sub (pvar_set px1)")
    apply (simp add: nz_sub_def)
   apply (auto)
   apply (case_tac "lbound_permx px1")
     apply (auto)
  apply (simp add: nz_sub_def)
  done

    (* only true assuming that for every var in px, p_sub is in Use *)
lemma own_lbound_eval_permx: "\<lbrakk> nz_sub p_sub (pvar_set px); lbound_permx px = OwnPerm \<rbrakk> \<Longrightarrow> eval_permx p_sub px = OwnPerm"
  apply (cut_tac px="px" and p_sub="p_sub" in lbound_eval_permx)
   apply (auto)
  apply (case_tac "eval_permx p_sub px")
    apply (auto)
  done

fun pvar_crn2 where
 "pvar_crn2 (LeqCrn2 px q) = (pvar_set px \<union> pvar_set_perm q)"
| "pvar_crn2 (DisjCrn2 px qx) = (pvar_set px \<union> pvar_set qx)"
| "pvar_crn2 (MiniDisjCrn2 px qx) = (pvar_set px \<union> pvar_set qx)"

fun pvar_crn_list2 where
  "pvar_crn_list2 [] = {}"
| "pvar_crn_list2 (c # c_t) = (pvar_crn2 c \<union> pvar_crn_list2 c_t)"
  (*
fun nz_sub_crn where
  "nz_sub_crn p_sub (LeqCrn2 px q) = (nz_sub p_sub px \<and> nz_sub p_sub (XPerm q))"
| "nz_sub_crn p_sub (DisjCrn2 px qx) = (nz_sub p_sub px \<and> nz_sub p_sub qx)"
| "nz_sub_crn p_sub (MiniDisjCrn2 px qx) = (nz_sub p_sub px \<and> nz_sub p_sub qx)"

fun nz_sub_crn_list where
  "nz_sub_crn_list p_sub [] = True"
| "nz_sub_crn_list p_sub (c # c_t) = (nz_sub_crn p_sub c \<and> nz_sub_crn_list p_sub c_t)"
  *)

lemma subset_nz_sub: "\<lbrakk> nz_sub p_sub ds'; ds \<subseteq> ds' \<rbrakk> \<Longrightarrow> nz_sub p_sub ds"
  apply (simp add: nz_sub_def)
  apply (auto)
  done

lemma union_nz_sub: "\<lbrakk> nz_sub p_sub ds; nz_sub p_sub ds' \<rbrakk> \<Longrightarrow> nz_sub p_sub (ds \<union> ds')"
  apply (simp add: nz_sub_def)
  done

lemma select_nz_sub_crn: "\<lbrakk> select_list f c_list = Some (c, c_t); nz_sub p_sub (pvar_crn_list2 c_list) \<rbrakk> \<Longrightarrow> nz_sub p_sub (pvar_crn2 c)"
  apply (induct c_list arbitrary: c c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
   apply (rule_tac subset_nz_sub)
    apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  apply (cut_tac p_sub="p_sub" and ds="pvar_crn_list2 c_list" and ds'="pvar_crn2 a \<union> pvar_crn_list2 c_list" in subset_nz_sub)
    apply (auto)
  done

lemma select_nz_sub_crn_list: "\<lbrakk> select_list f c_list = Some (c, c_t); nz_sub p_sub (pvar_crn_list2 c_list) \<rbrakk> \<Longrightarrow>
  nz_sub p_sub (pvar_crn_list2 c_t)"
  apply (induct c_list arbitrary: c c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
   apply (rule_tac subset_nz_sub)
    apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  apply (rule_tac union_nz_sub)
   apply (rule_tac subset_nz_sub)
    apply (auto)
  apply (cut_tac p_sub="p_sub" and ds="pvar_crn_list2 c_list" and ds'="pvar_crn2 a \<union> pvar_crn_list2 c_list" in subset_nz_sub)
    apply (auto)
  done

lemma sub1_pvar_set_perm: "pvar_set_perm (sub1_perm p r) \<subseteq> pvar_set_perm p"
  apply (case_tac p)
   apply (auto)
  done

lemma sub1_pvar_set: "pvar_set (sub1_permx px r) \<subseteq> pvar_set px"
  apply (induct px)
      apply (auto)
   apply (case_tac x)
    apply (auto)
   apply (case_tac "x2 = r")
    apply (auto)
  apply (case_tac "x2a")
   apply (auto)
  apply (case_tac "x2 = r")
   apply (auto)
  done

lemma sub1_pvar_crn: "pvar_crn2 (sub1_crn c r) \<subseteq> pvar_crn2 c"
  apply (case_tac c)
    apply (auto)
       apply (cut_tac px="x11" and r="r" in sub1_pvar_set)
       apply (auto)
      apply (cut_tac p="x12" and r="r" in sub1_pvar_set_perm)
      apply (auto)
     apply (cut_tac px="x21" and r="r" in sub1_pvar_set)
     apply (auto)
    apply (cut_tac px="x22" and r="r" in sub1_pvar_set)
    apply (auto)
   apply (cut_tac px="x31" and r="r" in sub1_pvar_set)
   apply (auto)
  apply (cut_tac px="x32" and r="r" in sub1_pvar_set)
  apply (auto)
  done

lemma sub1_pvar_crn_list: "pvar_crn_list2 (sub1_crn_list c_list r) \<subseteq> pvar_crn_list2 c_list"
  apply (induct c_list)
   apply (auto)
  apply (cut_tac c="a" and r="r" in sub1_pvar_crn)
  apply (auto)
  done

lemma sub1_nz_sub_crn_list: "\<lbrakk> nz_sub p_sub (pvar_crn_list2 c_list) \<rbrakk> \<Longrightarrow> nz_sub p_sub (pvar_crn_list2 (sub1_crn_list c_list r))"
  apply (rule_tac subset_nz_sub)
   apply (simp)
  apply (rule_tac sub1_pvar_crn_list)
  done

lemma sub1_eval_permx: "\<lbrakk> p_sub r = OwnPerm \<rbrakk> \<Longrightarrow> eval_permx p_sub px = eval_permx p_sub (sub1_permx px r)"
  apply (induct px)
      apply (auto)
    apply (case_tac x)
     apply (auto)
   apply (case_tac x2a)
    apply (auto)
   apply (case_tac "x2 = r")
    apply (auto)
  apply (case_tac x2a)
   apply (auto)
  apply (case_tac "x2 = r")
   apply (auto)
  done

lemma sub1_sol_sat_crn: "\<lbrakk> sol_sat_crn2 p_sub c; p_sub r = OwnPerm \<rbrakk> \<Longrightarrow> sol_sat_crn2 p_sub (sub1_crn c r)"
  apply (case_tac c)
    apply (auto)
            apply (cut_tac p_sub="p_sub" and px="x11" and r="r" in sub1_eval_permx)
             apply (auto)
            apply (case_tac x12)
             apply (auto)
           apply (cut_tac p_sub="p_sub" and px="x21" and r="r" in sub1_eval_permx)
            apply (auto)
          apply (cut_tac p_sub="p_sub" and px="x22" and r="r" in sub1_eval_permx)
           apply (auto)
         apply (cut_tac p_sub="p_sub" and px="x21" and r="r" in sub1_eval_permx)
          apply (auto)
        apply (cut_tac p_sub="p_sub" and px="x21" and r="r" in sub1_eval_permx)
         apply (auto)
       apply (cut_tac p_sub="p_sub" and px="x22" and r="r" in sub1_eval_permx)
        apply (auto)
      apply (cut_tac p_sub="p_sub" and px="x22" and r="r" in sub1_eval_permx)
       apply (auto)
     apply (cut_tac p_sub="p_sub" and px="x22" and r="r" in sub1_eval_permx)
      apply (auto)
    apply (cut_tac p_sub="p_sub" and px="x22" and r="r" in sub1_eval_permx)
     apply (auto)
   apply (cut_tac p_sub="p_sub" and px="x31" and r="r" in sub1_eval_permx)
    apply (auto)
  apply (cut_tac p_sub="p_sub" and px="x32" and r="r" in sub1_eval_permx)
   apply (auto)
  done

lemma sub1_sol_sat: "\<lbrakk> sol_sat2 p_sub c_list; p_sub r = OwnPerm \<rbrakk> \<Longrightarrow> sol_sat2 p_sub (sub1_crn_list c_list r)"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac sub1_sol_sat_crn)
   apply (auto)
  done

    (* unsat proof *)

lemma cscu_ih: "\<lbrakk> \<And>c_lista. \<lbrakk> length c_lista < length c_list; complete_sol_calc c_lista = None; nz_sub p_sub (pvar_crn_list2 c_lista) \<rbrakk> \<Longrightarrow> \<not> sol_sat2 p_sub c_lista;
   length c_lista < length c_list; complete_sol_calc c_lista = None; nz_sub p_sub (pvar_crn_list2 c_lista) \<rbrakk> \<Longrightarrow> \<not> sol_sat2 p_sub c_lista"
  apply (auto)
  done

lemma complete_sol_calc_unsat: "\<lbrakk> complete_sol_calc c_list = None; nz_sub p_sub (pvar_crn_list2 c_list) \<rbrakk> \<Longrightarrow>  \<not> sol_sat2 p_sub c_list"
  apply (induct "length c_list" arbitrary: c_list rule: less_induct)
  apply (auto)
    (* unroll algorithm definition *)
  apply (case_tac "\<not> (case select_list owner_crn c_list of None \<Rightarrow> Some use_semi_env
                | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = OwnPerm then complete_sol_calc_f c_t else None
                | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
                    (case complete_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some o_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then OwnPerm else o_sub r'))
                | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x) =
               None")
   apply (simp add: complete_sol_calc_def)
  apply (auto)
    (* attempt to select from list *)
  apply (case_tac "select_list owner_crn c_list")
   apply (auto)
  apply (case_tac a)
    apply (auto)
    apply (case_tac x12)
     apply (auto)
    (* inequality over permission constant. case where p \<noteq> 1 *)
     apply (case_tac "x1 \<noteq> OwnPerm")
      apply (auto)
      apply (cut_tac f="owner_crn" and c="LeqCrn2 x11 (SPerm x1)" in select_sol_sat_crn)
        apply (auto)
      apply (cut_tac f="owner_crn" and c="LeqCrn2 x11 (SPerm x1)" in select_cond_sat)
       apply (auto)
      apply (cut_tac p_sub="p_sub" and px="x11" in own_lbound_eval_permx)
        apply (cut_tac p_sub="p_sub" and c="LeqCrn2 x11 (SPerm x1)" and c_list="c_list" in select_nz_sub_crn)
          apply (auto)
      apply (case_tac x1)
        apply (auto)
    (* - inductive case where p = 1 *)
     apply (cut_tac c_lista="b" and c_list="c_list" in cscu_ih)
         apply (auto)
        apply (rule_tac select_less_length)
        apply (simp)
       apply (simp add: complete_sol_calc_def)
      apply (rule_tac select_nz_sub_crn_list)
       apply (auto)
     apply (cut_tac c_list="c_list" and c_t="b" in select_sol_sat)
       apply (auto)
    (* inequality over permission var *)
    apply (cut_tac c_lista="sub1_crn_list b x2" and c_list="c_list" in cscu_ih)
        apply (auto)
       apply (rule_tac t="length (sub1_crn_list b x2)" and s="length b" in subst)
        apply (rule_tac sub1_same_length)
       apply (rule_tac select_less_length)
       apply (simp)
      apply (case_tac "case select_list owner_crn (sub1_crn_list b x2) of None \<Rightarrow> Some use_semi_env
              | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = OwnPerm then complete_sol_calc_f c_t else None
              | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
                  (case complete_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some o_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then OwnPerm else o_sub r'))
              | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x")
       apply (auto)
      apply (simp add: complete_sol_calc_def)
     apply (rule_tac sub1_nz_sub_crn_list)
     apply (rule_tac select_nz_sub_crn_list)
      apply (simp_all)
    (* we know that p_sub does not assign r (x2) to 0 *)
    apply (case_tac "p_sub x2 = NoPerm")
     apply (cut_tac p_sub="p_sub" and c="LeqCrn2 x11 (SVar x2)" in select_nz_sub_crn)
       apply (auto)
     apply (simp add: nz_sub_def)
     apply (auto)
    (* if the constraints are solvable, then the solution assigns either 1 or * to r. we know an assignment of * will fail. an assignment of 1
        means sub1_crn_list should be solvable, a contradiction *)
    apply (case_tac "p_sub x2")
      apply (auto)
     apply (cut_tac p_sub="p_sub" and c="LeqCrn2 x11 (SVar x2)" in select_sol_sat_crn)
       apply (auto)
     apply (cut_tac f="owner_crn" and c="LeqCrn2 x11 (SVar x2)" in select_cond_sat)
      apply (auto)
     apply (cut_tac p_sub="p_sub" and px="x11" in lbound_eval_permx)
      apply (cut_tac p_sub="p_sub" and c="LeqCrn2 x11 (SVar x2)" in select_nz_sub_crn)
        apply (auto)
      apply (rule_tac ds'="insert x2 (pvar_set x11)" in subset_nz_sub)
       apply (auto)
     apply (case_tac "eval_permx p_sub x11")
       apply (auto)
    apply (cut_tac p_sub="p_sub" and c_list="b" and r="x2" in sub1_sol_sat)
      apply (auto)
    apply (rule_tac select_sol_sat)
     apply (auto)
    (* disjointness cases, should never happen *)
   apply (cut_tac f="owner_crn" and c="DisjCrn2 x21 x22" in select_cond_sat)
    apply (auto)
  apply (cut_tac f="owner_crn" and c="MiniDisjCrn2 x31 x32" in select_cond_sat)
   apply (auto)
  done

lemma add_eval_perm: "eval_perm p_sub (sub1_perm p r) = eval_perm (\<lambda>r'. if r' = r then OwnPerm else p_sub r') p"
  apply (case_tac p)
   apply (auto)
  done

lemma add_eval_permx: "eval_permx p_sub (sub1_permx px r) = eval_permx (\<lambda>r'. if r' = r then OwnPerm else p_sub r') px"
  apply (induct px)
      apply (auto)
    apply (case_tac x)
     apply (auto)
   apply (case_tac x2a)
    apply (auto)
   apply (case_tac "x2 = r")
    apply (auto)
  apply (case_tac x2a)
   apply (auto)
  apply (case_tac "x2 = r")
   apply (auto)
  done

lemma add_sol_sat_crn: "\<lbrakk> sol_sat_crn2 p_sub (sub1_crn c r) \<rbrakk> \<Longrightarrow> sol_sat_crn2 (\<lambda>r'. if r' = r then OwnPerm else p_sub r') c"
  apply (case_tac c)
    apply (auto)
            apply (simp add: add_eval_permx)
            apply (simp add: add_eval_perm)
           apply (simp_all add: add_eval_permx)
  done

lemma add_sol_sat: "\<lbrakk> sol_sat2 p_sub (sub1_crn_list c_list r) \<rbrakk> \<Longrightarrow> sol_sat2 (\<lambda>r'. if r' = r then OwnPerm else p_sub r') c_list"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac add_sol_sat_crn)
  apply (simp)
  done

lemma step3_solve_iter: "\<lbrakk> select_list owner_crn c_list = Some (LeqCrn2 px (SVar r), c_t);
  sol_sat2 p_sub (sub1_crn_list c_t r) \<rbrakk> \<Longrightarrow> sol_sat2 (\<lambda>r'. if r' = r then OwnPerm else  p_sub r') c_list"
  apply (rule_tac select_sol_sat_split)
    apply (auto)
  apply (rule_tac add_sol_sat)
  apply (auto)
  done

fun apply_zero_perm where
  "apply_zero_perm f_sub (SPerm p) = (SPerm p)"
| "apply_zero_perm f_sub (SVar r) = (if f_sub r then SVar r else SPerm NoPerm)"

fun apply_zero_permx where
  "apply_zero_permx f_sub (XPerm p) = XPerm (apply_zero_perm f_sub p)"
| "apply_zero_permx f_sub (XType a) = XType a"
| "apply_zero_permx f_sub (XComp px qx) = XComp (apply_zero_permx f_sub px) (apply_zero_permx f_sub qx)"
| "apply_zero_permx f_sub (XLift px q) = XLift (apply_zero_permx f_sub px) (apply_zero_perm f_sub q)"
| "apply_zero_permx f_sub (XIfZero px qx) = XIfZero (apply_zero_permx f_sub px) (apply_zero_permx f_sub qx)"

fun apply_zero_crn where
  "apply_zero_crn f_sub (LeqCrn2 px q) = LeqCrn2 (apply_zero_permx f_sub px) (apply_zero_perm f_sub q)"
| "apply_zero_crn f_sub (DisjCrn2 px qx) = DisjCrn2 (apply_zero_permx f_sub px) (apply_zero_permx f_sub qx)"
| "apply_zero_crn f_sub (MiniDisjCrn2 px qx) = MiniDisjCrn2 (apply_zero_permx f_sub px) (apply_zero_permx f_sub qx)"

fun apply_zero_crn_list where
  "apply_zero_crn_list f_sub [] = []"
| "apply_zero_crn_list f_sub (c # c_t) = (apply_zero_crn f_sub c # apply_zero_crn_list f_sub c_t)"

definition final_sub where
  "final_sub f_sub o_sub = (\<lambda> x. if f_sub x then o_sub x else NoPerm)"

lemma none_eval_permx: "\<lbrakk> lbound_permx px = NoPerm \<rbrakk> \<Longrightarrow> eval_permx use_semi_env px = NoPerm"
  apply (induct px)
      apply (auto)
    (* base case *)
      apply (case_tac x)
       apply (auto)
    (* comp case *)
     apply (case_tac "lbound_permx px1")
       apply (auto)
      apply (case_tac "lbound_permx px2")
        apply (auto)
     apply (case_tac "lbound_permx px2")
       apply (auto)
    (* lift case 1 *)
    apply (case_tac "lbound_perm x2a = OwnPerm \<and> lbound_permx px \<noteq> NoPerm")
     apply (auto)
    (* lift case 2 *)
   apply (case_tac "lbound_perm x2a = OwnPerm \<and> lbound_permx px \<noteq> NoPerm")
    apply (auto)
    (* if zero case *)
  apply (case_tac "lbound_permx px1 = NoPerm")
   apply (auto)
  done

lemma use_eval_permx: "\<lbrakk> lbound_permx px \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> eval_permx use_semi_env px \<noteq> OwnPerm"
  apply (induct px)
      apply (auto)
    (* base case *)
      apply (case_tac x)
       apply (auto)
      apply (simp add: use_semi_env_def)
    (* comp case *)
     apply (case_tac "lbound_permx px1 = OwnPerm")
      apply (simp)
     apply (case_tac "lbound_permx px2 = OwnPerm")
      apply (auto)
      apply (case_tac "lbound_permx px1")
        apply (auto)
     apply (case_tac "eval_permx use_semi_env px1")
       apply (auto)
      apply (case_tac "eval_permx use_semi_env px2")
        apply (auto)
     apply (case_tac "eval_permx use_semi_env px2")
       apply (auto)
    (* lift case 1. q (x2a) \<noteq> 1, a contradiction *)
    apply (case_tac "lbound_perm x2a = OwnPerm")
     apply (auto)
     apply (case_tac "lbound_permx px \<noteq> NoPerm")
      apply (auto)
     apply (rule_tac none_eval_permx)
     apply (simp)
    apply (case_tac x2a)
     apply (auto)
    apply (simp add: use_semi_env_def)
    (* lift case 2. *)
   apply (case_tac "lbound_perm x2a = OwnPerm \<and> lbound_permx px \<noteq> NoPerm")
    apply (auto)
    (* if zero case *)
  apply (case_tac "lbound_permx px1 = NoPerm")
   apply (auto)
  apply (cut_tac px="px1" in none_eval_permx)
   apply (auto)
  done

lemma non_owner_crn_sat: "\<lbrakk> \<not> owner_crn c; sol_sat_crn2 p_sub c; nz_sub p_sub (pvar_crn2 c) \<rbrakk> \<Longrightarrow> sol_sat_crn2 use_semi_env c"
  apply (case_tac c)
    apply (auto)
    (* inequality case. we must show that (USE)rho \<le> (USE)p given (sigma)rho \<le> (sigma)p, and rho has a non-1 lower bound.
      we first consider (sigma)p = 0. in this case sigma(rho) = 0, and rho's lower bound must be 0, meaning (USE)rho = 0
    *)
            apply (case_tac "eval_perm p_sub x12 = NoPerm")
             apply (case_tac "eval_permx p_sub x11")
               apply (auto)
             apply (cut_tac p_sub="p_sub" and px="x11" in lbound_eval_permx)
              apply (rule_tac subset_nz_sub)
               apply (auto)
             apply (cut_tac px="x11" in none_eval_permx)
              apply (auto)
             apply (case_tac "lbound_permx x11")
               apply (auto)
    (* - otherwise, since (sigma)p != 0, we know that (USE)p !=  0 *)
            apply (case_tac "eval_perm use_semi_env x12 = NoPerm")
             apply (case_tac x12)
              apply (case_tac x1)
                apply (auto)
             apply (simp add: use_semi_env_def)
    (* - since the lower bound of rho \<noteq> 1, (USE)rho \<noteq> 1, and our equality holds *)
            apply (cut_tac px="x11" in use_eval_permx)
             apply (auto)
            apply (case_tac "eval_perm use_semi_env x12")
              apply (auto)
            apply (case_tac "eval_permx use_semi_env x11")
              apply (auto)
    (* disjointness cases hold because of lower bounds *)
           apply (cut_tac p_sub="p_sub" and px="x21" in lbound_eval_permx)
            apply (rule_tac subset_nz_sub)
             apply (auto)
           apply (case_tac "lbound_permx x21 = OwnPerm")
            apply (case_tac "eval_permx p_sub x21")
              apply (auto)
           apply (cut_tac px="x21" in use_eval_permx)
            apply (auto)
    (* - ex case 1 *)
          apply (cut_tac p_sub="p_sub" and px="x22" in lbound_eval_permx)
           apply (rule_tac subset_nz_sub)
            apply (auto)
          apply (cut_tac px="x22" in use_eval_permx)
           apply (auto)
          apply (case_tac "eval_permx p_sub x22")
            apply (auto)
    (* - ex case 2 *)
          apply (cut_tac p_sub="p_sub" and px="x21" in lbound_eval_permx)
           apply (rule_tac subset_nz_sub)
            apply (auto)
         apply (cut_tac px="x21" in none_eval_permx)
          apply (auto)
         apply (case_tac "lbound_permx x21")
           apply (auto)
    (* - ex case 3 *)
        apply (cut_tac p_sub="p_sub" and px="x21" in lbound_eval_permx)
         apply (rule_tac subset_nz_sub)
          apply (auto)
        apply (cut_tac px="x21" in none_eval_permx)
         apply (auto)
        apply (case_tac "lbound_permx x21")
          apply (auto)
    (* - case 2 *)
       apply (cut_tac p_sub="p_sub" and px="x22" in lbound_eval_permx)
        apply (rule_tac subset_nz_sub)
         apply (auto)
       apply (case_tac "lbound_permx x22")
         apply (auto)
       apply (rule_tac none_eval_permx)
       apply (auto)
    (* - ex case 4 *)
      apply (cut_tac p_sub="p_sub" and px="x22" in lbound_eval_permx)
       apply (rule_tac subset_nz_sub)
        apply (auto)
      apply (cut_tac px="x22" in use_eval_permx)
       apply (auto)
    (* - ex case 5 *)
     apply (cut_tac p_sub="p_sub" and px="x21" in lbound_eval_permx)
      apply (rule_tac subset_nz_sub)
       apply (auto)
     apply (cut_tac px="x21" in use_eval_permx)
      apply (auto)
    apply (case_tac "eval_permx p_sub x21")
      apply (auto)
    (* - ex case 5 *)
    apply (cut_tac p_sub="p_sub" and px="x21" in lbound_eval_permx)
     apply (rule_tac subset_nz_sub)
      apply (auto)
    apply (case_tac "lbound_permx x21")
      apply (auto)
    apply (rule_tac none_eval_permx)
    apply (auto)
    (* - case 3 *)
   apply (cut_tac p_sub="p_sub" and px="x31" in lbound_eval_permx)
    apply (rule_tac subset_nz_sub)
     apply (auto)
   apply (case_tac "lbound_permx x31 = OwnPerm")
    apply (case_tac "eval_permx p_sub x31")
      apply (auto)
   apply (cut_tac px="x31" in use_eval_permx)
    apply (auto)
    (* - case 3 *)
  apply (cut_tac p_sub="p_sub" and px="x32" in lbound_eval_permx)
   apply (rule_tac subset_nz_sub)
    apply (auto)
  apply (case_tac "lbound_permx x32")
    apply (auto)
  apply (rule_tac none_eval_permx)
  apply (auto)
  done

  (*
      this lemma states that if no more ownership constraints can be taken - if the constraint set
      is solvable (with a non-zero solution), it is solvable with only use permissions.
  *)
lemma step3_solve_end: "\<lbrakk> select_list owner_crn c_list = None; sol_sat2 p_sub c_list;
  nz_sub p_sub (pvar_crn_list2 c_list) \<rbrakk> \<Longrightarrow> sol_sat2 use_semi_env c_list"
  apply (induct c_list)
   apply (auto)
    (* prove constraint is valid *)
   apply (case_tac "owner_crn a")
    apply (auto)
   apply (rule_tac non_owner_crn_sat)
     apply (auto)
   apply (rule_tac subset_nz_sub)
    apply (auto)
    (* induction *)
  apply (case_tac "owner_crn a")
   apply (auto)
  apply (case_tac "select_list owner_crn c_list")
   apply (auto)
  apply (cut_tac ds="pvar_crn_list2 c_list" and p_sub="p_sub" in subset_nz_sub)
    apply (auto)
  done

lemma final_sub_eval_perm: "eval_perm o_sub (apply_zero_perm f_sub p) = eval_perm (final_sub f_sub o_sub) p"
  apply (case_tac p)
   apply (auto)
   apply (simp add: final_sub_def)
  apply (simp add: final_sub_def)
  done

lemma final_sub_eval_permx: "eval_permx o_sub (apply_zero_permx f_sub px) = eval_permx (final_sub f_sub o_sub) px"
  apply (induct px)
      apply (auto)
    apply (simp add: final_sub_eval_perm)
   apply (simp add: final_sub_eval_perm)
  apply (simp add: final_sub_eval_perm)
  done

lemma final_sub_sol_crn: "\<lbrakk> sol_sat_crn2 o_sub (apply_zero_crn f_sub c) \<rbrakk> \<Longrightarrow> sol_sat_crn2 (final_sub f_sub o_sub) c"
  apply (case_tac c)
    apply (auto)
            apply (simp add: final_sub_eval_permx)
            apply (simp add: final_sub_eval_perm)
           apply (simp_all add: final_sub_eval_permx)
  done

lemma final_sub_sol_sat: "\<lbrakk> sol_sat2 o_sub (apply_zero_crn_list f_sub c_list) \<rbrakk> \<Longrightarrow> sol_sat2 (final_sub f_sub o_sub) c_list"
  apply (induct c_list)
   apply (auto)
  apply (simp add: final_sub_sol_crn)
  done

lemma apply_zero_eval_perm: "leq_perm (eval_perm p_sub (apply_zero_perm f_sub p)) (eval_perm p_sub p)"
  apply (case_tac p)
   apply (auto)
   apply (case_tac x1)
     apply (auto)
  apply (case_tac "p_sub x2")
    apply (auto)
  done

lemma apply_zero_eval_permx: "leq_perm (eval_permx p_sub (apply_zero_permx f_sub px)) (eval_permx p_sub px)"
  apply (induct px)
      apply (auto)
      apply (rule_tac apply_zero_eval_perm)
     apply (rule_tac dist_union_leq_perm)
      apply (rule_tac union_leq_perm1)
      apply (simp)
     apply (rule_tac union_leq_perm2)
     apply (simp)
    apply (cut_tac p_sub="p_sub" and f_sub="f_sub" and p="x2a" in apply_zero_eval_perm)
    apply (case_tac "eval_perm p_sub x2a")
      apply (auto)
   apply (case_tac " eval_permx p_sub (apply_zero_permx f_sub px)")
     apply (auto)
  apply (case_tac "eval_permx p_sub (apply_zero_permx f_sub px1)")
    apply (auto)
  done

lemma none_apply_zero_eval_permx: "\<lbrakk> \<not> semi_sol_permx f_sub px \<rbrakk> \<Longrightarrow> eval_permx p_sub (apply_zero_permx f_sub px) = NoPerm"
  apply (induct px)
      apply (auto)
  apply (case_tac x)
   apply (auto)
  apply (case_tac "x1 = NoPerm")
   apply (auto)
  done

lemma apply_zero_eval_perm_rev: "\<lbrakk> semi_sol_perm f_sub p \<rbrakk> \<Longrightarrow>
  leq_perm (eval_perm p_sub p) (eval_perm p_sub (apply_zero_perm f_sub p))"
  apply (case_tac p)
   apply (auto)
   apply (case_tac x1)
     apply (auto)
  apply (case_tac "p_sub x2")
    apply (auto)
  done

lemma apply_zero_sol_crn: "\<lbrakk> semi_sol_crn2 f_sub c; sol_sat_crn2 p_sub c \<rbrakk> \<Longrightarrow> sol_sat_crn2 p_sub (apply_zero_crn f_sub c)"
  apply (case_tac c)
    apply (auto)
             apply (simp add: none_apply_zero_eval_permx)
            apply (rule_tac q="eval_permx p_sub x11" in trans_leq_perm)
             apply (rule_tac apply_zero_eval_permx)
            apply (rule_tac q="eval_perm p_sub x12" in trans_leq_perm)
             apply (simp)
            apply (rule_tac apply_zero_eval_perm_rev)
            apply (simp)
           apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x21" in apply_zero_eval_permx)
           apply (auto)
           apply (case_tac "eval_permx p_sub x21")
             apply (auto)
          apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x22" in apply_zero_eval_permx)
          apply (auto)
          apply (case_tac "eval_permx p_sub x22")
            apply (auto)
         apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x21" in apply_zero_eval_permx)
         apply (auto)
        apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x21" in apply_zero_eval_permx)
        apply (auto)
        apply (case_tac "eval_permx p_sub (apply_zero_permx f_sub x21)")
          apply (auto)
       apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x22" in apply_zero_eval_permx)
       apply (auto)
       apply (case_tac "eval_permx p_sub (apply_zero_permx f_sub x22)")
         apply (auto)
      apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x22" in apply_zero_eval_permx)
      apply (auto)
     apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x22" in apply_zero_eval_permx)
     apply (auto)
     apply (case_tac "eval_permx p_sub (apply_zero_permx f_sub x22)")
       apply (auto)
    apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x21" in apply_zero_eval_permx)
    apply (auto)
    apply (case_tac "eval_permx p_sub (apply_zero_permx f_sub x21)")
      apply (auto)
   apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x31" in apply_zero_eval_permx)
   apply (auto)
   apply (case_tac "eval_permx p_sub x31")
     apply (auto)
  apply (cut_tac f_sub="f_sub" and p_sub="p_sub" and px="x32" in apply_zero_eval_permx)
  apply (auto)
  apply (case_tac "eval_permx p_sub (apply_zero_permx f_sub x32)")
    apply (auto)
  done

lemma apply_zero_sol_sat: "\<lbrakk> semi_sol_sat2 f_sub c_list; sol_sat2 p_sub c_list \<rbrakk> \<Longrightarrow> sol_sat2 p_sub (apply_zero_crn_list f_sub c_list)"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac apply_zero_sol_crn)
   apply (auto)
  done

lemma apply_zero_nz_sub_perm: "\<lbrakk> leq_semi_env f_sub (semi_sol_corr p_sub) \<rbrakk> \<Longrightarrow> nz_sub p_sub (pvar_set_perm (apply_zero_perm f_sub p))"
  apply (case_tac p)
   apply (auto)
    apply (simp add: nz_sub_def)
   apply (simp add: nz_sub_def)
   apply (simp add: leq_semi_env_def)
   apply (simp add: semi_sol_corr_def)
   apply (erule_tac x="x2" in allE)
   apply (auto)
  apply (simp add: nz_sub_def)
  done

lemma apply_zero_nz_sub_permx: "\<lbrakk> leq_semi_env f_sub (semi_sol_corr p_sub) \<rbrakk> \<Longrightarrow> nz_sub p_sub (pvar_set (apply_zero_permx f_sub px))"
  apply (induct px)
      apply (auto)
      apply (rule_tac apply_zero_nz_sub_perm)
      apply (simp)
     apply (simp add: nz_sub_def)
    apply (rule_tac union_nz_sub)
     apply (auto)
   apply (rule_tac union_nz_sub)
    apply (auto)
   apply (rule_tac apply_zero_nz_sub_perm)
   apply (simp)
  apply (rule_tac union_nz_sub)
   apply (auto)
  done

lemma apply_zero_nz_sub_crn: "\<lbrakk> leq_semi_env f_sub (semi_sol_corr p_sub) \<rbrakk> \<Longrightarrow> nz_sub p_sub (pvar_crn2 (apply_zero_crn f_sub c))"
  apply (case_tac c)
    apply (auto)
    apply (rule_tac union_nz_sub)
     apply (rule_tac apply_zero_nz_sub_permx)
     apply (simp)
    apply (rule_tac apply_zero_nz_sub_perm)
    apply (simp)
   apply (rule_tac union_nz_sub)
    apply (rule_tac apply_zero_nz_sub_permx)
    apply (simp)
   apply (rule_tac apply_zero_nz_sub_permx)
   apply (simp)
  apply (rule_tac union_nz_sub)
   apply (rule_tac apply_zero_nz_sub_permx)
   apply (simp)
  apply (rule_tac apply_zero_nz_sub_permx)
  apply (simp)
  done

lemma apply_zero_nz_sub_clist: "\<lbrakk> leq_semi_env f_sub (semi_sol_corr p_sub) \<rbrakk> \<Longrightarrow> nz_sub p_sub (pvar_crn_list2 (apply_zero_crn_list f_sub c_list))"
  apply (induct c_list)
   apply (auto)
   apply (simp add: nz_sub_def)
  apply (rule_tac union_nz_sub)
   apply (auto)
  apply (rule_tac apply_zero_nz_sub_crn)
  apply (simp)
  done

lemma apply_zero_same_length: "length (apply_zero_crn_list f_sub c_list) = length c_list"
  apply (induct c_list)
   apply (auto)
  done

lemma apply_zero_semi_sol_permx_rev: "\<lbrakk> semi_sol_permx p_sub (apply_zero_permx f_sub px) \<rbrakk> \<Longrightarrow> semi_sol_permx f_sub px"
  apply (induct px)
      apply (auto)
  apply (case_tac x)
   apply (auto)
  apply (case_tac "f_sub x2")
   apply (auto)
  done

lemma apply_zero_semi_sol_crn: "\<lbrakk> semi_sol_crn2 f_sub c \<rbrakk> \<Longrightarrow> semi_sol_crn2 f_sub (apply_zero_crn f_sub c)"
  apply (case_tac c)
    apply (auto)
   apply (cut_tac f_sub="f_sub" and px="x11" in apply_zero_semi_sol_permx_rev)
    apply (auto)
  apply (case_tac x12)
   apply (auto)
  done

lemma apply_zero_semi_sol_sat: "\<lbrakk> semi_sol_sat2 f_sub c_list \<rbrakk> \<Longrightarrow> semi_sol_sat2 f_sub (apply_zero_crn_list f_sub c_list)"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac apply_zero_semi_sol_crn)
  apply (auto)
  done

lemma double_apply_zero_permx: "apply_zero_permx f_sub (apply_zero_permx f_sub px) = apply_zero_permx f_sub px"
  apply (induct px)
      apply (auto)
   apply (case_tac x)
    apply (auto)
  apply (case_tac x2a)
   apply (auto)
  done

lemma double_apply_zero_crn: "apply_zero_crn f_sub (apply_zero_crn f_sub c) = apply_zero_crn f_sub c"
  apply (case_tac c)
   apply (auto)
       apply (rule_tac double_apply_zero_permx)
      apply (case_tac x12)
       apply (auto)
     apply (rule_tac double_apply_zero_permx)
    apply (rule_tac double_apply_zero_permx)
   apply (rule_tac double_apply_zero_permx)
  apply (rule_tac double_apply_zero_permx)
  done

lemma double_apply_zero_crn_list: "apply_zero_crn_list f_sub (apply_zero_crn_list f_sub c_list) = apply_zero_crn_list f_sub c_list"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac double_apply_zero_crn)
  done

lemma select_apply_zero_crn_list: "\<lbrakk> select_list f (apply_zero_crn_list f_sub c_list) = Some (c, c_t) \<rbrakk> \<Longrightarrow> apply_zero_crn_list f_sub c_t = c_t"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f (apply_zero_crn f_sub a)")
   apply (auto)
   apply (rule_tac double_apply_zero_crn_list)
  apply (case_tac "select_list f (apply_zero_crn_list f_sub c_list)")
   apply (auto)
  apply (rule_tac double_apply_zero_crn)
  done

lemma select_apply_zero_crn: "\<lbrakk> select_list f (apply_zero_crn_list f_sub c_list) = Some (c, c_t) \<rbrakk> \<Longrightarrow> apply_zero_crn f_sub c = c"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f (apply_zero_crn f_sub a)")
   apply (auto)
   apply (rule_tac double_apply_zero_crn)
  apply (case_tac "select_list f (apply_zero_crn_list f_sub c_list)")
   apply (auto)
  done

lemma comm_sub1_apply_zero_permx: "\<lbrakk> f_sub x \<rbrakk> \<Longrightarrow>
  sub1_permx (apply_zero_permx f_sub px) x = apply_zero_permx f_sub (sub1_permx px x)"
  apply (induct px)
      apply (auto)
   apply (case_tac xa)
    apply (auto)
  apply (case_tac x2a)
   apply (auto)
  done

lemma comm_sub1_apply_zero_crn: "\<lbrakk> f_sub x \<rbrakk> \<Longrightarrow>
  sub1_crn (apply_zero_crn f_sub c) x = apply_zero_crn f_sub (sub1_crn c x)"
  apply (case_tac c)
    apply (auto)
       apply (simp_all add: comm_sub1_apply_zero_permx)
  apply (case_tac x12)
   apply (auto)
  done

lemma comm_sub1_apply_zero_crn_list: "\<lbrakk> f_sub x \<rbrakk> \<Longrightarrow>
  sub1_crn_list (apply_zero_crn_list f_sub c_list) x = apply_zero_crn_list f_sub (sub1_crn_list c_list x)"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac comm_sub1_apply_zero_crn)
  apply (simp)
  done

lemma cscs_ih: "\<lbrakk> \<And>c_lista f_sub o_sub p_sub.
           \<lbrakk>length c_lista < length c_list; semi_sol_sat2 f_sub c_lista; leq_semi_env f_sub (semi_sol_corr p_sub);
            complete_sol_calc (apply_zero_crn_list f_sub c_lista) = Some o_sub; sol_sat2 p_sub c_lista\<rbrakk>
           \<Longrightarrow> sol_sat2 o_sub (apply_zero_crn_list f_sub c_lista); length c_lista < length c_list; semi_sol_sat2 f_sub c_lista; leq_semi_env f_sub (semi_sol_corr p_sub);
            complete_sol_calc (apply_zero_crn_list f_sub c_lista) = Some o_sub; sol_sat2 p_sub c_lista \<rbrakk> \<Longrightarrow>
    sol_sat2 o_sub (apply_zero_crn_list f_sub c_lista)"
  apply (auto)
  done

lemma complete_sol_calc_sat: "\<lbrakk> semi_sol_sat2 f_sub c_list; leq_semi_env f_sub (semi_sol_corr p_sub);
  complete_sol_calc (apply_zero_crn_list f_sub c_list) = Some o_sub; sol_sat2 p_sub c_list \<rbrakk> \<Longrightarrow> sol_sat2 o_sub (apply_zero_crn_list f_sub c_list)"
  apply (induct "length c_list" arbitrary: c_list f_sub o_sub p_sub rule: less_induct)
  apply (case_tac "\<not> (case select_list owner_crn (apply_zero_crn_list f_sub c_list) of None \<Rightarrow> Some use_semi_env
         | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = OwnPerm then complete_sol_calc_f c_t else None
         | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
             (case complete_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some o_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then OwnPerm else o_sub r'))
         | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x) =
        Some o_sub")
   apply (simp add: complete_sol_calc_def)
  apply (auto)
  apply (case_tac "select_list owner_crn (apply_zero_crn_list f_sub c_list)")
   apply (auto)
    (* base case. *)
   apply (rule_tac p_sub="p_sub" in step3_solve_end)
     apply (auto)
    apply (rule_tac apply_zero_sol_sat)
     apply (simp_all)
   apply (rule_tac apply_zero_nz_sub_clist)
   apply (simp)
    (* case analysis over constraint *)
  apply (case_tac a)
    apply (auto)
  apply (case_tac x12)
   apply (auto)
    (* - inequality constraint. permission case *)
   apply (cut_tac c_list="c_list" and c_lista="b" and p_sub="p_sub" and f_sub="f_sub" and o_sub="o_sub" in cscs_ih)
        apply (auto)
       apply (rule_tac t="length c_list" and s="length (apply_zero_crn_list f_sub c_list)" in subst)
        apply (rule_tac apply_zero_same_length)
       apply (rule_tac select_less_length)
       apply (auto)
      apply (rule_tac select_semi_sol)
       apply (auto)
      apply (rule_tac apply_zero_semi_sol_sat)
      apply (auto)
     apply (simp add: select_apply_zero_crn_list)
     apply (simp add: complete_sol_calc_def)
     apply (case_tac "x1 = OwnPerm")
      apply (auto)
    apply (rule_tac select_sol_sat)
     apply (auto)
    apply (rule_tac apply_zero_sol_sat)
     apply (auto)
   apply (rule_tac f="owner_crn" and c="LeqCrn2 x11 (SPerm x1)" and c_t="b" in select_sol_sat_split)
     apply (auto)
    apply (case_tac "x1 = OwnPerm")
     apply (auto)
   apply (simp add: select_apply_zero_crn_list)
    (* - inequality constraint. var case *)
  apply (case_tac "case select_list owner_crn (sub1_crn_list b x2) of None \<Rightarrow> Some use_semi_env
              | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = OwnPerm then complete_sol_calc_f c_t else None
              | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
                  (case complete_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some o_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then OwnPerm else o_sub r'))
              | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x")
   apply (auto)
    (* - given a as the solution for b[1/x2], we want to show that a + {x2: 1} is the solution for c_list. *)
  apply (rule_tac px="x11" and c_t="b" in step3_solve_iter)
   apply (simp)
    (* - to accurately say that a is the solution for b[1/x2], we need to know that b is still in a gamma applied form.
        we can do this because x2 is not a variable in f_sub *)
  apply (rule_tac t="b" and s="apply_zero_crn_list f_sub b" in subst)
   apply (simp add: select_apply_zero_crn_list)
  apply (cut_tac c_list="c_list" and c="LeqCrn2 x11 (SVar x2)" in select_apply_zero_crn)
   apply (simp_all)
  apply (case_tac "f_sub x2")
   apply (auto)
  apply (simp add: comm_sub1_apply_zero_crn_list)
    (* with this we are able to induct on b[1/x2] *)
  apply (rule_tac cscs_ih)
       apply (auto)
    (* - decreasing length *)
     apply (rule_tac t="length (sub1_crn_list b x2)" and s="length b" in subst)
      apply (rule_tac sub1_same_length)
     apply (rule_tac t="length c_list" and s="length (apply_zero_crn_list f_sub c_list)" in subst)
      apply (rule_tac apply_zero_same_length)
     apply (rule_tac select_less_length)
     apply (auto)
    (* - proving f_sub is still a semi-solution *)
    apply (rule_tac sub1_semi_sol_sat)
     apply (rule_tac select_semi_sol)
      apply (auto)
    apply (rule_tac apply_zero_semi_sol_sat)
    apply (auto)
    (* - reversing the identities used toa pply induction to show that a is the solution to b[1/x2] *)
   apply (rule_tac t="apply_zero_crn_list f_sub (sub1_crn_list b x2)"
      and s="sub1_crn_list (apply_zero_crn_list f_sub b) x2" in subst)
    apply (rule_tac comm_sub1_apply_zero_crn_list)
    apply (simp)
   apply (simp add: select_apply_zero_crn_list)
   apply (simp add: complete_sol_calc_def)
    (* - lastly, we must show that p_sub is a solution to b[1/x2]. to do this, we must show that p_sub x2 = Own. *)
  apply (case_tac "p_sub x2 \<noteq> OwnPerm")
   apply (cut_tac p_sub="p_sub" and c_list="apply_zero_crn_list f_sub c_list" and c="LeqCrn2 x11 (SVar x2)" in select_sol_sat_crn)
     apply (auto)
    apply (rule_tac apply_zero_sol_sat)
     apply (simp_all)
   apply (cut_tac f="owner_crn" and c="LeqCrn2 x11 (SVar x2)" in select_cond_sat)
    apply (auto)
   apply (cut_tac p_sub="p_sub" and px="x11" in lbound_eval_permx)
    (* > to prove that p_sub is non-zero over x11, we appeal to the fact that it is in C after the semi-solution is applied *)
    apply (rule_tac ds'="pvar_crn2 (LeqCrn2 x11 (SVar x2))" in subset_nz_sub)
     apply (rule_tac select_nz_sub_crn)
      apply (auto)
    apply (rule_tac apply_zero_nz_sub_clist)
    apply (simp)
   apply (case_tac "eval_permx p_sub x11")
     apply (auto)
   apply (case_tac "p_sub x2")
     apply (auto)
    (* since p_sub x2 = Own, the evaluation will be the same *)
  apply (rule_tac sub1_sol_sat)
   apply (auto)
  apply (rule_tac c_list="apply_zero_crn_list f_sub c_list" in select_sol_sat)
   apply (rule_tac apply_zero_sol_sat)
    apply (simp_all)
  done

definition full_sol_crn2 where
  "full_sol_crn2 c_list = (case min_semi_sol_calc c_list of
    None \<Rightarrow> None
    | Some f_sub \<Rightarrow> (case complete_sol_calc (apply_zero_crn_list f_sub c_list) of
      None \<Rightarrow> None
      | Some o_sub \<Rightarrow> Some (final_sub f_sub o_sub)
  ))"

lemma full_sol_unsat: "\<lbrakk> full_sol_crn2 c_list = None \<rbrakk> \<Longrightarrow> \<not> sol_sat2 p_sub c_list"
    (* if C is satisfiable by some p_sub, p_sub also semi-solves it *)
  apply (simp add: full_sol_crn2_def)
  apply (auto)
  apply (cut_tac p_sub="p_sub" and c_list="c_list" in corr_semi_sol)
   apply (simp_all)
    (* if our algorithm fails at the minimal semi-solution calc, it is unsatisfiable *)
  apply (case_tac "min_semi_sol_calc c_list")
   apply (auto)
   apply (cut_tac f_sub="semi_sol_corr p_sub" and c_list="c_list" in min_semi_sol_calc_unsat)
    apply (auto)
    (* otherwise we have f_sub, the minimal semi-solution *)
  apply (cut_tac f_sub="a" and c_list="c_list" in min_semi_sol_calc_sat)
   apply (simp)
    (* if our algorithm fails at the completion calc, f_sub(C) is unsatisfiable *)
  apply (case_tac "complete_sol_calc (apply_zero_crn_list a c_list)")
   apply (auto)
  apply (cut_tac p_sub="p_sub" and c_list="apply_zero_crn_list a c_list" in complete_sol_calc_unsat)
    apply (simp)
   apply (rule_tac apply_zero_nz_sub_clist)
   apply (simp add: min_semi_sol_def)
    (* if f_sub(C) is unsatisfiable, C is also unsatisfiable since f_sub semi-solves. *)
  apply (cut_tac p_sub="p_sub" and f_sub="a" and c_list="c_list" in apply_zero_sol_sat)
    apply (simp add: min_semi_sol_def)
   apply (simp_all)
  done

lemma full_sol_sat: "\<lbrakk> full_sol_crn2 c_list = Some p_sub; sol_sat2 p_subx c_list \<rbrakk> \<Longrightarrow> sol_sat2 p_sub c_list"
  apply (simp add: full_sol_crn2_def)
  apply (case_tac "min_semi_sol_calc c_list")
   apply (auto)
  apply (case_tac "complete_sol_calc (apply_zero_crn_list a c_list)")
   apply (auto)
    (* f_sub (a) is the minimal semi-solution of c_list *)
  apply (cut_tac f_sub="a" and c_list="c_list" in min_semi_sol_calc_sat)
   apply (simp)
    (* the final substitution is the same as applying f_sub and then applying o_sub, which we can solve using csc_sat *)
  apply (rule_tac final_sub_sol_sat)
  apply (rule_tac p_sub="p_subx" in complete_sol_calc_sat)
     apply (simp add: min_semi_sol_def)
    apply (simp add: min_semi_sol_def)
    apply (auto)
  apply (erule_tac x="semi_sol_corr p_subx" in allE)
  apply (auto)
  apply (cut_tac p_sub="p_subx" and c_list="c_list" in corr_semi_sol)
   apply (auto)
  done

definition solve_crn_list where
  "solve_crn_list c_list = (case reduce_crn_list c_list of
    None \<Rightarrow> False
    | Some c_listx \<Rightarrow> (case full_sol_crn2 c_listx of
      None \<Rightarrow> False
      | Some p_sub \<Rightarrow> sol_sat2 p_sub c_listx
    )
  )"

lemma solve_crn_list_unsat: "\<lbrakk> \<not> solve_crn_list c_list; no_mv_crn c_list \<rbrakk> \<Longrightarrow> \<not> dir_sol_sat t_sub p_sub c_list"
  apply (simp add: solve_crn_list_def)
  apply (case_tac "reduce_crn_list c_list")
   apply (auto)
   apply (cut_tac reduce_crn_list_unsat)
    apply (auto)
  apply (cut_tac p_sub="p_sub" and c_list="c_list" in reduce_crn_list_sat)
     apply (auto)
  apply (case_tac "full_sol_crn2 a")
   apply (auto)
   apply (cut_tac full_sol_unsat)
    apply (auto)
  apply (cut_tac p_sub="aa" and c_list="a" in full_sol_sat)
    apply (auto)
  done

lemma solve_crn_list_sat: "\<lbrakk> solve_crn_list c_list; no_mv_crn c_list \<rbrakk> \<Longrightarrow> (\<exists> t_sub p_sub. dir_sol_sat t_sub p_sub c_list)"
  apply (simp add: solve_crn_list_def)
  apply (case_tac "reduce_crn_list c_list")
   apply (auto)
  apply (case_tac "full_sol_crn2 a")
   apply (auto)
    (* if the solver returns a "checked" solution, since it means the original constraints must be solvable *)
  apply (cut_tac c_list="c_list" and c_listx="a" and p_sub="aa" in reduce_crn_list_satx)
     apply (auto)
  done

end


(*  Title:      HOL/Product_Type.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Cartesian products\<close>

theory Product_Type
  imports Typedef Inductive Fun
  keywords "inductive_set" "coinductive_set" :: thy_decl
begin

subsection \<open>@{typ bool} is a datatype\<close>

free_constructors (discs_sels) case_bool for True | False
  by auto

text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>

setup \<open>Sign.mandatory_path "old"\<close>

old_rep_datatype True False by (auto intro: bool_induct)

setup \<open>Sign.parent_path\<close>

text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>

setup \<open>Sign.mandatory_path "bool"\<close>

lemmas induct = old.bool.induct
lemmas inducts = old.bool.inducts
lemmas rec = old.bool.rec
lemmas simps = bool.distinct bool.case bool.rec

setup \<open>Sign.parent_path\<close>

declare case_split [cases type: bool]
  \<comment> "prefer plain propositional version"

lemma If_case_cert:
  assumes "CASE \<equiv> (\<lambda>b. If b f g)"
  shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
  using assms by simp_all

setup \<open>Code.add_case @{thm If_case_cert}\<close>

code_printing
  constant "HOL.equal :: bool \<Rightarrow> bool \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
| class_instance "bool" :: "equal" \<rightharpoonup> (Haskell) -

subsection \<open>The \<open>unit\<close> type\<close>

typedef unit = "{True}"
  by auto

definition Unity :: unit  ("'(')")
  where "() = Abs_unit True"

lemma unit_eq [no_atp]: "u = ()"
  by (induct u) (simp add: Unity_def)

text \<open>
  Simplification procedure for @{thm [source] unit_eq}.  Cannot use
  this rule directly --- it loops!
\<close>

simproc_setup unit_eq ("x::unit") = \<open>
  fn _ => fn _ => fn ct =>
    if HOLogic.is_unit (Thm.term_of ct) then NONE
    else SOME (mk_meta_eq @{thm unit_eq})
\<close>

free_constructors case_unit for "()"
  by auto

text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>

setup \<open>Sign.mandatory_path "old"\<close>

old_rep_datatype "()" by simp

setup \<open>Sign.parent_path\<close>

text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>

setup \<open>Sign.mandatory_path "unit"\<close>

lemmas induct = old.unit.induct
lemmas inducts = old.unit.inducts
lemmas rec = old.unit.rec
lemmas simps = unit.case unit.rec

setup \<open>Sign.parent_path\<close>

lemma unit_all_eq1: "(\<And>x::unit. PROP P x) \<equiv> PROP P ()"
  by simp

lemma unit_all_eq2: "(\<And>x::unit. PROP P) \<equiv> PROP P"
  by (rule triv_forall_equality)

text \<open>
  This rewrite counters the effect of simproc \<open>unit_eq\<close> on @{term
  [source] "\<lambda>u::unit. f u"}, replacing it by @{term [source]
  f} rather than by @{term [source] "\<lambda>u. f ()"}.
\<close>

lemma unit_abs_eta_conv [simp]: "(\<lambda>u::unit. f ()) = f"
  by (rule ext) simp

lemma UNIV_unit: "UNIV = {()}"
  by auto

instantiation unit :: default
begin

definition "default = ()"

instance ..

end

instantiation unit :: "{complete_boolean_algebra,complete_linorder,wellorder}"
begin

definition less_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
  where "(_::unit) \<le> _ \<longleftrightarrow> True"

lemma less_eq_unit [iff]: "u \<le> v" for u v :: unit
  by (simp add: less_eq_unit_def)

definition less_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
  where "(_::unit) < _ \<longleftrightarrow> False"

lemma less_unit [iff]: "\<not> u < v" for u v :: unit
  by (simp_all add: less_eq_unit_def less_unit_def)

definition bot_unit :: unit
  where [code_unfold]: "\<bottom> = ()"

definition top_unit :: unit
  where [code_unfold]: "\<top> = ()"

definition inf_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
  where [simp]: "_ \<sqinter> _ = ()"

definition sup_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
  where [simp]: "_ \<squnion> _ = ()"

definition Inf_unit :: "unit set \<Rightarrow> unit"
  where [simp]: "\<Sqinter>_ = ()"

definition Sup_unit :: "unit set \<Rightarrow> unit"
  where [simp]: "\<Squnion>_ = ()"

definition uminus_unit :: "unit \<Rightarrow> unit"
  where [simp]: "- _ = ()"

declare less_eq_unit_def [abs_def, code_unfold]
  less_unit_def [abs_def, code_unfold]
  inf_unit_def [abs_def, code_unfold]
  sup_unit_def [abs_def, code_unfold]
  Inf_unit_def [abs_def, code_unfold]
  Sup_unit_def [abs_def, code_unfold]
  uminus_unit_def [abs_def, code_unfold]

instance
  by intro_classes auto

end

lemma [code]: "HOL.equal u v \<longleftrightarrow> True" for u v :: unit
  unfolding equal unit_eq [of u] unit_eq [of v] by rule+

code_printing
  type_constructor unit \<rightharpoonup>
    (SML) "unit"
    and (OCaml) "unit"
    and (Haskell) "()"
    and (Scala) "Unit"
| constant Unity \<rightharpoonup>
    (SML) "()"
    and (OCaml) "()"
    and (Haskell) "()"
    and (Scala) "()"
| class_instance unit :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: unit \<Rightarrow> unit \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="

code_reserved SML
  unit

code_reserved OCaml
  unit

code_reserved Scala
  Unit

subsection \<open>The product type\<close>

subsubsection \<open>Type definition\<close>

definition Pair_Rep :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  where "Pair_Rep a b = (\<lambda>x y. x = a \<and> y = b)"

definition "prod = {f. \<exists>a b. f = Pair_Rep (a::'a) (b::'b)}"

typedef ('a, 'b) prod ("(_ \<times>/ _)" [21, 20] 20) = "prod :: ('a \<Rightarrow> 'b \<Rightarrow> bool) set"
  unfolding prod_def by auto

type_notation (ASCII)
  prod  (infixr "*" 20)

definition Pair :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<times> 'b"
  where "Pair a b = Abs_prod (Pair_Rep a b)"

lemma prod_cases: "(\<And>a b. P (Pair a b)) \<Longrightarrow> P p"
  by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)

free_constructors case_prod for Pair fst snd
proof -
  fix P :: bool and p :: "'a \<times> 'b"
  show "(\<And>x1 x2. p = Pair x1 x2 \<Longrightarrow> P) \<Longrightarrow> P"
    by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)
next
  fix a c :: 'a and b d :: 'b
  have "Pair_Rep a b = Pair_Rep c d \<longleftrightarrow> a = c \<and> b = d"
    by (auto simp add: Pair_Rep_def fun_eq_iff)
  moreover have "Pair_Rep a b \<in> prod" and "Pair_Rep c d \<in> prod"
    by (auto simp add: prod_def)
  ultimately show "Pair a b = Pair c d \<longleftrightarrow> a = c \<and> b = d"
    by (simp add: Pair_def Abs_prod_inject)
qed

text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>

setup \<open>Sign.mandatory_path "old"\<close>

old_rep_datatype Pair
  by (erule prod_cases) (rule prod.inject)

setup \<open>Sign.parent_path\<close>

text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>

setup \<open>Sign.mandatory_path "prod"\<close>

declare old.prod.inject [iff del]

lemmas induct = old.prod.induct
lemmas inducts = old.prod.inducts
lemmas rec = old.prod.rec
lemmas simps = prod.inject prod.case prod.rec

setup \<open>Sign.parent_path\<close>

declare prod.case [nitpick_simp del]
declare old.prod.case_cong_weak [cong del]
declare prod.case_eq_if [mono]
declare prod.split [no_atp]
declare prod.split_asm [no_atp]

text \<open>
  @{thm [source] prod.split} could be declared as \<open>[split]\<close>
  done after the Splitter has been speeded up significantly;
  precompute the constants involved and don't do anything unless the
  current goal contains one of those constants.
\<close>

subsubsection \<open>Tuple syntax\<close>

text \<open>
  Patterns -- extends pre-defined type @{typ pttrn} used in
  abstractions.
\<close>

nonterminal tuple_args and patterns
syntax
  "_tuple"      :: "'a \<Rightarrow> tuple_args \<Rightarrow> 'a \<times> 'b"        ("(1'(_,/ _'))")
  "_tuple_arg"  :: "'a \<Rightarrow> tuple_args"                   ("_")
  "_tuple_args" :: "'a \<Rightarrow> tuple_args \<Rightarrow> tuple_args"     ("_,/ _")
  "_pattern"    :: "pttrn \<Rightarrow> patterns \<Rightarrow> pttrn"         ("'(_,/ _')")
  ""            :: "pttrn \<Rightarrow> patterns"                  ("_")
  "_patterns"   :: "pttrn \<Rightarrow> patterns \<Rightarrow> patterns"      ("_,/ _")
  "_unit"       :: pttrn                                ("'(')")
translations
  "(x, y)" \<rightleftharpoons> "CONST Pair x y"
  "_pattern x y" \<rightleftharpoons> "CONST Pair x y"
  "_patterns x y" \<rightleftharpoons> "CONST Pair x y"
  "_tuple x (_tuple_args y z)" \<rightleftharpoons> "_tuple x (_tuple_arg (_tuple y z))"
  "\<lambda>(x, y, zs). b" \<rightleftharpoons> "CONST case_prod (\<lambda>x (y, zs). b)"
  "\<lambda>(x, y). b" \<rightleftharpoons> "CONST case_prod (\<lambda>x y. b)"
  "_abs (CONST Pair x y) t" \<rightharpoonup> "\<lambda>(x, y). t"
  \<comment> \<open>This rule accommodates tuples in \<open>case C \<dots> (x, y) \<dots> \<Rightarrow> \<dots>\<close>:
     The \<open>(x, y)\<close> is parsed as \<open>Pair x y\<close> because it is \<open>logic\<close>,
     not \<open>pttrn\<close>.\<close>
  "\<lambda>(). b" \<rightleftharpoons> "CONST case_unit b"
  "_abs (CONST Unity) t" \<rightharpoonup> "\<lambda>(). t"

text \<open>print @{term "case_prod f"} as @{term "\<lambda>(x, y). f x y"} and
  @{term "case_prod (\<lambda>x. f x)"} as @{term "\<lambda>(x, y). f x y"}\<close>

typed_print_translation \<open>
  let
    fun case_prod_guess_names_tr' T [Abs (x, _, Abs _)] = raise Match
      | case_prod_guess_names_tr' T [Abs (x, xT, t)] =
          (case (head_of t) of
            Const (@{const_syntax case_prod}, _) => raise Match
          | _ =>
            let
              val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
              val (y, t') = Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0);
              val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, xT, t');
            in
              Syntax.const @{syntax_const "_abs"} $
                (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
            end)
      | case_prod_guess_names_tr' T [t] =
          (case head_of t of
            Const (@{const_syntax case_prod}, _) => raise Match
          | _ =>
            let
              val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
              val (y, t') =
                Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0);
              val (x', t'') = Syntax_Trans.atomic_abs_tr' ("x", xT, t');
            in
              Syntax.const @{syntax_const "_abs"} $
                (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
            end)
      | case_prod_guess_names_tr' _ _ = raise Match;
  in [(@{const_syntax case_prod}, K case_prod_guess_names_tr')] end
\<close>

text \<open>Reconstruct pattern from (nested) @{const case_prod}s,
  avoiding eta-contraction of body; required for enclosing "let",
  if "let" does not avoid eta-contraction, which has been observed to occur.\<close>

print_translation \<open>
  let
    fun case_prod_tr' [Abs (x, T, t as (Abs abs))] =
          (* case_prod (\<lambda>x y. t) \<Rightarrow> \<lambda>(x, y) t *)
          let
            val (y, t') = Syntax_Trans.atomic_abs_tr' abs;
            val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
          in
            Syntax.const @{syntax_const "_abs"} $
              (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
          end
      | case_prod_tr' [Abs (x, T, (s as Const (@{const_syntax case_prod}, _) $ t))] =
          (* case_prod (\<lambda>x. (case_prod (\<lambda>y z. t))) \<Rightarrow> \<lambda>(x, y, z). t *)
          let
            val Const (@{syntax_const "_abs"}, _) $
              (Const (@{syntax_const "_pattern"}, _) $ y $ z) $ t' =
                case_prod_tr' [t];
            val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
          in
            Syntax.const @{syntax_const "_abs"} $
              (Syntax.const @{syntax_const "_pattern"} $ x' $
                (Syntax.const @{syntax_const "_patterns"} $ y $ z)) $ t''
          end
      | case_prod_tr' [Const (@{const_syntax case_prod}, _) $ t] =
          (* case_prod (case_prod (\<lambda>x y z. t)) \<Rightarrow> \<lambda>((x, y), z). t *)
          case_prod_tr' [(case_prod_tr' [t])]
            (* inner case_prod_tr' creates next pattern *)
      | case_prod_tr' [Const (@{syntax_const "_abs"}, _) $ x_y $ Abs abs] =
          (* case_prod (\<lambda>pttrn z. t) \<Rightarrow> \<lambda>(pttrn, z). t *)
          let val (z, t) = Syntax_Trans.atomic_abs_tr' abs in
            Syntax.const @{syntax_const "_abs"} $
              (Syntax.const @{syntax_const "_pattern"} $ x_y $ z) $ t
          end
      | case_prod_tr' _ = raise Match;
  in [(@{const_syntax case_prod}, K case_prod_tr')] end
\<close>

subsubsection \<open>Code generator setup\<close>

code_printing
  type_constructor prod \<rightharpoonup>
    (SML) infix 2 "*"
    and (OCaml) infix 2 "*"
    and (Haskell) "!((_),/ (_))"
    and (Scala) "((_),/ (_))"
| constant Pair \<rightharpoonup>
    (SML) "!((_),/ (_))"
    and (OCaml) "!((_),/ (_))"
    and (Haskell) "!((_),/ (_))"
    and (Scala) "!((_),/ (_))"
| class_instance  prod :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="
| constant fst \<rightharpoonup> (Haskell) "fst"
| constant snd \<rightharpoonup> (Haskell) "snd"

subsubsection \<open>Fundamental operations and properties\<close>

lemma Pair_inject: "(a, b) = (a', b') \<Longrightarrow> (a = a' \<Longrightarrow> b = b' \<Longrightarrow> R) \<Longrightarrow> R"
  by simp

lemma surj_pair [simp]: "\<exists>x y. p = (x, y)"
  by (cases p) simp

lemma fst_eqD: "fst (x, y) = a \<Longrightarrow> x = a"
  by simp

lemma snd_eqD: "snd (x, y) = a \<Longrightarrow> y = a"
  by simp

lemma case_prod_unfold [nitpick_unfold]: "case_prod = (\<lambda>c p. c (fst p) (snd p))"
  by (simp add: fun_eq_iff split: prod.split)

lemma case_prod_conv [simp, code]: "(case (a, b) of (c, d) \<Rightarrow> f c d) = f a b"
  by (fact prod.case)

lemmas surjective_pairing = prod.collapse [symmetric]

lemma prod_eq_iff: "s = t \<longleftrightarrow> fst s = fst t \<and> snd s = snd t"
  by (cases s, cases t) simp

lemma prod_eqI [intro?]: "fst p = fst q \<Longrightarrow> snd p = snd q \<Longrightarrow> p = q"
  by (simp add: prod_eq_iff)

lemma case_prodI: "f a b \<Longrightarrow> case (a, b) of (c, d) \<Rightarrow> f c d"
  by (rule prod.case [THEN iffD2])

lemma case_prodD: "(case (a, b) of (c, d) \<Rightarrow> f c d) \<Longrightarrow> f a b"
  by (rule prod.case [THEN iffD1])

lemma case_prod_Pair [simp]: "case_prod Pair = id"
  by (simp add: fun_eq_iff split: prod.split)

lemma case_prod_eta: "(\<lambda>(x, y). f (x, y)) = f"
  \<comment> \<open>Subsumes the old \<open>split_Pair\<close> when @{term f} is the identity function.\<close>
  by (simp add: fun_eq_iff split: prod.split)

lemma case_prod_comp: "(case x of (a, b) \<Rightarrow> (f \<circ> g) a b) = f (g (fst x)) (snd x)"
  by (cases x) simp

lemma The_case_prod: "The (case_prod P) = (THE xy. P (fst xy) (snd xy))"
  by (simp add: case_prod_unfold)

lemma cond_case_prod_eta: "(\<And>x y. f x y = g (x, y)) \<Longrightarrow> (\<lambda>(x, y). f x y) = g"
  by (simp add: case_prod_eta)

lemma split_paired_all [no_atp]: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))"
proof
  fix a b
  assume "\<And>x. PROP P x"
  then show "PROP P (a, b)" .
next
  fix x
  assume "\<And>a b. PROP P (a, b)"
  from \<open>PROP P (fst x, snd x)\<close> show "PROP P x" by simp
qed

text \<open>
  The rule @{thm [source] split_paired_all} does not work with the
  Simplifier because it also affects premises in congrence rules,
  where this can lead to premises of the form \<open>\<And>a b. \<dots> = ?P(a, b)\<close>
  which cannot be solved by reflexivity.
\<close>

lemmas split_tupled_all = split_paired_all unit_all_eq2

ML \<open>
  (* replace parameters of product type by individual component parameters *)
  local (* filtering with exists_paired_all is an essential optimization *)
    fun exists_paired_all (Const (@{const_name Pure.all}, _) $ Abs (_, T, t)) =
          can HOLogic.dest_prodT T orelse exists_paired_all t
      | exists_paired_all (t $ u) = exists_paired_all t orelse exists_paired_all u
      | exists_paired_all (Abs (_, _, t)) = exists_paired_all t
      | exists_paired_all _ = false;
    val ss =
      simpset_of
       (put_simpset HOL_basic_ss @{context}
        addsimps [@{thm split_paired_all}, @{thm unit_all_eq2}, @{thm unit_abs_eta_conv}]
        addsimprocs [@{simproc unit_eq}]);
  in
    fun split_all_tac ctxt = SUBGOAL (fn (t, i) =>
      if exists_paired_all t then safe_full_simp_tac (put_simpset ss ctxt) i else no_tac);

    fun unsafe_split_all_tac ctxt = SUBGOAL (fn (t, i) =>
      if exists_paired_all t then full_simp_tac (put_simpset ss ctxt) i else no_tac);

    fun split_all ctxt th =
      if exists_paired_all (Thm.prop_of th)
      then full_simplify (put_simpset ss ctxt) th else th;
  end;
\<close>

setup \<open>map_theory_claset (fn ctxt => ctxt addSbefore ("split_all_tac", split_all_tac))\<close>

lemma split_paired_All [simp, no_atp]: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>a b. P (a, b))"
  \<comment> \<open>\<open>[iff]\<close> is not a good idea because it makes \<open>blast\<close> loop\<close>
  by fast

lemma split_paired_Ex [simp, no_atp]: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>a b. P (a, b))"
  by fast

lemma split_paired_The [no_atp]: "(THE x. P x) = (THE (a, b). P (a, b))"
  \<comment> \<open>Can't be added to simpset: loops!\<close>
  by (simp add: case_prod_eta)

text \<open>
  Simplification procedure for @{thm [source] cond_case_prod_eta}.  Using
  @{thm [source] case_prod_eta} as a rewrite rule is not general enough,
  and using @{thm [source] cond_case_prod_eta} directly would render some
  existing proofs very inefficient; similarly for \<open>prod.case_eq_if\<close>.
\<close>

ML \<open>
local
  val cond_case_prod_eta_ss =
    simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms cond_case_prod_eta});
  fun Pair_pat k 0 (Bound m) = (m = k)
    | Pair_pat k i (Const (@{const_name Pair},  _) $ Bound m $ t) =
        i > 0 andalso m = k + i andalso Pair_pat k (i - 1) t
    | Pair_pat _ _ _ = false;
  fun no_args k i (Abs (_, _, t)) = no_args (k + 1) i t
    | no_args k i (t $ u) = no_args k i t andalso no_args k i u
    | no_args k i (Bound m) = m < k orelse m > k + i
    | no_args _ _ _ = true;
  fun split_pat tp i (Abs  (_, _, t)) = if tp 0 i t then SOME (i, t) else NONE
    | split_pat tp i (Const (@{const_name case_prod}, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t
    | split_pat tp i _ = NONE;
  fun metaeq ctxt lhs rhs = mk_meta_eq (Goal.prove ctxt [] []
        (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)))
        (K (simp_tac (put_simpset cond_case_prod_eta_ss ctxt) 1)));

  fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k + 1) i t
    | beta_term_pat k i (t $ u) =
        Pair_pat k i (t $ u) orelse (beta_term_pat k i t andalso beta_term_pat k i u)
    | beta_term_pat k i t = no_args k i t;
  fun eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg
    | eta_term_pat _ _ _ = false;
  fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t)
    | subst arg k i (t $ u) =
        if Pair_pat k i (t $ u) then incr_boundvars k arg
        else (subst arg k i t $ subst arg k i u)
    | subst arg k i t = t;
in
  fun beta_proc ctxt (s as Const (@{const_name case_prod}, _) $ Abs (_, _, t) $ arg) =
        (case split_pat beta_term_pat 1 t of
          SOME (i, f) => SOME (metaeq ctxt s (subst arg 0 i f))
        | NONE => NONE)
    | beta_proc _ _ = NONE;
  fun eta_proc ctxt (s as Const (@{const_name case_prod}, _) $ Abs (_, _, t)) =
        (case split_pat eta_term_pat 1 t of
          SOME (_, ft) => SOME (metaeq ctxt s (let val f $ _ = ft in f end))
        | NONE => NONE)
    | eta_proc _ _ = NONE;
end;
\<close>
simproc_setup case_prod_beta ("case_prod f z") =
  \<open>fn _ => fn ctxt => fn ct => beta_proc ctxt (Thm.term_of ct)\<close>
simproc_setup case_prod_eta ("case_prod f") =
  \<open>fn _ => fn ctxt => fn ct => eta_proc ctxt (Thm.term_of ct)\<close>

lemma case_prod_beta': "(\<lambda>(x,y). f x y) = (\<lambda>x. f (fst x) (snd x))"
  by (auto simp: fun_eq_iff)

text \<open>
  \<^medskip> @{const case_prod} used as a logical connective or set former.

  \<^medskip> These rules are for use with \<open>blast\<close>; could instead
  call \<open>simp\<close> using @{thm [source] prod.split} as rewrite.\<close>

lemma case_prodI2:
  "\<And>p. (\<And>a b. p = (a, b) \<Longrightarrow> c a b) \<Longrightarrow> case p of (a, b) \<Rightarrow> c a b"
  by (simp add: split_tupled_all)

lemma case_prodI2':
  "\<And>p. (\<And>a b. (a, b) = p \<Longrightarrow> c a b x) \<Longrightarrow> (case p of (a, b) \<Rightarrow> c a b) x"
  by (simp add: split_tupled_all)

lemma case_prodE [elim!]:
  "(case p of (a, b) \<Rightarrow> c a b) \<Longrightarrow> (\<And>x y. p = (x, y) \<Longrightarrow> c x y \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (induct p) simp

lemma case_prodE' [elim!]:
  "(case p of (a, b) \<Rightarrow> c a b) z \<Longrightarrow> (\<And>x y. p = (x, y) \<Longrightarrow> c x y z \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (induct p) simp

lemma case_prodE2:
  assumes q: "Q (case z of (a, b) \<Rightarrow> P a b)"
    and r: "\<And>x y. z = (x, y) \<Longrightarrow> Q (P x y) \<Longrightarrow> R"
  shows R
proof (rule r)
  show "z = (fst z, snd z)" by simp
  then show "Q (P (fst z) (snd z))"
    using q by (simp add: case_prod_unfold)
qed

lemma case_prodD': "(case (a, b) of (c, d) \<Rightarrow> R c d) c \<Longrightarrow> R a b c"
  by simp

lemma mem_case_prodI: "z \<in> c a b \<Longrightarrow> z \<in> (case (a, b) of (d, e) \<Rightarrow> c d e)"
  by simp

lemma mem_case_prodI2 [intro!]:
  "\<And>p. (\<And>a b. p = (a, b) \<Longrightarrow> z \<in> c a b) \<Longrightarrow> z \<in> (case p of (a, b) \<Rightarrow> c a b)"
  by (simp only: split_tupled_all) simp

declare mem_case_prodI [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
declare case_prodI2' [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
declare case_prodI2 [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
declare case_prodI [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>

lemma mem_case_prodE [elim!]:
  assumes "z \<in> case_prod c p"
  obtains x y where "p = (x, y)" and "z \<in> c x y"
  using assms by (rule case_prodE2)

ML \<open>
local (* filtering with exists_p_split is an essential optimization *)
  fun exists_p_split (Const (@{const_name case_prod},_) $ _ $ (Const (@{const_name Pair},_)$_$_)) = true
    | exists_p_split (t $ u) = exists_p_split t orelse exists_p_split u
    | exists_p_split (Abs (_, _, t)) = exists_p_split t
    | exists_p_split _ = false;
in
  fun split_conv_tac ctxt = SUBGOAL (fn (t, i) =>
    if exists_p_split t
    then safe_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms case_prod_conv}) i
    else no_tac);
end;
\<close>

(* This prevents applications of splitE for already splitted arguments leading
   to quite time-consuming computations (in particular for nested tuples) *)
setup \<open>map_theory_claset (fn ctxt => ctxt addSbefore ("split_conv_tac", split_conv_tac))\<close>

lemma split_eta_SetCompr [simp, no_atp]: "(\<lambda>u. \<exists>x y. u = (x, y) \<and> P (x, y)) = P"
  by (rule ext) fast

lemma split_eta_SetCompr2 [simp, no_atp]: "(\<lambda>u. \<exists>x y. u = (x, y) \<and> P x y) = case_prod P"
  by (rule ext) fast

lemma split_part [simp]: "(\<lambda>(a,b). P \<and> Q a b) = (\<lambda>ab. P \<and> case_prod Q ab)"
  \<comment> \<open>Allows simplifications of nested splits in case of independent predicates.\<close>
  by (rule ext) blast

(* Do NOT make this a simp rule as it
   a) only helps in special situations
   b) can lead to nontermination in the presence of split_def
*)
lemma split_comp_eq:
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
    and g :: "'d \<Rightarrow> 'a"
  shows "(\<lambda>u. f (g (fst u)) (snd u)) = case_prod (\<lambda>x. f (g x))"
  by (rule ext) auto

lemma pair_imageI [intro]: "(a, b) \<in> A \<Longrightarrow> f a b \<in> (\<lambda>(a, b). f a b) ` A"
  by (rule image_eqI [where x = "(a, b)"]) auto

lemma The_split_eq [simp]: "(THE (x',y'). x = x' \<and> y = y') = (x, y)"
  by blast

(*
the following  would be slightly more general,
but cannot be used as rewrite rule:
### Cannot add premise as rewrite rule because it contains (type) unknowns:
### ?y = .x
Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)"
by (rtac some_equality 1)
by ( Simp_tac 1)
by (split_all_tac 1)
by (Asm_full_simp_tac 1)
qed "The_split_eq";
*)

lemma case_prod_beta: "case_prod f p = f (fst p) (snd p)"
  by (fact prod.case_eq_if)

lemma prod_cases3 [cases type]:
  obtains (fields) a b c where "y = (a, b, c)"
  by (cases y, case_tac b) blast

lemma prod_induct3 [case_names fields, induct type]:
  "(\<And>a b c. P (a, b, c)) \<Longrightarrow> P x"
  by (cases x) blast

lemma prod_cases4 [cases type]:
  obtains (fields) a b c d where "y = (a, b, c, d)"
  by (cases y, case_tac c) blast

lemma prod_induct4 [case_names fields, induct type]:
  "(\<And>a b c d. P (a, b, c, d)) \<Longrightarrow> P x"
  by (cases x) blast

lemma prod_cases5 [cases type]:
  obtains (fields) a b c d e where "y = (a, b, c, d, e)"
  by (cases y, case_tac d) blast

lemma prod_induct5 [case_names fields, induct type]:
  "(\<And>a b c d e. P (a, b, c, d, e)) \<Longrightarrow> P x"
  by (cases x) blast

lemma prod_cases6 [cases type]:
  obtains (fields) a b c d e f where "y = (a, b, c, d, e, f)"
  by (cases y, case_tac e) blast

lemma prod_induct6 [case_names fields, induct type]:
  "(\<And>a b c d e f. P (a, b, c, d, e, f)) \<Longrightarrow> P x"
  by (cases x) blast

lemma prod_cases7 [cases type]:
  obtains (fields) a b c d e f g where "y = (a, b, c, d, e, f, g)"
  by (cases y, case_tac f) blast

lemma prod_induct7 [case_names fields, induct type]:
  "(\<And>a b c d e f g. P (a, b, c, d, e, f, g)) \<Longrightarrow> P x"
  by (cases x) blast

definition internal_case_prod :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c"
  where "internal_case_prod \<equiv> case_prod"

lemma internal_case_prod_conv: "internal_case_prod c (a, b) = c a b"
  by (simp only: internal_case_prod_def case_prod_conv)

ML_file "Tools/split_rule.ML"

hide_const internal_case_prod

subsubsection \<open>Derived operations\<close>

definition curry :: "('a \<times> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c"
  where "curry = (\<lambda>c x y. c (x, y))"

lemma curry_conv [simp, code]: "curry f a b = f (a, b)"
  by (simp add: curry_def)

lemma curryI [intro!]: "f (a, b) \<Longrightarrow> curry f a b"
  by (simp add: curry_def)

lemma curryD [dest!]: "curry f a b \<Longrightarrow> f (a, b)"
  by (simp add: curry_def)

lemma curryE: "curry f a b \<Longrightarrow> (f (a, b) \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (simp add: curry_def)

lemma curry_case_prod [simp]: "curry (case_prod f) = f"
  by (simp add: curry_def case_prod_unfold)

lemma case_prod_curry [simp]: "case_prod (curry f) = f"
  by (simp add: curry_def case_prod_unfold)

lemma curry_K: "curry (\<lambda>x. c) = (\<lambda>x y. c)"
  by (simp add: fun_eq_iff)

text \<open>The composition-uncurry combinator.\<close>

notation fcomp (infixl "\<circ>>" 60)

definition scomp :: "('a \<Rightarrow> 'b \<times> 'c) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd"  (infixl "\<circ>\<rightarrow>" 60)
  where "f \<circ>\<rightarrow> g = (\<lambda>x. case_prod g (f x))"

lemma scomp_unfold: "scomp = (\<lambda>f g x. g (fst (f x)) (snd (f x)))"
  by (simp add: fun_eq_iff scomp_def case_prod_unfold)

lemma scomp_apply [simp]: "(f \<circ>\<rightarrow> g) x = case_prod g (f x)"
  by (simp add: scomp_unfold case_prod_unfold)

lemma Pair_scomp: "Pair x \<circ>\<rightarrow> f = f x"
  by (simp add: fun_eq_iff)

lemma scomp_Pair: "x \<circ>\<rightarrow> Pair = x"
  by (simp add: fun_eq_iff)

lemma scomp_scomp: "(f \<circ>\<rightarrow> g) \<circ>\<rightarrow> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>\<rightarrow> h)"
  by (simp add: fun_eq_iff scomp_unfold)

lemma scomp_fcomp: "(f \<circ>\<rightarrow> g) \<circ>> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>> h)"
  by (simp add: fun_eq_iff scomp_unfold fcomp_def)

lemma fcomp_scomp: "(f \<circ>> g) \<circ>\<rightarrow> h = f \<circ>> (g \<circ>\<rightarrow> h)"
  by (simp add: fun_eq_iff scomp_unfold)

code_printing
  constant scomp \<rightharpoonup> (Eval) infixl 3 "#->"

no_notation fcomp (infixl "\<circ>>" 60)
no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

text \<open>
  @{term map_prod} --- action of the product functor upon functions.
\<close>

definition map_prod :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'd"
  where "map_prod f g = (\<lambda>(x, y). (f x, g y))"

lemma map_prod_simp [simp, code]: "map_prod f g (a, b) = (f a, g b)"
  by (simp add: map_prod_def)

functor map_prod: map_prod
  by (auto simp add: split_paired_all)

lemma fst_map_prod [simp]: "fst (map_prod f g x) = f (fst x)"
  by (cases x) simp_all

lemma snd_map_prod [simp]: "snd (map_prod f g x) = g (snd x)"
  by (cases x) simp_all

lemma fst_comp_map_prod [simp]: "fst \<circ> map_prod f g = f \<circ> fst"
  by (rule ext) simp_all

lemma snd_comp_map_prod [simp]: "snd \<circ> map_prod f g = g \<circ> snd"
  by (rule ext) simp_all

lemma map_prod_compose: "map_prod (f1 \<circ> f2) (g1 \<circ> g2) = (map_prod f1 g1 \<circ> map_prod f2 g2)"
  by (rule ext) (simp add: map_prod.compositionality comp_def)

lemma map_prod_ident [simp]: "map_prod (\<lambda>x. x) (\<lambda>y. y) = (\<lambda>z. z)"
  by (rule ext) (simp add: map_prod.identity)

lemma map_prod_imageI [intro]: "(a, b) \<in> R \<Longrightarrow> (f a, g b) \<in> map_prod f g ` R"
  by (rule image_eqI) simp_all

lemma prod_fun_imageE [elim!]:
  assumes major: "c \<in> map_prod f g ` R"
    and cases: "\<And>x y. c = (f x, g y) \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> P"
  shows P
  apply (rule major [THEN imageE])
  apply (case_tac x)
  apply (rule cases)
   apply simp_all
  done

definition apfst :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'b"
  where "apfst f = map_prod f id"

definition apsnd :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'c"
  where "apsnd f = map_prod id f"

lemma apfst_conv [simp, code]: "apfst f (x, y) = (f x, y)"
  by (simp add: apfst_def)

lemma apsnd_conv [simp, code]: "apsnd f (x, y) = (x, f y)"
  by (simp add: apsnd_def)

lemma fst_apfst [simp]: "fst (apfst f x) = f (fst x)"
  by (cases x) simp

lemma fst_comp_apfst [simp]: "fst \<circ> apfst f = f \<circ> fst"
  by (simp add: fun_eq_iff)

lemma fst_apsnd [simp]: "fst (apsnd f x) = fst x"
  by (cases x) simp

lemma fst_comp_apsnd [simp]: "fst \<circ> apsnd f = fst"
  by (simp add: fun_eq_iff)

lemma snd_apfst [simp]: "snd (apfst f x) = snd x"
  by (cases x) simp

lemma snd_comp_apfst [simp]: "snd \<circ> apfst f = snd"
  by (simp add: fun_eq_iff)

lemma snd_apsnd [simp]: "snd (apsnd f x) = f (snd x)"
  by (cases x) simp

lemma snd_comp_apsnd [simp]: "snd \<circ> apsnd f = f \<circ> snd"
  by (simp add: fun_eq_iff)

lemma apfst_compose: "apfst f (apfst g x) = apfst (f \<circ> g) x"
  by (cases x) simp

lemma apsnd_compose: "apsnd f (apsnd g x) = apsnd (f \<circ> g) x"
  by (cases x) simp

lemma apfst_apsnd [simp]: "apfst f (apsnd g x) = (f (fst x), g (snd x))"
  by (cases x) simp

lemma apsnd_apfst [simp]: "apsnd f (apfst g x) = (g (fst x), f (snd x))"
  by (cases x) simp

lemma apfst_id [simp]: "apfst id = id"
  by (simp add: fun_eq_iff)

lemma apsnd_id [simp]: "apsnd id = id"
  by (simp add: fun_eq_iff)

lemma apfst_eq_conv [simp]: "apfst f x = apfst g x \<longleftrightarrow> f (fst x) = g (fst x)"
  by (cases x) simp

lemma apsnd_eq_conv [simp]: "apsnd f x = apsnd g x \<longleftrightarrow> f (snd x) = g (snd x)"
  by (cases x) simp

lemma apsnd_apfst_commute: "apsnd f (apfst g p) = apfst g (apsnd f p)"
  by simp

context
begin

local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "prod")\<close>

definition swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a"
  where "swap p = (snd p, fst p)"

end

lemma swap_simp [simp]: "prod.swap (x, y) = (y, x)"
  by (simp add: prod.swap_def)

lemma swap_swap [simp]: "prod.swap (prod.swap p) = p"
  by (cases p) simp

lemma swap_comp_swap [simp]: "prod.swap \<circ> prod.swap = id"
  by (simp add: fun_eq_iff)

lemma pair_in_swap_image [simp]: "(y, x) \<in> prod.swap ` A \<longleftrightarrow> (x, y) \<in> A"
  by (auto intro!: image_eqI)

lemma inj_swap [simp]: "inj_on prod.swap A"
  by (rule inj_onI) auto

lemma swap_inj_on: "inj_on (\<lambda>(i, j). (j, i)) A"
  by (rule inj_onI) auto

lemma surj_swap [simp]: "surj prod.swap"
  by (rule surjI [of _ prod.swap]) simp

lemma bij_swap [simp]: "bij prod.swap"
  by (simp add: bij_def)

lemma case_swap [simp]: "(case prod.swap p of (y, x) \<Rightarrow> f x y) = (case p of (x, y) \<Rightarrow> f x y)"
  by (cases p) simp

lemma fst_swap [simp]: "fst (prod.swap x) = snd x"
  by (cases x) simp

lemma snd_swap [simp]: "snd (prod.swap x) = fst x"
  by (cases x) simp

text \<open>Disjoint union of a family of sets -- Sigma.\<close>

definition Sigma :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set"
  where "Sigma A B \<equiv> \<Union>x\<in>A. \<Union>y\<in>B x. {Pair x y}"

abbreviation Times :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"  (infixr "\<times>" 80)
  where "A \<times> B \<equiv> Sigma A (\<lambda>_. B)"

hide_const (open) Times

syntax
  "_Sigma" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"  ("(3SIGMA _:_./ _)" [0, 0, 10] 10)
translations
  "SIGMA x:A. B" \<rightleftharpoons> "CONST Sigma A (\<lambda>x. B)"

lemma SigmaI [intro!]: "a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> (a, b) \<in> Sigma A B"
  unfolding Sigma_def by blast

lemma SigmaE [elim!]: "c \<in> Sigma A B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> c = (x, y) \<Longrightarrow> P) \<Longrightarrow> P"
  \<comment> \<open>The general elimination rule.\<close>
  unfolding Sigma_def by blast

text \<open>
  Elimination of @{term "(a, b) \<in> A \<times> B"} -- introduces no
  eigenvariables.
\<close>

lemma SigmaD1: "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A"
  by blast

lemma SigmaD2: "(a, b) \<in> Sigma A B \<Longrightarrow> b \<in> B a"
  by blast

lemma SigmaE2: "(a, b) \<in> Sigma A B \<Longrightarrow> (a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> P) \<Longrightarrow> P"
  by blast

lemma Sigma_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (SIGMA x:A. C x) = (SIGMA x:B. D x)"
  by auto

lemma Sigma_mono: "A \<subseteq> C \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> D x) \<Longrightarrow> Sigma A B \<subseteq> Sigma C D"
  by blast

lemma Sigma_empty1 [simp]: "Sigma {} B = {}"
  by blast

lemma Sigma_empty2 [simp]: "A \<times> {} = {}"
  by blast

lemma UNIV_Times_UNIV [simp]: "UNIV \<times> UNIV = UNIV"
  by auto

lemma Compl_Times_UNIV1 [simp]: "- (UNIV \<times> A) = UNIV \<times> (-A)"
  by auto

lemma Compl_Times_UNIV2 [simp]: "- (A \<times> UNIV) = (-A) \<times> UNIV"
  by auto

lemma mem_Sigma_iff [iff]: "(a, b) \<in> Sigma A B \<longleftrightarrow> a \<in> A \<and> b \<in> B a"
  by blast

lemma mem_Times_iff: "x \<in> A \<times> B \<longleftrightarrow> fst x \<in> A \<and> snd x \<in> B"
  by (induct x) simp

lemma Sigma_empty_iff: "(SIGMA i:I. X i) = {} \<longleftrightarrow> (\<forall>i\<in>I. X i = {})"
  by auto

lemma Times_subset_cancel2: "x \<in> C \<Longrightarrow> A \<times> C \<subseteq> B \<times> C \<longleftrightarrow> A \<subseteq> B"
  by blast

lemma Times_eq_cancel2: "x \<in> C \<Longrightarrow> A \<times> C = B \<times> C \<longleftrightarrow> A = B"
  by (blast elim: equalityE)

lemma Collect_case_prod_Sigma: "{(x, y). P x \<and> Q x y} = (SIGMA x:Collect P. Collect (Q x))"
  by blast

lemma Collect_case_prod [simp]: "{(a, b). P a \<and> Q b} = Collect P \<times> Collect Q "
  by (fact Collect_case_prod_Sigma)

lemma Collect_case_prodD: "x \<in> Collect (case_prod A) \<Longrightarrow> A (fst x) (snd x)"
  by auto

lemma Collect_case_prod_mono: "A \<le> B \<Longrightarrow> Collect (case_prod A) \<subseteq> Collect (case_prod B)"
  by auto (auto elim!: le_funE)

lemma Collect_split_mono_strong:
  "X = fst ` A \<Longrightarrow> Y = snd ` A \<Longrightarrow> \<forall>a\<in>X. \<forall>b \<in> Y. P a b \<longrightarrow> Q a b
    \<Longrightarrow> A \<subseteq> Collect (case_prod P) \<Longrightarrow> A \<subseteq> Collect (case_prod Q)"
  by fastforce

lemma UN_Times_distrib: "(\<Union>(a, b)\<in>A \<times> B. E a \<times> F b) = UNION A E \<times> UNION B F"
  \<comment> \<open>Suggested by Pierre Chartier\<close>
  by blast

lemma split_paired_Ball_Sigma [simp, no_atp]: "(\<forall>z\<in>Sigma A B. P z) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B x. P (x, y))"
  by blast

lemma split_paired_Bex_Sigma [simp, no_atp]: "(\<exists>z\<in>Sigma A B. P z) \<longleftrightarrow> (\<exists>x\<in>A. \<exists>y\<in>B x. P (x, y))"
  by blast

lemma Sigma_Un_distrib1: "Sigma (I \<union> J) C = Sigma I C \<union> Sigma J C"
  by blast

lemma Sigma_Un_distrib2: "(SIGMA i:I. A i \<union> B i) = Sigma I A \<union> Sigma I B"
  by blast

lemma Sigma_Int_distrib1: "Sigma (I \<inter> J) C = Sigma I C \<inter> Sigma J C"
  by blast

lemma Sigma_Int_distrib2: "(SIGMA i:I. A i \<inter> B i) = Sigma I A \<inter> Sigma I B"
  by blast

lemma Sigma_Diff_distrib1: "Sigma (I - J) C = Sigma I C - Sigma J C"
  by blast

lemma Sigma_Diff_distrib2: "(SIGMA i:I. A i - B i) = Sigma I A - Sigma I B"
  by blast

lemma Sigma_Union: "Sigma (\<Union>X) B = (\<Union>A\<in>X. Sigma A B)"
  by blast

lemma Pair_vimage_Sigma: "Pair x -` Sigma A f = (if x \<in> A then f x else {})"
  by auto

text \<open>
  Non-dependent versions are needed to avoid the need for higher-order
  matching, especially when the rules are re-oriented.
\<close>

lemma Times_Un_distrib1: "(A \<union> B) \<times> C = A \<times> C \<union> B \<times> C "
  by (fact Sigma_Un_distrib1)

lemma Times_Int_distrib1: "(A \<inter> B) \<times> C = A \<times> C \<inter> B \<times> C "
  by (fact Sigma_Int_distrib1)

lemma Times_Diff_distrib1: "(A - B) \<times> C = A \<times> C - B \<times> C "
  by (fact Sigma_Diff_distrib1)

lemma Times_empty [simp]: "A \<times> B = {} \<longleftrightarrow> A = {} \<or> B = {}"
  by auto

lemma times_eq_iff: "A \<times> B = C \<times> D \<longleftrightarrow> A = C \<and> B = D \<or> (A = {} \<or> B = {}) \<and> (C = {} \<or> D = {})"
  by auto

lemma fst_image_times [simp]: "fst ` (A \<times> B) = (if B = {} then {} else A)"
  by force

lemma snd_image_times [simp]: "snd ` (A \<times> B) = (if A = {} then {} else B)"
  by force

lemma fst_image_Sigma: "fst ` (Sigma A B) = {x \<in> A. B(x) \<noteq> {}}"
  by force

lemma snd_image_Sigma: "snd ` (Sigma A B) = (\<Union> x \<in> A. B x)"
  by force

lemma vimage_fst: "fst -` A = A \<times> UNIV"
  by auto

lemma vimage_snd: "snd -` A = UNIV \<times> A"
  by auto

lemma insert_times_insert [simp]:
  "insert a A \<times> insert b B = insert (a,b) (A \<times> insert b B \<union> insert a A \<times> B)"
  by blast

lemma vimage_Times: "f -` (A \<times> B) = (fst \<circ> f) -` A \<inter> (snd \<circ> f) -` B"
proof (rule set_eqI)
  show "x \<in> f -` (A \<times> B) \<longleftrightarrow> x \<in> (fst \<circ> f) -` A \<inter> (snd \<circ> f) -` B" for x
    by (cases "f x") (auto split: prod.split)
qed

lemma times_Int_times: "A \<times> B \<inter> C \<times> D = (A \<inter> C) \<times> (B \<inter> D)"
  by auto

lemma product_swap: "prod.swap ` (A \<times> B) = B \<times> A"
  by (auto simp add: set_eq_iff)

lemma swap_product: "(\<lambda>(i, j). (j, i)) ` (A \<times> B) = B \<times> A"
  by (auto simp add: set_eq_iff)

lemma image_split_eq_Sigma: "(\<lambda>x. (f x, g x)) ` A = Sigma (f ` A) (\<lambda>x. g ` (f -` {x} \<inter> A))"
proof (safe intro!: imageI)
  fix a b
  assume *: "a \<in> A" "b \<in> A" and eq: "f a = f b"
  show "(f b, g a) \<in> (\<lambda>x. (f x, g x)) ` A"
    using * eq[symmetric] by auto
qed simp_all

lemma subset_fst_snd: "A \<subseteq> (fst ` A \<times> snd ` A)"
  by force

lemma inj_on_apfst [simp]: "inj_on (apfst f) (A \<times> UNIV) \<longleftrightarrow> inj_on f A"
  by (auto simp add: inj_on_def)

lemma inj_apfst [simp]: "inj (apfst f) \<longleftrightarrow> inj f"
  using inj_on_apfst[of f UNIV] by simp

lemma inj_on_apsnd [simp]: "inj_on (apsnd f) (UNIV \<times> A) \<longleftrightarrow> inj_on f A"
  by (auto simp add: inj_on_def)

lemma inj_apsnd [simp]: "inj (apsnd f) \<longleftrightarrow> inj f"
  using inj_on_apsnd[of f UNIV] by simp

context
begin

qualified definition product :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"
  where [code_abbrev]: "product A B = A \<times> B"

lemma member_product: "x \<in> Product_Type.product A B \<longleftrightarrow> x \<in> A \<times> B"
  by (simp add: product_def)

end

text \<open>The following @{const map_prod} lemmas are due to Joachim Breitner:\<close>

lemma map_prod_inj_on:
  assumes "inj_on f A"
    and "inj_on g B"
  shows "inj_on (map_prod f g) (A \<times> B)"
proof (rule inj_onI)
  fix x :: "'a \<times> 'c"
  fix y :: "'a \<times> 'c"
  assume "x \<in> A \<times> B"
  then have "fst x \<in> A" and "snd x \<in> B" by auto
  assume "y \<in> A \<times> B"
  then have "fst y \<in> A" and "snd y \<in> B" by auto
  assume "map_prod f g x = map_prod f g y"
  then have "fst (map_prod f g x) = fst (map_prod f g y)" by auto
  then have "f (fst x) = f (fst y)" by (cases x, cases y) auto
  with \<open>inj_on f A\<close> and \<open>fst x \<in> A\<close> and \<open>fst y \<in> A\<close> have "fst x = fst y"
    by (auto dest: inj_onD)
  moreover from \<open>map_prod f g x = map_prod f g y\<close>
  have "snd (map_prod f g x) = snd (map_prod f g y)" by auto
  then have "g (snd x) = g (snd y)" by (cases x, cases y) auto
  with \<open>inj_on g B\<close> and \<open>snd x \<in> B\<close> and \<open>snd y \<in> B\<close> have "snd x = snd y"
    by (auto dest: inj_onD)
  ultimately show "x = y" by (rule prod_eqI)
qed

lemma map_prod_surj:
  fixes f :: "'a \<Rightarrow> 'b"
    and g :: "'c \<Rightarrow> 'd"
  assumes "surj f" and "surj g"
  shows "surj (map_prod f g)"
  unfolding surj_def
proof
  fix y :: "'b \<times> 'd"
  from \<open>surj f\<close> obtain a where "fst y = f a"
    by (auto elim: surjE)
  moreover
  from \<open>surj g\<close> obtain b where "snd y = g b"
    by (auto elim: surjE)
  ultimately have "(fst y, snd y) = map_prod f g (a,b)"
    by auto
  then show "\<exists>x. y = map_prod f g x"
    by auto
qed

lemma map_prod_surj_on:
  assumes "f ` A = A'" and "g ` B = B'"
  shows "map_prod f g ` (A \<times> B) = A' \<times> B'"
  unfolding image_def
proof (rule set_eqI, rule iffI)
  fix x :: "'a \<times> 'c"
  assume "x \<in> {y::'a \<times> 'c. \<exists>x::'b \<times> 'd\<in>A \<times> B. y = map_prod f g x}"
  then obtain y where "y \<in> A \<times> B" and "x = map_prod f g y"
    by blast
  from \<open>image f A = A'\<close> and \<open>y \<in> A \<times> B\<close> have "f (fst y) \<in> A'"
    by auto
  moreover from \<open>image g B = B'\<close> and \<open>y \<in> A \<times> B\<close> have "g (snd y) \<in> B'"
    by auto
  ultimately have "(f (fst y), g (snd y)) \<in> (A' \<times> B')"
    by auto
  with \<open>x = map_prod f g y\<close> show "x \<in> A' \<times> B'"
    by (cases y) auto
next
  fix x :: "'a \<times> 'c"
  assume "x \<in> A' \<times> B'"
  then have "fst x \<in> A'" and "snd x \<in> B'"
    by auto
  from \<open>image f A = A'\<close> and \<open>fst x \<in> A'\<close> have "fst x \<in> image f A"
    by auto
  then obtain a where "a \<in> A" and "fst x = f a"
    by (rule imageE)
  moreover from \<open>image g B = B'\<close> and \<open>snd x \<in> B'\<close> obtain b where "b \<in> B" and "snd x = g b"
    by auto
  ultimately have "(fst x, snd x) = map_prod f g (a, b)"
    by auto
  moreover from \<open>a \<in> A\<close> and  \<open>b \<in> B\<close> have "(a , b) \<in> A \<times> B"
    by auto
  ultimately have "\<exists>y \<in> A \<times> B. x = map_prod f g y"
    by auto
  then show "x \<in> {x. \<exists>y \<in> A \<times> B. x = map_prod f g y}"
    by auto
qed

subsection \<open>Simproc for rewriting a set comprehension into a pointfree expression\<close>

ML_file "Tools/set_comprehension_pointfree.ML"

setup \<open>
  Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs
    [Simplifier.make_simproc @{context} "set comprehension"
      {lhss = [@{term "Collect P"}],
       proc = K Set_Comprehension_Pointfree.code_simproc}])
\<close>

subsection \<open>Inductively defined sets\<close>

(* simplify {(x1, ..., xn). (x1, ..., xn) : S} to S *)
simproc_setup Collect_mem ("Collect t") = \<open>
  fn _ => fn ctxt => fn ct =>
    (case Thm.term_of ct of
      S as Const (@{const_name Collect}, Type (@{type_name fun}, [_, T])) $ t =>
        let val (u, _, ps) = HOLogic.strip_ptupleabs t in
          (case u of
            (c as Const (@{const_name Set.member}, _)) $ q $ S' =>
              (case try (HOLogic.strip_ptuple ps) q of
                NONE => NONE
              | SOME ts =>
                  if not (Term.is_open S') andalso
                    ts = map Bound (length ps downto 0)
                  then
                    let val simp =
                      full_simp_tac (put_simpset HOL_basic_ss ctxt
                        addsimps [@{thm split_paired_all}, @{thm case_prod_conv}]) 1
                    in
                      SOME (Goal.prove ctxt [] []
                        (Const (@{const_name Pure.eq}, T --> T --> propT) $ S $ S')
                        (K (EVERY
                          [resolve_tac ctxt [eq_reflection] 1,
                           resolve_tac ctxt @{thms subset_antisym} 1,
                           resolve_tac ctxt @{thms subsetI} 1,
                           dresolve_tac ctxt @{thms CollectD} 1, simp,
                           resolve_tac ctxt @{thms subsetI} 1,
                           resolve_tac ctxt @{thms CollectI} 1, simp])))
                    end
                  else NONE)
          | _ => NONE)
        end
    | _ => NONE)
\<close>

ML_file "Tools/inductive_set.ML"

subsection \<open>Legacy theorem bindings and duplicates\<close>

lemmas fst_conv = prod.sel(1)
lemmas snd_conv = prod.sel(2)
lemmas split_def = case_prod_unfold
lemmas split_beta' = case_prod_beta'
lemmas split_beta = prod.case_eq_if
lemmas split_conv = case_prod_conv
lemmas split = case_prod_conv

hide_const (open) prod

end


section {* \isaheader{Set Implementation by Arrays} *}
theory ArraySetImpl
imports
  "../spec/SetSpec"
  "ArrayMapImpl"
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw {*\label{thy:ArraySetImpl}*}

(*@impl Set
  @type ias
  @abbrv ias,is
  Sets of natural numbers implemented by arrays.
*)

subsection "Definitions"
type_synonym ias = "(unit) iam"

setup Locale_Code.open_block
interpretation ias_sbm: OSetByOMap iam_basic_ops by unfold_locales
setup Locale_Code.close_block
definition ias_ops :: "(nat,ias) oset_ops"
  where [icf_rec_def]:
  "ias_ops \<equiv> ias_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation ias: StdOSet ias_ops
  unfolding ias_ops_def by (rule ias_sbm.obasic.dflt_oops_impl)
interpretation ias: StdSet_no_invar ias_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "ias"*}

lemmas ias_it_to_it_map_code_unfold[code_unfold] =
  it_to_it_map_fold'[OF pi_iam]
  it_to_it_map_fold'[OF pi_iam_rev]

lemma pi_ias[proper_it]:
  "proper_it' ias.iteratei ias.iteratei"
  "proper_it' ias.iterateoi ias.iterateoi"
  "proper_it' ias.rev_iterateoi ias.rev_iterateoi"
  unfolding ias.iteratei_def[abs_def] ias.iterateoi_def[abs_def]
    ias.rev_iterateoi_def[abs_def]
  apply (rule proper_it'I icf_proper_iteratorI)+
  done

interpretation
  pi_ias: proper_it_loc ias.iteratei ias.iteratei +
  pi_ias_o: proper_it_loc ias.iterateoi ias.iterateoi +
  pi_ias_ro: proper_it_loc ias.rev_iterateoi ias.rev_iterateoi
  apply unfold_locales by (rule pi_ias)+

definition test_codegen where "test_codegen \<equiv> (
  ias.empty,
  ias.memb,
  ias.ins,
  ias.delete,
  ias.list_it,
  ias.sng,
  ias.isEmpty,
  ias.isSng,
  ias.ball,
  ias.bex,
  ias.size,
  ias.size_abort,
  ias.union,
  ias.union_dj,
  ias.diff,
  ias.filter,
  ias.inter,
  ias.subset,
  ias.equal,
  ias.disjoint,
  ias.disjoint_witness,
  ias.sel,
  ias.to_list,
  ias.from_list,

  ias.ordered_list_it,
  ias.rev_list_it,
  ias.min,
  ias.max,
  ias.to_sorted_list,
  ias.to_rev_list
)"

export_code test_codegen in SML

end