header {* \isaheader{List Based Maps} *}
theory Impl_List_Map
imports
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
  List
begin

type_synonym ('k,'v) list_map = "('k\<times>'v) list"

definition "list_map_invar = distinct o map fst"

definition list_map_rel_internal_def:
    "list_map_rel Rk Rv \<equiv> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel O br map_of list_map_invar"

lemma list_map_rel_def:
    "\<langle>Rk,Rv\<rangle>list_map_rel = \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel O br map_of list_map_invar"
    unfolding list_map_rel_internal_def[abs_def] by (simp add: relAPP_def)

lemma list_rel_Range:
    "\<forall>x'\<in>set l'. x' \<in> Range R \<Longrightarrow> l' \<in> Range (\<langle>R\<rangle>list_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs') \<in> \<langle>R\<rangle> list_rel" by force
    moreover from Cons.prems obtain x where "(x,x') \<in> R" by force
    ultimately have "(x#xs, x'#xs') \<in> \<langle>R\<rangle> list_rel" by simp
    thus ?case ..
qed

text {* All finite maps can be represented *}
lemma list_map_rel_range:
  "Range (\<langle>Rk,Rv\<rangle>list_map_rel) =
       {m. finite (dom m) \<and> dom m \<subseteq> Range Rk \<and> ran m \<subseteq> Range Rv}"
       (is "?A = ?B")
proof (intro equalityI subsetI)
  fix m' assume "m' \<in> ?A"
  then obtain l l' where A: "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" and
                         B: "m' = map_of l'" and C: "list_map_invar l'"
       unfolding list_map_rel_def br_def by blast
  {
    fix x' y' assume "m' x' = Some y'"
    with B have "(x',y') \<in> set l'" by (fast dest: map_of_SomeD)
    hence "x' \<in> Range Rk" and "y' \<in> Range Rv"
      by (induction rule: list_rel_induct[OF A], auto)
  }
  with B show "m' \<in> ?B" by (force dest: map_of_SomeD simp: ran_def)

next
  fix m' assume "m' \<in> ?B"
  hence A: "finite (dom m')" and B: "dom m' \<subseteq> Range Rk" and
        C: "ran m' \<subseteq> Range Rv" by simp_all
  from A have "finite (map_to_set m')" by (simp add: finite_map_to_set)
  from finite_distinct_list[OF this]
      obtain l' where l'_props: "distinct l'" "set l' = map_to_set m'" by blast
  hence "distinct (map fst l')"
      by (force simp: distinct_map inj_on_def map_to_set_def)
  moreover from map_of_map_to_set[OF this] and l'_props
      have  "map_of l' = m'" by simp
  ultimately have "(l',m') \<in> br map_of list_map_invar"
      unfolding br_def list_map_invar_def o_def by simp

  moreover from B and C and l'_props
      have "\<forall>x \<in> set l'. x \<in> Range (\<langle>Rk,Rv\<rangle>prod_rel)"
      unfolding map_to_set_def ran_def prod_rel_def by force
  from list_rel_Range[OF this] obtain l where
      "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" by force

  ultimately show "m' \<in> ?A" unfolding list_map_rel_def by blast
qed

  lemmas [autoref_rel_intf] = REL_INTFI[of list_map_rel i_map]

  lemma list_map_rel_finite[autoref_ga_rules]:
    "finite_map_rel (\<langle>Rk,Rv\<rangle>list_map_rel)"
    unfolding finite_map_rel_def list_map_rel_def
    by (auto simp: br_def)

  lemma list_map_rel_sv[relator_props]:
    "single_valued Rk \<Longrightarrow> single_valued Rv \<Longrightarrow>
        single_valued (\<langle>Rk,Rv\<rangle>list_map_rel)"
    unfolding list_map_rel_def
    by tagged_solver

  (* TODO: Move to Misc *)

subsection {* Implementation *}

primrec list_map_lookup ::
    "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow> ('k,'v) list_map \<Rightarrow> 'v option" where
"list_map_lookup eq _ [] = None" |
"list_map_lookup eq k (y#ys) =
     (if eq (fst y) k then Some (snd y) else list_map_lookup eq k ys)"

primrec list_map_update_aux :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow>
    ('k,'v) list_map \<Rightarrow> ('k,'v) list_map \<Rightarrow> ('k,'v) list_map"where
"list_map_update_aux eq k v [] accu = (k,v) # accu" |
"list_map_update_aux eq k v (x#xs) accu =
    (if eq (fst x) k
        then (k,v) # xs @ accu
        else list_map_update_aux eq k v xs (x#accu))"

definition "list_map_update eq k v m \<equiv>
    list_map_update_aux eq k v m []"

primrec list_map_delete_aux :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow>
    ('k, 'v) list_map \<Rightarrow> ('k, 'v) list_map \<Rightarrow> ('k, 'v) list_map" where
"list_map_delete_aux eq k [] accu = accu" |
"list_map_delete_aux eq k (x#xs) accu =
    (if eq (fst x) k
        then xs @ accu
        else list_map_delete_aux eq k xs (x#accu))"

definition "list_map_delete eq k m \<equiv> list_map_delete_aux eq k m []"

definition list_map_isEmpty :: "('k,'v) list_map \<Rightarrow> bool"
    where "list_map_isEmpty \<equiv> List.null"

definition list_map_isSng :: "('k,'v) list_map \<Rightarrow> bool"
    where "list_map_isSng m = (case m of [x] \<Rightarrow> True | _ \<Rightarrow> False)"

definition list_map_size :: "('k,'v) list_map \<Rightarrow> nat"
    where "list_map_size \<equiv> length"

definition list_map_iteratei :: "('k,'v) list_map \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow>
    (('k\<times>'v) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'b"
    where "list_map_iteratei \<equiv> foldli"

definition list_map_to_list :: "('k,'v) list_map \<Rightarrow> ('k\<times>'v) list"
    where "list_map_to_list = id"

subsection {* Parametricity *}

lemma list_map_autoref_empty[autoref_rules]:
  "([], op_map_empty)\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
  by (auto simp: list_map_rel_def br_def list_map_invar_def)

lemma param_list_map_lookup[param]:
  "(list_map_lookup,list_map_lookup) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rv\<rangle>option_rel"
unfolding list_map_lookup_def[abs_def] by parametricity

lemma list_map_autoref_lookup_aux:
  assumes eq: "GEN_OP eq op= (Rk\<rightarrow>Rk\<rightarrow>Id)"
  assumes K: "(k, k') \<in> Rk"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_lookup eq k m, op_map_lookup k' (map_of m'))
               \<in> \<langle>Rv\<rangle>option_rel"
unfolding op_map_lookup_def
proof (induction rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
    show ?case by simp
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    with eq'[param_fo] and K  and Cons
        show ?case by (force simp: prod_rel_def)
qed

lemma param_list_map_update_aux[param]:
  "(list_map_update_aux,list_map_update_aux) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> Rv \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_aux_def[abs_def] by parametricity

lemma param_list_map_update[param]:
  "(list_map_update,list_map_update) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> Rv \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_def[abs_def] by parametricity

lemma list_map_autoref_update_aux1:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  assumes K: "(k, k') \<in> Rk"
  assumes V: "(v, v') \<in> Rv"
  assumes A: "(accu, accu') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_update_aux eq k v m accu,
          list_map_update_aux op= k' v' m' accu')
               \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
proof (insert A, induction arbitrary: accu accu'
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
      thus ?case by (simp add: K V)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    from eq'[param_fo] Cons(1) K
        have [simp]: "(eq (fst x) k) \<longleftrightarrow> ((fst x') = k')"
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        with K and V and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_update1[param]:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(list_map_update eq, list_map_update op=) \<in> Rk \<rightarrow> Rv \<rightarrow>
             \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_def[abs_def]
  by (intro fun_relI, erule (1) list_map_autoref_update_aux1[OF eq],
      simp_all)

(* TODO: Move - Perhaps. *)
lemma map_add_sng_right: "m ++ [k\<mapsto>v] = m(k \<mapsto> v)"
    unfolding map_add_def by force
lemma map_add_sng_right':
    "m ++ (\<lambda>a. if a = k then Some v else None) = m(k \<mapsto> v)"
    unfolding map_add_def by force

lemma list_map_autoref_update_aux2:
  assumes K: "(k, k') \<in> Id"
  assumes V: "(v, v') \<in> Id"
  assumes A: "(accu, accu') \<in> br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k \<notin> set (map fst accu)"
  assumes M: "(m, m') \<in> br map_of list_map_invar"
  shows "(list_map_update_aux op= k v m accu,
          accu' ++ op_map_update k' v' m')
               \<in> br map_of list_map_invar" (is "(?f m accu, _) \<in> _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K V show ?case by (auto simp: br_def list_map_invar_def
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        hence "((k, v) # xs @ accu, accu' ++ op_map_update k' v' m')
                   \<in> br map_of list_map_invar"
            using K V Cons.prems(3,4) unfolding br_def
            by (force simp add: A list_map_invar_def)
        also from True have "(k,v) # xs @ accu = ?f (x # xs) accu" by simp
        finally show ?thesis .
    next
      case False
        from Cons.prems(1) have B: "(xs, map_of xs) \<in> br map_of
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) \<in> br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
            by simp
        from Cons.prems(4) and False have E: "k \<notin> set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D]
            have F: "\<And>z. (fst x, z) \<in> set xs \<Longrightarrow> z = snd x" by force
        have "map_of (x # accu) ++ op_map_update k' v' (map_of xs) =
                  accu' ++ op_map_update k' v' m'"
            by (intro ext, auto simp: A F map_add_def
                    dest: map_of_SomeD split: option.split)
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_update2[param]:
  shows "(list_map_update op=, op_map_update) \<in> Id \<rightarrow> Id \<rightarrow>
             br map_of list_map_invar \<rightarrow> br map_of list_map_invar"
unfolding list_map_update_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_update_aux2
                 [where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done

lemma list_map_autoref_update[autoref_rules]:
  assumes eq: "GEN_OP eq op= (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(list_map_update eq, op_map_update) \<in>
      Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (2) list_map_autoref_update1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_update2[param_fo], simp_all)
done

context begin interpretation autoref_syn .
lemma list_map_autoref_update_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes new: "SIDE_PRECOND_OPT (k' \<notin> dom m')"
    assumes K: "(k,k')\<in>Rk" and V: "(v,v')\<in>Rv"
    assumes M: "(l,m')\<in>\<langle>Rk, Rv\<rangle>list_map_rel"
    defines "R_annot \<equiv> Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
    shows "
      ((k, v)#l,
        (OP op_map_update:::R_annot)$k'$v'$m')
      \<in> \<langle>Rk,Rv\<rangle>list_map_rel"
proof -
  from M obtain l' where A: "(l,l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" and
      B: "(l',m') \<in> br map_of list_map_invar"
      unfolding list_map_rel_def by blast
  hence "((k,v)#l, (k',v')#l')\<in>\<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
      and "((k',v')#l', m'(k' \<mapsto> v')) \<in> br map_of list_map_invar"
      using assms unfolding br_def list_map_invar_def
          by (simp_all add: dom_map_of_conv_image_fst)
  thus ?thesis
    unfolding autoref_tag_defs
    by (force simp: list_map_rel_def)
qed
end

lemma param_list_map_delete_aux[param]:
  "(list_map_delete_aux,list_map_delete_aux) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_aux_def[abs_def] by parametricity

lemma param_list_map_delete[param]:
  "(list_map_delete,list_map_delete) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_def[abs_def] by parametricity

lemma list_map_autoref_delete_aux1:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  assumes K: "(k, k') \<in> Rk"
  assumes A: "(accu, accu') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_delete_aux eq k m accu,
          list_map_delete_aux op= k' m' accu')
               \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
proof (insert A, induction arbitrary: accu accu'
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
      thus ?case by (simp add: K)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    from eq'[param_fo] Cons(1) K
        have [simp]: "(eq (fst x) k) \<longleftrightarrow> ((fst x') = k')"
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        with K and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_delete1[param]:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(list_map_delete eq, list_map_delete op=) \<in> Rk \<rightarrow>
             \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_def[abs_def]
  by (intro fun_relI, erule list_map_autoref_delete_aux1[OF eq],
      simp_all)

lemma list_map_autoref_delete_aux2:
  assumes K: "(k, k') \<in> Id"
  assumes A: "(accu, accu') \<in> br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k \<notin> set (map fst accu)"
  assumes M: "(m, m') \<in> br map_of list_map_invar"
  shows "(list_map_delete_aux op= k m accu,
          accu' ++ op_map_delete k' m')
               \<in> br map_of list_map_invar" (is "(?f m accu, _) \<in> _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K show ?case by (auto simp: br_def list_map_invar_def
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        with Cons.prems(3) have "map_of xs (fst x) = None"
            by (induction xs, simp_all)
        with fun_upd_triv[of "map_of xs" "fst x"]
            have "map_of xs |` (- {fst x}) = map_of xs" by simp
        with True have"(xs @ accu, accu' ++ op_map_delete k' m')
                           \<in> br map_of list_map_invar"
            using K Cons.prems unfolding br_def
            by (auto simp add: A list_map_invar_def)
        thus ?thesis using True by simp
    next
      case False
        from False and K have [simp]: "fst x \<noteq> k'" by simp
        from Cons.prems(1) have B: "(xs, map_of xs) \<in> br map_of
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) \<in> br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
            by simp
        from Cons.prems(4) and False have E: "k \<notin> set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D]
            have F: "\<And>z. (fst x, z) \<in> set xs \<Longrightarrow> z = snd x" by force

        from Cons.prems(3) have "map_of xs (fst x) = None"
            by (induction xs, simp_all)
        hence "map_of (x # accu) ++ op_map_delete k' (map_of xs) =
               accu' ++ op_map_delete k' m'"
            apply (intro ext, simp add: map_add_def A
                                   split: option.split)
            apply (intro conjI impI allI)
            apply (auto simp: restrict_map_def)
            done
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_delete[autoref_rules]:
  assumes eq: "GEN_OP eq op= (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(list_map_delete eq, op_map_delete) \<in>
      Rk \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (1) list_map_autoref_delete1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_delete2[param_fo], simp_all)
done

lemma list_map_autoref_isEmpty[autoref_rules]:
  shows "(list_map_isEmpty, op_map_isEmpty) \<in>
             \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> bool_rel"
unfolding list_map_isEmpty_def op_map_isEmpty_def[abs_def]
    list_map_rel_def br_def List.null_def[abs_def] by force

lemma param_list_map_isSng[param]:
  assumes "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_isSng l, list_map_isSng l') \<in> bool_rel"
unfolding list_map_isSng_def using assms by parametricity

(* TODO: clean up this mess *)
lemma list_map_autoref_isSng_aux:
  assumes "(l',m') \<in> br map_of list_map_invar"
  shows "(list_map_isSng l', op_map_isSng m') \<in> bool_rel"
using assms
unfolding list_map_isSng_def op_map_isSng_def br_def list_map_invar_def
apply (clarsimp split: list.split)
apply (intro conjI impI allI)
apply (metis map_upd_nonempty)
apply blast
apply (simp, metis fun_upd_apply option.distinct(1))
done

lemma list_map_autoref_isSng[autoref_rules]:
  "(list_map_isSng, op_map_isSng) \<in> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> bool_rel"
  using assms unfolding list_map_rel_def
  by (blast dest!: param_list_map_isSng list_map_autoref_isSng_aux)

lemma list_map_autoref_size_aux:
  assumes "distinct (map fst x)"
  shows "card (dom (map_of x)) = length x"
proof-
  have "card (dom (map_of x)) = card (map_to_set (map_of x))"
      by (simp add: card_map_to_set)
  also from assms have "... = card (set x)"
      by (simp add: map_to_set_map_of)
  also from assms have "... = length x"
      by (force simp: distinct_card dest!: distinct_mapI)
  finally show ?thesis .
qed

lemma param_list_map_size[param]:
  "(list_map_size, list_map_size) \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> nat_rel"
  unfolding list_map_size_def[abs_def] by parametricity

lemma list_map_autoref_size[autoref_rules]:
  shows "(list_map_size, op_map_size) \<in>
             \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> nat_rel"
unfolding list_map_size_def[abs_def] op_map_size_def[abs_def]
    list_map_rel_def br_def list_map_invar_def
    by (force simp: list_map_autoref_size_aux list_rel_imp_same_length)

lemma autoref_list_map_is_iterator[autoref_ga_rules]:
  shows "is_map_to_list Rk Rv list_map_rel list_map_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix l m'
  assume "(l,m') \<in> \<langle>Rk,Rv\<rangle>list_map_rel"
  then obtain l' where "(l,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and "(l',m')\<in>br map_of list_map_invar"
      unfolding list_map_rel_def by blast
  moreover from this have "RETURN l' \<le> it_to_sorted_list
                               (key_rel (\<lambda>_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def
      apply (intro refine_vcg)
      unfolding br_def list_map_invar_def key_rel_def[abs_def]
      apply (auto intro: distinct_mapI simp: map_to_set_map_of)
      done
  ultimately show
      "\<exists>l'. (list_map_to_list l, l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<and>
            RETURN l' \<le> it_to_sorted_list (key_rel (\<lambda>_ _. True))
                             (map_to_set m')"
       unfolding list_map_to_list_def by force
qed

lemma pi_list_map[icf_proper_iteratorI]:
  "proper_it (list_map_iteratei m) (list_map_iteratei m)"
unfolding proper_it_def list_map_iteratei_def by blast

lemma pi'_list_map[icf_proper_iteratorI]:
  "proper_it' list_map_iteratei list_map_iteratei"
  by (rule proper_it'I, rule pi_list_map)

primrec list_map_pick_remove where
  "list_map_pick_remove [] = undefined"
| "list_map_pick_remove (kv#l) = (kv,l)"

context begin interpretation autoref_syn .
  lemma list_map_autoref_pick_remove[autoref_rules]:
    assumes NE: "SIDE_PRECOND (m\<noteq>Map.empty)"
    assumes R: "(l,m)\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
    assumes SV:
      "PREFER single_valued Rk" "PREFER single_valued Rv"
    defines "Rres \<equiv> \<langle>(Rk\<times>\<^sub>rRv) \<times>\<^sub>r \<langle>Rk,Rv\<rangle>list_map_rel\<rangle>nres_rel"
    shows "(
        RETURN (list_map_pick_remove l),
        (OP op_map_pick_remove ::: \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> Rres)$m
      ) \<in> Rres"
  proof -
    note [relator_props] = SV[simplified]

    from NE R obtain k v lr where
      [simp]: "l=(k,v)#lr"
      by (cases l) (auto simp: list_map_rel_def br_def)

    thm list_map_rel_def
    from R obtain l' where
      LL': "(l,l')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel" and
      L'M: "(l',m)\<in>br map_of list_map_invar"
      unfolding list_map_rel_def by auto
    from LL' obtain k' v' lr' where
      [simp]: "l' = (k',v')#lr'" and
        KVR: "(k,k')\<in>Rk" "(v,v')\<in>Rv" and
        LRR: "(lr,lr')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel"
      by (fastforce elim!: list_relE)

    from L'M have
      MKV': "m k' = Some v'" and
      LRR': "(lr',m|`(-{k'}))\<in>br map_of list_map_invar"
      by (auto
        simp: restrict_map_def map_of_eq_None_iff br_def list_map_invar_def
        intro!: ext
        intro: sym)

    from LRR LRR' have LM: "(lr,m|`(-{k'}))\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
      unfolding list_map_rel_def by auto

    show ?thesis
      apply (simp add: Rres_def)
      apply (refine_rcg SPEC_refine_sv nres_relI refine_vcg)
      using LM KVR MKV'
      by auto
  qed
end

end


theory Gamma
  imports Main
         "Category3.Category"
         "Category3.Subcategory"

begin

type_synonym gamma = "(nat \<times> nat list) option"

fun get :: "('a list) \<Rightarrow> nat \<Rightarrow> 'a" where
 "get [] n = undefined" |
 "get (x # xs) 0 = x" |
 "get (x # xs) (Suc n) = get xs n"

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "app [] xs = xs" |
  "app (y # ys) xs = y # (app ys xs)"

fun rev_get :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list" where
  "rev_get 0 f = []" |
  "rev_get (Suc n) f = (f 0) # (rev_get n (\<lambda>k. f (Suc k)))"

fun fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "fmap f xs = (rev_get (length xs) (\<lambda>n. f (get xs n)))"

lemma app_length : "length (app xs ys) = length xs + length ys"
  apply (induction xs)
  by simp_all

lemma rev_get_length [simp] : "length (rev_get n f) = n"
  apply (induction n arbitrary: f)
   apply simp
  by simp

lemma getAppLemma : "n < length xs \<Longrightarrow> get (app xs ys) n = get xs n"
  apply (induction xs arbitrary: n)
   apply simp
proof-
  fix a xs n
  assume ind: "(\<And> m. m < length xs \<Longrightarrow> get (app xs ys) m = get xs m)"
  show "n < length (a # xs) \<Longrightarrow> get (app (a # xs) ys) n = get (a # xs) n"
    apply (induction n)
     apply simp
    by (simp add: ind)
qed

lemma getAppLemma2 : "get (app xs ys) (length xs) = get ys 0"
  apply (induction xs)
  by simp_all

lemma get_rev_get [simp]: "n < m \<Longrightarrow> get (rev_get m f) n = f n"
  apply (induction m arbitrary: n f)
   apply simp
  apply simp
proof-
  fix m n
  fix f :: "nat \<Rightarrow> 'a"
  assume ind : "(\<And>n (f :: nat \<Rightarrow> 'a). n < m \<Longrightarrow> get (rev_get m f) n = f n)"
  show "n < Suc m \<Longrightarrow> get (f 0 # rev_get m (\<lambda>k. f (Suc k))) n = f n"
    apply (induction n)
     apply simp
    by (simp add: ind)
qed

lemma getFaithful : "length xs = length ys \<Longrightarrow> (\<And> n. n < length xs \<Longrightarrow> get xs n = get ys n) \<Longrightarrow> xs = ys"
  apply(induction xs arbitrary : ys)
   apply simp
  apply simp
proof-
  fix a
  fix xs ys :: "'a list"
  assume ind: "(\<And>ys. length xs = length ys \<Longrightarrow>
              (\<And>n. n < length ys \<Longrightarrow> get xs n = get ys n) \<Longrightarrow> xs = ys)"
  assume length: "Suc (length xs) = length ys"
  assume ind2: "(\<And>n. n < length ys \<Longrightarrow> get (a # xs) n = get ys n)"
  from length  obtain b zs where " ys = b # zs"
    by (meson Suc_length_conv \<open>Suc (length xs) = length ys\<close>)
  from length have "length xs = length zs"
    using \<open>ys = b # zs\<close> by auto
  from this and ind have h1: "(\<And>n. n < length zs \<Longrightarrow> get xs n = get zs n) \<Longrightarrow> xs = zs" by simp
  have "(\<And>n. n < length zs \<Longrightarrow> get xs n = get zs n)"
  proof-
    fix n
    assume "n < length zs"
    then have "Suc n < length ys" using \<open>ys = b # zs\<close>  by simp
    from this and ind2 have "get (a # xs) (Suc n) = get ys (Suc n)" by blast
    thus "get xs n = get zs n" using \<open>ys = b # zs\<close>  by simp
  qed
  from this and h1 have h2: "xs = zs" by simp
  have "0 < length ys" using \<open>ys = b # zs\<close>  by simp
  from this and ind2 have "get (a # xs) 0 = get ys 0" by blast
  then have "a = b" using \<open>ys = b # zs\<close>  by simp
  from this and h2 have "a # xs = b # zs" by simp
  thus "a # xs = ys" using \<open>ys = b # zs\<close>  by simp
qed

lemma rev_get_get : "rev_get (length xs) (get xs) = xs"
  apply (rule_tac getFaithful)
   apply simp
  by simp

lemma rev_get_independence : "(\<And> n. n < m \<Longrightarrow> f n = g n) \<Longrightarrow> rev_get m f = rev_get m g"
  apply (rule_tac getFaithful)
  by simp_all

locale fin_set
begin

abbreviation Dom' :: "nat \<times> nat list \<Rightarrow> nat" where
  "Dom' t \<equiv> length (snd t)"

abbreviation Cod' :: "nat \<times> nat list \<Rightarrow> nat" where
  "Cod' t \<equiv> fst t"

abbreviation Obj' :: "nat \<Rightarrow> bool" where
  "Obj' t \<equiv> True"

definition Arr' :: "nat \<times> nat list \<Rightarrow> bool" where
  "Arr' t \<equiv> (\<forall>n. (n < (Dom' t) \<longrightarrow> get (snd t) n < Cod' t))"

definition Id' :: "nat \<Rightarrow> nat \<times> nat list" where
  "Id' n \<equiv> (n, rev_get n (\<lambda>k. k))"

definition Comp' :: "(nat \<times> nat list) \<Rightarrow> (nat \<times> nat list) \<Rightarrow> nat \<times> nat list" where
  "Comp' f g \<equiv> (fst f ,rev_get (length (snd g)) (\<lambda>n. get (snd f) (get (snd g) n)))"

interpretation CC: classical_category Obj' Arr' Dom' Cod' Id' Comp'
  apply (unfold_locales)
  unfolding Arr'_def
           apply simp_all
proof
  show "\<And>a n. n < length (snd (Id' a)) \<longrightarrow> get (snd (Id' a)) n < fst (Id' a)"
    by (simp add: Id'_def get_rev_get)
  show "\<And>a. length (snd (Id' a)) = a"
    by (simp add: Id'_def)
  show "\<And>a. fst (Id' a) = a"
    by (simp add: Id'_def)
  show "\<And>f g. \<forall>n<length (snd f). get (snd f) n < length (snd g) \<Longrightarrow>
           \<forall>n<length (snd g). get (snd g) n < fst g \<Longrightarrow>
           fst f = length (snd g) \<Longrightarrow>
           \<forall>n<length (snd (Comp' g f)). get (snd (Comp' g f)) n < fst (Comp' g f)"
    by (simp add: Comp'_def get_rev_get)
  show "\<And>f g. \<forall>n<length (snd f). get (snd f) n < length (snd g) \<Longrightarrow>
           \<forall>n<length (snd g). get (snd g) n < fst g \<Longrightarrow>
           fst f = length (snd g) \<Longrightarrow> length (snd (Comp' g f)) = length (snd f)"
    by (simp add: Comp'_def)
  show "\<And>f g. \<forall>n<length (snd f). get (snd f) n < length (snd g) \<Longrightarrow>
           \<forall>n<length (snd g). get (snd g) n < fst g \<Longrightarrow>
           fst f = length (snd g) \<Longrightarrow> fst (Comp' g f) = fst g"
    by (simp add: Comp'_def)
  show "\<And>f. \<forall>n<length (snd f). get (snd f) n < fst f \<Longrightarrow> Comp' f (Id' (length (snd f))) = f"
  proof
    show "\<And>f. \<forall>n<length (snd f). get (snd f) n < fst f \<Longrightarrow>
         fst (Comp' f (Id' (length (snd f)))) = fst f"
      unfolding Comp'_def Id'_def by simp
    have subst: "\<And>f. (snd (Comp' f (Id' (length (snd f)))) = snd f) =
(snd (Comp' f (Id' (length (snd f)))) = rev_get (length (snd f)) (get (snd f)))" by (simp add: rev_get_get)
    show "\<And>f. \<forall>n<length (snd f). get (snd f) n < fst f \<Longrightarrow>
         snd (Comp' f (Id' (length (snd f)))) = snd f"
      apply (subst subst)
      apply (simp add: Comp'_def Id'_def)
      apply (rule_tac getFaithful)
      by simp_all
  qed
  show "\<And>f. \<forall>n<length (snd f). get (snd f) n < fst f \<Longrightarrow> Comp' (Id' (fst f)) f = f"
  proof
    show "\<And>f. \<forall>n<length (snd f). get (snd f) n < fst f \<Longrightarrow> fst (Comp' (Id' (fst f)) f) = fst f"
      unfolding Comp'_def Id'_def by simp
    have subst: "\<And>f.
   (snd (Comp' (Id' (fst f)) f) = snd f) =
   (snd (Comp' (Id' (fst f)) f) =  rev_get (length (snd f)) (get (snd f)))" by (simp add: rev_get_get)
    show "\<And>f. \<forall>n<length (snd f). get (snd f) n < fst f \<Longrightarrow> snd (Comp' (Id' (fst f)) f) = snd f"
      apply (subst subst)
      apply (simp add: Comp'_def Id'_def)
      apply (rule_tac getFaithful)
      by simp_all
  qed
  show "\<And>f g h.
       \<forall>n<length (snd f). get (snd f) n < length (snd g) \<Longrightarrow>
       \<forall>n<length (snd g). get (snd g) n < length (snd h) \<Longrightarrow>
       \<forall>n<length (snd h). get (snd h) n < fst h \<Longrightarrow>
       fst f = length (snd g) \<Longrightarrow>
       fst g = length (snd h) \<Longrightarrow> Comp' (Comp' h g) f = Comp' h (Comp' g f)"
  proof
    show "\<And>f g h.
       \<forall>n<length (snd f). get (snd f) n < length (snd g) \<Longrightarrow>
       \<forall>n<length (snd g). get (snd g) n < length (snd h) \<Longrightarrow>
       \<forall>n<length (snd h). get (snd h) n < fst h \<Longrightarrow>
       fst f = length (snd g) \<Longrightarrow>
       fst g = length (snd h) \<Longrightarrow> fst (Comp' (Comp' h g) f) = fst (Comp' h (Comp' g f))"
      unfolding Comp'_def by simp
    show "\<And>f g h.
       \<forall>n<length (snd f). get (snd f) n < length (snd g) \<Longrightarrow>
       \<forall>n<length (snd g). get (snd g) n < length (snd h) \<Longrightarrow>
       \<forall>n<length (snd h). get (snd h) n < fst h \<Longrightarrow>
       fst f = length (snd g) \<Longrightarrow>
       fst g = length (snd h) \<Longrightarrow> snd (Comp' (Comp' h g) f) = snd (Comp' h (Comp' g f))"
      unfolding Comp'_def apply simp
      apply (rule_tac getFaithful)
      by simp_all
  qed
qed

definition comp where "comp = CC.comp"

lemma is_classical_category : "classical_category Obj' Arr' Dom' Cod' Id' Comp'"
  using local.CC.classical_category_axioms.

lemma is_category : "category comp"
  using CC.is_functor functor.axioms(1) local.comp_def by auto

lemma arr_char: "partial_magma.arr comp f = (f \<noteq> None \<and> Arr' (the f))"
  unfolding comp_def
  using CC.arr_char.

lemma ide_char : "partial_magma.ide comp a = (Arr' (the a) \<and> a = Some (Id' (length (snd (the a)))))"
  unfolding comp_def
  using CC.ide_char.

lemma cod_char: "partial_magma.cod comp f = (if CC.arr f then Some (Id' (fst (the f))) else None)"
  unfolding comp_def
  using CC.cod_char.

lemma comp_char : "partial_magma.arr comp f \<Longrightarrow>
                   partial_magma.arr comp g \<Longrightarrow>
                   partial_magma.dom comp g = partial_magma.cod comp f
               \<Longrightarrow> comp g f = Some (Comp' (the g) (the f))"
proof-
  have "partial_magma.arr comp f \<longrightarrow>
                   partial_magma.arr comp g \<longrightarrow>
                   partial_magma.dom comp g = partial_magma.cod comp f
               \<longrightarrow> comp g f = Some (Comp' (the g) (the f))"
    unfolding comp_def
    apply (subst CC.dom_char)
    apply (subst CC.cod_char)
    apply simp
    apply (subst CC.comp_char)
    apply (simp add: CC.arr_char)
    unfolding Id'_def by simp
  then show "partial_magma.arr comp f \<Longrightarrow>
                   partial_magma.arr comp g \<Longrightarrow>
                   partial_magma.dom comp g = partial_magma.cod comp f
               \<Longrightarrow> comp g f = Some (Comp' (the g) (the f))"
    by auto
qed

lemma comp_length : "length (snd (Comp' g f)) = length (snd f)"
  unfolding Comp'_def by simp

end

fun pairIndex:: "nat \<Rightarrow> (nat \<times> nat) \<Rightarrow> nat" where
  "pairIndex n (a, b) = a * n + b"

fun revPairIndex :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "revPairIndex n c = (c div n, c mod n)"

fun productMap :: "(nat \<times> nat list) \<Rightarrow> (nat \<times> nat list) \<Rightarrow> nat \<times> nat list" where
  "productMap (x,xs) (y,ys) = (x*y, rev_get (length xs * length ys)
        (\<lambda>k. pairIndex x (get xs (fst (revPairIndex (length xs) k)) ,
                          get ys (snd (revPairIndex (length xs) k)))))"

fun prod_proj1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat list" where
 "prod_proj1 n m = (n, rev_get (n*m) (\<lambda>k. fst (revPairIndex n k)))"

fun prod_proj2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat list" where
 "prod_proj2 n m = (m, rev_get (n*m) (\<lambda>k. snd (revPairIndex n k)))"

fun point :: "(nat \<times> nat list) \<Rightarrow> nat \<times> nat list" where
  "point (x, xs) = (x, 0 # xs)"

fun tail :: "(nat \<times> nat list) \<Rightarrow> nat \<times> nat list" where
  "tail (n,[]) = undefined" |
  "tail (n, x # xs) = (n, xs)"

fun smash_product :: "(nat \<times> nat list) \<Rightarrow> (nat \<times> nat list) \<Rightarrow> (nat \<times> nat list)" where
  "smash_product f g = point (productMap (tail f) (tail g))"

locale pointed_fin_set
begin

definition PointedArr' where
  "PointedArr' t \<equiv> (partial_magma.arr fin_set.comp t) \<and> (get (snd (the t)) 0 = 0) \<and> fin_set.Dom' (the t) \<noteq> 0"

lemma PointedArr_Id: "\<And>n. n \<noteq> 0 \<Longrightarrow> PointedArr' (Some (fin_set.Id' n))"
  unfolding PointedArr'_def
  apply auto
proof-
  fix n
  show "partial_magma.arr fin_set.comp (Some (fin_set.Id' n))"
    unfolding fin_set.comp_def
    apply (subst classical_category.arr_char)
    using fin_set.is_classical_category apply blast
    apply auto
    using fin_set.is_classical_category by (simp add: classical_category.Arr_Id)
  assume "0 < n"
  show "get (snd (fin_set.Id' n)) 0 = 0"
    unfolding fin_set.Id'_def apply simp
    apply (subst get_rev_get)
     apply simp_all
    using \<open>0<n\<close>.
  show "snd (fin_set.Id' n) = [] \<Longrightarrow> False"
    unfolding fin_set.Id'_def apply simp
    by (metis \<open>0 < n\<close> less_numeral_extra(3) list.size(3) rev_get_length)
qed

interpretation SC : subcategory fin_set.comp PointedArr'
  unfolding subcategory_def
  apply (simp add: fin_set.is_category)
  apply (unfold_locales)
proof-
  fix f
  assume p_arr: "PointedArr' f"
  show "partial_magma.arr fin_set.comp f"
    using p_arr by (simp add: PointedArr'_def)
  from p_arr have arr: "partial_magma.arr
               (classical_category.comp fin_set.Arr' (\<lambda>t. length (snd t)) fst fin_set.Comp')
               f" unfolding PointedArr'_def fin_set.comp_def by simp

  show "PointedArr' (partial_magma.dom fin_set.comp f)"
    apply (simp add: fin_set.comp_def)
    apply (subst classical_category.dom_char)
    using fin_set.is_classical_category apply blast
    apply (simp add: arr)
    apply (subst PointedArr_Id)
    using p_arr unfolding PointedArr'_def apply simp
    by simp
  have "fst (the f) \<noteq> 0"
  proof-
    have "partial_magma.arr fin_set.comp f"
      using p_arr unfolding PointedArr'_def by simp
    then have "fin_set.Arr' (the f)"
      unfolding fin_set.comp_def
      using classical_category.arr_char fin_set.is_classical_category by blast
    then show "fst (the f) \<noteq> 0"
      unfolding fin_set.Arr'_def
      using p_arr pointed_fin_set.PointedArr'_def by auto
  qed
  show "PointedArr' (partial_magma.cod fin_set.comp f)"
    apply (simp add: fin_set.comp_def)
    apply (subst classical_category.cod_char)
    using fin_set.is_classical_category apply blast
    apply (simp add: arr)
    apply (subst PointedArr_Id)
    using p_arr unfolding PointedArr'_def
     apply (simp add: \<open>fst (the f) \<noteq> 0\<close>)
    by simp
  fix g
  assume p_arr_g: "PointedArr' g"
  assume seq : "partial_magma.cod fin_set.comp f = partial_magma.dom fin_set.comp g"
  have seq2: "fin_set.Cod' (the f) = fin_set.Dom' (the g)"
  proof-
    have eq1: "Some (fin_set.Id' (fin_set.Cod' (the f))) = partial_magma.cod fin_set.comp f"
      using fin_set.is_classical_category classical_category.cod_char
      using arr fin_set.comp_def by fastforce
    have eq2: "Some (fin_set.Id' (fin_set.Dom' (the g))) = partial_magma.dom fin_set.comp g"
      using fin_set.is_classical_category classical_category.dom_char
      using fin_set.comp_def p_arr_g pointed_fin_set.PointedArr'_def by fastforce
    from eq1 and eq2 and seq have
      "Some (fin_set.Id' (fin_set.Cod' (the f))) = Some (fin_set.Id' (fin_set.Dom' (the g)))" by simp
    then show "fin_set.Cod' (the f) = fin_set.Dom' (the g)"
      by (simp add: fin_set.Id'_def)
  qed

  have subst: "(f \<noteq> None \<and>
         g \<noteq> None \<and>
         fin_set.Arr' (the f) \<and>
         fin_set.Arr' (the g) \<and> fst (the f) = length (snd (the g))) = True"
    apply auto
    using arr classical_category.arr_char fin_set.is_classical_category apply fastforce
    using classical_category.arr_char fin_set.comp_def fin_set.is_classical_category p_arr_g pointed_fin_set.PointedArr'_def apply fastforce
    using p_arr unfolding PointedArr'_def
    using arr classical_category.arr_char fin_set.is_classical_category apply blast
    using p_arr_g unfolding PointedArr'_def
    using classical_category.arr_char fin_set.comp_def fin_set.is_classical_category pointed_fin_set.PointedArr'_def apply fastforce
    by (simp add: seq2)
  show "PointedArr' (fin_set.comp g f)"
    unfolding PointedArr'_def
    apply (subst category.seqI')
    apply (simp add: fin_set.is_category)
    apply (subst category.in_homI)
          apply (simp add: fin_set.is_category)
    using p_arr apply (simp add: PointedArr'_def)
        apply blast
       apply blast
      apply simp
     apply (subst category.in_homI)
         apply (simp add: fin_set.is_category)
    using p_arr_g apply (simp add: PointedArr'_def)
       apply (simp add: seq)
      apply blast
     apply simp
    apply simp
    apply (rule_tac conjI)
    unfolding fin_set.comp_def
     apply (subst classical_category.comp_char)
    using fin_set.is_classical_category apply blast
     apply (subst subst)
    unfolding fin_set.Comp'_def apply simp
     apply (subst get_rev_get)
    using p_arr unfolding PointedArr'_def apply simp
    using p_arr p_arr_g unfolding PointedArr'_def apply simp
    apply (subst classical_category.comp_char)
    using fin_set.is_classical_category unfolding fin_set.Comp'_def apply blast
    apply (subst subst)
    apply simp
  proof
    assume "rev_get (length (snd (the f))) (\<lambda>n. get (snd (the g)) (get (snd (the f)) n)) = []"
    then have "length (rev_get (length (snd (the f))) (\<lambda>n. get (snd (the g)) (get (snd (the f)) n))) = 0" by simp
    then have "length (snd (the f)) = 0" by simp
    then show "False" using p_arr unfolding PointedArr'_def by simp
  qed
qed

definition comp where "comp = SC.comp"

lemma is_category : "category comp"
  by (simp add: SC.subcategory_axioms local.comp_def subcategory.is_category)

lemma is_subcategory : "subcategory fin_set.comp PointedArr'"
  using local.SC.subcategory_axioms.

lemma dom_char : "partial_magma.arr local.comp f \<Longrightarrow>
               partial_magma.dom local.comp f =
               Some (fin_set.Id' (length (snd (the f))))"
  unfolding local.comp_def
  apply (subst subcategory.dom_char)
   apply (simp add: is_subcategory)
  apply simp
  unfolding fin_set.comp_def
  apply (subst classical_category.dom_char)
  using fin_set.is_classical_category apply blast
  apply simp
  using subcategory.arr_char
  using SC.arrE SC.inclusion fin_set.comp_def by auto

lemma cod_char: "partial_magma.arr local.comp f \<Longrightarrow>
               partial_magma.cod local.comp f =
               Some (fin_set.Id' (fst (the f)))"
  unfolding local.comp_def
  apply (subst subcategory.cod_char)
   apply (simp add: is_subcategory)
  apply simp
  unfolding fin_set.comp_def
  apply (subst classical_category.cod_char)
  using fin_set.is_classical_category apply blast
  apply simp
  using subcategory.arr_char
  using SC.arrE SC.inclusion fin_set.comp_def by auto

lemma ide_char : "partial_magma.ide comp f =
                  (f = Some (fin_set.Id' (length (snd (the f)))) \<and> (length (snd (the f)) \<noteq> 0))"
  unfolding local.comp_def
  apply (subst SC.ide_char)
  apply (subst SC.arr_char)
  unfolding fin_set.comp_def
  apply (subst classical_category.ide_char)
  using fin_set.is_classical_category apply simp
proof
  show "PointedArr' f \<and>
    fin_set.Arr' (the f) \<and> f = Some (fin_set.Id' (length (snd (the f)))) \<Longrightarrow>
    f = Some (fin_set.Id' (length (snd (the f)))) \<and> length (snd (the f)) \<noteq> 0"
    unfolding PointedArr'_def by simp
  have arr_f: "f = Some (fin_set.Id' (length (snd (the f)))) \<Longrightarrow>
    snd (the f) \<noteq> [] \<Longrightarrow> fin_set.Arr' (the f)"
  proof-
    assume eq: "f = Some (fin_set.Id' (length (snd (the f))))"
    show "fin_set.Arr' (the f)"
      apply (subst eq)
      apply simp
      using classical_category.Arr_Id [OF fin_set.is_classical_category] by simp
  qed
  show "f = Some (fin_set.Id' (length (snd (the f)))) \<and> length (snd (the f)) \<noteq> 0 \<Longrightarrow>
    PointedArr' f \<and> fin_set.Arr' (the f) \<and> f = Some (fin_set.Id' (length (snd (the f))))"
    apply auto
    unfolding PointedArr'_def
    apply simp
    unfolding fin_set.comp_def
     apply (subst classical_category.arr_char [OF fin_set.is_classical_category])
    using arr_f apply auto
    unfolding fin_set.Id'_def apply auto
  proof-
    assume eq: "f = Some (length (snd (the f)), rev_get (length (snd (the f))) (\<lambda>k. k))"
    assume "snd (the f) \<noteq> []"
    show "get (snd (the f)) 0 = 0"
      apply (subst eq)
      apply simp
      apply (subst get_rev_get)
      by (simp_all add: \<open>snd (the f) \<noteq> []\<close>)
  qed
qed

lemma comp_char : "partial_magma.arr comp f \<Longrightarrow>
                   partial_magma.arr comp g \<Longrightarrow>
                   partial_magma.dom comp g = partial_magma.cod comp f \<Longrightarrow>
                   comp g f = Some (fin_set.Comp' (the g) (the f))"
  unfolding comp_def
  apply (subst SC.comp_char)
  apply simp
  apply (simp add: SC.arr_char)
  unfolding PointedArr'_def
  apply simp
  by (simp add: fin_set.comp_char)

end

end


(*  Title:       Tarski's geometry
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

section "Tarski's geometry"

theory Tarski
  imports Complex_Main Miscellany Metric
begin

subsection "The axioms"
text \<open>The axioms, and all theorems beginning with \emph{th}
  followed by a number, are based on corresponding axioms and
  theorems in \<^cite>\<open>"schwabhauser"\<close>.\<close>

locale tarski_first3 =
  fixes C :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"     ("_ _ \<congruent> _ _" [99,99,99,99] 50)
  assumes A1: "\<forall>a b. a b \<congruent> b a"
  and A2: "\<forall>a b p q r s. a b \<congruent> p q \<and> a b \<congruent> r s \<longrightarrow> p q \<congruent> r s"
  and A3: "\<forall>a b c. a b \<congruent> c c \<longrightarrow> a = b"

locale tarski_first5 = tarski_first3 +
  fixes B :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"
  assumes A4: "\<forall>q a b c. \<exists>x. B q a x \<and> a x \<congruent> b c"
  and A5: "\<forall>a b c d a' b' c' d'. a \<noteq> b \<and> B a b c \<and> B a' b' c'
                                               \<and> a b \<congruent> a' b' \<and> b c \<congruent> b' c' \<and> a d \<congruent> a' d' \<and> b d \<congruent> b' d'
                                       \<longrightarrow> c d \<congruent> c' d'"

locale tarski_absolute_space = tarski_first5 +
  assumes A6: "\<forall>a b. B a b a \<longrightarrow> a = b"
  and A7: "\<forall>a b c p q. B a p c \<and> B b q c \<longrightarrow> (\<exists>x. B p x b \<and> B q x a)"
  and A11: "\<forall>X Y. (\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y)
                        \<longrightarrow> (\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y)"

locale tarski_absolute = tarski_absolute_space +
  assumes A8: "\<exists>a b c. \<not> B a b c \<and> \<not> B b c a \<and> \<not> B c a b"
  and A9: "\<forall>p q a b c. p \<noteq> q \<and> a p \<congruent> a q \<and> b p \<congruent> b q \<and> c p \<congruent> c q
                             \<longrightarrow> B a b c \<or> B b c a \<or> B c a b"

locale tarski_space = tarski_absolute_space +
  assumes A10: "\<forall>a b c d t. B a d t \<and> B b d c \<and> a \<noteq> d
                                    \<longrightarrow> (\<exists>x y. B a b x \<and> B a c y \<and> B x t y)"

locale tarski = tarski_absolute + tarski_space

subsection "Semimetric spaces satisfy the first three axioms"

context semimetric
begin
  definition smC :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool" ("_ _ \<congruent>\<^sub>s\<^sub>m _ _" [99,99,99,99] 50)
    where [simp]: "a b \<congruent>\<^sub>s\<^sub>m c d \<equiv> dist a b = dist c d"
end

sublocale semimetric < tarski_first3 smC
proof
  from symm show "\<forall>a b. a b \<congruent>\<^sub>s\<^sub>m b a" by simp
  show "\<forall>a b p q r s. a b \<congruent>\<^sub>s\<^sub>m p q \<and> a b \<congruent>\<^sub>s\<^sub>m r s \<longrightarrow> p q \<congruent>\<^sub>s\<^sub>m r s" by simp
  show "\<forall>a b c. a b \<congruent>\<^sub>s\<^sub>m c c \<longrightarrow> a = b" by simp
qed

subsection "Some consequences of the first three axioms"

context tarski_first3
begin
  notation %invisible C ("_ _ \<equiv> _ _" [99,99,99,99] 50)
  lemma A1': "a b \<congruent> b a"
    by (simp add: A1)

  lemma A2': "\<lbrakk>a b \<congruent> p q; a b \<congruent> r s\<rbrakk> \<Longrightarrow> p q \<congruent> r s"
  proof -
    assume "a b \<congruent> p q" and "a b \<congruent> r s"
    with A2 show ?thesis by blast
  qed

  lemma A3': "a b \<congruent> c c \<Longrightarrow> a = b"
    by (simp add: A3)

  theorem th2_1: "a b \<congruent> a b"
  proof -
    from A2' [of b a a b a b] and A1' [of b a] show ?thesis by simp
  qed

  theorem th2_2: "a b \<congruent> c d \<Longrightarrow> c d \<congruent> a b"
  proof -
    assume "a b \<congruent> c d"
    with A2' [of a b c d a b] and th2_1 [of a b] show ?thesis by simp
  qed

  theorem th2_3: "\<lbrakk>a b \<congruent> c d; c d \<congruent> e f\<rbrakk> \<Longrightarrow> a b \<congruent> e f"
  proof -
    assume "a b \<congruent> c d"
    with th2_2 [of a b c d] have "c d \<congruent> a b" by simp
    assume "c d \<congruent> e f"
    with A2' [of c d a b e f] and \<open>c d \<congruent> a b\<close> show ?thesis by simp
  qed

  theorem th2_4: "a b \<congruent> c d \<Longrightarrow> b a \<congruent> c d"
  proof -
    assume "a b \<congruent> c d"
    with th2_3 [of b a a b c d] and A1' [of b a] show ?thesis by simp
  qed

  definition is_segment :: "'p set \<Rightarrow> bool" where
  "is_segment X \<equiv> \<exists>x y. X = {x, y}"

  definition segments :: "'p set set" where
  "segments = {X. is_segment X}"

  definition SC :: "'p set \<Rightarrow> 'p set \<Rightarrow> bool" where
  "SC X Y \<equiv> \<exists>w x y z. X = {w, x} \<and> Y = {y, z} \<and> w x \<congruent> y z"

  definition SC_rel :: "('p set \<times> 'p set) set" where
  "SC_rel = {(X, Y) | X Y. SC X Y}"

  lemma left_segment_congruence:
    assumes "{a, b} = {p, q}" and "p q \<congruent> c d"
    shows "a b \<congruent> c d"
  proof cases
    assume "a = p"
    with unordered_pair_element_equality [of a b p q] and \<open>{a, b} = {p, q}\<close>
      have "b = q" by simp
    with \<open>p q \<congruent> c d\<close> and \<open>a = p\<close> show ?thesis by simp
  next
    assume "a \<noteq> p"
    with \<open>{a, b} = {p, q}\<close> have "a = q" by auto
    with unordered_pair_element_equality [of a b q p] and \<open>{a, b} = {p, q}\<close>
      have "b = p" by auto
    with \<open>p q \<congruent> c d\<close> and \<open>a = q\<close> have "b a \<congruent> c d" by simp
    with th2_4 [of b a c d] show ?thesis by simp
  qed

  lemma right_segment_congruence:
    assumes "{c, d} = {p, q}" and "a b \<congruent> p q"
    shows "a b \<congruent> c d"
  proof -
    from th2_2 [of a b p q] and \<open>a b \<congruent> p q\<close> have "p q \<congruent> a b" by simp
    with left_segment_congruence [of c d p q a b] and \<open>{c, d} = {p, q}\<close>
      have "c d \<congruent> a b" by simp
    with th2_2 [of c d a b] show ?thesis by simp
  qed

  lemma C_SC_equiv: "a b \<congruent> c d = SC {a, b} {c, d}"
  proof
    assume "a b \<congruent> c d"
    with SC_def [of "{a, b}" "{c, d}"] show "SC {a, b} {c, d}" by auto
  next
    assume "SC {a, b} {c, d}"
    with SC_def [of "{a, b}" "{c, d}"]
      obtain w x y z where "{a, b} = {w, x}" and "{c, d} = {y, z}" and "w x \<congruent> y z"
        by blast
    from left_segment_congruence [of a b w x y z] and
        \<open>{a, b} = {w, x}\<close> and
        \<open>w x \<congruent> y z\<close>
      have "a b \<congruent> y z" by simp
    with right_segment_congruence [of c d y z a b] and \<open>{c, d} = {y, z}\<close>
      show "a b \<congruent> c d" by simp
  qed

  lemmas SC_refl = th2_1 [simplified]

  lemma SC_rel_refl: "refl_on segments SC_rel"
  proof -
    note refl_on_def [of segments SC_rel]
    moreover
    { fix Z
      assume "Z \<in> SC_rel"
      with SC_rel_def obtain X Y where "Z = (X, Y)" and "SC X Y" by auto
      from \<open>SC X Y\<close> and SC_def [of X Y]
        have "\<exists>w x. X = {w, x}" and "\<exists>y z. Y = {y, z}" by auto
      with is_segment_def [of X] and is_segment_def [of Y]
        have "is_segment X" and "is_segment Y" by auto
      with segments_def have "X \<in> segments" and "Y \<in> segments" by auto
      with \<open>Z = (X, Y)\<close> have "Z \<in> segments \<times> segments" by simp }
    hence "SC_rel \<subseteq> segments \<times> segments" by auto
    moreover
    { fix X
      assume "X \<in> segments"
      with segments_def have "is_segment X" by auto
      with is_segment_def [of X] obtain x y where "X = {x, y}" by auto
      with SC_def [of X X] and SC_refl have "SC X X" by (simp add: C_SC_equiv)
      with SC_rel_def have "(X, X) \<in> SC_rel" by simp }
    hence "\<forall>X. X \<in> segments \<longrightarrow> (X, X) \<in> SC_rel" by simp
    ultimately show ?thesis by simp
  qed

  lemma SC_sym:
    assumes "SC X Y"
    shows "SC Y X"
  proof -
    from SC_def [of X Y] and \<open>SC X Y\<close>
      obtain w x y z where "X = {w, x}" and "Y = {y, z}" and "w x \<congruent> y z"
        by auto
    from th2_2 [of w x y z] and \<open>w x \<congruent> y z\<close> have "y z \<congruent> w x" by simp
    with SC_def [of Y X] and \<open>X = {w, x}\<close> and \<open>Y = {y, z}\<close>
      show "SC Y X" by (simp add: C_SC_equiv)
  qed

  lemma SC_sym': "SC X Y = SC Y X"
  proof
    assume "SC X Y"
    with SC_sym [of X Y] show "SC Y X" by simp
  next
    assume "SC Y X"
    with SC_sym [of Y X] show "SC X Y" by simp
  qed

  lemma SC_rel_sym: "sym SC_rel"
  proof -
    { fix X Y
      assume "(X, Y) \<in> SC_rel"
      with SC_rel_def have "SC X Y" by simp
      with SC_sym' have "SC Y X" by simp
      with SC_rel_def have "(Y, X) \<in> SC_rel" by simp }
    with sym_def [of SC_rel] show ?thesis by blast
  qed

  lemma SC_trans:
    assumes "SC X Y" and "SC Y Z"
    shows "SC X Z"
  proof -
    from SC_def [of X Y] and \<open>SC X Y\<close>
      obtain w x y z where "X = {w, x}" and "Y = {y, z}" and "w x \<congruent> y z"
        by auto
    from SC_def [of Y Z] and \<open>SC Y Z\<close>
      obtain p q r s where "Y = {p, q}" and "Z = {r, s}" and "p q \<congruent> r s" by auto
    from \<open>Y = {y, z}\<close> and \<open>Y = {p, q}\<close> and \<open>p q \<congruent> r s\<close>
      have "y z \<congruent> r s" by (simp add: C_SC_equiv)
    with th2_3 [of w x y z r s] and \<open>w x \<congruent> y z\<close> have "w x \<congruent> r s" by simp
    with SC_def [of X Z] and \<open>X = {w, x}\<close> and \<open>Z = {r, s}\<close>
      show "SC X Z" by (simp add: C_SC_equiv)
  qed

  lemma SC_rel_trans: "trans SC_rel"
  proof -
    { fix X Y Z
      assume "(X, Y) \<in> SC_rel" and "(Y, Z) \<in> SC_rel"
      with SC_rel_def have "SC X Y" and "SC Y Z" by auto
      with SC_trans [of X Y Z] have "SC X Z" by simp
      with SC_rel_def have "(X, Z) \<in> SC_rel" by simp }
    with trans_def [of SC_rel] show ?thesis by blast
  qed

  lemma A3_reversed:
    assumes "a a \<congruent> b c"
    shows "b = c"
  proof -
    from \<open>a a \<congruent> b c\<close> have "b c \<congruent> a a" by (rule th2_2)
    thus "b = c" by (rule A3')
  qed

  lemma equiv_segments_SC_rel: "equiv segments SC_rel"
    by (simp add: equiv_def SC_rel_refl SC_rel_sym SC_rel_trans)

end

subsection "Some consequences of the first five axioms"

context tarski_first5
begin
  lemma A4': "\<exists>x. B q a x \<and> a x \<congruent> b c"
    by (simp add: A4 [simplified])

  theorem th2_8: "a a \<congruent> b b"
  proof -
    from A4' [of _ a b b] obtain x where "a x \<congruent> b b" by auto
    with A3' [of a x b] have "x = a" by simp
    with \<open>a x \<congruent> b b\<close> show ?thesis by simp
  qed

  definition OFS :: "['p,'p,'p,'p,'p,'p,'p,'p] \<Rightarrow> bool" where
   "OFS a b c d a' b' c' d' \<equiv>
      B a b c \<and> B a' b' c' \<and> a b \<congruent> a' b' \<and> b c \<congruent> b' c' \<and> a d \<congruent> a' d' \<and> b d \<congruent> b' d'"

  lemma A5': "\<lbrakk>OFS a b c d a' b' c' d'; a \<noteq> b\<rbrakk> \<Longrightarrow> c d \<congruent> c' d'"
  proof -
    assume "OFS a b c d a' b' c' d'" and "a \<noteq> b"
    with A5 and OFS_def show ?thesis by blast
  qed

  theorem th2_11:
    assumes hypotheses:
      "B a b c"
      "B a' b' c'"
      "a b \<congruent> a' b'"
      "b c \<congruent> b' c'"
    shows "a c \<congruent> a' c'"
  proof cases
    assume "a = b"
    with \<open>a b \<congruent> a' b'\<close> have "a' = b'" by (simp add: A3_reversed)
    with \<open>b c \<congruent> b' c'\<close> and \<open>a = b\<close> show ?thesis by simp
  next
    assume "a \<noteq> b"
    moreover
      note A5' [of a b c a a' b' c' a'] and
        unordered_pair_equality [of a c] and
        unordered_pair_equality [of a' c']
    moreover
      from OFS_def [of a b c a a' b' c' a'] and
          hypotheses and
          th2_8 [of a a'] and
          unordered_pair_equality [of a b] and
          unordered_pair_equality [of a' b']
        have "OFS a b c a a' b' c' a'" by (simp add: C_SC_equiv)
    ultimately show ?thesis by (simp add: C_SC_equiv)
  qed

  lemma A4_unique:
    assumes "q \<noteq> a" and "B q a x" and "a x \<congruent> b c"
    and "B q a x'" and "a x' \<congruent> b c"
    shows "x = x'"
  proof -
    from SC_sym' and SC_trans and C_SC_equiv and \<open>a x' \<congruent> b c\<close> and \<open>a x \<congruent> b c\<close>
      have "a x \<congruent> a x'" by blast
    with th2_11 [of q a x q a x'] and \<open>B q a x\<close> and \<open>B q a x'\<close> and SC_refl
      have "q x \<congruent> q x'" by simp
    with OFS_def [of q a x x q a x x'] and
        \<open>B q a x\<close> and
        SC_refl and
        \<open>a x \<congruent> a x'\<close>
      have "OFS q a x x q a x x'" by simp
    with A5' [of q a x x q a x x'] and \<open>q \<noteq> a\<close> have "x x \<congruent> x x'" by simp
    thus "x = x'" by (rule A3_reversed)
  qed

  theorem th2_12:
    assumes "q \<noteq> a"
    shows "\<exists>!x. B q a x \<and> a x \<congruent> b c"
    using \<open>q \<noteq> a\<close> and A4' and A4_unique
    by blast
end

subsection "Simple theorems about betweenness"

theorem (in tarski_first5) th3_1: "B a b b"
proof -
  from A4 [rule_format, of a b b b] obtain x where "B a b x" and "b x \<congruent> b b" by auto
  from A3 [rule_format, of b x b] and \<open>b x \<congruent> b b\<close> have "b = x" by simp
  with \<open>B a b x\<close> show "B a b b" by simp
qed

context tarski_absolute_space
begin
  lemma A6':
    assumes "B a b a"
    shows "a = b"
  proof -
    from A6 and \<open>B a b a\<close> show "a = b" by simp
  qed

  lemma A7':
    assumes "B a p c" and "B b q c"
    shows "\<exists>x. B p x b \<and> B q x a"
  proof -
    from A7 and \<open>B a p c\<close> and \<open>B b q c\<close> show ?thesis by blast
  qed

  lemma A11':
    assumes "\<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y"
    shows "\<exists> b. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y"
  proof -
    from assms have "\<exists> a. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y" by (rule exI)
    thus "\<exists> b. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y" by (rule A11 [rule_format])
  qed

  theorem th3_2:
    assumes "B a b c"
    shows "B c b a"
  proof -
    from th3_1 have "B b c c" by simp
    with A7' and \<open>B a b c\<close> obtain x where "B b x b" and "B c x a" by blast
    from A6' and \<open>B b x b\<close> have "x = b" by auto
    with \<open>B c x a\<close> show "B c b a" by simp
  qed

  theorem th3_4:
    assumes "B a b c" and "B b a c"
    shows "a = b"
  proof -
    from \<open>B a b c\<close> and \<open>B b a c\<close> and A7' [of a b c b a]
    obtain x where "B b x b" and "B a x a" by auto
    hence "b = x" and "a = x" by (simp_all add: A6')
    thus "a = b" by simp
  qed

  theorem th3_5_1:
    assumes "B a b d" and "B b c d"
    shows "B a b c"
  proof -
    from \<open>B a b d\<close> and \<open>B b c d\<close> and A7' [of a b d b c]
    obtain x where "B b x b" and "B c x a" by auto
    from \<open>B b x b\<close> have "b = x" by (rule A6')
    with \<open>B c x a\<close> have "B c b a" by simp
    thus "B a b c" by (rule th3_2)
  qed

  theorem th3_6_1:
    assumes "B a b c" and "B a c d"
    shows "B b c d"
  proof -
    from \<open>B a c d\<close> and \<open>B a b c\<close> and th3_2 have "B d c a" and "B c b a" by fast+
    hence "B d c b" by (rule th3_5_1)
    thus "B b c d" by (rule th3_2)
  qed

  theorem th3_7_1:
    assumes "b \<noteq> c" and "B a b c" and "B b c d"
    shows "B a c d"
  proof -
    from A4' obtain x where "B a c x" and "c x \<congruent> c d" by fast
    from \<open>B a b c\<close> and \<open>B a c x\<close> have "B b c x" by (rule th3_6_1)
    have "c d \<congruent> c d" by (rule th2_1)
    with \<open>b \<noteq> c\<close> and \<open>B b c x\<close> and \<open>c x \<congruent> c d\<close> and \<open>B b c d\<close>
    have "x = d" by (rule A4_unique)
    with \<open>B a c x\<close> show "B a c d" by simp
  qed

subsection "Simple theorems about congruence and betweenness"

definition (in tarski_first5) Col :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool" where
  "Col a b c \<equiv> B a b c \<or> B b c a \<or> B c a b"

end


theory Ground_Ctxt
  imports Ground_Terms
begin

subsubsection \<open>Ground context\<close>

datatype (gfuns_ctxt: 'f) gctxt =
  GHole ("\<box>\<^sub>G") | GMore 'f "'f gterm list" "'f gctxt" "'f gterm list"
declare gctxt.map_comp[simp]

fun gctxt_apply_term :: "'f gctxt \<Rightarrow> 'f gterm \<Rightarrow> 'f gterm" ("_\<langle>_\<rangle>\<^sub>G" [1000, 0] 1000) where
  "\<box>\<^sub>G\<langle>s\<rangle>\<^sub>G = s" |
  "(GMore f ss1 C ss2)\<langle>s\<rangle>\<^sub>G = GFun f (ss1 @ C\<langle>s\<rangle>\<^sub>G # ss2)"

fun hole_gpos where
  "hole_gpos \<box>\<^sub>G = []" |
  "hole_gpos (GMore f ss1 C ss2) = length ss1 # hole_gpos C"

lemma gctxt_eq [simp]: "(C\<langle>s\<rangle>\<^sub>G = C\<langle>t\<rangle>\<^sub>G) = (s = t)"
  by (induct C) auto

fun gctxt_compose :: "'f gctxt \<Rightarrow> 'f gctxt \<Rightarrow> 'f gctxt" (infixl "\<circ>\<^sub>G\<^sub>c" 75) where
  "\<box>\<^sub>G \<circ>\<^sub>G\<^sub>c D = D" |
  "(GMore f ss1 C ss2) \<circ>\<^sub>G\<^sub>c D = GMore f ss1 (C \<circ>\<^sub>G\<^sub>c D) ss2"

fun gctxt_at_pos :: "'f gterm \<Rightarrow> pos \<Rightarrow> 'f gctxt" where
  "gctxt_at_pos t [] = \<box>\<^sub>G" |
  "gctxt_at_pos (GFun f ts) (i # ps) =
    GMore f (take i ts) (gctxt_at_pos (ts ! i) ps) (drop (Suc i) ts)"

interpretation ctxt_monoid_mult: monoid_mult "\<box>\<^sub>G" "(\<circ>\<^sub>G\<^sub>c)"
proof
  fix C D E :: "'f gctxt"
  show "C \<circ>\<^sub>G\<^sub>c D \<circ>\<^sub>G\<^sub>c E = C \<circ>\<^sub>G\<^sub>c (D \<circ>\<^sub>G\<^sub>c E)" by (induct C) simp_all
  show "\<box>\<^sub>G \<circ>\<^sub>G\<^sub>c C = C" by simp
  show "C \<circ>\<^sub>G\<^sub>c \<box>\<^sub>G = C" by (induct C) simp_all
qed

instantiation gctxt :: (type) monoid_mult
begin
  definition [simp]: "1 = \<box>\<^sub>G"
  definition [simp]: "(*) = (\<circ>\<^sub>G\<^sub>c)"
  instance by (intro_classes) (simp_all add: ac_simps)
end

lemma ctxt_ctxt_compose [simp]: "(C \<circ>\<^sub>G\<^sub>c D)\<langle>t\<rangle>\<^sub>G = C\<langle>D\<langle>t\<rangle>\<^sub>G\<rangle>\<^sub>G"
  by (induct C) simp_all

lemmas ctxt_ctxt = ctxt_ctxt_compose [symmetric]

fun ctxt_of_gctxt where
   "ctxt_of_gctxt \<box>\<^sub>G = \<box>"
|  "ctxt_of_gctxt (GMore f ss C ts) = More f (map term_of_gterm ss) (ctxt_of_gctxt C) (map term_of_gterm ts)"

fun gctxt_of_ctxt where
   "gctxt_of_ctxt \<box> = \<box>\<^sub>G"
|  "gctxt_of_ctxt (More f ss C ts) = GMore f (map gterm_of_term ss) (gctxt_of_ctxt C) (map gterm_of_term ts)"

lemma ground_ctxt_of_gctxt [simp]:
  "ground_ctxt (ctxt_of_gctxt s)"
  by (induct s) auto

lemma ground_ctxt_of_gctxt' [simp]:
  "ctxt_of_gctxt C = More f ss D ts \<Longrightarrow> ground_ctxt (More f ss D ts)"
  by (induct C) auto

lemma ctxt_of_gctxt_inv [simp]:
  "gctxt_of_ctxt (ctxt_of_gctxt t) = t"
  by (induct t) (auto intro!: nth_equalityI)

lemma inj_ctxt_of_gctxt: "inj_on ctxt_of_gctxt X"
  by (metis inj_on_def ctxt_of_gctxt_inv)

lemma gctxt_of_ctxt_inv [simp]:
  "ground_ctxt C \<Longrightarrow> ctxt_of_gctxt (gctxt_of_ctxt C) = C"
  by (induct C) (auto 0 0 intro!: nth_equalityI)

lemma map_ctxt_of_gctxt [simp]:
  "map_ctxt f g (ctxt_of_gctxt C) = ctxt_of_gctxt (map_gctxt f C)"
  by (induct C) auto

lemma map_gctxt_of_ctxt [simp]:
  "ground_ctxt C \<Longrightarrow> gctxt_of_ctxt (map_ctxt f g C) = map_gctxt f (gctxt_of_ctxt C)"
  by (induct C) auto

lemma map_gctxt_nempty [simp]:
  "C \<noteq> \<box>\<^sub>G \<Longrightarrow> map_gctxt f C \<noteq> \<box>\<^sub>G"
  by (cases C) auto

lemma gctxt_set_funs_ctxt:
  "gfuns_ctxt C = funs_ctxt (ctxt_of_gctxt C)"
  using gterm_set_gterm_funs_terms
  by (induct C) fastforce+

lemma ctxt_set_funs_gctxt:
  assumes "ground_ctxt C"
  shows "gfuns_ctxt (gctxt_of_ctxt C) = funs_ctxt C"
  using assms term_set_gterm_funs_terms
  by (induct C) fastforce+

lemma vars_ctxt_of_gctxt [simp]:
  "vars_ctxt (ctxt_of_gctxt C) = {}"
  by (induct C) auto

lemma vars_ctxt_of_gctxt_subseteq [simp]:
  "vars_ctxt (ctxt_of_gctxt C) \<subseteq> Q \<longleftrightarrow> True"
  by auto

lemma term_of_gterm_ctxt_apply_ground [simp]:
  "term_of_gterm s = C\<langle>l\<rangle> \<Longrightarrow> ground_ctxt C"
  "term_of_gterm s = C\<langle>l\<rangle> \<Longrightarrow> ground l"
  by (metis ground_ctxt_apply ground_term_of_gterm)+

lemma term_of_gterm_ctxt_subst_apply_ground [simp]:
  "term_of_gterm s = C\<langle>l \<cdot> \<sigma>\<rangle> \<Longrightarrow> x \<in> vars_term l \<Longrightarrow> ground (\<sigma> x)"
  by (meson ground_substD term_of_gterm_ctxt_apply_ground(2))

lemma gctxt_compose_HoleE:
 "C \<circ>\<^sub>G\<^sub>c D = \<box>\<^sub>G \<Longrightarrow> C = \<box>\<^sub>G"
 "C \<circ>\<^sub>G\<^sub>c D = \<box>\<^sub>G \<Longrightarrow> D = \<box>\<^sub>G"
  by (cases C; cases D, auto)+

\<comment> \<open>Relations between ground contexts and contexts\<close>

lemma nempty_ground_ctxt_gctxt [simp]:
  "C \<noteq> \<box> \<Longrightarrow> ground_ctxt C \<Longrightarrow> gctxt_of_ctxt C \<noteq> \<box>\<^sub>G"
  by (induct C) auto

lemma ctxt_of_gctxt_apply [simp]:
  "gterm_of_term (ctxt_of_gctxt C)\<langle>term_of_gterm t\<rangle> = C\<langle>t\<rangle>\<^sub>G"
  by (induct C) (auto simp: comp_def map_idI)

lemma ctxt_of_gctxt_apply_gterm:
  "gterm_of_term (ctxt_of_gctxt C)\<langle>t\<rangle> = C\<langle>gterm_of_term t\<rangle>\<^sub>G"
  by (induct C) (auto simp: comp_def map_idI)

lemma ground_gctxt_of_ctxt_apply_gterm:
  assumes "ground_ctxt C"
  shows "term_of_gterm (gctxt_of_ctxt C)\<langle>t\<rangle>\<^sub>G = C\<langle>term_of_gterm t\<rangle>" using assms
  by (induct C) (auto simp: comp_def map_idI)

lemma ground_gctxt_of_ctxt_apply [simp]:
  assumes "ground_ctxt C" "ground t"
  shows "term_of_gterm (gctxt_of_ctxt C)\<langle>gterm_of_term t\<rangle>\<^sub>G = C\<langle>t\<rangle>" using assms
  by (induct C) (auto simp: comp_def map_idI)

lemma term_of_gterm_ctxt_apply [simp]:
  "term_of_gterm s = C\<langle>l\<rangle> \<Longrightarrow> (gctxt_of_ctxt C)\<langle>gterm_of_term l\<rangle>\<^sub>G = s"
  by (metis ctxt_of_gctxt_apply_gterm gctxt_of_ctxt_inv term_of_gterm_ctxt_apply_ground(1) term_of_gterm_inv)

lemma gctxt_apply_inj_term: "inj (gctxt_apply_term C)"
  by (auto simp: inj_on_def)

lemma gctxt_apply_inj_on_term: "inj_on (gctxt_apply_term C) S"
  by (auto simp: inj_on_def)

lemma ctxt_of_pos_gterm [simp]:
  "p \<in> gposs t \<Longrightarrow> ctxt_at_pos (term_of_gterm t) p = ctxt_of_gctxt (gctxt_at_pos t p)"
  by (induct t arbitrary: p) (auto simp add: take_map drop_map)

lemma gctxt_of_gpos_gterm_gsubt_at_to_gterm [simp]:
  assumes "p \<in> gposs t"
  shows "(gctxt_at_pos t p)\<langle>gsubt_at t p\<rangle>\<^sub>G = t" using assms
  by (induct t arbitrary: p) (auto simp: comp_def min_def nth_append_Cons intro!: nth_equalityI)

text \<open>The position of the hole in a context is uniquely determined\<close>
fun ghole_pos :: "'f gctxt \<Rightarrow> pos" where
  "ghole_pos \<box>\<^sub>G = []" |
  "ghole_pos (GMore f ss D ts) = length ss # ghole_pos D"

lemma ghole_pos_gctxt_at_pos [simp]:
  "p \<in> gposs t \<Longrightarrow> ghole_pos (gctxt_at_pos t p) = p"
  by (induct t arbitrary: p) auto

lemma ghole_pos_id_ctxt [simp]:
  "C\<langle>s\<rangle>\<^sub>G = t \<Longrightarrow> gctxt_at_pos t (ghole_pos C) = C"
  by (induct C arbitrary: t) auto

lemma ghole_pos_in_apply:
  "ghole_pos C = p \<Longrightarrow> p \<in> gposs C\<langle>u\<rangle>\<^sub>G"
  by (induct C arbitrary: p) (auto simp: nth_append)

lemma ground_hole_pos_to_ghole:
  "ground_ctxt C \<Longrightarrow> ghole_pos (gctxt_of_ctxt C) = hole_pos C"
  by (induct C) auto

lemma gsubst_at_gctxt_at_eq_gtermD:
  assumes "s = t" "p \<in> gposs t"
  shows "gsubt_at s p = gsubt_at t p \<and> gctxt_at_pos s p = gctxt_at_pos t p" using assms
  by auto

lemma gsubst_at_gctxt_at_eq_gtermI:
  assumes "p \<in> gposs s" "p \<in> gposs t"
    and "gsubt_at s p = gsubt_at t p"
    and "gctxt_at_pos s p = gctxt_at_pos t p"
  shows "s = t" using assms
  using gctxt_of_gpos_gterm_gsubt_at_to_gterm by force

lemma gsubt_at_gctxt_apply_ghole [simp]:
  "gsubt_at C\<langle>u\<rangle>\<^sub>G (ghole_pos C) = u"
  by (induct C) auto

lemma gctxt_at_pos_gsubt_at_pos [simp]:
  "p \<in> gposs t \<Longrightarrow> gsubt_at (gctxt_at_pos t p)\<langle>u\<rangle>\<^sub>G p = u"
proof (induct p arbitrary: t)
  case (Cons i p)
  then show ?case using id_take_nth_drop
    by (cases t) (auto simp: nth_append)
qed auto

lemma gfun_at_gctxt_at_pos_not_after:
  assumes "p \<in> gposs t" "q \<in> gposs t" "\<not> (p \<le>\<^sub>p q)"
  shows "gfun_at (gctxt_at_pos t p)\<langle>v\<rangle>\<^sub>G q = gfun_at t q" using assms
proof (induct q arbitrary: p t)
  case Nil
  then show ?case
    by (cases p; cases t) auto
next
  case (Cons i q)
  from Cons(4) obtain j r where [simp]: "p = j # r" by (cases p) auto
  from Cons(4) have "j = i \<Longrightarrow> \<not> (r \<le>\<^sub>p q)" by auto
  from this Cons(2-) Cons(1)[of r "gargs t ! j"]
  have "j = i \<Longrightarrow> gfun_at (gctxt_at_pos (gargs t ! j) r)\<langle>v\<rangle>\<^sub>G q = gfun_at (gargs t ! j) q"
    by (cases t) auto
  then show ?case using Cons(2, 3)
    by (cases t) (auto simp: nth_append_Cons min_def)
qed

lemma gpos_less_eq_append [simp]: "p \<le>\<^sub>p (p @ q)"
  unfolding position_less_eq_def
  by blast

lemma gposs_ConsE [elim]:
  assumes "i # p \<in> gposs t"
  obtains f ts where "t = GFun f ts" "ts \<noteq> []" "i < length ts" "p \<in> gposs (ts ! i)" using assms
  by (cases t) force+

lemma gposs_gctxt_at_pos_not_after:
  assumes "p \<in> gposs t" "q \<in> gposs t" "\<not> (p \<le>\<^sub>p q)"
  shows "q \<in> gposs (gctxt_at_pos t p)\<langle>v\<rangle>\<^sub>G \<longleftrightarrow> q \<in> gposs t" using assms
proof (induct q arbitrary: p t)
  case Nil then show ?case
    by (cases p; cases t) auto
next
  case (Cons i q)
  from Cons(4) obtain j r where [simp]: "p = j # r" by (cases p) auto
  from Cons(4) have "j = i \<Longrightarrow> \<not> (r \<le>\<^sub>p q)" by auto
  from this Cons(2-) Cons(1)[of r "gargs t ! j"]
  have "j = i \<Longrightarrow> q \<in> gposs (gctxt_at_pos (gargs t ! j) r)\<langle>v\<rangle>\<^sub>G \<longleftrightarrow> q \<in> gposs (gargs t ! j)"
    by (cases t) auto
  then show ?case using Cons(2, 3)
    by (cases t) (auto simp: nth_append_Cons min_def)
qed

lemma gposs_gctxt_at_pos:
  "p \<in> gposs t \<Longrightarrow> gposs (gctxt_at_pos t p)\<langle>v\<rangle>\<^sub>G = {q. q \<in> gposs t \<and> \<not> (p \<le>\<^sub>p q)} \<union> (@) p ` gposs v"
proof (induct p arbitrary: t)
  case (Cons i p)
  show ?case using Cons(1)[of "gargs t ! i"] Cons(2) gposs_gctxt_at_pos_not_after[OF Cons(2)]
    by (auto simp: min_def nth_append_Cons split: if_splits elim!: gposs_ConsE)
qed auto

lemma eq_gctxt_at_pos:
  assumes "p \<in> gposs s" "p \<in> gposs t"
    and "\<And> q. \<not> (p \<le>\<^sub>p q) \<Longrightarrow> q \<in> gposs s \<longleftrightarrow> q \<in> gposs t"
    and "(\<And> q. q \<in> gposs s \<Longrightarrow> \<not> (p \<le>\<^sub>p q) \<Longrightarrow> gfun_at s q = gfun_at t q)"
  shows "gctxt_at_pos s p = gctxt_at_pos t p" using assms(1, 2)
  using arg_cong[where ?f = gctxt_of_ctxt, OF eq_ctxt_at_pos_by_poss, of _ "term_of_gterm s :: (_, unit) term"
   "term_of_gterm t :: (_, unit) term" for s t, unfolded poss_gposs_conv fun_at_gfun_at_conv ctxt_of_pos_gterm,
   OF assms]
  by simp

text \<open>Signature of a ground context\<close>

fun funas_gctxt :: "'f gctxt \<Rightarrow> ('f \<times> nat) set" where
  "funas_gctxt GHole = {}" |
  "funas_gctxt (GMore f ss1 D ss2) = {(f, Suc (length (ss1 @ ss2)))}
     \<union> funas_gctxt D \<union> \<Union>(set (map funas_gterm (ss1 @ ss2)))"

lemma funas_gctxt_of_ctxt [simp]:
  "ground_ctxt C \<Longrightarrow> funas_gctxt (gctxt_of_ctxt C) = funas_ctxt C"
  by (induct C) (auto simp: funas_gterm_gterm_of_term)

lemma funas_ctxt_of_gctxt_conv [simp]:
  "funas_ctxt (ctxt_of_gctxt C) = funas_gctxt C"
  by (induct C) (auto simp flip: funas_gterm_gterm_of_term)

lemma inj_gctxt_of_ctxt_on_ground:
  "inj_on gctxt_of_ctxt (Collect ground_ctxt)"
  using gctxt_of_ctxt_inv by (fastforce simp: inj_on_def)

lemma funas_gterm_ctxt_apply [simp]:
  "funas_gterm C\<langle>s\<rangle>\<^sub>G = funas_gctxt C \<union> funas_gterm s"
  by (induct C) auto

lemma funas_gctxt_compose [simp]:
  "funas_gctxt (C \<circ>\<^sub>G\<^sub>c D) = funas_gctxt C \<union> funas_gctxt D"
  by (induct C arbitrary: D) auto

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Rational Root Test\<close>

text \<open>This theory contains a formalization of the rational root test, i.e., a decision
  procedure to test whether a polynomial over the rational numbers has a rational root.\<close>

theory Rational_Root_Test
imports
  Gauss_Lemma
  Missing_List
  Prime_Factorization
begin

definition rational_root_test_main ::
  "(int \<Rightarrow> int list) \<Rightarrow> (int \<Rightarrow> int list) \<Rightarrow> rat poly \<Rightarrow> rat option" where
  "rational_root_test_main df dp p \<equiv> let ip = snd (rat_to_normalized_int_poly p);
    a0 = coeff ip 0; an = coeff ip (degree ip)
    in if a0 = 0 then Some 0 else
     let d0 = df a0; dn = dp an
     in map_option fst
     (find_map_filter (\<lambda> x. (x,poly p x))
     (\<lambda> (_, res). res = 0) [rat_of_int b0 / of_int bn . b0 <- d0, bn <- dn, coprime b0 bn ])"

definition rational_root_test :: "rat poly \<Rightarrow> rat option" where
  "rational_root_test p =
     rational_root_test_main divisors_int divisors_int_pos p"

lemma rational_root_test_main:
  "rational_root_test_main df dp p = Some x \<Longrightarrow> poly p x = 0"
  "divisors_fun df \<Longrightarrow> divisors_pos_fun dp \<Longrightarrow> rational_root_test_main df dp p = None \<Longrightarrow> \<not> (\<exists> x. poly p x = 0)"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  obtain a ip where rp: "rat_to_normalized_int_poly p = (a,ip)" by force
  from rat_to_normalized_int_poly[OF this] have p: "p = smult a (?rp ip)" and a00: "a \<noteq> 0"
    and cip: "p \<noteq> 0 \<Longrightarrow> content ip = 1" by auto
  let ?a0 = "coeff ip 0"
  let ?an = "coeff ip (degree ip)"
  let ?d0 = "df ?a0"
  let ?dn = "dp ?an"
  let ?ip = "?rp ip"
  define tests where "tests = [rat_of_int b0 / rat_of_int bn . b0 <- ?d0, bn <- ?dn, coprime b0 bn ]"
  let ?f = "(\<lambda> x. (x,poly p x))"
  let ?test = "(\<lambda> (_, res). res = 0)"
  define mo where "mo = find_map_filter ?f ?test tests"
  note d = rational_root_test_main_def[of df dp p, unfolded Let_def rp snd_conv mo_def[symmetric] tests_def[symmetric]]
  {
    assume "rational_root_test_main df dp p = Some x"
    from this[unfolded d] have "?a0 = 0 \<and> x = 0 \<or> map_option fst mo = Some x" by (auto split: if_splits)
    thus "poly p x = 0"
    proof
      assume *: "?a0 = 0 \<and> x = 0"
      hence "coeff p 0 = 0" unfolding p coeff_smult by simp
      hence "poly p 0 = 0" by (cases p, auto)
      with * show ?thesis by auto
    next
      assume "map_option fst mo = Some x"
      then obtain pair where find: "find_map_filter ?f ?test tests = Some pair" and x: "x = fst pair"
        unfolding mo_def by (auto split: option.splits)
      then obtain z where pair: "pair = (x,z)" by (cases pair, auto)
      from find_map_filter_Some[OF find, unfolded pair split] show "poly p x = 0" by auto
    qed
  }
  assume df: "divisors_fun df" and dp: "divisors_pos_fun dp" and res: "rational_root_test_main df dp p = None"
  note df = divisors_funD[OF df] note dp = divisors_pos_funD[OF dp]
  from res[unfolded d] have a0: "?a0 \<noteq> 0" and res: "map_option fst mo = None" by (auto split: if_splits)
  from res[unfolded mo_def] have find: "find_map_filter ?f ?test tests = None" by auto
  show "\<not> (\<exists> x. poly p x = 0)"
  proof
    assume "\<exists> x. poly p x = 0"
    then obtain x where "poly p x = 0" by auto
    from this[unfolded p] a00 have "poly (?rp ip) x = 0" by auto
    from this[unfolded poly_eq_0_iff_dvd] have "[: -x , 1 :] dvd ?ip" by auto
    then obtain q where ip_id: "?ip = [: -x, 1 :] * q" unfolding dvd_def by auto
    obtain c q where x1: "rat_to_normalized_int_poly [: -x, 1 :] = (c, q)" by force
    from rat_to_int_factor_explicit[OF ip_id x1] obtain r where  ip: "ip = q * r" by blast
    from rat_to_normalized_int_poly(4)[OF x1] have deg: "degree q = 1" by auto
    from degree1_coeffs[OF deg] obtain a b where q: "q = [: b, a :]" and a: "a \<noteq> 0" by auto
    have ipr: "ip = [: b, a :] * r" using ip q by auto
    from arg_cong[OF ipr, of "\<lambda> p. coeff p 0"] have ba0: "b dvd ?a0" by auto
    have rpq: "?rp q = [: ?r b, ?r a :]" unfolding q
    proof (rule poly_eqI, unfold of_int_hom.coeff_map_poly_hom)
      fix n
      show "?r (coeff [:b, a:] n) = coeff [: ?r b, ?r a:] n"
        unfolding coeff_pCons
        by (cases n, force, cases "n - 1", auto)
    qed
    from arg_cong[OF ip, of ?rp, unfolded of_int_poly_hom.hom_mult rpq] have "[: ?r b, ?r a :] dvd ?rp ip"
      unfolding dvd_def by blast
    hence "smult (inverse (?r a)) [: ?r b , ?r a :] dvd ?rp ip"
      by (rule smult_dvd, insert a, auto)
    also have "smult (inverse (?r a)) [: ?r b , ?r a :] = [: ?r b / ?r a, 1 :]" using a
      by (simp add: field_simps)
    finally have "[: - (- ?r b / ?r a), 1 :] dvd ?rp ip" by simp
    from this[unfolded poly_eq_0_iff_dvd[symmetric]]
    have rt: "poly (?rp ip) (- ?r b / ?r a) = 0" .
    hence rt: "poly p (- ?r b / ?r a) = 0"
      unfolding p using a00 by simp
    obtain aa bb where quot: "quotient_of (- ?r b / ?r a) = (bb,aa)" by force
    hence "quotient_of (?r (-b) / ?r a) = (bb, aa)" by simp
    from quotient_of_int_div[OF this \<open>a \<noteq> 0\<close>] obtain z where
      z: "z \<noteq> 0" and b: "- b = z * bb" and a: "a = z * aa" by auto
    from rt[unfolded quotient_of_div[OF quot]] have rt: "poly p (?r bb / ?r aa) = 0" by auto
    from quotient_of_coprime[OF quot] have cop: "coprime bb aa" "coprime (- bb) aa" by auto
    from quotient_of_denom_pos[OF quot] have aa: "aa > 0" by auto
    from ba0 arg_cong[OF b, of uminus] z have bba0: "bb dvd ?a0" unfolding dvd_def
      by (metis ba0 dvdE dvd_mult_right minus_dvd_iff)
    hence bb0: "bb \<noteq> 0" using a0 by auto
    from df[OF a0 bba0] have bb: "bb \<in> set ?d0" by auto
    from a0 have ip0: "ip \<noteq> 0" by auto
    hence an0: "?an \<noteq> 0" by auto
    from ipr ip0 have "r \<noteq> 0" by auto
    from degree_mult_eq[OF _ this, of "[:b,a:]", folded ipr] \<open>a \<noteq> 0\<close> ipr
    have deg: "degree ip = Suc (degree r)" by auto
    from arg_cong[OF ipr, of "\<lambda> p. coeff p (degree ip)"] have ba0: "a dvd ?an"
      unfolding deg by (auto simp: coeff_eq_0)
    hence "aa dvd ?an" using \<open>a \<noteq> 0\<close> unfolding a by (auto simp: dvd_def)
    from dp[OF an0 this aa] have aa: "aa \<in> set ?dn" .
    from find_map_filter_None[OF find] rt have "(?r bb / ?r aa) \<notin> set tests" by auto
    note test = this[unfolded tests_def, simplified, rule_format, of _ aa]
    from this[of bb] cop bb aa
    show False by auto
  qed
qed

lemma rational_root_test:
  "rational_root_test p = Some x \<Longrightarrow> poly p x = 0"
  "rational_root_test p = None \<Longrightarrow> \<not> (\<exists> x. poly p x = 0)"
  using rational_root_test_main(1) rational_root_test_main(2)[OF divisors_fun_int divisors_pos_fun_int]
  unfolding rational_root_test_def by blast+

end


theory Defs
  imports Main
begin

text \<open>Definitions and lemmas from the tutorial\<close>

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] x = [x]" |
"snoc (y # ys) x = y # (snoc ys x)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x # xs) = snoc (reverse xs) x"

lemma reverse_snoc: "reverse (snoc xs y) = y # reverse xs"
by (induct xs) auto

theorem reverse_reverse: "reverse (reverse xs) = xs"
  by (induct xs) (auto simp add: reverse_snoc)

end


section \<open>Internally Vertex-Disjoint Paths\<close>

theory DisjointPaths imports Separations begin

text \<open>
  Menger's Theorem talks about internally vertex-disjoint @{term v0}-@{term v1}-paths.  Let us
  define this concept.
\<close>

locale DisjointPaths = v0_v1_Digraph +
  fixes paths :: "'a Walk set"
  assumes paths:
    "\<And>xs. xs \<in> paths \<Longrightarrow> v0\<leadsto>xs\<leadsto>v1"
  and paths_disjoint: "\<And>xs ys v.
    \<lbrakk> xs \<in> paths; ys \<in> paths; xs \<noteq> ys; v \<in> set xs; v \<in> set ys \<rbrakk> \<Longrightarrow> v = v0 \<or> v = v1"

subsection \<open>Basic Properties\<close>

text \<open>The empty set of paths trivially satisfies the conditions.\<close>
lemma (in v0_v1_Digraph) DisjointPaths_empty: "DisjointPaths G v0 v1 {}"
  by (simp add: DisjointPaths.intro DisjointPaths_axioms_def v0_v1_Digraph_axioms)

text \<open>Re-adding a deleted vertex is fine.\<close>
lemma (in v0_v1_Digraph) DisjointPaths_supergraph:
  assumes "DisjointPaths (remove_vertex v) v0 v1 paths"
  shows "DisjointPaths G v0 v1 paths"
proof
  interpret H: DisjointPaths "remove_vertex v" v0 v1 paths using assms .
  show "\<And>xs. xs \<in> paths \<Longrightarrow> v0 \<leadsto>xs\<leadsto> v1" using remove_vertex_path_from_to_add H.paths by blast
  show "\<And>xs ys v. \<lbrakk> xs \<in> paths; ys \<in> paths; xs \<noteq> ys; v \<in> set xs; v \<in> set ys \<rbrakk> \<Longrightarrow> v = v0 \<or> v = v1"
    by (meson DisjointPaths.paths_disjoint H.DisjointPaths_axioms)
qed

context DisjointPaths begin

lemma paths_in_all_paths: "paths \<subseteq> all_paths" unfolding all_paths_def using paths by blast
lemma finite_paths: "finite paths"
  using finitely_many_paths infinite_super paths_in_all_paths by blast

lemma paths_edge_finite: "finite (\<Union>(edges_of_walk ` paths))" proof-
  have "\<Union>(edges_of_walk ` paths) \<subseteq> E" using edges_of_walk_in_E paths by fastforce
  then show ?thesis by (meson finite_edge_set finite_subset)
qed

lemma paths_tl_notnil: "xs \<in> paths \<Longrightarrow> tl xs \<noteq> Nil"
  by (metis path_from_toE hd_Cons_tl last_ConsL paths v0_neq_v1)

lemma paths_second_in_V: "xs \<in> paths \<Longrightarrow> hd (tl xs) \<in> V"
  by (metis paths edges_are_in_V(2) list.exhaust_sel path_from_toE paths_tl_notnil walk_first_edge')

lemma paths_second_not_v1: "xs \<in> paths \<Longrightarrow> hd (tl xs) \<noteq> v1"
  using paths paths_tl_notnil v0_nonadj_v1 walk_first_edge' by fastforce

lemma paths_second_disjoint: "\<lbrakk> xs \<in> paths; ys \<in> paths; xs \<noteq> ys \<rbrakk> \<Longrightarrow> hd (tl xs) \<noteq> hd (tl ys)"
  by (metis paths_disjoint Nil_tl hd_in_set list.set_sel(2)
      paths_second_not_v0 paths_second_not_v1 paths_tl_notnil)

lemma paths_edge_disjoint:
  assumes "xs \<in> paths" "ys \<in> paths" "xs \<noteq> ys"
  shows "edges_of_walk xs \<inter> edges_of_walk ys = {}"
proof (rule ccontr)
  assume "edges_of_walk xs \<inter> edges_of_walk ys \<noteq> {}"
  then obtain v w where v_w: "(v,w) \<in> edges_of_walk xs" "(v,w) \<in> edges_of_walk ys" by auto
  then have "v \<in> set xs" "w \<in> set xs" "v \<in> set ys" "w \<in> set ys" by (meson walk_edges_vertices)+
  then have "v = v0 \<or> v = v1" "w = v0 \<or> w = v1" using assms paths_disjoint by blast+
  then show False using v_w(1) assms(1) v0_nonadj_v1 edges_of_walk_edge path_edges
    by (metis distinct_length_2_or_more path_decomp(2) path_from_to_def path_from_to_ends paths)
qed

text \<open>Specify the conditions for adding a new disjoint path to the set of disjoint paths.\<close>
lemma DisjointPaths_extend:
  assumes P_path: "v0\<leadsto>P\<leadsto>v1"
      and P_disjoint: "\<And>xs v. \<lbrakk> xs \<in> paths; xs \<noteq> P; v \<in> set xs; v \<in> set P \<rbrakk> \<Longrightarrow> v = v0 \<or> v = v1"
  shows "DisjointPaths G v0 v1 (insert P paths)"
proof
  fix xs ys v
  assume "xs \<in> insert P paths" "ys \<in> insert P paths" "xs \<noteq> ys" "v \<in> set xs" "v \<in> set ys"
  then show "v = v0 \<or> v = v1"
    by (metis DisjointPaths.paths_disjoint DisjointPaths_axioms P_disjoint insert_iff)
next
  show "\<And>xs. xs \<in> insert P paths \<Longrightarrow> v0 \<leadsto>xs\<leadsto> v1"
    using P_path paths by blast
qed

lemma DisjointPaths_reduce:
  assumes "paths' \<subseteq> paths"
  shows "DisjointPaths G v0 v1 paths'"
proof
  fix xs assume "xs \<in> paths'" then show "v0 \<leadsto>xs\<leadsto> v1" using assms paths by blast
next
  fix xs ys v assume "xs \<in> paths'" "ys \<in> paths'" "xs \<noteq> ys" "v \<in> set xs" "v \<in> set ys"
  then show "v = v0 \<or> v = v1" by (meson assms paths_disjoint subsetCE)
qed

subsection \<open>Second Vertices\<close>

text \<open>
  Let us now define the set of second vertices of the paths.  We are going to need this in order
  to find a path avoiding the old paths on its first edge.
\<close>

definition second_vertex where "second_vertex \<equiv> \<lambda>xs :: 'a Walk. hd (tl xs)"
definition second_vertices where "second_vertices \<equiv> second_vertex ` paths"

lemma second_vertex_inj: "inj_on second_vertex paths"
  unfolding second_vertex_def using paths_second_disjoint by (meson inj_onI)

lemma second_vertices_card: "card second_vertices = card paths"
  unfolding second_vertices_def using finite_paths card_image second_vertex_inj by blast

lemma second_vertices_in_V: "second_vertices \<subseteq> V"
  unfolding second_vertex_def second_vertices_def using paths_second_in_V by blast
lemma v0_v1_notin_second_vertices: "v0 \<notin> second_vertices" "v1 \<notin> second_vertices"
  unfolding second_vertices_def second_vertex_def
  using paths_second_not_v0 paths_second_not_v1 by blast+

lemma second_vertices_new_path: "hd (tl xs) \<notin> second_vertices \<Longrightarrow> xs \<notin> paths"
  by (metis image_iff second_vertex_def second_vertices_def)

text \<open>
  If we have no small separations, then the set of second vertices is not a separator and we can
  find a path avoiding this set.
\<close>
lemma disjoint_paths_new_path:
  assumes no_small_separations: "\<And>S. Separation G v0 v1 S \<Longrightarrow> card S \<ge> Suc (card paths)"
  shows "\<exists>P_new. v0\<leadsto>P_new\<leadsto>v1 \<and> set P_new \<inter> second_vertices = {}"
proof-
  have "\<not>Separation G v0 v1 second_vertices"
    using no_small_separations second_vertices_card by force
  then show ?thesis
      by (simp add: path_exists_if_no_separation second_vertices_in_V v0_v1_notin_second_vertices)
qed

text \<open>
  We need the following predicate to find the first vertex on a new path that hits one of the
  other paths.  We add the condition @{term "x = v1"} to cover the case @{term "paths = {}"}.
\<close>
definition hitting_paths where
  "hitting_paths \<equiv> \<lambda>x. x \<noteq> v0 \<and> ((\<exists>xs \<in> paths. x \<in> set xs) \<or> x = v1)"

end \<comment> \<open>DisjointPaths\<close>

section \<open>One More Path\<close>

text \<open>
  Let us define a set of disjoint paths with one more path.  Except for the first and last vertex,
  the new path must be disjoint from all other paths.  The first vertex must be @{term v0} and the
  last vertex must be on some other path.  In the ideal case, the last vertex will be @{term v1},
  in which case we are already done because we have found a new disjoint path between @{term v0}
  and @{term v1}.
\<close>
locale DisjointPathsPlusOne = DisjointPaths +
  fixes P_new :: "'a Walk"
  assumes P_new:
    "v0 \<leadsto>P_new\<leadsto> (last P_new)"
  and tl_P_new:
    "tl P_new \<noteq> Nil"
    "hd (tl P_new) \<notin> second_vertices"
  and last_P_new:
    "hitting_paths (last P_new)"
    "\<And>v. v \<in> set (butlast P_new) \<Longrightarrow> \<not>hitting_paths v"
begin

subsection \<open>Characterizing the New Path\<close>

lemma P_new_hd_disjoint: "\<And>xs. xs \<in> paths \<Longrightarrow> hd (tl P_new) \<noteq> hd (tl xs)"
  using tl_P_new(2) unfolding second_vertices_def second_vertex_def by blast

lemma P_new_new: "P_new \<notin> paths" using P_new_hd_disjoint by auto

definition paths_with_new where "paths_with_new \<equiv> insert P_new paths"

lemma card_paths_with_new: "card paths_with_new = Suc (card paths)"
  unfolding paths_with_new_def using P_new_new by (simp add: finite_paths)

lemma paths_with_new_no_Nil: "Nil \<notin> paths_with_new"
  using P_new paths_tl_notnil paths_with_new_def by fastforce

lemma paths_with_new_start_in_v0: "xs \<in> paths_with_new \<Longrightarrow> hd xs = v0"
  using P_new paths paths_with_new_def by auto

subsection \<open>The Last Vertex of the New Path\<close>

text \<open>
  McCuaig in \cite{DBLP:journals/jgt/McCuaig84} calls the last vertex of @{term P_new} by the name
  @{term x}.  However, this name is somewhat confusing because it is so short and it will be visible
  in most places from now on, so let us give this vertex the more descriptive name of
  @{term new_last}.
\<close>
definition new_pre where "new_pre \<equiv> butlast P_new"
definition new_last where "new_last \<equiv> last P_new"

lemma P_new_decomp: "P_new = new_pre @ [new_last]"
  by (metis new_pre_def append_butlast_last_id list.sel(2) tl_P_new(1) new_last_def)

lemma new_pre_not_Nil: "new_pre \<noteq> Nil" using P_new(1) hitting_paths_def
  by (metis P_new_decomp list.sel(3) self_append_conv2 tl_P_new(1))

lemma new_pre_hitting: "x' \<in> set new_pre \<Longrightarrow> \<not>hitting_paths x'"
  by (simp add: new_pre_def last_P_new(2))

lemma new_last_neq_v0: "new_last \<noteq> v0" using hitting_paths_def P_hit by force

lemma new_last_in_V: "new_last \<in> V" using P_new new_last_def path_in_V by fastforce

lemma new_last_to_v1: "\<exists>R. new_last \<leadsto>R\<leadsto>\<^bsub>remove_vertex v0\<^esub> v1"
proof (cases)
  assume "new_last = v1"
  then have "new_last \<leadsto>[v1]\<leadsto>\<^bsub>remove_vertex v0\<^esub> v1"
    by (metis last.simps list.sel(1) list.set(1) list.simps(15) list.simps(3) path_from_to_def
        path_singleton remove_vertex_path_from_to singletonD v0_V v0_neq_v1 v1_V)
  then show ?thesis by blast
next
  assume "new_last \<noteq> v1"
  then obtain xs where xs: "xs \<in> paths" "new_last \<in> set xs"
    using hitting_paths_def last_P_new(1) new_last_def by auto
  then obtain xs_pre xs_post where xs_decomp: "xs = xs_pre @ new_last # xs_post"
    by (meson split_list)
  then have "new_last \<leadsto>(new_last # xs_post)\<leadsto> v1" using \<open>xs \<in> paths\<close>
    by (metis paths last_appendR list.sel(1) list.simps(3) path_decomp(2) path_from_to_def)
  then have "new_last \<leadsto>(new_last # xs_post)\<leadsto>\<^bsub>remove_vertex v0\<^esub> v1"
    using remove_vertex_path_from_to
    by (metis paths Set.set_insert xs_decomp xs(1) disjoint_insert(1) distinct_append hd_append
        hitting_paths_def last_P_new(1) list.set_sel(1) path_from_to_def v0_V new_last_def)
  then show ?thesis by blast
qed

lemma paths_plus_one_disjoint:
  assumes "xs \<in> paths_with_new" "ys \<in> paths_with_new" "xs \<noteq> ys" "v \<in> set xs" "v \<in> set ys"
  shows "v = v0 \<or> v = v1 \<or> v = new_last"
proof-
  have "xs \<in> paths \<or> ys \<in> paths" using assms(1,2,3) paths_with_new_def by auto
  then have "hitting_paths v \<or> v = v0" using assms(1,2,4,5) unfolding hitting_paths_def by blast
  then show ?thesis using assms last_P_new(2) set_butlast paths_disjoint
    by (metis insert_iff paths_with_new_def new_last_def)
qed

text \<open>If the new path is disjoint, we are happy.\<close>

lemma P_new_solves_if_disjoint:
  "new_last = v1 \<Longrightarrow> \<exists>paths'. DisjointPaths G v0 v1 paths' \<and> card paths' = Suc (card paths)"
  using DisjointPaths_extend P_new(1) paths_plus_one_disjoint card_paths_with_new
  unfolding paths_with_new_def new_last_def by blast

subsection \<open>Removing the Last Vertex\<close>

definition H_x where "H_x \<equiv> remove_vertex new_last"

lemma H_x_Digraph: "Digraph H_x" unfolding H_x_def using remove_vertex_Digraph .

lemma H_x_v0_v1_Digraph: "new_last \<noteq> v1 \<Longrightarrow> v0_v1_Digraph H_x v0 v1" unfolding H_x_def
  using remove_vertices_v0_v1_Digraph hitting_paths_def P_hit by (simp add: H_x_def)

subsection \<open>A New Path Following the Other Paths\<close>

text \<open>
  The following lemma is one of the most complicated technical lemmas in the proof of Menger's
  Theorem.

  Suppose we have a non-trivial path whose edges are all in the edge set of @{term path_with_new}
  and whose first edge equals the first edge of some @{term "P \<in> path_with_new"}.  Also suppose that
  the path does not contain @{term v1} or @{term new_last}.  Then it follows by induction that this
  path is an initial segment of @{term P}.

  Note that McCuaig does not mention this statement at all in his proof because it looks so obvious.
\<close>

lemma new_path_follows_old_paths:
  assumes xs: "v0 \<leadsto>xs\<leadsto> w" "tl xs \<noteq> Nil" "v1 \<notin> set xs" "new_last \<notin> set xs"
      and P: "P \<in> paths_with_new" "hd (tl xs) = hd (tl P)"
      and edges_subset: "edges_of_walk xs \<subseteq> \<Union>(edges_of_walk ` paths_with_new)"
    shows "edges_of_walk xs \<subseteq> edges_of_walk P"
using xs P(2) edges_subset proof (induct "length xs" arbitrary: xs w)
  case 0
  then show ?case using xs(1) by auto
next
  case (Suc n xs w)
  have "n \<noteq> 0" using Suc.hyps(2) Suc.prems(1,2)
    by (metis path_from_toE Nitpick.size_list_simp(2) Suc_inject length_0_conv)
  show ?case proof (cases)
    assume "n = Suc 0"
    then obtain v w where v_w: "xs = [v,w]"
      by (metis (full_types) Suc.hyps(2) length_0_conv length_Suc_conv)
    then have "v = v0" using Suc.prems(1) by auto
    moreover have "w = hd (tl P)" using Suc.prems(5) v_w by auto
    moreover have "edges_of_walk xs = {(v, w)}" using v_w edges_of_walk_2 by simp
    moreover have "(v0, hd (tl P)) \<in> edges_of_walk P" using P tl_P_new(1) P_new paths
      by (metis first_edge_hd_tl first_edge_in_edges insert_iff paths_tl_notnil paths_with_new_def)
    ultimately show ?thesis by auto
  next
    assume "n \<noteq> Suc 0"
    obtain xs' x where xs': "xs = xs' @ [x]"
      by (metis path_from_toE Suc.prems(1) append_butlast_last_id)
    then have "n = length xs'" using xs' using Suc.hyps(2) by auto
    moreover have xs'_path: "v0 \<leadsto>xs'\<leadsto> last xs'"
      using xs' Suc.prems(1) \<open>tl xs \<noteq> Nil\<close> walk_decomp(1)
      by (metis distinct_append hd_append list.sel(3) path_from_to_def self_append_conv2)
    moreover have "tl xs' \<noteq> []" using \<open>n \<noteq> Suc 0\<close>
      by (metis path_from_toE Nitpick.size_list_simp(2) calculation(1,2))
    moreover have "v1 \<notin> set xs'" using xs' Suc.prems(3) by auto
    moreover have "new_last \<notin> set xs'" using xs' Suc.prems(4) by auto
    moreover have "hd (tl xs') = hd (tl P)"
      using xs' \<open>tl xs' \<noteq> []\<close> Suc.prems(5) calculation(2) by auto
    moreover have "edges_of_walk xs' \<subseteq> \<Union>(edges_of_walk ` paths_with_new)"
      using xs' Suc.prems(6) edges_of_comp1 by blast
    ultimately have xs'_edges: "edges_of_walk xs' \<subseteq> edges_of_walk P" using Suc.hyps(1) by blast
    moreover have "edges_of_walk xs = edges_of_walk xs' \<union> { (last xs', x) }"
      using xs' using walk_edges_decomp'[of "butlast xs'" "last xs'" x Nil] xs'_path
      by (metis path_from_toE Un_empty_right append_assoc append_butlast_last_id butlast.simps(2)
          edges_of_walk_empty(2) last_ConsL last_ConsR list.distinct(1))
    moreover have "(last xs', x) \<in> edges_of_walk P" proof (rule ccontr)
      assume contra: "(last xs', x) \<notin> edges_of_walk P"
      have xs_last_edge: "(last xs', x) \<in> edges_of_walk xs"
        using xs' calculation(2) by blast
      then obtain P' where
        P': "P' \<in> paths_with_new" "(last xs', x) \<in> edges_of_walk P'"
        using Suc.prems(6) by auto
      then have "P \<noteq> P'" using contra by blast
      moreover have "last xs' \<in> set P" using xs_last_edge xs'_edges \<open>tl xs' \<noteq> []\<close> xs'_path
        by (metis path_from_toE last_in_set subsetCE walk_edges_subset)
      moreover have "last xs' \<in> set P'" using P'(2) by (meson walk_edges_vertices(1))
      ultimately have "last xs' = v0 \<or> last xs' = v1 \<or> last xs' = new_last"
        using paths_plus_one_disjoint P'(1) P paths_with_new_def by auto
      then show False using Suc.prems(3) \<open>new_last \<notin> set xs'\<close> \<open>tl xs' \<noteq> []\<close> xs' xs'_path
         by (metis path_from_toE butlast_snoc in_set_butlastD last_in_set last_tl path_from_to_first)
    qed
    ultimately show ?thesis by simp
  qed
qed

end \<comment> \<open>locale @{locale DisjointPathsPlusOne}\<close>

end