theory Tree_Automata_Impl
  imports Tree_Automata_Abstract_Impl
   "HOL-Library.List_Lexorder"
   "HOL-Library.AList_Mapping"
   Tree_Automata_Class_Instances_Impl
   Containers.Containers
begin

definition map_val_of_list :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'c list) \<Rightarrow> 'b list \<Rightarrow> ('a, 'c list) mapping" where
  "map_val_of_list ek ev xs = foldr (\<lambda>x m. Mapping.update (ek x) (ev x @ case_option Nil id (Mapping.lookup m (ek x))) m) xs Mapping.empty"

abbreviation "map_of_list ek ev xs \<equiv> map_val_of_list ek (\<lambda> x. [ev x]) xs"

lemma map_val_of_list_tabulate_conv:
  "map_val_of_list ek ev xs = Mapping.tabulate (sort (remdups (map ek xs))) (\<lambda> k. concat (map ev (filter (\<lambda> x. k = ek x) xs)))"
  unfolding map_val_of_list_def
proof (induct xs)
  case (Cons x xs) then show ?case
    by (intro mapping_eqI) (auto simp: lookup_combine lookup_update' lookup_empty lookup_tabulate image_iff)
qed (simp add: empty_Mapping tabulate_Mapping)

lemmas map_val_of_list_simp = map_val_of_list_tabulate_conv lookup_tabulate
subsection \<open>Setup for the list implementation of reachable states\<close>

definition reach_infer0_cont where
  "reach_infer0_cont \<Delta> =
     map r_rhs (filter (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> ps = []) (sorted_list_of_fset \<Delta>))"

definition reach_infer1_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'q \<Rightarrow> 'q fset \<Rightarrow> 'q list" where
  "reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
    (let rules = sorted_list_of_fset \<Delta> in
     let eps   = sorted_list_of_fset \<Delta>\<^sub>\<epsilon> in
     let mapp_r = map_val_of_list fst snd (concat (map (\<lambda> r. map (\<lambda> q. (q, [r])) (r_lhs_states r)) rules)) in
     let mapp_e = map_of_list fst snd eps in
    (\<lambda> p bs.
    (map r_rhs (filter (\<lambda> r. case r of TA_rule f qs q \<Rightarrow>
      fset_of_list qs |\<subseteq>| finsert p bs) (case_option Nil id (Mapping.lookup mapp_r p)))) @
      case_option Nil id (Mapping.lookup mapp_e p)))"

locale reach_rules_fset =
  fixes \<Delta> :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin

sublocale reach_horn "TA \<Delta> \<Delta>\<^sub>\<epsilon>" .

lemma infer1:
  "infer1 p (fset bs) = set (reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> p bs)"
  unfolding reach_infer1 reach_infer1_cont_def set_append Un_assoc[symmetric] Let_def
  unfolding sorted_list_of_fset_simps union_fset
  apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
  subgoal
    apply (auto simp: fset_of_list_elem less_eq_fset.rep_eq fset_of_list.rep_eq image_iff
      map_val_of_list_simp fmember_iff_member_fset split!: ta_rule.splits)
    apply (metis list.set_intros(1) ta_rule.sel(2, 3))
    apply (metis in_set_simps(2) ta_rule.exhaust_sel)
    done
  subgoal
    apply (simp add: image_def Bex_def fmember_iff_member_fset map_val_of_list_simp)
    done
  done

sublocale l: horn_fset "reach_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>)" "reach_infer0_cont \<Delta>" "reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>"
  apply (unfold_locales)
  unfolding reach_infer0 reach_infer0_cont_def
  subgoal
    apply (auto simp: image_iff ta_rule.case_eq_if Bex_def fset_of_list_elem fmember_iff_member_fset)
    apply force
    apply (metis ta_rule.collapse)+
    done
  subgoal using infer1
    apply blast
    done
  done

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon> =
   horn_fset_impl.saturate_impl (reach_infer0_cont \<Delta>) (reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"

lemma reach_fset_impl_sound:
  "reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon> = Some xs \<Longrightarrow> fset xs = ta_reach (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
  using reach_rules_fset.saturate_impl_sound unfolding reach_cont_impl_def
  unfolding reach_horn.reach_sound .

lemma reach_fset_impl_complete:
  "reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon> \<noteq> None"
proof -
  have "finite (ta_reach (TA \<Delta> \<Delta>\<^sub>\<epsilon>))"
    unfolding ta_reach_reachable by simp
  then show ?thesis unfolding reach_cont_impl_def
    by (intro reach_rules_fset.saturate_impl_complete)
      (auto simp: reach_horn.reach_sound)
qed

lemma reach_impl [code]:
  "ta_reachable (TA \<Delta> \<Delta>\<^sub>\<epsilon>) = the (reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon>)"
  using reach_fset_impl_sound[of \<Delta> \<Delta>\<^sub>\<epsilon>]
  apply (auto simp add: ta_reach_reachable reach_fset_impl_complete fset_of_list_elem)
  apply (metis fset_inject option.exhaust_sel reach_fset_impl_complete)+
  done

subsection \<open>Setup for list implementation of productive states\<close>
definition productive_infer1_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'q \<Rightarrow> 'q fset \<Rightarrow> 'q list" where
  "productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
    (let rules = sorted_list_of_fset \<Delta> in
     let eps   = sorted_list_of_fset \<Delta>\<^sub>\<epsilon> in
     let mapp_r = map_of_list (\<lambda> r. r_rhs r) r_lhs_states rules in
     let mapp_e = map_of_list snd fst eps in
    (\<lambda> p bs.
     (case_option Nil id (Mapping.lookup mapp_e p)) @
     concat (case_option Nil id (Mapping.lookup mapp_r p))))"

locale productive_rules_fset =
  fixes \<Delta> :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>\<epsilon> :: "('q \<times> 'q) fset" and P :: "'q fset"
begin

sublocale productive_horn "TA \<Delta> \<Delta>\<^sub>\<epsilon>" P .

lemma infer1:
  "infer1 p (fset bs) = set (productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> p bs)"
  unfolding productive_infer1 productive_infer1_cont_def set_append Un_assoc[symmetric]
  unfolding union_fset sorted_list_of_fset_simps Let_def set_append
  apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
  subgoal
    apply (simp add: image_def Bex_def fmember_iff_member_fset map_val_of_list_simp)
    done
  subgoal
    apply (auto simp flip: fmember_iff_member_fset simp: map_val_of_list_simp image_iff)
    apply (metis ta_rule.sel(2, 3))
    apply (metis ta_rule.collapse)
    apply (metis notin_fset ta_rule.sel(3))
    done
  done

sublocale l: horn_fset "productive_rules P (TA \<Delta> \<Delta>\<^sub>\<epsilon>)" "sorted_list_of_fset P" "productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>"
  apply (unfold_locales)
  using infer1 productive_infer0 fset_of_list.rep_eq
  by fastforce+

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon> =
   horn_fset_impl.saturate_impl (sorted_list_of_fset P) (productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"

lemma productive_cont_impl_sound:
  "productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon> = Some xs \<Longrightarrow> fset xs = ta_productive_ind P (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
  using productive_rules_fset.saturate_impl_sound unfolding productive_cont_impl_def
  unfolding productive_horn.productive_sound .

lemma productive_cont_impl_complete:
  "productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon> \<noteq> None"
proof -
  have "finite (ta_productive_ind  P (TA \<Delta> \<Delta>\<^sub>\<epsilon>))"
    unfolding ta_productive_ind by simp
  then show ?thesis unfolding productive_cont_impl_def
    by (intro productive_rules_fset.saturate_impl_complete)
      (auto simp: productive_horn.productive_sound)
qed

lemma productive_impl [code]:
  "ta_productive P (TA \<Delta> \<Delta>\<^sub>\<epsilon>) = the (productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon>)"
  using productive_cont_impl_complete[of P \<Delta>] productive_cont_impl_sound[of P \<Delta>]
  by (auto simp add: ta_productive_ind fset_of_list_elem fmember_iff_member_fset)

subsection \<open>Setup for the implementation of power set construction states\<close>

abbreviation "r_statesl r \<equiv> length (r_lhs_states r)"

definition ps_reachable_states_list where
  "ps_reachable_states_list mapp_r mapp_e f ps =
   (let R = filter (\<lambda> r. list_all2 (|\<in>|) (r_lhs_states r) ps)
      (case_option Nil id (Mapping.lookup mapp_r (f, length ps))) in
    let S = map r_rhs R in
    S @ concat (map (case_option Nil id \<circ> Mapping.lookup mapp_e) S))"

lemma ps_reachable_states_list_sound:
  assumes "length ps = n"
  and mapp_r: "case_option Nil id (Mapping.lookup mapp_r (f, n)) =
     filter (\<lambda>r. r_root r = f \<and> r_statesl r = n) (sorted_list_of_fset \<Delta>)"
  and mapp_e: "\<And>p. case_option Nil id (Mapping.lookup mapp_e p) =
     map snd (filter (\<lambda> q. fst q = p) (sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|)))"
  shows "fset_of_list (ps_reachable_states_list mapp_r mapp_e f (map ex ps)) =
   ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex ps)" (is "?Ls = ?Rs")
proof -
  have *: "length ps = n" "length (map ex ps) = n" using assms by auto
  {fix q assume "q |\<in>| ?Ls"
    then obtain qs p where "TA_rule f qs p |\<in>| \<Delta>" "length ps = length qs"
       "list_all2 (|\<in>|) qs (map ex ps)" "p = q \<or> (p, q) |\<in>| \<Delta>\<^sub>\<epsilon>|\<^sup>+|"
      unfolding ps_reachable_states_list_def Let_def comp_def assms(1, 2, 3) *
      by (force simp add: fset_of_list_elem image_iff fBex_def simp flip: fmember_iff_member_fset)
    then have "q |\<in>| ?Rs"
      by (force simp add: ps_reachable_states_fmember image_iff)}
  moreover
    {fix q assume "q |\<in>| ?Rs"
       then obtain qs p where "TA_rule f qs p |\<in>| \<Delta>" "length ps = length qs"
         "list_all2 (|\<in>|) qs (map ex ps)" "p = q \<or> (p, q) |\<in>| \<Delta>\<^sub>\<epsilon>|\<^sup>+|"
         by (auto simp add: ps_reachable_states_fmember list_all2_iff)
       then have "q |\<in>| ?Ls"
         unfolding ps_reachable_states_list_def Let_def * comp_def assms(2, 3)
         by (force simp add: fset_of_list_elem image_iff simp flip: fmember_iff_member_fset)}
  ultimately show ?thesis by blast
qed

lemma rule_target_statesI:
  "\<exists> r |\<in>| \<Delta>. r_rhs r = q \<Longrightarrow> q |\<in>| rule_target_states \<Delta>"
  by auto

definition ps_states_infer0_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset \<Rightarrow>
   ('q \<times> 'q) fset \<Rightarrow> 'q FSet_Lex_Wrapper list" where
   "ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
     (let sig = filter (\<lambda> r. r_lhs_states r = []) (sorted_list_of_fset \<Delta>) in
        filter (\<lambda> p. ex p \<noteq> {||}) (map (\<lambda> r. Wrapp (ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) (r_root r) [])) sig))"

definition ps_states_infer1_cont :: "('q :: linorder , 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow>
   'q FSet_Lex_Wrapper \<Rightarrow> 'q FSet_Lex_Wrapper fset \<Rightarrow> 'q FSet_Lex_Wrapper list" where
  "ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
    (let sig = remdups (map (\<lambda> r. (r_root r, r_statesl r)) (filter (\<lambda> r. r_lhs_states r \<noteq> []) (sorted_list_of_fset \<Delta>))) in
     let arities = remdups (map snd sig) in
     let etr   = sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|) in
     let mapp_r = map_of_list (\<lambda> r. (r_root r, r_statesl r)) id (sorted_list_of_fset \<Delta>) in
     let mapp_e = map_of_list fst snd etr in
    (\<lambda> p bs.
      (let states = sorted_list_of_fset (finsert p bs) in
       let arity_to_states_map = Mapping.tabulate arities (\<lambda> n. list_of_permutation_element_n p n states) in
       let res = map (\<lambda> (f, n).
         map (\<lambda> s. let rules = the (Mapping.lookup mapp_r (f, n)) in
            Wrapp (fset_of_list (ps_reachable_states_list mapp_r mapp_e f (map ex s))))
           (the (Mapping.lookup arity_to_states_map n)))
          sig in
      filter (\<lambda> p. ex p \<noteq> {||}) (concat res))))"

locale ps_states_fset =
  fixes \<Delta> :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin

sublocale ps_states_horn "TA \<Delta> \<Delta>\<^sub>\<epsilon>" .

lemma infer0: "infer0 = set (ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"
  unfolding ps_states_horn.ps_construction_infer0
  unfolding ps_states_infer0_cont_def Let_def
  using ps_reachable_states_fmember
  by (auto simp add: image_def Ball_def Bex_def)
     (metis fmember_iff_member_fset list_all2_Nil2 ps_reachable_states_fmember ta.sel(1) ta_rule.sel(1, 2))

lemma r_lhs_states_nConst:
  "r_lhs_states r \<noteq> [] \<Longrightarrow> r_statesl r \<noteq> 0" for r by auto

lemma filter_empty_conv':
  "[] = filter P xs \<longleftrightarrow> (\<forall>x\<in>set xs. \<not> P x)"
  by (metis filter_empty_conv)

lemma infer1:
  "infer1 p (fset bs) = set (ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> p bs)" (is "?Ls = ?Rs")
proof -
  let ?mapp_r = "map_of_list (\<lambda>r. (r_root r, r_statesl r)) (\<lambda>x. x) (sorted_list_of_fset \<Delta>)"
  let ?mapp_e = "map_of_list fst snd (sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|))"
  have mapr: "case_option Nil id (Mapping.lookup ?mapp_r (f, n)) =
     filter (\<lambda>r. r_root r = f \<and> r_statesl r = n) (sorted_list_of_fset \<Delta>)" for f n
    by (auto simp: map_val_of_list_simp image_iff filter_empty_conv' intro: filter_cong)
  have epsr: "\<And>p. case_option Nil id (Mapping.lookup ?mapp_e p) =
     map snd (filter (\<lambda> q. fst q = p) (sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|)))"
    by (auto simp: map_val_of_list_simp image_iff filter_empty_conv) metis
  have *: "p \<in> set qs \<Longrightarrow> x |\<in>| ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex qs) \<Longrightarrow>
    (\<exists> ps q. TA_rule f ps q |\<in>| \<Delta> \<and> length ps = length qs)" for x f qs
    by (auto simp: ps_reachable_states_fmember list_all2_conv_all_nth)
  {fix q assume "q \<in> ?Ls"
    then obtain f qss where sp: "q = Wrapp (ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex qss))"
      "ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex qss) \<noteq> {||}" "p \<in> set qss" "set qss \<subseteq> insert p (fset bs)"
      by (auto simp add: ps_construction_infer1 ps_reachable_states_fmember)
    from sp(2, 3) obtain ps p' where r: "TA_rule f ps p' |\<in>| \<Delta>" "length ps = length qss" using *
      by blast
    then have mem: "qss \<in> set (list_of_permutation_element_n p (length ps) (sorted_list_of_fset (finsert p bs)))" using sp(2-)
      by (auto simp: list_of_permutation_element_n_iff)
         (meson in_set_idx insertE set_list_subset_eq_nth_conv)
    then have "q \<in> ?Rs" using sp r
      unfolding ps_construction_infer1 ps_states_infer1_cont_def Let_def
      apply (simp add: lookup_tabulate ps_reachable_states_fmember image_iff flip: fmember_iff_member_fset)
      apply (rule_tac x = "f ps \<rightarrow> p'" in exI)
      apply (auto simp: Bex_def ps_reachable_states_list_sound[OF _ mapr epsr] intro: exI[of _ qss])
      done}
  moreover
  {fix q assume ass: "q \<in> ?Rs"
    then obtain r qss where "r |\<in>| \<Delta>" "r_lhs_states r \<noteq> []" "qss \<in> set (list_of_permutation_element_n p (r_statesl r) (sorted_list_of_fset (finsert p bs)))"
      "q = Wrapp (ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) (r_root r) (map ex qss))"
      unfolding ps_states_infer1_cont_def Let_def
      by (auto simp add: lookup_tabulate ps_reachable_states_fmember image_iff
         ps_reachable_states_list_sound[OF _ mapr epsr] split: if_splits simp flip: fmember_iff_member_fset)
    moreover have "q \<noteq> Wrapp {||}" using ass
      by (auto simp: ps_states_infer1_cont_def Let_def)
    ultimately have "q \<in> ?Ls" unfolding ps_construction_infer1
      apply (auto simp: list_of_permutation_element_n_iff intro!: exI[of _ "r_root r"] exI[of _ qss])
      apply (metis in_set_idx)
      done}
  ultimately show ?thesis by blast
qed

sublocale l: horn_fset "ps_states_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>)" "ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon>" "ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>"
  apply (unfold_locales)
  using infer0 infer1
  by fastforce+

lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete

end

definition "ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon> =
   horn_fset_impl.saturate_impl (ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon>) (ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"

lemma ps_states_fset_impl_sound:
  assumes "ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon> = Some xs"
  shows "xs = ps_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
  using ps_states_fset.saturate_impl_sound[OF assms[unfolded ps_states_fset_impl_def]]
  using ps_states_horn.ps_states_sound[of "TA \<Delta> \<Delta>\<^sub>\<epsilon>"]
  by (auto simp: fset_of_list_elem fmember_iff_member_fset ps_states.rep_eq fset_of_list.rep_eq)

lemma ps_states_fset_impl_complete:
  "ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon> \<noteq> None"
proof -
  let ?R = "ps_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
  let ?S = "horn.saturate (ps_states_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>))"
  have "?S \<subseteq> fset ?R"
    using ps_states_horn.ps_states_sound
    by (simp add: ps_states_horn.ps_states_sound ps_states.rep_eq)
  from finite_subset[OF this] show ?thesis
  unfolding ps_states_fset_impl_def
  by (intro ps_states_fset.saturate_impl_complete) simp
qed

lemma ps_ta_impl [code]:
  "ps_ta (TA \<Delta> \<Delta>\<^sub>\<epsilon>) =
    (let xs = the (ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon>) in
      TA (ps_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>) xs) {||})"
  using ps_states_fset_impl_complete
  using ps_states_fset_impl_sound
  unfolding ps_ta_def Let_def
  by (metis option.exhaust_sel)

lemma ps_reg_impl [code]:
  "ps_reg (Reg Q (TA \<Delta> \<Delta>\<^sub>\<epsilon>)) =
    (let xs = the (ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon>) in
     Reg (ffilter (\<lambda> S. Q |\<inter>| ex S \<noteq> {||}) xs)
         (TA (ps_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>) xs) {||}))"
  using ps_states_fset_impl_complete[of \<Delta> \<Delta>\<^sub>\<epsilon>]
  using ps_states_fset_impl_sound[of \<Delta> \<Delta>\<^sub>\<epsilon>]
  unfolding ps_reg_def ps_ta_Q\<^sub>f_def Let_def
  unfolding ps_ta_def Let_def
  using eq_ffilter by auto

lemma prod_ta_zip [code]:
  "prod_ta_rules (\<A> :: ('q1 :: linorder, 'f :: linorder) ta) (\<B> :: ('q2 :: linorder, 'f :: linorder) ta) =
   (let sig = sorted_list_of_fset (ta_sig \<A> |\<inter>| ta_sig \<B>) in
    let mapA = map_of_list (\<lambda>r. (r_root r, r_statesl r)) id (sorted_list_of_fset (rules \<A>)) in
    let mapB = map_of_list (\<lambda>r. (r_root r, r_statesl r)) id (sorted_list_of_fset (rules \<B>)) in
    let merge = (\<lambda> (ra, rb). TA_rule (r_root ra) (zip (r_lhs_states ra) (r_lhs_states rb)) (r_rhs ra, r_rhs rb)) in
      fset_of_list (
      concat (map (\<lambda> (f, n). map merge
        (List.product (the (Mapping.lookup mapA (f, n))) (the (Mapping.lookup mapB (f, n))))) sig)))"
 (is "?Ls = ?Rs")
proof -
  have [simp]: "distinct (sorted_list_of_fset (ta_sig \<A>))"  "distinct (sorted_list_of_fset (ta_sig \<B>))"
    by (simp_all add: distinct_sorted_list_of_fset)
  have *: "sort (remdups (map (\<lambda>r. (r_root r, r_statesl r)) (sorted_list_of_fset (rules \<A>)))) = sorted_list_of_fset (ta_sig \<A>)"
   "sort (remdups (map (\<lambda>r. (r_root r, r_statesl r)) (sorted_list_of_fset (rules \<B>)))) = sorted_list_of_fset (ta_sig \<B>)"
     by (auto simp: ta_sig_def sorted_list_of_fset_fimage_dist)
  {fix r assume ass: "r |\<in>| ?Ls"
    then obtain f qs q where [simp]: "r = f qs \<rightarrow> q" by auto
    then have "(f, length qs) |\<in>| ta_sig \<A> |\<inter>| ta_sig \<B>" using ass by auto
    then have "r |\<in>| ?Rs" using ass unfolding map_val_of_list_tabulate_conv *
      by (auto simp: Let_def fset_of_list_elem image_iff case_prod_beta lookup_tabulate simp flip: fmember_iff_member_fset intro!: bexI[of _ "(f, length qs)"])
         (metis (no_types, lifting) length_map ta_rule.sel(1 - 3) zip_map_fst_snd)}
    moreover
    {fix r assume ass: "r |\<in>| ?Rs" then have "r |\<in>| ?Ls" unfolding map_val_of_list_tabulate_conv *
        by (auto simp: fset_of_list_elem finite_Collect_prod_ta_rules lookup_tabulate simp flip: fmember_iff_member_fset)
           (metis ta_rule.collapse)}
  ultimately show ?thesis by blast
qed

(*
export_code ta_der in Haskell
export_code ta_reachable in Haskell
export_code ta_productive in Haskell
export_code trim_ta in Haskell
export_code ta_restrict in Haskell
export_code ps_reachable_states in Haskell
export_code prod_ta_rules in Haskell
export_code ps_ta in Haskell
export_code ps_reg in Haskell
export_code reg_intersect in Haskell
*)

end


(*
    Title:      Rref.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Reduced row echelon form*}

theory Rref
imports
  "../Rank_Nullity_Theorem/Mod_Type"
  "../Rank_Nullity_Theorem/Miscellaneous"
begin

subsection{*Defining the concept of Reduced Row Echelon Form*}

subsubsection{*Previous definitions and properties*}
text{*This function returns True if each position lesser than k in a column contains a zero.*}
definition is_zero_row_upt_k :: "'rows => nat =>'a::{zero}^'columns::{mod_type}^'rows => bool"
  where "is_zero_row_upt_k i k A = (\<forall>j::'columns. (to_nat j) < k \<longrightarrow> A $ i $ j = 0)"

definition is_zero_row :: "'rows =>'a::{zero}^'columns::{mod_type}^'rows => bool"
  where "is_zero_row i A = is_zero_row_upt_k i (ncols A) A"

lemma is_zero_row_upt_ncols:
  fixes A::"'a::{zero}^'columns::{mod_type}^'rows"
  shows "is_zero_row_upt_k i (ncols A) A = (\<forall>j::'columns. A $ i $ j = 0)" unfolding is_zero_row_def is_zero_row_upt_k_def ncols_def by auto

corollary is_zero_row_def':
  fixes A::"'a::{zero}^'columns::{mod_type}^'rows"
  shows "is_zero_row i A = (\<forall>j::'columns. A $ i $ j = 0)" using is_zero_row_upt_ncols unfolding is_zero_row_def ncols_def .

lemma is_zero_row_eq_row_zero: "is_zero_row a A = (row a A = 0)"
  unfolding is_zero_row_def' row_def
  unfolding vec_nth_inverse
  unfolding vec_eq_iff zero_index ..

lemma not_is_zero_row_upt_suc:
  assumes "\<not> is_zero_row_upt_k i (Suc k) A"
  and "\<forall>i. A $ i $ (from_nat k) = 0"
  shows "\<not> is_zero_row_upt_k i k A"
  using assms from_nat_to_nat_id
  using is_zero_row_upt_k_def less_SucE
  by metis

lemma is_zero_row_upt_k_suc:
  assumes "is_zero_row_upt_k i k A"
  and "A $ i $ (from_nat k) = 0"
  shows "is_zero_row_upt_k i (Suc k) A"
  using assms unfolding is_zero_row_upt_k_def using less_SucE to_nat_from_nat by metis

lemma is_zero_row_utp_0:
  shows "is_zero_row_upt_k m 0 A" unfolding is_zero_row_upt_k_def by fast

lemma is_zero_row_upt_k_le:
  assumes "is_zero_row_upt_k i (Suc k) A"
  shows "is_zero_row_upt_k i k A"
  using assms unfolding is_zero_row_upt_k_def by simp

lemma is_zero_row_imp_is_zero_row_upt:
assumes "is_zero_row i A"
shows "is_zero_row_upt_k i k A"
using assms unfolding  is_zero_row_def is_zero_row_upt_k_def ncols_def by simp

subsubsection{*Definition of reduced row echelon form up to a column*}

text{*This definition returns True if a matrix is in reduced row echelon form up to the column k (not included), otherwise False.*}

(*In the third condition, i<i+1 is assumed to avoid that row i can be the last row (in that case, i+1 would be the first row):*)

definition reduced_row_echelon_form_upt_k :: "'a::{zero, one}^'m::{mod_type}^'n::{finite, ord, plus, one} => nat => bool"
  where "reduced_row_echelon_form_upt_k A k =
  (
    (\<forall>i. is_zero_row_upt_k i k A \<longrightarrow> \<not> (\<exists>j. j>i \<and> \<not> is_zero_row_upt_k j k A)) \<and>
    (\<forall>i. \<not> (is_zero_row_upt_k i k A) \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1) \<and>
    (\<forall>i. i<i+1 \<and> \<not> (is_zero_row_upt_k i k A) \<and> \<not> (is_zero_row_upt_k (i+1) k A) \<longrightarrow> ((LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i+1) $ n \<noteq> 0))) \<and>
    (\<forall>i. \<not> (is_zero_row_upt_k i k A) \<longrightarrow> (\<forall>j. i \<noteq> j \<longrightarrow> A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0))
  )"

lemma rref_upt_0: "reduced_row_echelon_form_upt_k A 0"
  unfolding reduced_row_echelon_form_upt_k_def is_zero_row_upt_k_def by auto

lemma rref_upt_condition1:
  assumes r: "reduced_row_echelon_form_upt_k A k"
  shows "(\<forall>i. is_zero_row_upt_k i k A \<longrightarrow> \<not> (\<exists>j. j>i \<and> \<not> is_zero_row_upt_k j k A))"
  using r unfolding reduced_row_echelon_form_upt_k_def by simp

lemma rref_upt_condition2:
  assumes r: "reduced_row_echelon_form_upt_k A k"
  shows "(\<forall>i. \<not> (is_zero_row_upt_k i k A) \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1)"
  using r unfolding reduced_row_echelon_form_upt_k_def by simp

lemma rref_upt_condition3:
  assumes r: "reduced_row_echelon_form_upt_k A k"
  shows "(\<forall>i. i<i+1 \<and> \<not> (is_zero_row_upt_k i k A) \<and> \<not> (is_zero_row_upt_k (i+1) k A) \<longrightarrow> ((LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i+1) $ n \<noteq> 0)))"
  using r unfolding reduced_row_echelon_form_upt_k_def by simp

lemma rref_upt_condition4:
  assumes r: "reduced_row_echelon_form_upt_k A k"
  shows " (\<forall>i. \<not> (is_zero_row_upt_k i k A) \<longrightarrow> (\<forall>j. i \<noteq> j \<longrightarrow> A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0))"
  using r unfolding reduced_row_echelon_form_upt_k_def by simp

text{*Explicit lemmas for each condition*}

lemma rref_upt_condition1_explicit:
assumes "reduced_row_echelon_form_upt_k A k"
and "is_zero_row_upt_k i k A"
and "j>i"
shows "is_zero_row_upt_k j k A"
using assms rref_upt_condition1 by blast

lemma rref_upt_condition2_explicit:
assumes rref_A: "reduced_row_echelon_form_upt_k A k"
and "\<not> is_zero_row_upt_k i k A"
shows "A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1"
using rref_upt_condition2 assms by blast

lemma rref_upt_condition3_explicit:
assumes "reduced_row_echelon_form_upt_k A k"
and "i < i + 1"
and "\<not> is_zero_row_upt_k i k A"
and "\<not> is_zero_row_upt_k (i + 1) k A "
shows "(LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i + 1) $ n \<noteq> 0)"
using assms rref_upt_condition3 by blast

lemma rref_upt_condition4_explicit:
assumes "reduced_row_echelon_form_upt_k A k"
and "\<not> is_zero_row_upt_k i k A"
and "i \<noteq> j"
shows "A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0"
using assms rref_upt_condition4 by auto

text{*Intro lemma and general properties*}

lemma reduced_row_echelon_form_upt_k_intro:
  assumes "(\<forall>i. is_zero_row_upt_k i k A \<longrightarrow> \<not> (\<exists>j. j>i \<and> \<not> is_zero_row_upt_k j k A))"
  and "(\<forall>i. \<not> (is_zero_row_upt_k i k A) \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1)"
  and "(\<forall>i. i<i+1 \<and> \<not> (is_zero_row_upt_k i k A) \<and> \<not> (is_zero_row_upt_k (i+1) k A) \<longrightarrow> ((LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i+1) $ n \<noteq> 0)))"
  and "(\<forall>i. \<not> (is_zero_row_upt_k i k A) \<longrightarrow> (\<forall>j. i \<noteq> j \<longrightarrow> A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0))"
  shows "reduced_row_echelon_form_upt_k A k"
  unfolding reduced_row_echelon_form_upt_k_def using assms by fast

lemma rref_suc_imp_rref:
  fixes A::"'a::{semiring_1}^'n::{mod_type}^'m::{mod_type}"
  assumes r: "reduced_row_echelon_form_upt_k A (Suc k)"
  and k_le_card: "Suc k < ncols A"
  shows "reduced_row_echelon_form_upt_k A k"
proof (rule reduced_row_echelon_form_upt_k_intro)
  show "\<forall>i. \<not> is_zero_row_upt_k i k A \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1"
    using rref_upt_condition2[OF r] less_SucI unfolding is_zero_row_upt_k_def by blast
  show "\<forall>i. i < i + 1 \<and> \<not> is_zero_row_upt_k i k A \<and> \<not> is_zero_row_upt_k (i + 1) k A \<longrightarrow> (LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i + 1) $ n \<noteq> 0)"
    using rref_upt_condition3[OF r] less_SucI unfolding is_zero_row_upt_k_def by blast
  show "\<forall>i. \<not> is_zero_row_upt_k i k A \<longrightarrow> (\<forall>j. i \<noteq> j \<longrightarrow> A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0)"
    using rref_upt_condition4[OF r] less_SucI unfolding is_zero_row_upt_k_def by blast
  show "\<forall>i. is_zero_row_upt_k i k A \<longrightarrow> \<not> (\<exists>j>i. \<not> is_zero_row_upt_k j k A)"
  proof (clarify, rule ccontr)
    fix i j
    assume zero_i: "is_zero_row_upt_k i k A"
      and i_less_j: "i < j"
      and not_zero_j: "\<not> is_zero_row_upt_k j k A"
    have not_zero_j_suc: "\<not> is_zero_row_upt_k j (Suc k) A"
      using not_zero_j unfolding is_zero_row_upt_k_def by fastforce
    hence not_zero_i_suc: "\<not> is_zero_row_upt_k i (Suc k) A"
      using rref_upt_condition1[OF r] i_less_j by fast
    have not_zero_i_plus_suc: "\<not> is_zero_row_upt_k (i+1) (Suc k) A"
    proof (cases "j=i+1")
      case True thus ?thesis using not_zero_j_suc by simp
    next
      case False
      have "i+1<j" by (rule Suc_less[OF i_less_j False[symmetric]])
      thus ?thesis  using rref_upt_condition1[OF r] not_zero_j_suc by blast
    qed
    from this obtain n where a: "A $ (i+1) $ n \<noteq> 0" and n_less_suc: "to_nat n < Suc k"
      unfolding is_zero_row_upt_k_def by blast
    have "(LEAST n. A $ (i+1) $ n \<noteq> 0) \<le> n" by (rule Least_le, simp add: a)
    also have "... \<le> from_nat k" by (metis Suc_lessD from_nat_mono' from_nat_to_nat_id k_le_card less_Suc_eq_le n_less_suc ncols_def)
    finally have least_le: "(LEAST n. A $ (i + 1) $ n \<noteq> 0) \<le> from_nat k" .
    have least_eq_k: "(LEAST n. A $ i $ n \<noteq> 0) = from_nat k"
    proof (rule Least_equality)
      show "A $ i $ from_nat k \<noteq> 0" using not_zero_i_suc zero_i unfolding is_zero_row_upt_k_def by (metis from_nat_to_nat_id less_SucE)
      show "\<And>y. A $ i $ y \<noteq> 0 \<Longrightarrow> from_nat k \<le> y" by (metis is_zero_row_upt_k_def not_leE to_nat_le zero_i)
    qed
    have i_less: "i<i+1"
    proof (rule Suc_le', rule ccontr)
      assume "\<not> i + 1 \<noteq> 0" hence "i+1=0" by simp
      hence "i=-1" using diff_0 diff_add_cancel diff_minus_eq_add by metis
      hence "j <= i" using Greatest_is_minus_1 by blast
      thus False using i_less_j by fastforce
    qed
    have "from_nat k < (LEAST n. A $ (i+1) $ n \<noteq> 0)"
      using rref_upt_condition3[OF r] i_less not_zero_i_suc not_zero_i_plus_suc least_eq_k by fastforce
    thus False using least_le by simp
  qed
qed

lemma reduced_row_echelon_if_all_zero:
  assumes all_zero: "\<forall>n. is_zero_row_upt_k n k A"
  shows "reduced_row_echelon_form_upt_k A k"
  using assms unfolding reduced_row_echelon_form_upt_k_def is_zero_row_upt_k_def by auto

subsubsection{*The definition of reduced row echelon form*}

text{*Definition of reduced row echelon form, based on @{thm "reduced_row_echelon_form_upt_k_def"[no_vars]}*}
definition reduced_row_echelon_form :: "'a::{zero, one}^'m::{mod_type}^'n::{finite, ord, plus, one} => bool"
  where "reduced_row_echelon_form A = reduced_row_echelon_form_upt_k A (ncols A)"

text{*Equivalence between our definition of reduced row echelon form and the one presented
in Steven Roman's book: Advanced Linear Algebra.*}

lemma reduced_row_echelon_form_def':
"reduced_row_echelon_form A =
  (
    (\<forall>i. is_zero_row i A \<longrightarrow> \<not> (\<exists>j. j>i \<and> \<not> is_zero_row j A)) \<and>
    (\<forall>i. \<not> (is_zero_row i A) \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1) \<and>
    (\<forall>i. i<i+1 \<and> \<not> (is_zero_row i A) \<and> \<not> (is_zero_row (i+1) A) \<longrightarrow> ((LEAST k. A $ i $ k \<noteq> 0) < (LEAST k. A $ (i+1) $ k \<noteq> 0))) \<and>
    (\<forall>i. \<not> (is_zero_row i A) \<longrightarrow> (\<forall>j. i \<noteq> j \<longrightarrow> A $ j $ (LEAST k. A $ i $ k \<noteq> 0) = 0))
  )" unfolding reduced_row_echelon_form_def reduced_row_echelon_form_upt_k_def is_zero_row_def ..

subsection{*Properties of the reduced row echelon form of a matrix*}

lemma rref_condition1:
  assumes r: "reduced_row_echelon_form A"
  shows "(\<forall>i. is_zero_row i A \<longrightarrow> \<not> (\<exists>j. j>i \<and> \<not> is_zero_row j A))" using r unfolding reduced_row_echelon_form_def' by simp

lemma rref_condition2:
  assumes r: "reduced_row_echelon_form A"
  shows " (\<forall>i. \<not> (is_zero_row i A) \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1)" using r unfolding reduced_row_echelon_form_def' by simp

lemma rref_condition3:
  assumes r: "reduced_row_echelon_form A"
  shows "(\<forall>i. i<i+1 \<and> \<not> (is_zero_row i A) \<and> \<not> (is_zero_row (i+1) A) \<longrightarrow> ((LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i+1) $ n \<noteq> 0)))"
  using r unfolding reduced_row_echelon_form_def' by simp

text{*Explicit lemmas for each condition*}

lemma rref_condition1_explicit:
assumes rref_A: "reduced_row_echelon_form A"
and "is_zero_row i A"
shows "\<forall>j>i. is_zero_row j A"
using rref_condition1 assms by blast

lemma rref_condition2_explicit:
assumes rref_A: "reduced_row_echelon_form A"
and "\<not> is_zero_row i A"
shows "A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1"
using rref_condition2 assms by blast

lemma rref_condition3_explicit:
assumes rref_A: "reduced_row_echelon_form A"
and i_le: "i < i + 1"
and "\<not> is_zero_row i A" and "\<not> is_zero_row (i + 1) A"
shows "(LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i + 1) $ n \<noteq> 0)"
using rref_condition3 assms by blast

lemma rref_condition4_explicit:
assumes rref_A: "reduced_row_echelon_form A"
and "\<not> is_zero_row i A"
and "i \<noteq> j"
shows "A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0"
using rref_condition4 assms by blast

text{*Other properties and equivalences*}

lemma rref_condition3_equiv1:
fixes A::"'a::{one, zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
and i_less_j: "i<j"
and j_less_nrows: "j<nrows A"
and not_zero_i: "\<not> is_zero_row (from_nat i) A"
and not_zero_j: "\<not> is_zero_row (from_nat j) A"
shows "(LEAST n. A $ (from_nat i) $ n \<noteq> 0) < (LEAST n. A $ (from_nat j) $ n \<noteq> 0)"
using i_less_j not_zero_j j_less_nrows
proof (induct j)
case 0
show ?case using "0.prems"(1) by simp
next
fix j
assume hyp: "i < j \<Longrightarrow> \<not> is_zero_row (from_nat j) A \<Longrightarrow> j < nrows A \<Longrightarrow> (LEAST n. A $ from_nat i $ n \<noteq> 0) < (LEAST n. A $ from_nat j $ n \<noteq> 0)"
and i_less_suc_j: "i < Suc j"
and not_zero_suc_j: "\<not> is_zero_row (from_nat (Suc j)) A"
and Suc_j_less_nrows: "Suc j < nrows A"
have j_less: "(from_nat j::'rows) < from_nat (j+1)" by (rule from_nat_mono, auto simp add: Suc_j_less_nrows[unfolded nrows_def])
hence not_zero_j: "\<not> is_zero_row (from_nat j) A" using rref_condition1[OF rref] not_zero_suc_j unfolding Suc_eq_plus1 by blast
show "(LEAST n. A $ from_nat i $ n \<noteq> 0) < (LEAST n. A $ from_nat (Suc j) $ n \<noteq> 0)"
proof (cases "i=j")
case True
show ?thesis
 proof (unfold True Suc_eq_plus1 from_nat_suc, rule rref_condition3_explicit)
     show "reduced_row_echelon_form A" using rref .
     show "(from_nat j::'rows) < from_nat j + 1" using j_less unfolding from_nat_suc .
     show "\<not> is_zero_row (from_nat j) A" using not_zero_j .
     show "\<not> is_zero_row (from_nat j + 1) A" using not_zero_suc_j unfolding Suc_eq_plus1 from_nat_suc .
  qed
next
case False
have "(LEAST n. A $ from_nat i $ n \<noteq> 0) < (LEAST n. A $ from_nat j $ n \<noteq> 0)"
  proof (rule hyp)
     show "i < j" using False i_less_suc_j by simp
     show "\<not> is_zero_row (from_nat j) A" using not_zero_j .
     show "j < nrows A" using Suc_j_less_nrows by simp
  qed
also have "... < (LEAST n. A $ from_nat (j+1) $ n \<noteq> 0)"
  proof (unfold from_nat_suc, rule rref_condition3_explicit)
     show "reduced_row_echelon_form A" using rref .
     show "(from_nat j::'rows) < from_nat j + 1" using j_less unfolding from_nat_suc .
     show "\<not> is_zero_row (from_nat j) A" using not_zero_j .
     show "\<not> is_zero_row (from_nat j + 1) A" using not_zero_suc_j unfolding Suc_eq_plus1 from_nat_suc .
  qed
finally show "(LEAST n. A $ from_nat i $ n \<noteq> 0) < (LEAST n. A $ from_nat (Suc j) $ n \<noteq> 0)" unfolding Suc_eq_plus1 .
qed
qed

corollary rref_condition3_equiv:
fixes A::"'a::{one, zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
and i_less_j: "i<j"
and i: "\<not> is_zero_row i A"
and j: "\<not> is_zero_row j A"
shows "(LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ j $ n \<noteq> 0)"
proof (rule rref_condition3_equiv1[of A "to_nat i" "to_nat j", unfolded from_nat_to_nat_id])
 show "reduced_row_echelon_form A" using rref .
 show "to_nat i < to_nat j" by (rule to_nat_mono[OF i_less_j])
 show "to_nat j < nrows A" using to_nat_less_card unfolding nrows_def .
 show "\<not> is_zero_row i A" using i .
 show "\<not> is_zero_row j A" using j .
qed

lemma rref_implies_rref_upt:
fixes A::"'a::{one,zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
shows "reduced_row_echelon_form_upt_k A k"
proof (rule reduced_row_echelon_form_upt_k_intro)
  show "\<forall>i. \<not> is_zero_row_upt_k i k A \<longrightarrow> A $ i $ (LEAST k. A $ i $ k \<noteq> 0) = 1"
    using rref_condition2[OF rref] is_zero_row_imp_is_zero_row_upt by blast
  show "\<forall>i. i < i + 1 \<and> \<not> is_zero_row_upt_k i k A \<and> \<not> is_zero_row_upt_k (i + 1) k A \<longrightarrow> (LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ (i + 1) $ n \<noteq> 0)"
    using rref_condition3[OF rref] is_zero_row_imp_is_zero_row_upt by blast
  show "\<forall>i. \<not> is_zero_row_upt_k i k A \<longrightarrow> (\<forall>j. i \<noteq> j \<longrightarrow> A $ j $ (LEAST n. A $ i $ n \<noteq> 0) = 0)"
    using rref_condition4[OF rref] is_zero_row_imp_is_zero_row_upt by blast
show "\<forall>i. is_zero_row_upt_k i k A \<longrightarrow> \<not> (\<exists>j>i. \<not> is_zero_row_upt_k j k A)"
proof (auto, rule ccontr)
fix i j assume zero_i_k: "is_zero_row_upt_k i k A" and i_less_j: "i < j"
and not_zero_j_k:"\<not> is_zero_row_upt_k j k A"
have not_zero_j: "\<not> is_zero_row j A" using is_zero_row_imp_is_zero_row_upt not_zero_j_k by blast
hence not_zero_i: "\<not> is_zero_row i A" using rref_condition1[OF rref] i_less_j by blast
have Least_less: "(LEAST n. A $ i $ n \<noteq> 0) < (LEAST n. A $ j $ n \<noteq> 0)" by (rule rref_condition3_equiv[OF rref i_less_j not_zero_i not_zero_j])
moreover have "(LEAST n. A $ j $ n \<noteq> 0) < (LEAST n. A $ i $ n \<noteq> 0)"
  proof (rule LeastI2_ex)
     show "\<exists>a. A $ i $ a \<noteq> 0" using not_zero_i unfolding is_zero_row_def is_zero_row_upt_k_def by fast
     fix x assume Aix_not_0: "A $ i $ x \<noteq> 0"
     have k_less_x: "k \<le> to_nat x"  using zero_i_k Aix_not_0 unfolding is_zero_row_upt_k_def by force
     hence k_less_ncols: "k < ncols A" unfolding ncols_def using to_nat_less_card[of x] by simp
     obtain s where Ajs_not_zero: "A $ j $ s \<noteq> 0" and s_less_k: "to_nat s < k" using not_zero_j_k unfolding is_zero_row_upt_k_def by blast
     have "(LEAST n. A $ j $ n \<noteq> 0) \<le> s" using Ajs_not_zero Least_le by fast
     also have "... = from_nat (to_nat s)" unfolding from_nat_to_nat_id ..
     also have "... < from_nat k" by (rule from_nat_mono[OF s_less_k k_less_ncols[unfolded ncols_def]])
     also have "... \<le> x" using k_less_x leD not_leE to_nat_le by fast
     finally show "(LEAST n. A $ j $ n \<noteq> 0) < x" .
  qed
ultimately show False by fastforce
qed
qed

lemma rref_first_position_zero_imp_column_0:
fixes A::"'a::{one,zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
and A_00: "A $ 0 $ 0 = 0"
shows "column 0 A = 0"
proof (unfold column_def, vector, clarify)
fix i
have "is_zero_row_upt_k 0 1 A" unfolding is_zero_row_upt_k_def using A_00 by (metis One_nat_def less_Suc0 to_nat_eq_0)
hence "is_zero_row_upt_k i 1 A" using rref_upt_condition1[OF rref_implies_rref_upt[OF rref]] using least_mod_type less_le by metis
thus "A $ i $ 0 = 0" unfolding is_zero_row_upt_k_def using to_nat_eq_0 by blast
qed

lemma rref_first_element:
fixes A::"'a::{one,zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes rref: "reduced_row_echelon_form A"
and column_not_0: "column 0 A \<noteq> 0"
shows "A $ 0 $ 0 = 1"
proof (rule ccontr)
have A_00_not_0: "A $ 0 $ 0 \<noteq> 0"
  proof (rule ccontr, simp)
    assume A_00: "A $ 0 $ 0 = 0"
    from this obtain i where Ai0: "A $ i $ 0 \<noteq> 0" and i: "i>0" using column_not_0 unfolding column_def by (metis column_def rref rref_first_position_zero_imp_column_0)
    have "is_zero_row_upt_k 0 1 A" unfolding is_zero_row_upt_k_def using A_00 by (metis One_nat_def less_Suc0 to_nat_eq_0)
    moreover have "\<not> is_zero_row_upt_k i 1 A" using Ai0 by (metis is_zero_row_upt_k_def to_nat_0 zero_less_one)
    ultimately have "\<not> reduced_row_echelon_form A" by (metis A_00 column_not_0 rref_first_position_zero_imp_column_0)
    thus False using rref by contradiction
qed
assume A_00_not_1: "A $ 0 $ 0 \<noteq> 1"
have Least_eq_0: "(LEAST n. A $ 0 $ n \<noteq> 0) = 0"
  proof (rule Least_equality)
     show "A $ 0 $ 0 \<noteq> 0" by (rule A_00_not_0)
     show "\<And>y. A $ 0 $ y \<noteq> 0 \<Longrightarrow> 0 \<le> y" using least_mod_type .
  qed
moreover have "\<not> is_zero_row 0 A" unfolding is_zero_row_def is_zero_row_upt_k_def ncols_def using A_00_not_0 by auto
ultimately have "A $ 0 $ (LEAST n. A $ 0 $ n \<noteq> 0) = 1" using rref_condition2[OF rref] by fast
thus False unfolding Least_eq_0 using A_00_not_1 by contradiction
qed

end


theory Utils
  imports "HOL-Library.Multiset"
begin

definition remove :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> ('a \<rightharpoonup> 'b)" where
  "remove f a = f(a := None)"

lemma [simp]: "x \<noteq> y \<Longrightarrow> remove f y x = f x"
  by (simp add: remove_def)

lemma [simp]: "dom (remove f y) = dom f - {y}"
  by (simp add: remove_def)

lemma [simp]: "dom (\<lambda>a. if a = x then Some y else f a) = insert x (dom f)"
  by (auto simp add: dom_if)

lemma [simp]: "ran (f(x \<mapsto> z)) \<subseteq> insert z (ran f)"
  by (auto simp add: ran_def)

lemma [simp]: "map_option Suc opt \<noteq> Some 0"
  by (induction opt) simp_all

lemma [simp]: "image_mset fst (mset ab) = add_mset a s \<Longrightarrow> Some (the (map_of ab a)) = map_of ab a"
proof (induction ab arbitrary: s)
  case (Cons ab abb)
  thus ?case
  proof (induction ab)
    case (Pair aa bb)
    thus ?case
    proof (cases "a = aa")
      case False
      from Pair have "add_mset aa (image_mset fst (mset abb)) - {# aa #} = add_mset a s - {# aa #}"
        by simp
      with False have "image_mset fst (mset abb) = add_mset a (s - {# aa #})" by simp
      with Pair show ?thesis by simp
    qed simp_all
  qed
qed simp_all

lemma [simp]: "length (concat (map f as)) = sum_list (map (length \<circ> f) as)"
  by (induction as) simp_all

lemma [simp]: "length as \<noteq> length bs \<Longrightarrow> map f as \<noteq> map f bs"
proof (induction as arbitrary: bs)
  case Nil
  thus ?case by (induction bs) simp_all
next
  case (Cons a as)
  thus ?case by (induction bs) simp_all
qed

lemma [simp]: "finite as \<Longrightarrow> x \<in> as \<Longrightarrow> 0 < card as"
  by (induction "card as") simp_all

lemma [simp]: "finite as \<Longrightarrow> a \<in> as \<Longrightarrow> Suc (card as - Suc 0) = card as"
  by (induction as rule: finite_induct) simp_all

lemma [simp]: "finite as \<Longrightarrow> finite bs \<Longrightarrow> card as < Suc (card (bs \<union> as))"
proof -
  assume "finite as" and "finite bs"
  hence "card as \<le> card (bs \<union> as)" by (simp add: card_mono)
  thus ?thesis by simp
qed

lemma [simp]: "finite as \<Longrightarrow> finite bs \<Longrightarrow> x \<in> as \<Longrightarrow> x \<notin> bs \<Longrightarrow> card bs < card (as \<union> bs)"
proof (induction as arbitrary: bs rule: finite_induct)
  case (insert a as)
  thus ?case by (cases "x = a") (simp_all add: card_insert_if)
qed simp_all

lemma [simp]: "finite as \<Longrightarrow> finite bs \<Longrightarrow> x \<notin> as \<Longrightarrow> x \<in> bs \<Longrightarrow> card (bs - {x} \<union> as) < card (as \<union> bs)"
proof -
  assume "finite as" and "finite bs" and "x \<in> bs"
  moreover hence "card (insert x (as \<union> bs)) = card (as \<union> bs)" by (simp add: card_insert_if)
  moreover assume "x \<notin> as"
  ultimately show ?thesis by (simp add: Un_Diff card.insert_remove sup_commute)
qed

lemma [simp]: "map_option f \<circ> map_option g \<circ> h = map_option (f \<circ> g) \<circ> h"
  by (rule, auto, metis option.map_comp)

lemma [simp]: "map_option f \<circ> (map_option g \<circ> h) = map_option (f \<circ> g) \<circ> h"
  by (rule, auto, metis option.map_comp)

lemma [simp]: "length as = length bs \<Longrightarrow>
  list_all (\<lambda>(a, b). P a \<and> Q b) (zip as bs) = (list_all P as \<and> list_all Q bs)"
proof (induction as arbitrary: bs)
  case (Cons a as)
  thus ?case by (induction bs) auto
qed simp_all

abbreviation nmem :: "nat \<Rightarrow> 'a" where
  "nmem x \<equiv> undefined"

lemma [simp]: "(a # as @ bs) ! length as = (a # as) ! length as"
  by (induction as arbitrary: a) simp_all

lemma [simp]: "0 < x \<Longrightarrow> x \<le> length as \<Longrightarrow> (as @ bs) ! (length as - x) = as ! (length as - x)"
proof (induction as arbitrary: x bs rule: rev_induct)
  case (snoc a as)
  thus ?case
  proof (induction x)
    case (Suc x)
    thus ?case by (induction x) simp_all
  qed simp_all
qed simp_all

lemma [simp]: "length (concat (replicate x as)) = length as * x"
  by (induction x) simp_all

lemma [simp]: "map f (concat (replicate x as)) = concat (replicate x (map f as))"
  by (induction x) simp_all

lemma [simp]: "map prod.swap (zip as bs) = zip bs as"
proof (induction as arbitrary: bs)
  case (Cons a as)
  thus ?case by (induction bs) simp_all
qed simp_all

lemma [simp]: "x < y \<Longrightarrow> 1 < k \<Longrightarrow> Suc (k * x) < k * y"
  by (metis One_nat_def Suc_lessE Suc_lessI Suc_mult_less_cancel1 Suc_times_mod_eq
            mod_mult_self1_is_0 nat.simps(3))

fun opt_pair :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c) \<Rightarrow> 'a \<rightharpoonup> 'b \<times> 'c" where
  "opt_pair f g a = (case f a of
      None \<Rightarrow> None
    | Some b \<Rightarrow> (case g a of
        None \<Rightarrow> None
      | Some c \<Rightarrow> Some (b, c)))"

end


theory HartshorneCh1 imports Main begin

locale affine_plane_syntax =
  fixes Points :: "'a set" and Lines :: "'a set set"
begin

definition parallel (infix "||" 50)
  where "\<lbrakk> l \<in> Lines; m \<in> Lines \<rbrakk> \<Longrightarrow> l || m \<longleftrightarrow> l = m \<or> \<not> (\<exists> P \<in> Points. P \<in> l \<and> P \<in> m)"
end

definition collinear
  where "\<lbrakk>P \<in> Points; Q \<in> Points; R \<in> Points\<rbrakk> \<Longrightarrow> collinear P Q R \<longleftrightarrow>
(\<exists>l. P \<in> l \<and> Q \<in> l \<and> R \<in> l)"

locale affine_plane = affine_plane_syntax +
  assumes
a1: "\<lbrakk>P \<in> Points; Q \<in> Points; P \<noteq> Q \<rbrakk> \<Longrightarrow> \<exists>!l \<in> Lines. P \<in> l \<and> Q \<in> l" and
a2: "\<lbrakk>l \<in> Lines; P \<in> Points; P \<notin> l \<rbrakk> \<Longrightarrow> \<exists>!m \<in> Lines. l || m \<and> P \<in> m" and
a3: "\<exists> P Q R . (P \<in> Points \<and> Q \<in> Points \<and> R \<in> Points \<and> P \<noteq> Q \<and> Q \<noteq> R \<and> P \<noteq> R) \<and>
\<not> (\<exists>m \<in> Lines. P \<in> m \<and> Q \<in> m \<and> R\<in>m)"
begin

(* work on affine planes to take place here *)
(* perhaps define collinear? *)

(* try to prove, for instance, that if k and m are distinct, then they intersect in at
most one point *)
(* NB: The axioms above are DELIBERATELY incorrect as stated. Let's try to fix them. *)

theorem collinear_comm: "\<lbrakk>A \<in> Points; B \<in> Points; C \<in> Points; collinear A B C\<rbrakk> \<Longrightarrow> collinear A C B"
  using collinear_def by fastforce

lemma parallel_symm[simp]: "\<lbrakk>l \<in> Lines; m \<in> Lines; l || m\<rbrakk> \<Longrightarrow> m || l"
  using parallel_def by blast

lemma parallel_refl[simp]: "\<lbrakk>l \<in> Lines\<rbrakk> \<Longrightarrow> l || l"
  using parallel_def by blast

lemma parallel_trans[simp]: "\<lbrakk>l \<in> Lines; m \<in> Lines; n \<in> Lines; l || m; m || n\<rbrakk> \<Longrightarrow> l || n"
  by (metis a2 parallel_def)

(* Every point lies on some line *)
lemma line_for_point: "\<lbrakk>P \<in> Points\<rbrakk> \<Longrightarrow> \<exists>l \<in> Lines . P \<in> l"
  by (metis a1 a3)

lemma no_empty_line: "{} \<notin> Lines"
proof -
  have "{} \<in> Lines \<Longrightarrow> False"
  proof-
    assume 1: "{} \<in> Lines"
    show False
      proof -
        obtain P Q R where PQR: "P \<in> Points \<and> Q \<in> Points \<and> R \<in> Points \<and> P \<noteq> Q \<and> Q \<noteq> R \<and> P \<noteq> R \<and>
\<not> (\<exists>m \<in> Lines. P \<in> m \<and> Q \<in> m \<and> R\<in>m)" using a3 by blast
        obtain PQ where PQ: "PQ \<in> Lines \<and> P \<in> PQ \<and> Q \<in> PQ"
           using a1 PQR by metis
        obtain PR where PR: "PR \<in> Lines \<and> P \<in> PR \<and> R \<in> PR"
           using a1 PQR by metis
         have "PQ || {} \<and> PR || {}"
           by (simp add: "1" PQ PR parallel_def)
         moreover have "PQ \<noteq> PR"
           using PQ PQR PR by blast
         ultimately have "(PQ \<in> Lines \<and> P \<in> PQ \<and> {} || PQ) \<and> (PR \<in> Lines \<and> P \<in> PR \<and> {} || PR)"
           by (simp add: \<open>PQ || {} \<and> PR || {}\<close> "1" PQ PR)
         thus False
           using "1" PQR \<open>PQ \<noteq> PR\<close> a2 by auto
      qed
    qed
    thus ?thesis by blast
qed

(* when saying P \<in> Points, try couldn't find the proof.
Why omit this statement? *)
(* Every line contains at least one point *)
lemma contained_point: "\<lbrakk>l \<in> Lines\<rbrakk> \<Longrightarrow> \<exists>P . P \<in> l"
proof -
  assume l: "l \<in> Lines"
  have "l \<noteq> {}"
    using l no_empty_line by auto
  thus "\<exists> P .  P \<in> l"
    by auto
qed

lemma four_point: "\<exists> P Q R S . P \<in> Points \<and> Q \<in> Points \<and> R \<in> Points \<and> S \<in> Points \<and>
P \<noteq> Q \<and> P \<noteq> R \<and> P \<noteq> S \<and> Q \<noteq> R \<and> Q \<noteq> S"
proof -
  obtain P Q R where PQR: "P \<in> Points \<and> Q \<in> Points \<and> R \<in> Points \<and> P \<noteq> Q \<and> Q \<noteq> R \<and> P \<noteq> R \<and>
    \<not> (\<exists>m \<in> Lines. P \<in> m \<and> Q \<in> m \<and> R \<in>m)" using a3 by blast
  obtain QR where QR: "QR \<in> Lines \<and> Q \<in> QR \<and> R \<in> QR"
    using a1 PQR by metis
  obtain l where l: "l \<in> Lines \<and> l || QR \<and> P \<in> l"
    by (meson PQR QR affine_plane.a2 affine_plane_axioms parallel_symm)

  obtain PQ where PQ: "PQ \<in> Lines \<and> P \<in> PQ \<and> Q \<in> PQ"
    using a1 PQR by metis
  obtain m where m : "m \<in> Lines \<and> m || PQ \<and> R \<in> m"
    by (meson PQR PQ affine_plane.a2 affine_plane_axioms parallel_symm)

  have "\<not>(l || m)"
    by (metis PQ PQR QR l m parallel_def parallel_trans)

  obtain S where S_meets : "S \<in> Points \<and> S \<in> l \<and>  S \<in> m"
    using \<open>\<not> l || m\<close> l m parallel_def by blast

  have "S \<notin> PQ"
    using PQR PQ S_meets m parallel_def by blast

  have "S \<notin> QR"
    using PQR QR S_meets l parallel_def by blast

  have "S \<noteq> P \<and> S \<noteq> Q \<and> S \<noteq> R"
    using PQ QR \<open>S \<notin> PQ\<close> \<open>S \<notin> QR\<close> by blast

  thus ?thesis
    using PQR by auto
qed

(* Every line contains at least two points *)
lemma contains_two_points: "\<lbrakk>l \<in> Lines\<rbrakk> \<Longrightarrow> \<exists> P Q . P \<in> Points \<and> Q \<in> Points
\<and> P \<in> l \<and> Q \<in> l \<and> P \<noteq> Q"
  sorry

lemma contains_three_points:  "\<lbrakk>l \<in> Lines\<rbrakk> \<Longrightarrow> \<exists> P Q R . (P \<in> Points \<and> Q \<in> Points \<and> R \<in> Points
\<and> P \<in> l \<and> Q \<in> l \<and> R \<in> l \<and> P \<noteq> Q \<and> Q \<noteq> R \<and> P \<noteq> R)"
  nitpick

end (* affine_plane locale *)

end (* theory *)


(*
 * Copyright Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*<*)
theory Guide
  imports Word_Lib_Sumo Word_64
begin

hide_const (open) Generic_set_bit.set_bit

(*>*)
section \<open>A short overview over bit operations and word types\<close>

subsection \<open>Basic theories and key ideas\<close>

text \<open>
  When formalizing bit operations, it is tempting to represent
  bit values as explicit lists over a binary type. This however
  is a bad idea, mainly due to the inherent ambiguities in
  representation concerning repeating leading bits.

  Hence this approach avoids such explicit lists altogether
  following an algebraic path:

    \<^item> Bit values are represented by numeric types: idealized
      unbounded bit values can be represented by type \<^typ>\<open>int\<close>,
      bounded bit values by quotient types over \<^typ>\<open>int\<close>, aka \<^typ>\<open>'a word\<close>.

    \<^item> (A special case are idealized unbounded bit values ending
      in @{term [source] 0} which can be represented by type \<^typ>\<open>nat\<close> but
      only support a restricted set of operations).

  The most fundamental ideas are developed in theory \<^theory>\<open>HOL.Parity\<close>
  (which is part of \<^theory>\<open>Main\<close>):

    \<^item> Multiplication by \<^term>\<open>2 :: int\<close> is a bit shift to the left and

    \<^item> Division by \<^term>\<open>2 :: int\<close> is a bit shift to the right.

    \<^item> Concerning bounded bit values, iterated shifts to the left
    may result in eliminating all bits by shifting them all
    beyond the boundary.  The property \<^prop>\<open>(2 :: int) ^ n \<noteq> 0\<close>
    represents that \<^term>\<open>n\<close> is \<^emph>\<open>not\<close> beyond that boundary.

    \<^item> The projection on a single bit is then @{thm [mode=iff] bit_iff_odd [where ?'a = int, no_vars]}.

    \<^item> This leads to the most fundamental properties of bit values:

      \<^item> Equality rule: @{thm [display, mode=iff] bit_eq_iff [where ?'a = int, no_vars]}

      \<^item> Induction rule: @{thm [display, mode=iff] bits_induct [where ?'a = int, no_vars]}

    \<^item> Characteristic properties \<^prop>\<open>bit (f x) n \<longleftrightarrow> P x n\<close>
      are available in fact collection \<^text>\<open>bit_simps\<close>.

  On top of this, the following generic operations are provided
  after import of theory \<^theory>\<open>HOL-Library.Bit_Operations\<close>:

    \<^item> Singleton \<^term>\<open>n\<close>th bit: \<^term>\<open>(2 :: int) ^ n\<close>

    \<^item> Bit mask upto bit \<^term>\<open>n\<close>: @{thm mask_eq_exp_minus_1 [where ?'a = int, no_vars]}

    \<^item> Left shift: @{thm push_bit_eq_mult [where ?'a = int, no_vars]}

    \<^item> Right shift: @{thm drop_bit_eq_div [where ?'a = int, no_vars]}

    \<^item> Truncation: @{thm take_bit_eq_mod [where ?'a = int, no_vars]}

    \<^item> Negation: @{thm [mode=iff] bit_not_iff [where ?'a = int, no_vars]}

    \<^item> And: @{thm [mode=iff] bit_and_iff [where ?'a = int, no_vars]}

    \<^item> Or: @{thm [mode=iff] bit_or_iff [where ?'a = int, no_vars]}

    \<^item> Xor: @{thm [mode=iff] bit_xor_iff [where ?'a = int, no_vars]}

    \<^item> Set a single bit: @{thm set_bit_def [where ?'a = int, no_vars]}

    \<^item> Unset a single bit: @{thm unset_bit_def [where ?'a = int, no_vars]}

    \<^item> Flip a single bit: @{thm flip_bit_def [where ?'a = int, no_vars]}

    \<^item> Signed truncation, or modulus centered around \<^term>\<open>0::int\<close>:
        @{thm [display] signed_take_bit_def [where ?'a = int, no_vars]}

    \<^item> (Bounded) conversion from and to a list of bits:
        @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}

  Proper word types are introduced in theory \<^theory>\<open>HOL-Library.Word\<close>, with
  the following specific operations:

    \<^item> Standard arithmetic:
        @{term \<open>(+) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
        @{term \<open>uminus :: 'a::len word \<Rightarrow> 'a word\<close>},
        @{term \<open>(-) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
        @{term \<open>(*) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
        @{term \<open>0 :: 'a::len word\<close>}, @{term \<open>1 :: 'a::len word\<close>}, numerals etc.

    \<^item> Standard bit operations: see above.

    \<^item> Conversion with unsigned interpretation of words:

        \<^item> @{term [source] \<open>unsigned :: 'a::len word \<Rightarrow> 'b::semiring_1\<close>}

        \<^item> Important special cases as abbreviations:

            \<^item> @{term [source] \<open>unat :: 'a::len word \<Rightarrow> nat\<close>}

            \<^item> @{term [source] \<open>uint :: 'a::len word \<Rightarrow> int\<close>}

            \<^item> @{term [source] \<open>ucast :: 'a::len word \<Rightarrow> 'b::len word\<close>}

    \<^item> Conversion with signed interpretation of words:

        \<^item> @{term [source] \<open>signed :: 'a::len word \<Rightarrow> 'b::ring_1\<close>}

        \<^item> Important special cases as abbreviations:

            \<^item> @{term [source] \<open>sint :: 'a::len word \<Rightarrow> int\<close>}

            \<^item> @{term [source] \<open>scast :: 'a::len word \<Rightarrow> 'b::len word\<close>}

    \<^item> Operations with unsigned interpretation of words:

        \<^item> @{thm [mode=iff] word_le_nat_alt [no_vars]}

        \<^item> @{thm [mode=iff] word_less_nat_alt [no_vars]}

        \<^item> @{thm unat_div_distrib [no_vars]}

        \<^item> @{thm unat_drop_bit_eq [no_vars]}

        \<^item> @{thm unat_mod_distrib [no_vars]}

        \<^item> @{thm [mode=iff] udvd_iff_dvd [no_vars]}

    \<^item> Operations with signed interpretation of words:

        \<^item> @{thm [mode=iff] word_sle_eq [no_vars]}

        \<^item> @{thm [mode=iff] word_sless_alt [no_vars]}

        \<^item> @{thm sint_signed_drop_bit_eq [no_vars]}

    \<^item> Rotation and reversal:

        \<^item> @{term [source] \<open>word_rotl :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

        \<^item> @{term [source] \<open>word_rotr :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

        \<^item> @{term [source] \<open>word_roti :: int \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

        \<^item> @{term [source] \<open>word_reverse :: 'a::len word \<Rightarrow> 'a word\<close>}

    \<^item> Concatenation: @{term [source, display] \<open>word_cat :: 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'c::len word\<close>}

  For proofs about words the following default strategies are applicable:

    \<^item> Using bit extensionality (facts \<^text>\<open>bit_eq_iff\<close>, \<^text>\<open>bit_eqI\<close>; fact
      collection \<^text>\<open>bit_simps\<close>).

    \<^item> Using the @{method transfer} method.
\<close>

subsection \<open>More library theories\<close>

text \<open>
  Note: currently, the theories listed here are hardly separate
  entities since they import each other in various ways.
  Always inspect them to understand what you pull in if you
  want to import one.

    \<^descr>[Syntax]

      \<^descr>[\<^theory>\<open>Word_Lib.Hex_Words\<close>]
        Printing word numerals as hexadecimal numerals.

      \<^descr>[\<^theory>\<open>Word_Lib.Type_Syntax\<close>]
        Pretty type-sensitive syntax for cast operations.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_Syntax\<close>]
        Specific ASCII syntax for prominent bit operations on word.

    \<^descr>[Proof tools]

      \<^descr>[\<^theory>\<open>Word_Lib.Norm_Words\<close>]
        Rewriting word numerals to normal forms.

      \<^descr>[\<^theory>\<open>Word_Lib.Bitwise\<close>]
        Method @{method word_bitwise} decomposes word equalities and inequalities into bit propositions.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_EqI\<close>]
        Method @{method word_eqI_solve} decomposes word equalities and inequalities into bit propositions.

    \<^descr>[Operations]

      \<^descr>[\<^theory>\<open>Word_Lib.Signed_Division_Word\<close>]

        Signed division on word:

          \<^item> @{term [source] \<open>(sdiv) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}

          \<^item> @{term [source] \<open>(smod) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}

      \<^descr>[\<^theory>\<open>Word_Lib.Aligned\<close>] \

          \<^item> @{thm [mode=iff] is_aligned_iff_udvd [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Least_significant_bit\<close>]

        The least significant bit as an alias:
        @{thm [mode=iff] lsb_odd [where ?'a = int, no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Most_significant_bit\<close>]

        The most significant bit:

          \<^item> @{thm [mode=iff] msb_int_def [of k]}

          \<^item> @{thm [mode=iff] word_msb_sint [no_vars]}

          \<^item> @{thm [mode=iff] msb_word_iff_sless_0 [no_vars]}

          \<^item> @{thm [mode=iff] msb_word_iff_bit [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Traditional_Infix_Syntax\<close>]

        Clones of existing operations decorated with
        traditional syntax:

          \<^item> @{thm test_bit_eq_bit [no_vars]}

          \<^item> @{thm shiftl_eq_push_bit [no_vars]}

          \<^item> @{thm shiftr_eq_drop_bit [no_vars]}

          \<^item> @{thm sshiftr_eq [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Next_and_Prev\<close>] \

          \<^item> @{thm word_next_unfold [no_vars]}

          \<^item> @{thm word_prev_unfold [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]

        More on explicit enumeration of word types.

      \<^descr>[\<^theory>\<open>Word_Lib.More_Word_Operations\<close>]

        Even more operations on word.

    \<^descr>[Types]

      \<^descr>[\<^theory>\<open>Word_Lib.Signed_Words\<close>]

          Formal tagging of word types with a \<^text>\<open>signed\<close> marker.

    \<^descr>[Lemmas]

      \<^descr>[\<^theory>\<open>Word_Lib.More_Word\<close>]

          More lemmas on words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>]

          More lemmas on words, covering many other theories mentioned here.

    \<^descr>[Words of popular lengths].

      \<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>]

          for 8-bit words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>]

          for 16-bit words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>]

          for 32-bit words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>]

          for 64-bit words. This theory is not part of \<^text>\<open>Word_Lib_Sumo\<close>, because it shadows
          names from \<^theory>\<open>Word_Lib.Word_32\<close>. They can be used together, but then will have
          to use qualified names in applications.
\<close>

subsection \<open>More library sessions\<close>

text \<open>
  \<^descr>[\<^text>\<open>Native_Word\<close>] Makes machine words and machine arithmetic available for code generation.
  It provides a common abstraction that hides the differences between the different target languages.
  The code generator maps these operations to the APIs of the target languages.
\<close>

subsection \<open>Legacy theories\<close>

text \<open>
  The following theories contain material which has been
  factored out since it is not recommended to use it in
  new applications, mostly because matters can be expressed
  succinctly using already existing operations.

  This section gives some indication how to migrate away
  from those theories.  However theorem coverage may still
  be terse in some cases.

  \<^descr>[\<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>]

    An entry point importing any relevant theory in that session.  Intended
    for backward compatibility: start importing this theory when
    migrating applications to Isabelle2021, and later sort out
    what you really need. You may need to include
   \<^theory>\<open>Word_Lib.Word_32\<close> or \<^theory>\<open>Word_Lib.Word_64\<close> separately.

  \<^descr>[\<^theory>\<open>Word_Lib.Generic_set_bit\<close>]

    Kind of an alias: @{thm set_bit_eq [no_vars]}

  \<^descr>[\<^theory>\<open>Word_Lib.Typedef_Morphisms\<close>]

    A low-level extension to HOL typedef providing
    conversions along type morphisms.  The @{method transfer} method
    seems to be sufficient for most applications though.

  \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension\<close>]

    Comprehension syntax for bit values over predicates
    \<^typ>\<open>nat \<Rightarrow> bool\<close>.  For \<^typ>\<open>'a::len word\<close>, straightforward
    alternatives exist; difficult to handle for \<^typ>\<open>int\<close>.

  \<^descr>[\<^theory>\<open>Word_Lib.Reversed_Bit_Lists\<close>]

    Representation of bit values as explicit list in
    \<^emph>\<open>reversed\<close> order.

    This should rarely be necessary: the \<^const>\<open>bit\<close> projection
    should be sufficient in most cases.  In case explicit lists
    are needed, existing operations can be used:

    @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}

  \<^descr>[\<^theory>\<open>Word_Lib.Many_More\<close>]

    Collection of operations and theorems which are kept for backward
    compatibility and not used in other theories in session \<^text>\<open>Word_Lib\<close>.
    They are used in applications of \<^text>\<open>Word_Lib\<close>, but should be migrated to there.
\<close>

(*<*)
end
(*>*)


theory T61
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


section\<open>Evaluate procedure\<close>
theory Evaluate
imports ROBDD.BDT Data
begin

text \<open>To evaluate a BDD for a function \<open>f\<close> given as assignment a, i.e. to compute \<open>f(a)\<close>, one should
      start at the root and then follow pointers until one reaches a leaf.\<close>

fun bdd_eval_node :: \<open>'l node list \<Rightarrow> 'l assignment \<Rightarrow> 'l uid \<Rightarrow> bool\<close>
and bdd_eval_ptr :: \<open>'l node list \<Rightarrow> 'l assignment \<Rightarrow> 'l ptr \<Rightarrow> bool\<close>
  where
  \<open>bdd_eval_node []     _ _ = undefined\<close>
| \<open>bdd_eval_node (N i t e # ns) a tgt = (if i = tgt
                                         then bdd_eval_ptr ns a (if a (label i) then t else e)
                                         else bdd_eval_node ns a tgt)\<close>
| \<open>bdd_eval_ptr ns a (Leaf b) = b\<close>
| \<open>bdd_eval_ptr ns a (Node u) = bdd_eval_node ns a u\<close>

fun bdd_eval :: \<open>'l bdd \<Rightarrow> 'l assignment \<Rightarrow> bool\<close> where
  \<open>bdd_eval (Constant b)          _ = b\<close>
| \<open>bdd_eval (Nodes (root # ns))   a = bdd_eval_node (root#ns) a (uid root)\<close>
| \<open>bdd_eval (Nodes [])            _ = undefined\<close>

subsection \<open>Linking to Binary Decision Tree\<close>

text \<open>To prove that @{term bdd_eval} above establishes a semantics for our BDD data structure,
      we will map our BDDs to the Binary Decision Trees in @{cite Michaelis2016}
      and prove that @{term bdd_eval} is equivalent to the recursive semantics on the tree.\<close>

abbreviation Ifleaf_of_leaf :: \<open>bool \<Rightarrow> 'l ifex\<close> where
  \<open>Ifleaf_of_leaf b \<equiv> (if b then Trueif else Falseif)\<close>

fun bdt_of_node :: \<open>'l node list \<Rightarrow> 'l uid \<Rightarrow> 'l ifex\<close>
and bdt_of_ptr :: \<open>'l node list \<Rightarrow> 'l ptr \<Rightarrow> 'l ifex\<close>
where
  \<open>bdt_of_node []     _ = undefined\<close>
| \<open>bdt_of_node (N i t e # ns) tgt = (if i = tgt
                                     then IF (label tgt) (bdt_of_ptr ns t) (bdt_of_ptr ns e)
                               else bdt_of_node ns tgt)\<close>
| \<open>bdt_of_ptr ns (Leaf b) = Ifleaf_of_leaf b\<close>
| \<open>bdt_of_ptr ns (Node u) = bdt_of_node ns u\<close>

fun bdt_of_bdd :: \<open>'l bdd \<Rightarrow> 'l ifex\<close> where
  \<open>bdt_of_bdd (Constant b)        = Ifleaf_of_leaf b\<close>
| \<open>bdt_of_bdd (Nodes (root # ns)) = bdt_of_node (root # ns) (uid root)\<close>
| \<open>bdt_of_bdd (Nodes [])          = undefined\<close>

lemma bdd_eval_node_iff_val_ifex_aux:
  assumes \<open>closed ns\<close> \<open>tgt \<in> uid ` set ns\<close>
  shows \<open>bdd_eval_node ns a tgt \<longleftrightarrow> val_ifex (bdt_of_node ns tgt) a\<close>
  using assms
proof (induction ns arbitrary: tgt rule: nl_induct)
  case (Cons i t e ns)
  then show ?case
    by (cases \<open>ns = []\<close>; auto split: ptr.splits)
qed simp

theorem bdd_eval_iff_val_ifex:
  assumes \<open>well_formed bdd\<close>
  shows \<open>bdd_eval bdd a \<longleftrightarrow> val_ifex (bdt_of_bdd bdd) a\<close>
proof (cases bdd rule: bdd_cases)
  case (Nodes i t e ns)
  with assms show ?thesis
    by (auto split: ptr.splits
             dest:  imageI[where f = uid] bdd_eval_node_iff_val_ifex_aux[where a = a]
             dest!: closed_if_well_formed_nl)
qed (use assms in auto)

subsubsection \<open>Variable domain of Binary Decision Diagrams and Trees\<close>

fun vars_of_bdt where
  "vars_of_bdt (IF i t e) = insert i (vars_of_bdt t \<union> vars_of_bdt e)"
| "vars_of_bdt _ = {}"

definition dom_bounded_vars where
  "dom_bounded_vars S a \<equiv> \<forall>x. x \<notin> S \<longrightarrow> a x = False"

definition
  "vars_of_bdd bdd = vars_of_bdt (bdt_of_bdd bdd)"

definition
  "vars_of_node ns node = vars_of_bdt (bdt_of_node ns node)"

definition
  "vars_of_ptr ns ptr = vars_of_bdt (bdt_of_ptr ns ptr)"

definition
  "num_assignments_vars bdd = card {a. bdd_eval bdd a \<and> dom_bounded_vars (vars_of_bdd bdd) a}"

definition
  "num_assignments_vars_ptr ns ptr =
    card {a. bdd_eval_ptr ns a ptr \<and> dom_bounded_vars (vars_of_ptr ns ptr) a}"

definition
  "num_assignments_vars_node ns node =
    card {a. bdd_eval_node ns a node \<and> dom_bounded_vars (vars_of_node ns node) a}"

lemma vars_of_bdd_to_node[simp]:
  "vars_of_bdd (Nodes (N i t e # ns)) = vars_of_node (N i t e # ns) i"
  unfolding vars_of_bdd_def vars_of_node_def by simp

lemma num_assignments_vars_to_node[simp]:
  "num_assignments_vars (Nodes (N i t e # ns)) = num_assignments_vars_node (N i t e # ns) i"
  unfolding num_assignments_vars_def num_assignments_vars_node_def by simp

end