theory ComponentsWithInterfaces
  imports Interface

begin
type_synonym ('n,'l) component_model = "('n,'l) interface \<times> ('n,'l)graph \<times> ('n,'l) interface"

abbreviation graph :: "('n,'l) component_model \<Rightarrow> ('n,'l) graph" where
  "graph c \<equiv> fst (snd c)"
abbreviation (import) nodes :: "('n,'l) component_model \<Rightarrow> 'n set" where
  "nodes c \<equiv> graph_nodes (graph c)"
abbreviation (import) transitions :: "('n,'l) component_model \<Rightarrow> 'n tss" where
  "transitions c \<equiv> graph_transitions (graph c)"
abbreviation left_interface :: "('n,'l) component_model \<Rightarrow>  ('n,'l) interface" ("\<^sup>\<star>_" [81] 80) where
  "left_interface c \<equiv> fst c"
abbreviation right_interface :: "('n,'l) component_model \<Rightarrow>  ('n,'l) interface" ("_\<^sup>\<star>" [81] 80) where
  "right_interface c \<equiv> snd (snd c)"
definition inner ::  "('n,'l) component_model \<Rightarrow> 'n set" where
  "inner c = (nodes c) - (inter_nodes(\<^sup>\<star>c) \<union> inter_nodes(c\<^sup>\<star>))"

abbreviation empty :: "('n,'l) component_model" ("\<langle>\<rangle>") where
  "empty \<equiv> (\<lparr>\<rparr>, Graph.empty, \<lparr>\<rparr>)"

lemma empty_interfaces[simp]:
  shows "\<^sup>\<star>\<langle>\<rangle> = \<lparr>\<rparr>"
  and "\<langle>\<rangle>\<^sup>\<star>= \<lparr>\<rparr>"
  by simp+

abbreviation is_component :: "('n,'l) component_model \<Rightarrow> bool" where
  "is_component c \<equiv> is_graph(graph c) \<and>
                    (\<forall>l. \<forall>n\<in>set((\<^sup>\<star>c) l). fst(graph c) n = Some l) \<and>
                    (\<forall>l. \<forall>n\<in>set((c\<^sup>\<star>) l). fst(graph c) n = Some l)"

lemma is_component_props:
  assumes "is_component c"
  shows "is_graph(graph c)"
  and "n\<in>set((\<^sup>\<star>c) l) \<Longrightarrow> fst(graph c) n = Some l"
  and "inter_nodes(\<^sup>\<star>c) \<subseteq>  nodes c"
  and "inter_nodes(c\<^sup>\<star>) \<subseteq>  nodes c"
  and "tss_nodes (transitions c) \<subseteq>  graph_nodes(graph c)"
  and "inter_nodes(\<^sup>\<star>c) \<subseteq>  graph_nodes(graph c)"
  and "inter_nodes(c\<^sup>\<star>) \<subseteq>  graph_nodes(graph c)"
        unfolding inter_nodes_def graph_nodes_def
        using assms apply blast
       using assms apply blast
      using assms apply blast
     using assms apply blast
    using assms apply (simp add: graph_nodes_def graph_transitions_def is_graph_var tss_sources_def)
   using assms apply blast
  using assms by blast

lemma is_component_lists_distinct:
  assumes "is_component c"
  shows "k\<noteq>l \<Longrightarrow> set((c\<^sup>\<star>) k) \<inter> set((c\<^sup>\<star>) l) = {}"
  and "k\<noteq>l \<Longrightarrow> set((\<^sup>\<star>c) k) \<inter> set((\<^sup>\<star>c) l) = {}"
  by (metis assms Int_emptyI option.inject)+

lemma empty_iscomponent:
  "is_component empty"
  using empty_isgraph by simp

section \<open>Composition\<close>
(* to be sorted *)
(* more general types *)
definition rename :: "'n \<Rightarrow> ('n \<rightharpoonup> 'n) \<Rightarrow> 'n" where
  "rename s m = (if s\<in>dom m then the(m s) else s)"

definition rename_tss :: "'n tss \<Rightarrow> ('n \<rightharpoonup> 'n) \<Rightarrow> 'n tss" where
  "rename_tss T m = {(rename n\<^sub>1 m, rename n\<^sub>2 m) | n\<^sub>1 n\<^sub>2. (n\<^sub>1,n\<^sub>2)\<in>T}"

definition lrename_tss :: "'n tss \<Rightarrow> ('l \<Rightarrow> 'n \<rightharpoonup> 'n) \<Rightarrow> 'n tss" where
  "lrename_tss T M = \<Union>{rename_tss T (M l) | l. True}"

lemma lrename_tss_var:
  "lrename_tss T M = \<Union>{{(rename n\<^sub>1 (M l), rename n\<^sub>2 (M l)) | n\<^sub>1 n\<^sub>2. (n\<^sub>1,n\<^sub>2)\<in>T} | l. True}"
  unfolding rename_tss_def lrename_tss_def..

lemma rename_tss_empty[simp]:
  "rename_tss T Map.empty = T"
  "lrename_tss T (\<lambda>l. Map.empty) = T"
  unfolding rename_def rename_tss_def lrename_tss_def
  by simp_all

lemma rename_tss_dist:
  "rename_tss (S\<union>T) m = rename_tss S m \<union> rename_tss T m"
  unfolding rename_def rename_tss_def
  by fast

lemma lrename_tss_dist:
  "lrename_tss (S\<union>T) M = lrename_tss S M \<union> lrename_tss T M"
proof-
  have "lrename_tss (S\<union>T) M = \<Union>{rename_tss S (M l) \<union> rename_tss T (M l) | l. True}"
    unfolding lrename_tss_def
    by (simp add: rename_tss_dist)
  also have "... = \<Union>{rename_tss S (M l) | l. True} \<union> \<Union>{rename_tss T (M l) | l. True}"
    by blast
  also have "... = lrename_tss S M \<union> lrename_tss T M"
    unfolding lrename_tss_def ..
  ultimately show ?thesis
    by simp
qed

primrec rename_list :: "'n list \<Rightarrow> ('n \<rightharpoonup> 'n) \<Rightarrow> 'n list" where
  "rename_list [] m = []" |
  "rename_list (l#ls) m = (rename l m) # (rename_list ls m)"

lemma rename_list_dist:
  "rename_list (xs @ ys) m = (rename_list xs m) @ (rename_list ys m)"
  by(induct xs arbitrary: ys, simp_all)

definition rename_inter :: "('n,'l) interface \<Rightarrow> ('l \<Rightarrow> 'n \<rightharpoonup> 'n) \<Rightarrow> ('n,'l) interface" where
  "rename_inter i M = (\<lambda>l. rename_list (i l) (M l))"

lemma rename_inter_dist:
   "rename_inter (i @@ j) M =(rename_inter i M) @@ (rename_inter j M)"
  unfolding rename_inter_def inter_comp_def
  by (simp add: rename_list_dist)

definition rename_nodes :: "('n \<rightharpoonup> 'l) => ('n \<rightharpoonup> 'n) => ('n \<rightharpoonup> 'l)" where
  "rename_nodes N m = N |`(- dom m)"

lemma  rename_nodes_alt:
  "rename_nodes N m = (\<lambda>n. if n \<in> (dom m) then None else N n)"
  unfolding rename_nodes_def restrict_map_def
  by (metis Compl_iff)

definition lrename_nodes :: "('n \<rightharpoonup> 'l) => ('l \<Rightarrow> 'n \<rightharpoonup> 'n) => ('n \<rightharpoonup> 'l)" where
  "lrename_nodes N M = N |` (-\<Union>{dom (M l) |l. True})"

lemma lrename_nodes:
  "lrename_nodes N M = N|`(\<Inter>{-dom (M l)|l. True})"
  unfolding lrename_nodes_def restrict_map_def
  by (simp add: full_SetCompr_eq)

lemma lrename_nodes_var:
  "lrename_nodes N M  = (\<lambda>n. if n \<in> \<Union>{dom (M l) |l. True} then None else N n)"
  unfolding lrename_nodes_def restrict_map_def
  by (meson Compl_iff)

lemma dom_lrename:
  "dom(lrename_nodes N M) = dom N \<inter> (\<Inter>{-dom (M l)|l. True})"
  by (simp add: lrename_nodes)

(* can probably be made more beautiful *)
(* what if 2 graphs have the same node id, but different labels? *)
definition comp_merge :: "('n,'l) component_model \<Rightarrow> ('n,'l) component_model
                          \<Rightarrow> ('n,'l) component_model" (infixl "\<cdot>" 70) where
  "comp_merge c d = (
      (\<^sup>\<star>c @@ inter_prune (\<^sup>\<star>d) (c\<^sup>\<star>)),
      (lrename_nodes (fst(graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d)) ++ (fst(graph d)),
       lrename_tss (transitions c) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d)) \<union> transitions d),
      (d\<^sup>\<star>@@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d)))"

lemma comp_merge_left:
  "\<^sup>\<star>c @@ inter_prune (\<^sup>\<star>d @@ inter_prune (\<^sup>\<star>e) (d\<^sup>\<star>)) (c\<^sup>\<star>) =
    \<^sup>\<star>c @@ inter_prune (\<^sup>\<star>d) (c\<^sup>\<star>) @@ inter_prune (\<^sup>\<star>e) (d\<^sup>\<star>@@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d))"
  unfolding inter_prune_def inter_comp_def
  apply(standard)
  by (simp add: add.commute)

(*
lemma a1:
 "dom(M |` (A\<inter>-(dom (N))\<union>(A\<inter>-B))) \<inter> dom(N|`B) = {}"
  unfolding dom_def restrict_map_def
  apply clarsimp
  by fastforce

lemma a2:
 "M |`A ++ N|`B = ((M++(N|`B)) |` (A\<inter>-(dom (N))\<union> (A\<inter>-B)) ++ N|`B)"
  unfolding restrict_map_def map_add_def dom_def
  by fastforce

lemma a3:
  "length ((\<^sup>\<star>d @@ (\<lambda>l. drop (length ((d\<^sup>\<star>) l)) ((\<^sup>\<star>e) l))) l)
    =
   length ((\<^sup>\<star>d) l) + (max ((length((\<^sup>\<star>e) l))-(length ((d\<^sup>\<star>) l))) 0)"
  by (simp add: inter_comp_def)

lemma a4:
  "((d\<^sup>\<star>@@ (\<lambda>l. drop (length ((\<^sup>\<star>d) l)) ((c\<^sup>\<star>) l))) l)
   =
   ((d\<^sup>\<star>) l) @ drop (length ((\<^sup>\<star>d) l)) ((c\<^sup>\<star>) l)"
  by (simp add: inter_comp_def)

lemma a:
  "M|`A ++ N|`B = M|`(A-dom(N|`B)) ++ N|`B"
  unfolding restrict_map_def map_add_def dom_def
  by fastforce
*)
lemma restrict_add_map_distribute:
  "(M|`A ++ N)|`B = (M|`A)|`B ++ N|`B"
  unfolding restrict_map_def map_add_def
  by fastforce

lemma not_dom_none: "x\<notin>dom M \<Longrightarrow> M x = None"
  unfolding dom_def by blast

lemma doms_comp:
  "dom(lrename_nodes (fst (graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d @@ inter_prune (\<^sup>\<star>e) (d\<^sup>\<star>))) ++
    lrename_nodes (fst (graph d)) (match_inter (d\<^sup>\<star>) (\<^sup>\<star>e)) ++
    fst (graph e)) =
dom(lrename_nodes (lrename_nodes (fst (graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d)) ++ fst (graph d))
     (match_inter (d\<^sup>\<star>@@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d)) (\<^sup>\<star>e)) ++
    fst (graph e))"
  apply(simp add:sup_commute dom_lrename match_inter_def  match_lists_dom inter_prune_def  inter_comp_def)
  unfolding dom_def
  sledgehammer
  sledgehammer
  apply standard
  sledgehammer
  sorry

lemma comp_merge_graph_nodes_aux:
  "(fst (graph c) |` \<Inter> {u. \<exists>l. u = - set (take (length ((\<^sup>\<star>d) l) + (length ((\<^sup>\<star>e) l) - length ((d\<^sup>\<star>) l))) ((c\<^sup>\<star>) l))} ++
          fst (graph d) |` \<Inter> {u. \<exists>l. u = - set (take (length ((\<^sup>\<star>e) l)) ((d\<^sup>\<star>) l))} ++
          fst (graph e))
          x =
         (fst (graph c) |`
          (\<Inter> {u. \<exists>l. u = - set (take (length ((\<^sup>\<star>d) l)) ((c\<^sup>\<star>) l))} \<inter>
           \<Inter> {u. \<exists>l. u = - set (take (length ((\<^sup>\<star>e) l)) ((d\<^sup>\<star>) l)) \<inter>
                          - set (take (length ((\<^sup>\<star>e) l) - length ((d\<^sup>\<star>) l)) (drop (length ((\<^sup>\<star>d) l)) ((c\<^sup>\<star>) l)))}) ++
          fst (graph d) |`
          \<Inter> {u. \<exists>l. u = - set (take (length ((\<^sup>\<star>e) l)) ((d\<^sup>\<star>) l)) \<inter>
                         - set (take (length ((\<^sup>\<star>e) l) - length ((d\<^sup>\<star>) l)) (drop (length ((\<^sup>\<star>d) l)) ((c\<^sup>\<star>) l)))} ++
          fst (graph e))
          x"
  (is "(?l1 ++ ?l2 ++ ?l3) x = (?r1 ++ ?r2 ++ ?r3) x")
proof -
  have dom_iff: "dom(?l1 ++ ?l2 ++ ?l3) = dom(?r1 ++ ?r2 ++ ?r3)"
    using doms_comp
    by (simp add: lrename_nodes match_inter_def inter_prune_def match_lists_dom
          inter_comp_def restrict_add_map_distribute)

  have  "x\<notin>dom(?l1 ++ ?l2 ++ ?l3) \<or>
         x\<in>dom(?l3) \<or>
        (x\<in>dom ?l2 - dom ?l3 \<and> x\<in>dom ?r3) \<or>
        (x\<in>dom ?l2 - dom ?l3 \<and> x\<in>dom ?r2) \<or>
        (x\<in>dom ?l2 - dom ?l3 \<and> x\<in>dom ?r1 - dom ?r2) \<or>
        (x\<in>dom ?l1 - dom ?l2 -dom ?l3 \<and> x\<in>dom ?r3) \<or>
        (x\<in>dom ?l1 - dom ?l2 -dom ?l3 \<and> x\<in>dom ?r1) \<or>
        (x\<in>dom ?l1 - dom ?l2 -dom ?l3 \<and> x\<in>dom ?r2 - dom ?r1)"
    by (metis (no_types, lifting) DiffI domIff map_add_None dom_iff)
  moreover
  { (* shorten *)
    assume a: "x\<notin>dom(?l1 ++ ?l2 ++ ?l3)"
    hence lhs: "(?l1 ++ ?l2 ++ ?l3) x = None"
      apply(rule not_dom_none) done

    have "x\<notin>dom(?l1 ++ ?l2 ++ ?l3) \<longleftrightarrow> x\<notin>dom(?r1 ++ ?r2 ++ ?r3)"
      using dom_iff by auto
    hence ?thesis
      by (metis (no_types, lifting) domIff lhs)
  }
  moreover
  { assume "x\<in>dom(?l3)"
    hence ?thesis
      by force
  }
  moreover
  { assume "x\<in>dom ?l2 - dom ?l3 \<and> x\<in>dom ?r3"
    hence ?thesis
      by force
  }
  moreover
  { assume "x\<in>dom ?l2 - dom ?l3 \<and> x\<in>dom ?r2"
    hence ?thesis
      by (simp add: map_add_dom_app_simps(1) map_add_dom_app_simps(3))
  }
  moreover
  { assume "x\<in>dom ?l2 - dom ?l3 \<and> x\<in>dom ?r1 - dom ?r2"
    hence ?thesis
      by auto
  }
  moreover
  { assume "x\<in>dom (?l1)-dom (?l2)-dom ?l3 \<and> x\<in>dom ?r3"
    hence ?thesis
      by force
  }
  moreover
  { assume "x\<in>dom ?l1 - dom ?l2 - dom ?l3 \<and> x\<in>dom ?r1"
    hence ?thesis
    by (smt (z3) DiffD2 IntD1 diff_eq domIff map_add_dom_app_simps(3) mem_Collect_eq mem_simps(11) restrict_map_def)
  }
  moreover
  { assume "x\<in>dom (?l1)-dom (?l2)-dom ?l3 \<and> x\<in>dom(?r2)-dom(?r1)"
    hence ?thesis
      apply clarsimp by blast
  }
  ultimately show ?thesis
    by fastforce
qed

lemma comp_merge_graph_nodes:
shows "lrename_nodes (fst (graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d @@ inter_prune (\<^sup>\<star>e) (d\<^sup>\<star>))) ++
    lrename_nodes (fst (graph d)) (match_inter (d\<^sup>\<star>) (\<^sup>\<star>e)) ++
    fst (graph e) =
    lrename_nodes (lrename_nodes (fst (graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d)) ++ fst (graph d))
     (match_inter (d\<^sup>\<star>@@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d)) (\<^sup>\<star>e)) ++
    fst (graph e)"
  apply(standard)
  by (simp add: lrename_nodes match_inter_def inter_prune_def match_lists_dom
                inter_comp_def restrict_add_map_distribute comp_merge_graph_nodes_aux)

lemma comp_merge_graph_tss:
  "lrename_tss (graph_transitions (graph c))
     (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d @@ inter_prune (\<^sup>\<star>e) (d\<^sup>\<star>))) \<union>
    graph_transitions
     (lrename_nodes (fst (graph d)) (match_inter (d\<^sup>\<star>) (\<^sup>\<star>e)) ++ fst (graph e),
      lrename_tss (graph_transitions (graph d)) (match_inter (d\<^sup>\<star>) (\<^sup>\<star>e)) \<union>
      graph_transitions (graph e)) =
    lrename_tss
     (graph_transitions
       (lrename_nodes (fst (graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d)) ++ fst (graph d),
        lrename_tss (graph_transitions (graph c)) (match_inter (c\<^sup>\<star>) (\<^sup>\<star>d)) \<union>
        graph_transitions (graph d)))
     (match_inter (d\<^sup>\<star>@@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d)) (\<^sup>\<star>e)) \<union>
    graph_transitions (graph e)"
  unfolding lrename_tss_def rename_tss_def inter_prune_def lrename_nodes_def
  apply standard
  sorry

lemma comp_merge_right:
  "e\<^sup>\<star>@@ inter_prune (d\<^sup>\<star>) (\<^sup>\<star>e) @@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d @@ inter_prune (\<^sup>\<star>e) (d\<^sup>\<star>)) =
    e\<^sup>\<star>@@ inter_prune (d\<^sup>\<star>@@ inter_prune (c\<^sup>\<star>) (\<^sup>\<star>d)) (\<^sup>\<star>e)"
  unfolding inter_prune_def inter_comp_def
  apply(standard)
  by (simp add: add.commute)

lemma comp_merge_assoc:
  "c \<cdot> (d \<cdot> e) = (c \<cdot> d) \<cdot> e"
  unfolding comp_merge_def
  apply(simp)
  apply(rule conjI, rule comp_merge_left)
  apply(rule conjI, rule comp_merge_graph_nodes)
  apply(rule conjI, rule comp_merge_graph_tss)
  by(rule comp_merge_right)

end


(*
 * This is an autogenerated file. Do not edit.
 * The original is Laws_Complement.thy. It was converted using instantiate_laws.py.
 *)

section \<open>Generic laws about complements, instantiated quantumly\<close>

theory Laws_Complement_Quantum
  imports Laws_Quantum Axioms_Complement_Quantum
begin

notation cblinfun_compose (infixl "*\<^sub>u" 55)
notation tensor_op (infixr "\<otimes>\<^sub>u" 70)

definition \<open>complements F G \<longleftrightarrow> compatible F G \<and> iso_register (F;G)\<close>

lemma complementsI: \<open>compatible F G \<Longrightarrow> iso_register (F;G) \<Longrightarrow> complements F G\<close>
  using complements_def by blast

lemma complements_sym: \<open>complements G F\<close> if \<open>complements F G\<close>
proof (rule complementsI)
  show [simp]: \<open>compatible G F\<close>
    using compatible_sym complements_def that by blast
  from that have \<open>iso_register (F;G)\<close>
    by (meson complements_def)
  then obtain I where [simp]: \<open>register I\<close> and \<open>(F;G) o I = id\<close> and \<open>I o (F;G) = id\<close>
    using iso_register_def by blast
  have \<open>register (swap o I)\<close>
    using \<open>register I\<close> register_comp register_swap by blast
  moreover have \<open>(G;F) o (swap o I) = id\<close>
    by (simp add: \<open>(F;G) \<circ> I = id\<close> rewriteL_comp_comp)
  moreover have \<open>(swap o I) o (G;F) = id\<close>
    by (metis (no_types, opaque_lifting) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
  ultimately show \<open>iso_register (G;F)\<close>
    using \<open>compatible G F\<close> iso_register_def pair_is_register by blast
qed

definition complement :: \<open>('a::finite update \<Rightarrow> 'b::finite update) \<Rightarrow> (('a,'b) complement_domain update \<Rightarrow> 'b update)\<close> where
  \<open>complement F = (SOME G :: ('a, 'b) complement_domain update \<Rightarrow> 'b update. compatible F G \<and> iso_register (F;G))\<close>

lemma register_complement[simp]: \<open>register (complement F)\<close> if \<open>register F\<close>
  using complement_exists[OF that]
  by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)

lemma complement_is_complement:
  assumes \<open>register F\<close>
  shows \<open>complements F (complement F)\<close>
  using complement_exists[OF assms] unfolding complements_def
  by (metis (mono_tags, lifting) complement_def some_eq_imp)

lemma complement_unique:
  assumes \<open>complements F G\<close>
  shows \<open>equivalent_registers G (complement F)\<close>
  apply (rule complement_unique[where F=F])
  using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+

lemma compatible_complement[simp]: \<open>register F \<Longrightarrow> compatible F (complement F)\<close>
  using complement_is_complement complements_def by blast

lemma complements_register_tensor:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  shows \<open>complements (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
proof (rule complementsI)
  have sep4: \<open>separating TYPE('z::finite) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d) |a b c d. True}\<close>
    apply (rule separating_tensor'[where A=\<open>{(a \<otimes>\<^sub>u b) |a b. True}\<close> and B=\<open>{(c \<otimes>\<^sub>u d) |c d. True}\<close>])
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
    by auto
  show compat: \<open>compatible (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
    by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
  let ?reorder = \<open>((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
  have [simp]: \<open>register ?reorder\<close>
    by auto
  have [simp]: \<open>?reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close>
    for a::\<open>'t::finite update\<close> and b::\<open>'u::finite update\<close> and c::\<open>'v::finite update\<close> and d::\<open>'w::finite update\<close>
    by (simp add: register_pair_apply Fst_def Snd_def comp_tensor_op)
  have [simp]: \<open>iso_register ?reorder\<close>
    apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
     apply (rule register_eqI[OF sep4]) apply auto[3]
    apply (rule register_eqI[OF sep4]) by auto
  have \<open>(F \<otimes>\<^sub>r G; complement F \<otimes>\<^sub>r complement G) = ((F; complement F) \<otimes>\<^sub>r (G; complement G)) o ?reorder\<close>
    apply (rule register_eqI[OF sep4])
    by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
        simp: compat register_pair_apply comp_tensor_op)
  moreover have \<open>iso_register \<dots>\<close>
    apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
    using assms complement_is_complement complements_def by blast+
  ultimately show \<open>iso_register (F \<otimes>\<^sub>r G;complement F \<otimes>\<^sub>r complement G)\<close>
    by simp
qed

definition is_unit_register where
  \<open>is_unit_register U \<longleftrightarrow> complements U id\<close>

lemma register_unit_register[simp]: \<open>is_unit_register U \<Longrightarrow> register U\<close>
  by (simp add: compatible_def complements_def is_unit_register_def)

lemma unit_register_compatible[simp]: \<open>compatible U X\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
  by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))

lemma unit_register_compatible'[simp]: \<open>compatible X U\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
  using compatible_sym that(1) that(2) unit_register_compatible by blast

lemma compatible_complement_left[simp]: \<open>register X \<Longrightarrow> compatible (complement X) X\<close>
  using compatible_sym complement_is_complement complements_def by blast

lemma compatible_complement_right[simp]: \<open>register X \<Longrightarrow> compatible X (complement X)\<close>
  using complement_is_complement complements_def by blast

lemma unit_register_pair[simp]: \<open>equivalent_registers X (U; X)\<close> if [simp]: \<open>is_unit_register U\<close> \<open>register X\<close>
proof -
  have \<open>equivalent_registers id (U; id)\<close>
    using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
  also have \<open>equivalent_registers \<dots> (U; (X; complement X))\<close>
    apply (rule equivalent_registers_pair_right)
     apply (auto intro!: unit_register_compatible)
    using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
  also have \<open>equivalent_registers \<dots> ((U; X); complement X)\<close>
    apply (rule equivalent_registers_assoc)
    by auto
  finally have \<open>complements (U; X) (complement X)\<close>
    by (auto simp: equivalent_registers_def complements_def)
  moreover have \<open>equivalent_registers (X; complement X) id\<close>
    by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
  ultimately show ?thesis
    by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed

lemma unit_register_compose_left:
  assumes [simp]: \<open>is_unit_register U\<close>
  assumes [simp]: \<open>register A\<close>
  shows \<open>is_unit_register (A o U)\<close>
proof -
  have \<open>compatible (A o U) (A; complement A)\<close>
    apply (auto intro!: compatible3')
    by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
  then have compat[simp]: \<open>compatible (A o U) id\<close>
    by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
  have \<open>equivalent_registers (A o U; id) (A o U; (A; complement A))\<close>
    apply (auto intro!: equivalent_registers_pair_right)
    using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
  also have \<open>equivalent_registers \<dots> ((A o U; A o id); complement A)\<close>
    apply auto
    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
  also have \<open>equivalent_registers \<dots> (A o (U; id); complement A)\<close>
    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
  also have \<open>equivalent_registers \<dots> (A o id; complement A)\<close>
    apply (intro equivalent_registers_pair_left equivalent_registers_comp)
      apply (auto simp: assms)
    using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
  also have \<open>equivalent_registers \<dots> id\<close>
    by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
  finally show ?thesis
    using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed

lemma unit_register_compose_right:
  assumes [simp]: \<open>is_unit_register U\<close>
  assumes [simp]: \<open>iso_register A\<close>
  shows \<open>is_unit_register (U o A)\<close>
proof (unfold is_unit_register_def, rule complementsI)
  show \<open>compatible (U \<circ> A) id\<close>
    by (simp add: iso_register_is_register)
  have 1: \<open>iso_register ((U;id) \<circ> A \<otimes>\<^sub>r id)\<close>
    by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
  have 2: \<open>id \<circ> ((U;id) \<circ> A \<otimes>\<^sub>r id) = (U \<circ> A;id)\<close>
    by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
  show \<open>iso_register (U \<circ> A;id)\<close>
    using 1 2 by auto
qed

lemma unit_register_unique:
  assumes \<open>is_unit_register F\<close>
  assumes \<open>is_unit_register G\<close>
  shows \<open>equivalent_registers F G\<close>
proof -
  have \<open>complements F id\<close> \<open>complements G id\<close>
    using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
  then show ?thesis
    by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed

lemma unit_register_domains_isomorphic:
  fixes F :: \<open>'a::finite update \<Rightarrow> 'c::finite update\<close>
  fixes G :: \<open>'b::finite update \<Rightarrow> 'd::finite update\<close>
  assumes \<open>is_unit_register F\<close>
  assumes \<open>is_unit_register G\<close>
  shows \<open>\<exists>I :: 'a update \<Rightarrow> 'b update. iso_register I\<close>
proof -
  have \<open>is_unit_register ((\<lambda>d. tensor_op id_cblinfun d) o G)\<close>
    by (simp add: assms(2) unit_register_compose_left)
  moreover have \<open>is_unit_register ((\<lambda>c. tensor_op c id_cblinfun) o F)\<close>
    using assms(1) register_tensor_left unit_register_compose_left by blast
  ultimately have \<open>equivalent_registers ((\<lambda>d. tensor_op id_cblinfun d) o G) ((\<lambda>c. tensor_op c id_cblinfun) o F)\<close>
    using unit_register_unique by blast
  then show ?thesis
    unfolding equivalent_registers_def by auto
qed

lemma id_complement_is_unit_register[simp]: \<open>is_unit_register (complement id)\<close>
  by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)

type_synonym unit_register_domain = \<open>(unit, unit) complement_domain\<close>
definition unit_register :: \<open>unit_register_domain update \<Rightarrow> 'a::finite update\<close> where \<open>unit_register = (SOME U. is_unit_register U)\<close>

lemma unit_register_is_unit_register[simp]: \<open>is_unit_register (unit_register :: unit_register_domain update \<Rightarrow> 'a::finite update)\<close>
proof -
  let ?U0 = \<open>complement id :: unit_register_domain update \<Rightarrow> unit update\<close>
  let ?U1 = \<open>complement id :: ('a, 'a) complement_domain update \<Rightarrow> 'a update\<close>
  have \<open>is_unit_register ?U0\<close> \<open>is_unit_register ?U1\<close>
    by auto
  then obtain I :: \<open>unit_register_domain update \<Rightarrow> ('a, 'a) complement_domain update\<close> where \<open>iso_register I\<close>
    apply atomize_elim by (rule unit_register_domains_isomorphic)
  with \<open>is_unit_register ?U1\<close> have \<open>is_unit_register (?U1 o I)\<close>
    by (rule unit_register_compose_right)
  then show ?thesis
    by (metis someI_ex unit_register_def)
qed

lemma unit_register_domain_tensor_unit:
  fixes U :: \<open>'a::finite update \<Rightarrow> _\<close>
  assumes \<open>is_unit_register U\<close>
  shows \<open>\<exists>I :: 'b::finite update \<Rightarrow> ('a*'b) update. iso_register I\<close>
  (* Can we show that I = (\<lambda>x. tensor_op id_cblinfun x) ? It would be nice but I do not see how to prove it. *)
proof -
  have \<open>equivalent_registers (id :: 'b update \<Rightarrow> _) (complement id; id)\<close>
    using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
  then obtain J :: \<open>'b update \<Rightarrow> ((('b, 'b) complement_domain * 'b) update)\<close> where \<open>iso_register J\<close>
    using equivalent_registers_def iso_register_inv by blast
  moreover obtain K :: \<open>('b, 'b) complement_domain update \<Rightarrow> 'a update\<close> where \<open>iso_register K\<close>
    using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
  ultimately have \<open>iso_register ((K \<otimes>\<^sub>r id) o J)\<close>
    by auto
  then show ?thesis
    by auto
qed

lemma compatible_complement_pair1:
  assumes \<open>compatible F G\<close>
  shows \<open>compatible F (complement (F;G))\<close>
  by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)

lemma compatible_complement_pair2:
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>compatible G (complement (F;G))\<close>
proof -
  have \<open>compatible (F;G) (complement (F;G))\<close>
    by simp
  then have \<open>compatible ((F;G) o Snd) (complement (F;G))\<close>
    by auto
  then show ?thesis
    by (auto simp: register_pair_Snd)
qed

lemma equivalent_complements:
  assumes \<open>complements F G\<close>
  assumes \<open>equivalent_registers G G'\<close>
  shows \<open>complements F G'\<close>
  apply (rule complementsI)
   apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
  by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)

lemma complements_complement_pair:
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>complements F (G; complement (F;G))\<close>
proof (rule complementsI)
  have \<open>equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))\<close>
    apply (rule equivalent_registers_assoc)
    by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
  also have \<open>equivalent_registers \<dots> id\<close>
    by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
  finally show \<open>iso_register (F;(G;complement (F;G)))\<close>
    using equivalent_registers_sym iso_register_equivalent_id by blast
  show \<open>compatible F (G;complement (F;G))\<close>
    using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed

lemma equivalent_registers_complement:
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers (complement F) (complement G)\<close>
proof -
  have \<open>complements F (complement F)\<close>
    using assms complement_is_complement equivalent_registers_register_left by blast
  with assms have \<open>complements G (complement F)\<close>
    by (meson complements_sym equivalent_complements)
  then show ?thesis
    by (rule complement_unique)
qed

lemma complements_complement_pair':
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>complements G (F; complement (F;G))\<close>
proof -
  have \<open>equivalent_registers (F;G) (G;F)\<close>
    apply (rule equivalent_registersI[where I=swap])
    by auto
  then have \<open>equivalent_registers (complement (F;G)) (complement (G;F))\<close>
    by (rule equivalent_registers_complement)
  then have \<open>equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))\<close>
    apply (rule equivalent_registers_pair_right[rotated])
    using assms compatible_complement_pair1 by blast
  moreover have \<open>complements G (F; complement (G;F))\<close>
    apply (rule complements_complement_pair)
    using assms compatible_sym by blast
  ultimately show ?thesis
    by (meson equivalent_complements equivalent_registers_sym)
qed

lemma complements_chain:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  shows \<open>complements (F o G) (complement F; F o complement G)\<close>
proof (rule complementsI)
  show \<open>compatible (F o G) (complement F; F o complement G)\<close>
    by auto
  have \<open>equivalent_registers (F \<circ> G;(complement F;F \<circ> complement G)) (F \<circ> G;(F \<circ> complement G;complement F))\<close>
    apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r swap\<close>])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have \<open>equivalent_registers \<dots> ((F \<circ> G;F \<circ> complement G);complement F)\<close>
    apply (rule equivalent_registersI[where I=assoc])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have \<open>equivalent_registers \<dots> (F o (G; complement G);complement F)\<close>
    by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
        equivalent_registers_sym equivalent_registers_trans register_comp_pair)
  also have \<open>equivalent_registers \<dots> (F o id;complement F)\<close>
    apply (rule equivalent_registers_pair_left, simp)
    apply (rule equivalent_registers_comp, simp)
    by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
  also have \<open>equivalent_registers \<dots> id\<close>
    by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
  finally show \<open>iso_register (F \<circ> G;(complement F;F \<circ> complement G))\<close>
    using equivalent_registers_sym iso_register_equivalent_id by blast
qed

lemma complements_Fst_Snd[simp]: \<open>complements Fst Snd\<close>
  by (auto intro!: complementsI simp: pair_Fst_Snd)

lemma complements_Snd_Fst[simp]: \<open>complements Snd Fst\<close>
  by (auto intro!: complementsI simp flip: swap_def)

lemma compatible_unit_register[simp]: \<open>register F \<Longrightarrow> compatible F unit_register\<close>
  using compatible_sym unit_register_compatible unit_register_is_unit_register by blast

lemma complements_id_unit_register[simp]: \<open>complements id unit_register\<close>
  using complements_sym is_unit_register_def unit_register_is_unit_register by blast

lemma complements_iso_unit_register: \<open>iso_register I \<Longrightarrow> is_unit_register U \<Longrightarrow> complements I U\<close>
  using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast

lemma iso_register_complement_is_unit_register[simp]:
  assumes \<open>iso_register F\<close>
  shows \<open>is_unit_register (complement F)\<close>
  by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)

text \<open>Adding support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> to the [@{attribute register}] attribute\<close>
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of \<open>is_unit_register _\<close>]

no_notation cblinfun_compose (infixl "*\<^sub>u" 55)
no_notation tensor_op (infixr "\<otimes>\<^sub>u" 70)

end


(* Title: HOL/Library/AList_Mapping.thy
   Author: Florian Haftmann, TU Muenchen
*)

section {* Implementation of mappings with Association Lists *}

theory AList_Mapping
imports AList Mapping
begin

lift_definition Mapping :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping" is map_of .

code_datatype Mapping

lemma lookup_Mapping [simp, code]:
  "Mapping.lookup (Mapping xs) = map_of xs"
  by transfer rule

lemma keys_Mapping [simp, code]:
  "Mapping.keys (Mapping xs) = set (map fst xs)"
  by transfer (simp add: dom_map_of_conv_image_fst)

lemma empty_Mapping [code]:
  "Mapping.empty = Mapping []"
  by transfer simp

lemma is_empty_Mapping [code]:
  "Mapping.is_empty (Mapping xs) \<longleftrightarrow> List.null xs"
  by (case_tac xs) (simp_all add: is_empty_def null_def)

lemma update_Mapping [code]:
  "Mapping.update k v (Mapping xs) = Mapping (AList.update k v xs)"
  by transfer (simp add: update_conv')

lemma delete_Mapping [code]:
  "Mapping.delete k (Mapping xs) = Mapping (AList.delete k xs)"
  by transfer (simp add: delete_conv')

lemma ordered_keys_Mapping [code]:
  "Mapping.ordered_keys (Mapping xs) = sort (remdups (map fst xs))"
  by (simp only: ordered_keys_def keys_Mapping sorted_list_of_set_sort_remdups) simp

lemma size_Mapping [code]:
  "Mapping.size (Mapping xs) = length (remdups (map fst xs))"
  by (simp add: size_def length_remdups_card_conv dom_map_of_conv_image_fst)

lemma tabulate_Mapping [code]:
  "Mapping.tabulate ks f = Mapping (map (\<lambda>k. (k, f k)) ks)"
  by transfer (simp add: map_of_map_restrict)

lemma bulkload_Mapping [code]:
  "Mapping.bulkload vs = Mapping (map (\<lambda>n. (n, vs ! n)) [0..<length vs])"
  by transfer (simp add: map_of_map_restrict fun_eq_iff)

lemma equal_Mapping [code]:
  "HOL.equal (Mapping xs) (Mapping ys) \<longleftrightarrow>
    (let ks = map fst xs; ls = map fst ys
    in (\<forall>l\<in>set ls. l \<in> set ks) \<and> (\<forall>k\<in>set ks. k \<in> set ls \<and> map_of xs k = map_of ys k))"
proof -
  have aux: "\<And>a b xs. (a, b) \<in> set xs \<Longrightarrow> a \<in> fst ` set xs"
    by (auto simp add: image_def intro!: bexI)
  show ?thesis apply transfer
    by (auto intro!: map_of_eqI) (auto dest!: map_of_eq_dom intro: aux)
qed

lemma [code nbe]:
  "HOL.equal (x :: ('a, 'b) mapping) x \<longleftrightarrow> True"
  by (fact equal_refl)

end


section \<open>Basics\<close>

theory Basic
imports Main
begin

  subsection \<open>Miscellaneous\<close>

  abbreviation (input) "const x \<equiv> \<lambda> _. x"

  lemmas [simp] = map_prod.id map_prod.comp[symmetric]
  lemma prod_UNIV[iff]: "A \<times> B = UNIV \<longleftrightarrow> A = UNIV \<and> B = UNIV" by auto
  lemma prod_singleton:
    "fst ` A = {x} \<Longrightarrow> A = fst ` A \<times> snd ` A"
    "snd ` A = {y} \<Longrightarrow> A = fst ` A \<times> snd ` A"
    by force+

  lemma infinite_subset[trans]: "infinite A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> infinite B" using infinite_super by this
  lemma finite_subset[trans]: "A \<subseteq> B \<Longrightarrow> finite B \<Longrightarrow> finite A" using finite_subset by this

  declare infinite_coinduct[case_names infinite, coinduct pred: infinite]
  lemma infinite_psubset_coinduct[case_names infinite, consumes 1]:
    assumes "R A"
    assumes "\<And> A. R A \<Longrightarrow> \<exists> B \<subset> A. R B"
    shows "infinite A"
  proof
    show "False" if "finite A" using that assms by (induct rule: finite_psubset_induct) (auto)
  qed

  (* TODO: why are there two copies of this theorem? *)
  thm inj_on_subset subset_inj_on

  lemma inj_inj_on[dest]: "inj f \<Longrightarrow> inj_on f S" using inj_on_subset by auto

end


theory Llength_lmap
  imports Main "$HIPSTER_HOME/IsaHipster"
    "Llength"
    "Lmap"

begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

cohipster llength lmap
(* Discovers and proves the following in ca. 20 seconds *)
lemma lemma_ac [thy_expl]: "llength (lmap y z) = llength z"
  by (coinduction arbitrary: y z rule: ENat.ENat.coinduct_strong)
    (metis lemma_ab llength.disc_iff(1) llength.sel lmap.disc_iff(2))

end


theory "Zorn-lemma"
  imports misc HOL.Zorn
begin

(*Introduces technical definitions for translations between Isabelle/HOL's sets and predicates*)
definition set2pred1::"'a set \<Rightarrow> 'a Set" ("\<lbrakk>_\<rbrakk>\<^sup>1") where "\<lbrakk>S\<rbrakk>\<^sup>1 \<equiv> \<lambda>x. x \<in> S"
definition pred2set1::"'a Set \<Rightarrow> 'a set" ("\<lbrace>_\<rbrace>\<^sup>1") where "\<lbrace>P\<rbrace>\<^sup>1 \<equiv> {x. P x}"
definition set2pred2::"'a set set \<Rightarrow> 'a Set Set" ("\<lbrakk>_\<rbrakk>\<^sup>2") where "\<lbrakk>S\<rbrakk>\<^sup>2 \<equiv> \<lambda>X. \<lbrace>X\<rbrace>\<^sup>1 \<in> S"
definition pred2set2::"'a Set Set \<Rightarrow> 'a set set" ("\<lbrace>_\<rbrace>\<^sup>2") where "\<lbrace>P\<rbrace>\<^sup>2 \<equiv> {X. P \<lbrakk>X\<rbrakk>\<^sup>1}"

(*Proves useful translation lemmas between Isabelle/HOL's sets and predicates*)
lemma trans1a: "A = \<lbrakk>\<lbrace>A\<rbrace>\<^sup>1\<rbrakk>\<^sup>1" unfolding set2pred1_def pred2set1_def by simp
lemma trans1b: "A = \<lbrace>\<lbrakk>A\<rbrakk>\<^sup>1\<rbrace>\<^sup>1" unfolding set2pred1_def pred2set1_def by simp
lemma trans2a: "A = \<lbrakk>\<lbrace>A\<rbrace>\<^sup>2\<rbrakk>\<^sup>2" unfolding set2pred2_def pred2set2_def using trans1a by (metis mem_Collect_eq)
lemma trans2b: "A = \<lbrace>\<lbrakk>A\<rbrakk>\<^sup>2\<rbrace>\<^sup>2" unfolding set2pred2_def pred2set2_def using trans1b by (metis (mono_tags, lifting) Collect_cong Collect_mem_eq)

(*Introduces technical definition to facilitate substitutions in subsequent proofs*)
definition chains :: "'a Set Set \<Rightarrow> 'a Set Set Set"
  where "chains A \<equiv> \<lambda>C. C \<subseteq> A \<and> chain C"

(*Proves useful translation lemmas between Isabelle/HOL's sets and predicates*)
lemma chainEq: "chain A \<longleftrightarrow> chain\<^sub>\<subseteq> \<lbrace>A\<rbrace>\<^sup>2" unfolding chain_subset_def chain_def
  by (smt (verit, ccfv_SIG) Collect_mono_iff pred2set1_def pred2set2_def set2pred1_def subsetI trans1a)
lemma chainsEq: "(X::'a set set) \<in> Zorn.chains \<lbrace>A\<rbrace>\<^sup>2 \<longleftrightarrow> chains (A::'a Set Set) \<lbrakk>X\<rbrakk>\<^sup>2"
  using chainEq by (smt (verit, del_insts) chains_def Collect_mono_iff Zorn.chains_def mem_Collect_eq pred2set2_def set2pred2_def trans2a trans2b)

lemma ZornLemma: "allChainsHaveUB A \<Longrightarrow> \<exists>M. maximal A M id"
proof -
  fix A::"'a Set Set"
  let ?A = "\<lbrace>A\<rbrace>\<^sup>2"
  assume "allChainsHaveUB A"
  hence "\<forall>C\<in>Zorn.chains ?A. \<exists>U\<in>?A. \<forall>X\<in>C. Set.subset_eq X U" (* uses subset relation from the library *)
    using allChainsHaveUB_def upper_bound_def chainsEq by (smt (z3) chains_def mem_Collect_eq pred2set1_def pred2set2_def subsetI trans1a trans1b trans2b)
  hence "\<exists>M\<in>?A. \<forall>X\<in>?A. Set.subset_eq M X \<longrightarrow> X = M"
    by (simp add: Zorn.Zorn_Lemma2) (* uses Zorn's lemma from the library*)
  thus "\<exists>M. maximal A M id"
    unfolding maximal_def id_apply by (metis Collect_mono_iff pred2set1_def set2pred2_def trans1a trans1b trans2a)
qed

lemma ZornLemma2: "allChainsHaveUB A \<Longrightarrow> \<forall>X. A X \<longrightarrow> (\<exists>M. maximal A M id \<and> X \<subseteq> M)"
proof -
  fix A::"'a Set Set"
  assume "allChainsHaveUB A"
  {
    fix X assume *: "A X"
    let ?F= "\<lambda>Y. A Y \<and> X \<subseteq> Y"
    have "allChainsHaveUB ?F"
      by (smt (verit, del_insts) "*" \<open>allChainsHaveUB A\<close> allChainsHaveUB_def upper_bound_def)
    hence "\<exists>M. maximal ?F M id" by (simp add: ZornLemma)
    then obtain M where max: "maximal ?F M id" by (rule exE)
    hence gtX: "X \<subseteq> M" by (simp add: maximal_def)
    moreover from max have "maximal A M id"
      by (smt (verit) id_apply maximal_def)
    ultimately have "\<exists>M. maximal A M id \<and> X \<subseteq> M" by blast
  }
  thus "\<forall>X. A X \<longrightarrow> (\<exists>M. maximal A M id \<and> X \<subseteq> M)" by blast
qed

lemma ZornLemma_\<omega>: "\<omega>-cpo A \<Longrightarrow> \<exists>M. maximal A M id" by (simp add: ZornLemma omegaCompleteUB)
lemma ZornLemma2_\<omega>: "\<omega>-cpo A \<Longrightarrow> \<forall>X. A X \<longrightarrow> (\<exists>M. maximal A M id \<and> X \<subseteq> M)" by (simp add: ZornLemma2 omegaCompleteUB)

(****************************************************************)
(************* TODO: Relativized variants ***********************)
(****************************************************************)

(* TODO: prove the following bridge lemmas (seem prima facie true)*)
lemma bridge1: "allChainsHaveUB A \<Longrightarrow> \<exists>M. maximal A M id \<Longrightarrow> \<exists>N. maximal\<^sup>U A N id" sorry
lemma bridge2: "allChainsHaveUB\<^sup>U A \<Longrightarrow> allChainsHaveUB A" sorry

lemma ZornLemma_rel: "allChainsHaveUB\<^sup>U A \<Longrightarrow> \<exists>M. maximal\<^sup>U A M id" by (simp add: ZornLemma bridge1 bridge2)
lemma ZornLemma2_rel: "allChainsHaveUB\<^sup>U A \<Longrightarrow> \<forall>X. A X \<longrightarrow> (\<exists>M. maximal\<^sup>U A M id \<and> X \<subseteq>\<^sup>U M)"
  using ZornLemma2 bridge1 bridge2 sorry (* TODO: prove(?)*)

lemma ZornLemma_\<omega>_rel: "\<omega>-cpo\<^sup>U A \<Longrightarrow> \<exists>M. maximal\<^sup>U A M id" by (simp add: ZornLemma_rel omegaCompleteUB_rel)
lemma ZornLemma2_\<omega>_rel: "\<omega>-cpo\<^sup>U A \<Longrightarrow> \<forall>X. A X \<longrightarrow> (\<exists>M. maximal\<^sup>U A M id \<and> X \<subseteq>\<^sup>U M)" by (simp add: ZornLemma2_rel omegaCompleteUB_rel)

end


section \<open>LLVM like Integer Types with Flexible Bit-Width\<close>
theory LLVM_Integer
imports LLVM_More_Word "HOL-Library.Signed_Division"
begin

subsection \<open>Lifting of Operations\<close>

definition "cnv_uop1 f a \<equiv> bin_to_bl (length a) (f (bl_to_bin a))"
definition "cnv_uop2 nel f a b \<equiv>
  if length a = length b then
    bin_to_bl (length a) (f (bl_to_bin a) (bl_to_bin b))
  else nel ()"

definition "cnv_uop2b nel f a b \<equiv> if length a = length b then
    f (bl_to_bin a) (bl_to_bin b)
  else nel ()"

lemma cnv_uop1_correct[simp]:
  "bl_to_bin (cnv_uop1 f a) = bintrunc (length a) (f (bl_to_bin a))
  \<and> length (cnv_uop1 f a) = length a"
  by (auto simp: cnv_uop1_def)

lemma cnv_uop2_correct[simp]:
  "length a = length b
    \<Longrightarrow> bl_to_bin (cnv_uop2 nel f a b) = bintrunc (length a) (f (bl_to_bin a) (bl_to_bin b))
      \<and> length (cnv_uop2 nel f a b) = length b"
  by (auto simp: cnv_uop2_def)

lemma cnv_uop2b_correct[simp]:
  "length a = length b \<Longrightarrow> cnv_uop2b nel f a b = f (bl_to_bin a) (bl_to_bin b)"
  by (auto simp: cnv_uop2b_def)

definition "cnv_sop1 f a \<equiv> bin_to_bl (length a) (f (bl_to_sbin a))"
definition "cnv_sop2 nel f a b \<equiv>
  if length a = length b then
    bin_to_bl (length a) (f (bl_to_sbin a) (bl_to_sbin b))
  else
    nel ()"

definition "cnv_sop2b nel f a b \<equiv> if length a = length b then
    f (bl_to_sbin a) (bl_to_sbin b)
  else nel ()"

lemma length_cnv_sop1[simp]: "length (cnv_sop1 f a) = length a"
  unfolding cnv_sop1_def by auto

lemma cnv_sop1_correct[simp]: "a\<noteq>[]
  \<Longrightarrow> bl_to_sbin (cnv_sop1 f a) = sbintrunc (length a - 1) (f (bl_to_sbin a))
    \<and> length (cnv_sop1 f a) = length a"
  by (auto simp: cnv_sop1_def)

lemma cnv_sop2_correct[simp]: "a\<noteq>[] \<Longrightarrow> length a = length b
  \<Longrightarrow> bl_to_sbin (cnv_sop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))
    \<and> length (cnv_sop2 nel f a b) = length b"
  apply (auto simp: cnv_sop2_def)
  using sbin_bl_bin by fastforce

lemma cnv_sop2_correct'[simp]: "b\<noteq>[] \<Longrightarrow> length a = length b
  \<Longrightarrow> bl_to_sbin (cnv_sop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))
    \<and> length (cnv_sop2 nel f a b) = length b"
  by (metis cnv_sop2_correct length_0_conv)

lemma cnv_sop2b_correct[simp]:
  "length a = length b \<Longrightarrow> cnv_sop2b nel f a b = f (bl_to_sbin a) (bl_to_sbin b)"
  by (auto simp: cnv_sop2b_def)

lemma cnv_uop1_empty_iff[simp]: "cnv_uop1 f a = [] \<longleftrightarrow> a=[]"
  by (auto simp: cnv_uop1_def)

lemma cnv_uop2_empty_iff[simp]: "cnv_uop2 nel f a b = [] \<longleftrightarrow> (if length a = length b then a=[] else nel () = [])"
  by (auto simp: cnv_uop2_def)

lemma cnv_sop2_empty_iff[simp]: "cnv_sop2 nel f a b = [] \<longleftrightarrow> (if length a = length b then a=[] else nel () = [])"
  by (auto simp: cnv_sop2_def)

lemma cnv_sop1_empty_iff[simp]: "cnv_sop1 f a = [] \<longleftrightarrow> a=[]"
  by (auto simp: cnv_sop1_def)

subsubsection \<open>Operations Independent of Signed/Unsigned Interpretation \<close>

definition "signed_unsigned_compat1 f \<equiv> \<forall>w a. sbintrunc w (f (sbintrunc w a)) = sbintrunc w (f a)"
definition "signed_unsigned_compat2 f \<equiv> \<forall>w a b. sbintrunc w (f (sbintrunc w a) (sbintrunc w b)) = sbintrunc w (f a b)"

lemma cnv_uop1_to_sop1:
  assumes "signed_unsigned_compat1 f"
  shows "cnv_uop1 f a = cnv_sop1 f a"
  apply (auto simp: cnv_uop1_def cnv_sop1_def bl_to_sbin_def)
  using assms unfolding signed_unsigned_compat1_def
  by (metis (no_types, lifting) bin_bl_bin bintrunc_sbintruncS0 bl_bin_bl length_greater_0_conv size_bin_to_bl)

lemma cnv_uop2_to_sop2:
  assumes [simp]: "length a = length b"
  assumes "signed_unsigned_compat2 f"
  shows "cnv_uop2 nel f a b = cnv_sop2 nel f a b"
  apply (auto simp: cnv_uop2_def cnv_sop2_def bl_to_sbin_def)
  using assms(2) unfolding signed_unsigned_compat2_def
  by (metis (no_types, lifting) bin_bl_bin bintrunc_sbintruncS0 bl_bin_bl length_greater_0_conv size_bin_to_bl)

lemma cnv_uop1_compat_correct:
  assumes [simp]: "signed_unsigned_compat1 f"
  assumes [simp]: "a\<noteq>[]"
  shows "bl_to_sbin (cnv_uop1 f a) = sbintrunc (length a - 1) (f (bl_to_sbin a))"
  by (auto simp: cnv_uop1_to_sop1)

lemma cnv_uop2_compat_correct:
  assumes [simp]: "length a = length b"
  assumes [simp]: "signed_unsigned_compat2 f"
  assumes [simp]: "a\<noteq>[]"
  shows "bl_to_sbin (cnv_uop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))"
  by (auto simp: cnv_uop2_to_sop2)

lemma cnv_uop2_compat_correct':
  assumes [simp]: "length a = length b"
  assumes [simp]: "signed_unsigned_compat2 f"
  assumes [simp]: "b\<noteq>[]"
  shows "bl_to_sbin (cnv_uop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))"
  by (metis assms cnv_uop2_compat_correct length_0_conv)

lemma signed_unsigned_compat2_plus[simp]: "signed_unsigned_compat2 (+)"
  apply (auto simp: signed_unsigned_compat2_def sbintrunc_mod2p)
  apply (pull_push_mods)
  by (simp add: algebra_simps)

lemma signed_unsigned_compat2_minus[simp]: "signed_unsigned_compat2 (-)"
  apply (clarsimp simp: signed_unsigned_compat2_def sbintrunc_mod2p)
  apply (pull_push_mods)
  by (simp add: algebra_simps)

lemma signed_unsigned_compat2_mult[simp]: "signed_unsigned_compat2 (*)"
  apply (auto simp: signed_unsigned_compat2_def sbintrunc_mod2p)
  apply pull_push_mods
  by (simp add: algebra_simps)

subsection \<open>Bitwise Interpretation of Operations\<close>
text \<open>Provides an additional sanity check, by equating our definitions with the definitions found in
  "OLD:HOL-Word.Bits_Int". Unfortunately, they do not define minus there.\<close>

lemma cnv_plus_rbl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (+) a b = rev (rbl_add (rev a) (rev b))"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def rbl_add simp del: bl_bin_bl)

lemma cnv_mult_rbl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (*) a b = rev (rbl_mult (rev a) (rev b))"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def rbl_mult simp del: bl_bin_bl)

lemma cnv_AND_bl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (AND) a b = map2 (\<and>) a b"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def bl_and_bin simp del: bl_bin_bl)

lemma cnv_OR_bl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (OR) a b = map2 (\<or>) a b"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def bl_or_bin simp del: bl_bin_bl)

(* TODO: Lemma bl_xor_bin has non-normalized lhs! *)
lemma cnv_XOR_bl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (XOR) a b = map2 (\<noteq>) a b"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: bl_xor_bin[simplified] cnv_uop2_def simp del: bl_bin_bl)

lemma cnv_NOT_bl_conv: "cnv_uop1 (NOT) a = map Not a"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (simp only: bl_not_bin)
  by (auto simp: cnv_uop1_def)

lemma cnv_SHL_bl_conv: "n\<le>length a \<Longrightarrow> cnv_uop1 (\<lambda>x. x * 2^n) a = drop n a @ replicate n False"
  by (auto simp: cnv_uop1_def bl_bin_bl_rep_drop)

lemma butlast_bin_to_bl_aux: "acc\<noteq>[] \<Longrightarrow> butlast (bin_to_bl_aux w i acc) = bin_to_bl_aux w i (butlast acc)"
  by (simp add: bin_to_bl_aux_alt butlast_append)

(*lemma bin_rest_div2[simp]: "bin_rest (n div 2) = bin_rest n div 2"
  by (auto simp: bin_rest_def)
*)

(*lemma bin_last_div2[simp]: "bin_last (n div 2) = bin_last (bin_rest n)"
  by (auto simp: bin_rest_def)
*)

find_theorems bin_to_bl_aux "(@)"

lemma bin_to_bl_Suc: "bin_to_bl (Suc w) i = bin_to_bl w (bin_rest i) @ [bin_last i]"
  by (simp add: bin_to_bl_aux_append bin_to_bl_def)

lemma "butlast (bin_to_bl w n) = bin_to_bl (w-1) (bin_rest n)" oops
  thm butlast_rest_bin

  find_theorems "bin_to_bl _ _ ! _"

lemma bin_to_bl_div2_shift: "\<lbrakk>w\<noteq>0; n\<ge>0; n<2^w\<rbrakk> \<Longrightarrow> bin_to_bl w (n div 2) = False # butlast (bin_to_bl w n)"
  apply (cases w; simp)
  apply (rule nth_equalityI)
  apply (auto simp: butlast_rest_bin nth_Cons nth_bin_to_bl bit_iff_odd split: nat.splits)
  done

lemma div_div_p2_eq_div_p2s:
  "w div (2^a) div (2^b) = (w::int) div 2^(a+b)"
  "w div 2 div (2^b) = (w::int) div 2^(Suc b)"
  by (simp_all add: div_mult2_eq power_add zdiv_zmult2_eq)

lemma bin_to_bl_div2p_shift: "\<lbrakk>n\<ge>0; n<2^w; k\<le>w\<rbrakk> \<Longrightarrow> bin_to_bl w (n div 2^k) = replicate k False @ take (w-k) (bin_to_bl w n)"
  apply (rule nth_equalityI)
  apply simp
  apply clarsimp
  apply auto
   apply (auto simp: butlast_rest_bin nth_Cons nth_append nth_bin_to_bl split: nat.splits if_splits)
  subgoal apply (auto simp: bit_int_def algebra_simps div_div_p2_eq_div_p2s)
    by (metis Nat.add_diff_assoc2 Suc_leI add.commute bits_div_0 div_div_p2_eq_div_p2s(1) div_pos_pos_trivial dvd_0_right)
  subgoal
    by (simp add: add.commute bit_int_def div_exp_eq)
  subgoal
    by (simp add: add.commute bit_iff_odd div_div_p2_eq_div_p2s(1))
  done

lemma cnv_LSHR_bl_conv: "n\<le>length a \<Longrightarrow> cnv_uop1 (\<lambda>x. x div 2^n) a = replicate n False @ take (length a - n) a"
  apply (cases "length a")
  apply (auto simp: cnv_uop1_def bin_to_bl_div2p_shift)
  by (metis bin_to_bl_div2p_shift bl_bin_bl bl_to_bin_ge0 bl_to_bin_lt2p)

text \<open>Note: This division is with rounding down!\<close>
lemma bin_to_bl_sdiv2_shift:
  assumes ran: "-(2^w)\<le>i" "i<2^w"
  shows "bin_to_bl (Suc w) (i div 2) = hd (bin_to_bl (Suc w) i) # butlast (bin_to_bl (Suc w) i)"
proof -
  have "\<lbrakk> \<not> 0 \<le> (i::int)\<rbrakk> \<Longrightarrow> i div (2*2^w) = -1" using ran
    by (smt cancel_div_mod_rules(2) div_pos_pos_trivial mod_add_self2 mult_cancel_left1 mult_minus_right)

  then show ?thesis using ran
    apply (rule_tac nth_equalityI)
    apply (auto
        simp: butlast_rest_bin nth_Cons bl_sbin_sign nth_bin_to_bl bin_sign_def sbintrunc_mod2p div_div_p2_eq_div_p2s bit_int_def
        split: nat.splits)
    done

qed

lemma bin_to_bl_sdiv2p_shift:
  assumes ran: "-(2^w)\<le>i" "i<2^w" and K: "k<Suc w"
  shows "bin_to_bl (Suc w) (i div 2^k) = replicate k (hd (bin_to_bl (Suc w) i)) @ take (Suc w - k) (bin_to_bl (Suc w) i)"
proof -

  have "\<lbrakk>\<not>0\<le>i; x\<ge>w\<rbrakk> \<Longrightarrow> i div (2^x) = -1" for x using ran
    apply auto
    by (smt cancel_div_mod_rules(2) int_mod_eq' linorder_not_le mod_add_self2 mult_cancel_left1 mult_minus_right power_strict_increasing_iff)

  with ran K show ?thesis
    apply (rule_tac nth_equalityI)
    apply (auto
        simp: butlast_rest_bin nth_Cons bl_sbin_sign nth_bin_to_bl bit_int_def bin_sign_def sbintrunc_mod2p div_div_p2_eq_div_p2s
        simp: nth_append algebra_simps
        split: nat.splits)
    by (smt (verit, ccfv_SIG) Nat.add_diff_assoc2 div_pos_pos_trivial even_add le_add2 le_eq_less_or_eq power_increasing_iff)
qed

lemma cnv_ASHR_bl_conv: "n<length a \<Longrightarrow> cnv_sop1 (\<lambda>x. x div 2^n) a = replicate n (hd a) @ take (length a - n) a"
  apply (cases "length a")
  apply (auto simp: cnv_sop1_def)
  by (metis bin_to_bl_sdiv2p_shift bl_sbin_bl bl_to_sbin_def diff_Suc_1 sbintr_ge sbintr_lt)

subsection \<open>Signed and Unsigned Extension and Truncation\<close>

definition bl_trunc :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where "bl_trunc w bl \<equiv> drop (length bl - w) bl"

lemma bl_trunc_ge[simp]: "length bl < w \<Longrightarrow> bl_trunc w bl = bl"
  by (simp add: bl_trunc_def)

lemma trunc_bl_to_bin[simp]: "bl_to_bin (bl_trunc w bl) = bintrunc w (bl_to_bin bl)"
  by (simp add: bl_trunc_def trunc_bl2bin)

lemma trunc_bl_to_sbin[simp]:
  "w>0 \<Longrightarrow> bl_to_sbin (bl_trunc w bl) = sbintrunc (w-1) (bl_to_sbin bl)"
  apply (cases "w \<le> length bl")
  apply (auto simp: bl_trunc_def bl_to_sbin_def bl2bin_drop min_def)
  done

lemma bl_trunc_len[simp]: "length (bl_trunc w bl) = min w (length bl)"
  by (auto simp: bl_trunc_def)

lemma bl_trunc_eq_Nil_conv[simp]: "bl_trunc w l = [] \<longleftrightarrow> w=0 \<or> l=[]"
  by (cases l) (auto simp: bl_trunc_def)

definition bl_zext :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where "bl_zext w bl \<equiv> replicate (w - length bl) False @ bl"

lemma bl_zext_le[simp]: "w\<le>length bl \<Longrightarrow> bl_zext w bl = bl"
  by (auto simp: bl_zext_def)

lemma bl_zext_to_bin[simp]: "bl_to_bin (bl_zext w bl) = bl_to_bin bl"
  by (auto simp: bl_zext_def bl_to_bin_rep_F)

lemma bl_zext_len[simp]: "length (bl_zext w bl) = max w (length bl)"
  by (auto simp: bl_zext_def)

lemma bl_zext_Nil_conv[simp]: "bl_zext w bl = [] \<longleftrightarrow> w=0 \<and> bl = []"
  by (auto simp: bl_zext_def)

definition bl_sext :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where "bl_sext w bl \<equiv> replicate (w - length bl) (hd bl) @ bl"

lemma bl_sext_le[simp]: "w\<le>length bl \<Longrightarrow> bl_sext w bl = bl"
  by (auto simp: bl_sext_def)

lemma bl_to_sbin_pos_conv_bin: "\<not>hd bl \<Longrightarrow> bl_to_sbin bl = bl_to_bin bl"
  by (auto simp: bl_to_sbin_alt split: list.split)

lemma bl_to_sbin_neg_conv_bin: "bl\<noteq>[] \<Longrightarrow> hd bl \<Longrightarrow> bl_to_sbin bl = bl_to_bin bl - 2^(length bl)"
  by (auto simp: bl_to_sbin_alt split: list.split)

lemma bl_sext_to_sbin[simp]:
  assumes [simp]: "bl\<noteq>[]"
  shows "bl_to_sbin (bl_sext w bl) = bl_to_sbin bl"
  apply (cases "w>length bl"; simp?)
proof (cases "hd bl")
  case True
  assume "length bl < w"
  with True show ?thesis
    apply (auto simp: bl_to_sbin_neg_conv_bin bl_sext_def bl_to_bin_rep_T algebra_simps)
    by (metis diff_add_inverse less_imp_add_positive power_add)
next
  case False
  assume "length bl < w"
  with False show ?thesis by (auto simp: bl_to_sbin_pos_conv_bin bl_sext_def bl_to_bin_rep_F)
qed

lemma bl_sext_len[simp]: "length (bl_sext w bl) = max w (length bl)"
  by (auto simp: bl_sext_def)

lemma bl_sext_Nil_conv[simp]: "bl_sext w bl = [] \<longleftrightarrow> w=0 \<and> bl = []"
  by (auto simp: bl_sext_def)

subsection \<open>LLVM Integer Datatype\<close>

typedef lint = "{l::bool list. True }"
  morphisms lint_to_bits bits_to_lint
  by auto

setup_lifting type_definition_lint

(*lemma Rep_lint_neq_Nil[simp]: "lint_to_bits x \<noteq> []"
  using lint_to_bits by simp
*)

instantiation lint :: equal
begin
  lift_definition equal_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" is "equal_class.equal" .

  instance
    apply intro_classes
    apply transfer
    apply (rule equal_eq)
    done

end

lift_definition width :: "lint \<Rightarrow> nat" is length .
lift_definition lint_to_uint :: "lint \<Rightarrow> int" is bl_to_bin .
lift_definition lint_to_sint :: "lint \<Rightarrow> int" is bl_to_sbin .

(*lemma width_notZ[simp]: "width a \<noteq> 0" by transfer auto*)

lemma uint_lower_bound[simp]: "0\<le>lint_to_uint a"
  apply transfer using bl_to_bin_ge0 by auto

lemma uint_upper_bound[simp]: "lint_to_uint a < 2^width a"
  apply transfer by (simp add: bl_to_bin_lt2p)

lemma sint_lower_bound[simp]: "-(2^(width a - 1))\<le>lint_to_sint a"
  apply transfer by (simp add: bl_to_sbin_def sbintr_ge)

lemma sint_upper_bound[simp]: "lint_to_sint a < 2^(width a - 1)"
  apply transfer by (simp add: bl_to_sbin_def sbintr_lt)

subsubsection \<open>Overflows\<close>

definition "uovf1 f a \<equiv> f (lint_to_uint a) \<notin> uints (width a)"
definition "sovf1 f a \<equiv> f (lint_to_sint a) \<notin> sints (width a)"

definition "uovf2 f a b \<equiv> f (lint_to_uint a) (lint_to_uint b) \<notin> uints (width a)"
definition "sovf2 f a b \<equiv> f (lint_to_sint a) (lint_to_sint b) \<notin> sints (width a)"

subsubsection \<open>Operations\<close>

lift_definition lconst :: "nat \<Rightarrow> int \<Rightarrow> lint" is "\<lambda>w i. bin_to_bl w i" by simp

lemma width_lconst[simp]: "width (lconst w i) = w"
  by transfer auto

lemma uint_const[simp]: "lint_to_uint (lconst w c) = bintrunc w c"
  by transfer auto

lemma sint_const[simp]: "w\<noteq>0 \<Longrightarrow> lint_to_sint (lconst w c) = sbintrunc (w-1) c"
  by transfer (auto)

lemma bits_zero[simp]: "lint_to_bits (lconst w 0) = replicate w False"
  by transfer (auto simp: bin_to_bl_zero)

lemma bits_minus1[simp]: "lint_to_bits (lconst w (-1)) = replicate w True"
  by transfer (auto simp: bin_to_bl_minus1)

lemma lconst_eq_iff[simp]:
  "lconst w c = lconst w' c' \<longleftrightarrow> w'=w \<and> (c' mod 2^w = c mod 2^w)"
  apply safe
  subgoal
    apply transfer
    by (metis len_bin_to_bl)
  subgoal
    apply transfer
    by (metis bin_bl_bin bintrunc_mod2p len_bin_to_bl)
  subgoal
    apply transfer
    by (auto simp: max_def bintrunc_mod2p bl_to_bin_inj)
  done

definition "lint_abort (_::unit) \<equiv> lint_to_bits undefined"
definition "lint_abort_bool (_::unit) \<equiv> undefined::bool"

(*lemma l_abort_ne[simp]: "lint_abort () \<noteq> []" unfolding lint_abort_def by auto*)
declare [[ code abort: lint_abort lint_abort_bool]]

instantiation lint :: "{plus,minus,times,divide,modulo,uminus,signed_division}"
begin
  lift_definition plus_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (+)" by simp
  lift_definition minus_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (-)" by simp
  lift_definition times_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (*)" by simp
  lift_definition divide_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (div)" by simp
  lift_definition modulo_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (mod)" by simp

  lift_definition uminus_lint :: "lint \<Rightarrow> lint" is "cnv_sop1 uminus" by simp

  definition sdivrem_ovf :: "lint \<Rightarrow> lint \<Rightarrow> bool" where
    "sdivrem_ovf a b \<equiv> lint_to_sint a sdiv lint_to_sint b \<notin> sints (width a)"

  lift_definition signed_divide_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint"
    is "\<lambda>a b. if bl_to_sbin a sdiv bl_to_sbin b \<in> sints (length a) then cnv_sop2 lint_abort (sdiv) a b else lint_abort ()"
    by simp

  lift_definition signed_modulo_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint"
    is "\<lambda>a b. if bl_to_sbin a sdiv bl_to_sbin b \<in> sints (length a) then cnv_sop2 lint_abort (smod) a b else lint_abort ()"
    by simp

  instance ..
end

lemma width_plus[simp]:
  assumes "width a = width b"
  shows "width (a+b) = width b"
  using assms by transfer auto

lemma uint_plus[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a+b) = bintrunc (width b) (lint_to_uint a + lint_to_uint b)"
  using assms by transfer auto

lemma sint_plus[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  shows "lint_to_sint (a+b) = sbintrunc (width b - 1) (lint_to_sint a + lint_to_sint b)"
  using assms by transfer (auto simp: cnv_uop2_compat_correct')

lemma width_minus[simp]:
  assumes "width a = width b"
  shows "width (a-b) = width b"
  using assms by transfer auto

lemma uint_minus[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a-b) = bintrunc (width b) (lint_to_uint a - lint_to_uint b)"
  using assms
  by transfer auto

lemma sint_minus[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  shows "lint_to_sint (a-b) = sbintrunc (width b - 1) (lint_to_sint a - lint_to_sint b)"
  using assms
  by transfer (auto simp: cnv_uop2_compat_correct')

lemma width_times[simp]:
  assumes "width a = width b"
  shows "width (a*b) = width b"
  using assms by transfer auto

lemma uint_times[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a*b) = bintrunc (width b) (lint_to_uint a * lint_to_uint b)"
  using assms
  by transfer auto

lemma sint_times[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  shows "lint_to_sint (a*b) = sbintrunc (width b - 1) (lint_to_sint a * lint_to_sint b)"
  using assms
  by transfer (auto simp: cnv_uop2_compat_correct')

lemma width_divide[simp]:
  assumes "width a = width b"
  shows "width (a div b) = width b"
  using assms by transfer auto

lemma uint_divide[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a div b) = bintrunc (width b) (lint_to_uint a div lint_to_uint b)"
  using assms
  by transfer auto

lemma width_sdivide[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "width (a sdiv b) = width b"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma sint_sdivide[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "lint_to_sint (a sdiv b) = sbintrunc (width b - 1) ((lint_to_sint a) sdiv (lint_to_sint b))"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma width_modulo[simp]:
  assumes "width a = width b"
  shows "width (a mod b) = width b"
  using assms by transfer auto

lemma uint_modulo[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a mod b) = bintrunc (width b) (lint_to_uint a mod lint_to_uint b)"
  using assms
  by transfer auto

lemma width_srem[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "width (a smod b) = width b"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma sint_remainder[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "lint_to_sint (a smod b) = sbintrunc (width b - 1) ((lint_to_sint a) smod (lint_to_sint b))"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma width_uminus[simp]:
  "width (- a) = width a"
  by transfer auto

lemma sint_uminus[simp]:
  "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (- a) = sbintrunc (width a - 1) (- lint_to_sint a)"
  by transfer auto

instantiation lint :: "{ord}"
begin
  lift_definition less_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" is "cnv_uop2b lint_abort_bool (<)" .
  lift_definition less_eq_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" is "cnv_uop2b lint_abort_bool (\<le>)" .
  instance ..
end

lift_definition sless_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" (infix "<\<^sub>s" 50) is "cnv_sop2b lint_abort_bool (<)" .
lift_definition sless_eq_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" (infix "\<le>\<^sub>s" 50) is "cnv_sop2b lint_abort_bool (\<le>)" .

lemma uint_less[simp]:
  assumes "width a = width b"
  shows "a < b \<longleftrightarrow> lint_to_uint a < lint_to_uint b"
  using assms by transfer auto

lemma uint_less_eq[simp]:
  assumes "width a = width b"
  shows "a \<le> b \<longleftrightarrow> lint_to_uint a \<le> lint_to_uint b"
  using assms by transfer auto

lemma sint_less[simp]:
  assumes "width a = width b"
  shows "a <\<^sub>s b \<longleftrightarrow> lint_to_sint a < lint_to_sint b"
  using assms by transfer auto

lemma sint_less_eq[simp]:
  assumes "width a = width b"
  shows "a \<le>\<^sub>s b \<longleftrightarrow> lint_to_sint a \<le> lint_to_sint b"
  using assms by transfer auto

text \<open>Yields \<open>0\<^sub>1\<close> on attempt to truncate to zero\<close>
lift_definition trunc :: "nat \<Rightarrow> lint \<Rightarrow> lint" is "\<lambda>w a. if w=0 then [False] else bl_trunc w a"
  by auto

lemma width_trunc[simp]: "w\<noteq>0 \<Longrightarrow> width (trunc w a) = min w (width a)" by transfer auto

lemma uint_trunc[simp]: "w\<noteq>0 \<Longrightarrow> lint_to_uint (trunc w a) = bintrunc w (lint_to_uint a)"
  by transfer auto

lemma sint_trunc[simp]: "w\<noteq>0 \<Longrightarrow> lint_to_sint (trunc w a) = sbintrunc (w-1) (lint_to_sint a)"
  by transfer auto

lift_definition zext :: "nat \<Rightarrow> lint \<Rightarrow> lint" is "bl_zext" by simp
lift_definition sext :: "nat \<Rightarrow> lint \<Rightarrow> lint" is "bl_sext" by simp

lemma width_zext[simp]: "width (zext w a) = max w (width a)"
  by transfer auto
lemma width_sext[simp]: "width (sext w a) = max w (width a)"
  by transfer auto

lemma uint_zext[simp]: "lint_to_uint (zext w a) = lint_to_uint a"
  by transfer auto

lemma sint_sext[simp]: "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (sext w a) = lint_to_sint a"
  by transfer auto

(*
instantiation lint :: semiring_bit_operations
begin
*)

  lift_definition and_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" (infixr \<open>lliAND\<close> 64) is "cnv_uop2 lint_abort (AND)" by simp
  lift_definition or_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" (infixr \<open>lliOR\<close>  59) is "cnv_uop2 lint_abort (OR)" by simp
  lift_definition xor_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" (infixr \<open>lliXOR\<close> 59) is "cnv_uop2 lint_abort (XOR)" by simp

  lift_definition not_lint :: "lint \<Rightarrow> lint" (\<open>lliNOT\<close>) is "cnv_uop1 (NOT)" by simp

(*
  instance ..
end
*)

lemma width_AND[simp]:
  assumes "width a = width b"
  shows "width (a lliAND b) = width b"
  using assms by transfer auto

lemma uint_AND[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a lliAND b) = lint_to_uint a AND lint_to_uint b"
  using assms apply (transfer)
  apply (auto simp: )
  by (metis bin_trunc_ao(1) trunc_bl2bin_len)

lemma width_OR[simp]:
  assumes "width a = width b"
  shows "width (a lliOR b) = width b"
  using assms by transfer auto

lemma uint_OR[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a lliOR b) = lint_to_uint a OR lint_to_uint b"
  using assms apply (transfer)
  by (metis bin_trunc_ao(2) cnv_uop2_correct trunc_bl2bin_len)

lemma width_XOR[simp]:
  assumes "width a = width b"
  shows "width (a lliXOR b) = width b"
  using assms by transfer auto

lemma uint_XOR[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a lliXOR b) = lint_to_uint a XOR lint_to_uint b"
  using assms apply (transfer)
  by (metis cnv_uop2_correct take_bit_xor trunc_bl2bin_len)

lemma width_NOT[simp]:
  "width (lliNOT a) = width a"
  by transfer auto

lemma uint_NOT[simp]:
  shows "lint_to_uint (lliNOT a) = bintrunc (width a) (NOT (lint_to_uint a))"
  by transfer auto

lemma bits_NOT[simp]: "lint_to_bits (lliNOT a) = map Not (lint_to_bits a)"
  by transfer (auto simp: cnv_NOT_bl_conv)

lemma bits_AND[simp]: "width a = width b \<Longrightarrow> lint_to_bits (a lliAND b) = map2 (\<and>) (lint_to_bits a) (lint_to_bits b)"
  by transfer (auto simp: cnv_AND_bl_conv)

lemma bits_OR[simp]: "width a = width b \<Longrightarrow> lint_to_bits (a lliOR b) = map2 (\<or>) (lint_to_bits a) (lint_to_bits b)"
  by transfer (auto simp: cnv_OR_bl_conv)

lemma bits_XOR[simp]: "width a = width b \<Longrightarrow> lint_to_bits (a lliXOR b) = map2 (\<noteq>) (lint_to_bits a) (lint_to_bits b)"
  by transfer (auto simp: cnv_XOR_bl_conv)

lift_definition bitSHL :: "lint \<Rightarrow> nat \<Rightarrow> lint" is "\<lambda>bl n. cnv_uop1 (\<lambda>x. x*2^n) bl" by simp
lift_definition bitLSHR :: "lint \<Rightarrow> nat \<Rightarrow> lint" is "\<lambda>bl n. cnv_uop1 (\<lambda>x. x div 2^n) bl" by simp
lift_definition bitASHR :: "lint \<Rightarrow> nat \<Rightarrow> lint" is "\<lambda>bl n. cnv_sop1 (\<lambda>x. x div 2^n) bl" by simp

lemma width_bitSHL[simp]: "width (bitSHL a n) = width a"
  by transfer auto

lemma uint_bitSHL[simp]: "lint_to_uint (bitSHL a n) = bintrunc (width a) (2^n * lint_to_uint a)"
  by transfer (auto simp: algebra_simps)

lemma sint_bitSHL[simp]: "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (bitSHL a n) = sbintrunc (width a - 1) (2^n * lint_to_sint a)"
  apply transfer
  apply (simp add: bl_to_sbin_def sbintrunc_mod2p bintrunc_mod2p)
  apply (pull_push_mods)
  apply (auto simp: algebra_simps)
  done

lemma width_bitLSHR[simp]: "width (bitLSHR a n) = width a"
  by transfer auto

lemma uint_bitLSHR[simp]: "lint_to_uint (bitLSHR a n) = lint_to_uint a div 2^n"
  apply transfer
  apply (auto
      simp: bintrunc_mod2p algebra_simps pos_imp_zdiv_nonneg_iff bl_to_bin_ge0
      intro!: mod_pos_pos_trivial)
  by (smt bl_to_bin_ge0 bl_to_bin_lt2p div_by_1 div_pos_pos_trivial int_div_less_self zero_less_power)

lemma width_bitASHR[simp]: "width (bitASHR a n) = width a"
  by transfer auto

lemma sint_bitASHR[simp]: "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (bitASHR a n) = lint_to_sint a div 2^n"
  apply transfer
  using bl_to_sbin_in_sints
  apply (clarsimp simp: sbintrunc_eq_if_in_range sints_num)
  by (smt div_by_1 pos_imp_zdiv_nonneg_iff zdiv_mono2 zdiv_mono2_neg zero_less_power)

lemma uint_eq:
  "a = b \<longleftrightarrow> lint_to_uint a = lint_to_uint b \<and> width a = width b"
  apply (transfer)
  using bl_to_bin_inj
  by auto

lemma sint_eq:
  "a = b \<longleftrightarrow> lint_to_sint a = lint_to_sint b \<and> width a = width b"
  apply (transfer)
  apply auto
  by (metis bl_sbin_bl)

lemma lconst_inj: "lconst w a = lconst w b \<longleftrightarrow> a mod 2^w = b mod 2^w" by auto

subsection \<open>\<open>i1\<close> as Boolean\<close>

definition "ltrue \<equiv> lconst 1 1"
definition "lfalse \<equiv> lconst 1 0"
definition "bool_to_lint b \<equiv> if b then ltrue else lfalse"
definition "lint_to_bool a \<equiv> if a = ltrue then True else if a = lfalse then False else lint_abort_bool ()"

lemma lbool_cases: "width a = 1 \<Longrightarrow> a=ltrue \<or> a=lfalse"
  unfolding ltrue_def lfalse_def
  apply transfer
  apply auto
  by (smt (verit, ccfv_threshold) append.simps(2) bin_to_bl_Suc bin_to_bl_eq_Nil_conv bin_to_bl_zero bl_sbin_bl div_pos_pos_trivial even_add last_snoc rbbl_Cons rev_append rev_bin_to_bl_simps(1) rev_bin_to_bl_simps(4))

lemma lint_bool_simps[simp]:
  "width ltrue = 1"
  "width lfalse = 1"
  "lint_to_uint ltrue = 1"
  "lint_to_uint lfalse = 0"
  "lint_to_sint ltrue = -1"
  "lint_to_sint lfalse = 0"

  "width (bool_to_lint b) = 1"
  "width a = 1 \<Longrightarrow> lint_to_bool a \<longleftrightarrow> a = ltrue"
  "lint_to_bool (bool_to_lint b) = b"
  "width a = 1 \<Longrightarrow> bool_to_lint (lint_to_bool a) = a"
  using lbool_cases
  unfolding ltrue_def lfalse_def bool_to_lint_def lint_to_bool_def
  by (auto)

section \<open>Connection to Word Datatype\<close>

definition lint_to_word :: "lint \<Rightarrow> 'a::len word" where "lint_to_word \<equiv> word_of_int o lint_to_uint"
definition word_to_lint :: "'a::len word \<Rightarrow> lint" where "word_to_lint \<equiv> lconst (len_of TYPE('a)) o uint"

lemma lint_word_inv[simp]: "lint_to_word (word_to_lint w) = w"
  by (auto simp: word_to_lint_def lint_to_word_def)

lemma word_lint_inv[simp]: "LENGTH ('a::len) = width i \<Longrightarrow> word_to_lint (lint_to_word i :: 'a word) = i"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  by (metis uint_const uint_eq uint_lower_bound uint_upper_bound width_lconst word_of_int_inverse word_ubin.norm_Rep)

lemma bin_to_bl_eq_iff: "bin_to_bl w x = bin_to_bl w y \<longleftrightarrow> bintrunc w x = bintrunc w y"
  by (metis bin_bl_bin bl_bin_bl size_bin_to_bl)

named_theorems word_to_lint_convs

lemma word_to_lint_plus[word_to_lint_convs]: "word_to_lint (a+b) = word_to_lint a + word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p mod_add_eq)
  done

lemma word_to_lint_minus[word_to_lint_convs]: "word_to_lint (a-b) = word_to_lint a - word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p mod_diff_eq)
  done

lemma word_to_lint_mult[word_to_lint_convs]: "word_to_lint (a*b) = word_to_lint a * word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p mod_mult_eq)
  done

lemma word_to_lint_eq[word_to_lint_convs]: "word_to_lint a = word_to_lint b \<longleftrightarrow> a=b"
  by (auto simp: word_to_lint_def word_uint.Rep_inject)

lemma word_to_lint_ule[word_to_lint_convs]: "word_to_lint a \<le> word_to_lint b \<longleftrightarrow> a\<le>b"
  by (auto simp: word_to_lint_def lint_to_word_def word_le_def)

lemma word_to_lint_ult[word_to_lint_convs]: "word_to_lint a < word_to_lint b \<longleftrightarrow> a<b"
  by (auto simp: word_to_lint_def lint_to_word_def word_less_def)

lemma word_to_lint_sle[word_to_lint_convs]: "word_to_lint a \<le>\<^sub>s word_to_lint b \<longleftrightarrow> a <=s b"
  by (auto simp: word_to_lint_def lint_to_word_def word_sle_def sint_uint)

lemma word_to_lint_slt[word_to_lint_convs]: "word_to_lint a <\<^sub>s word_to_lint b \<longleftrightarrow> a <s b"
  by (auto simp: word_to_lint_def lint_to_word_def word_sless_alt sint_uint)

lemma word_to_lint_div[word_to_lint_convs]: "word_to_lint (a div b) = word_to_lint a div word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer'
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p uint_div_alt)
  done

lemma word_to_lint_mod[word_to_lint_convs]: "word_to_lint (a mod b) = word_to_lint a mod word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer'
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p uint_mod_alt)
  done

lemma word_to_lint_sdiv[word_to_lint_convs]:
  fixes a b :: "'a::len word"
  assumes "sint a sdiv sint b \<in> sints LENGTH('a)"
  shows "word_to_lint (a sdiv b) = word_to_lint a sdiv word_to_lint b"
  using assms
  apply (auto simp: word_to_lint_def lint_to_word_def sints_def)
  apply transfer'
  by (smt (z3) One_nat_def bin_to_bl_trunc bintrunc_sbintruncS0 cnv_sop2_def len_bin_to_bl len_gt_0 order_refl sbin_bl_bin sbintrunc_eq_if_in_range)

lemma word_to_lint_smod[word_to_lint_convs]:
  fixes a b :: "'a::len word"
  assumes "sint a sdiv sint b \<in> sints LENGTH('a)"
  shows "word_to_lint (a smod b) = word_to_lint a smod word_to_lint b"
  using assms
  apply (auto simp: word_to_lint_def lint_to_word_def sints_def)
  apply transfer'
  by (smt (z3) One_nat_def bin_to_bl_trunc cnv_sop2_def len_gt_0 order_refl sbin_bl_bin sbintrunc_eq_if_in_range sbintrunc_sbintrunc size_bin_to_bl)

lemma word_to_lint_shl[word_to_lint_convs]: "word_to_lint ((a::_::len word) << n) = bitSHL (word_to_lint a) n"
  apply (auto simp: word_to_lint_def)
  apply transfer'
  apply (auto simp: cnv_uop1_def bin_to_bl_eq_iff bintrunc_mod2p shiftl_t2n uint_word_ariths algebra_simps)
  by (simp add: mod_mult_right_eq semiring_normalization_rules(7) shiftl_int_def)

lemma word_to_lint_lshr[word_to_lint_convs]: "word_to_lint ((a::_::len word) >> n) = bitLSHR (word_to_lint a) n"
  apply (auto simp: word_to_lint_def)
  apply transfer'
  apply (auto simp: cnv_uop1_def bin_to_bl_eq_iff bintrunc_mod2p uint_word_ariths shiftr_div_2n algebra_simps)
  by (metis drop_bit_eq_div)

lemma word_to_lint_ashr[word_to_lint_convs]: "word_to_lint (a >>> n) = bitASHR (word_to_lint (a::'a::len word)) n"
  unfolding word_to_lint_def
  apply transfer'
  apply (auto simp: cnv_sop1_def uint_sint sshiftr_div_2n drop_bit_eq_div)
  done

lemma word_to_lint_ucast_down[word_to_lint_convs]: "is_down UCAST('a \<rightarrow> 'b) \<Longrightarrow> word_to_lint (UCAST('a::len\<rightarrow>'b::len) a) = trunc (LENGTH('b)) (word_to_lint a)"
  unfolding word_to_lint_def
  apply transfer'
  apply (auto simp: to_bl_ucast simp flip: to_bl_bin)
  apply (auto simp: bl_trunc_def)
  using diff_diff_cancel drop_bin2bl by presburger

lemma word_to_lint_scast_down[word_to_lint_convs]: "is_down SCAST('a \<rightarrow> 'b) \<Longrightarrow> word_to_lint (SCAST('a::len\<rightarrow>'b::len) a) = trunc (LENGTH('b)) (word_to_lint a)"
  unfolding word_to_lint_def
  apply transfer'
  apply (auto simp: to_bl_scast_down simp flip: to_bl_bin)
  apply (auto simp: bl_trunc_def)
  using diff_diff_cancel drop_bin2bl by presburger

(* TODO: Move *)
lemma zext_in_range: "\<lbrakk>w'\<noteq>0; w'\<le>w; 0\<le>a; a<2^w'\<rbrakk> \<Longrightarrow> zext w (lconst w' a) = lconst w a"
  apply transfer'
  apply (auto simp: bl_zext_def)
  by (metis bin_bl_bin bintrunc_mod2p bl_bin_bl_rep_drop diff_is_0_eq' diff_zero drop_bin2bl len_bin_to_bl mod_pos_pos_trivial)

lemma word_to_lint_ucast_up[word_to_lint_convs]:
  "is_up UCAST('a::len\<rightarrow>'b::len) \<Longrightarrow> word_to_lint (UCAST('a\<rightarrow>'b) a) = zext LENGTH ('b) (word_to_lint a)"
  unfolding word_to_lint_def
  by (simp add: zext_in_range is_up cast_simps)

lemma word_to_lint_scast_up[word_to_lint_convs]:
  "is_up SCAST('a::len\<rightarrow>'b::len) \<Longrightarrow> word_to_lint (SCAST('a\<rightarrow>'b) a) = sext LENGTH ('b) (word_to_lint a)"
  unfolding word_to_lint_def
  apply (simp add: is_up sint_eq uint_sint max_def)
  by (simp add: is_up sint_up_scast)

lemma word_to_lint_and_simp[word_to_lint_convs]: "word_to_lint (a AND b) = word_to_lint a lliAND word_to_lint b"
  apply (auto simp: uint_eq word_to_lint_def)
  apply (simp add: uint_and)
  done

lemma word_to_lint_or_simp[word_to_lint_convs]: "word_to_lint (a OR b) = word_to_lint a lliOR word_to_lint b"
  apply (auto simp: uint_eq word_to_lint_def)
  apply (simp add: uint_or)
  done

lemma word_to_lint_xor_simp[word_to_lint_convs]: "word_to_lint (a XOR b) = word_to_lint a lliXOR word_to_lint b"
  apply (auto simp: uint_eq word_to_lint_def)
  apply (simp add: uint_xor)
  done

(* TODO: Quite arbitrary lemmas! Sort them! *)

lemma from_bool_lint_conv: "(from_bool b :: 1 word) = lint_to_word (bool_to_lint b)"
  apply (cases b)
  apply (auto simp: from_bool_def bool_to_lint_def ltrue_def lfalse_def lint_to_word_def)
  done

lemma word_to_lint_to_uint_conv: "lint_to_uint (word_to_lint a) = uint a"
  by (auto simp: word_to_lint_def)

lemma word_to_lint_to_sint_conv: "lint_to_sint (word_to_lint a) = sint a"
  by (auto simp: word_to_lint_def sint_uint)

lemma word_to_lint_to_uint_0_iff: "(lint_to_uint (word_to_lint b) = 0) = (b = 0)"
  by (clarsimp simp: word_to_lint_to_uint_conv uint_0_iff)

lemma word_to_lint_to_sint_0_iff: "(lint_to_sint (word_to_lint (b::_::len word)) = 0) = (b = 0)"
  by (auto simp: word_to_lint_to_sint_conv)

lemma width_word_to_lint[simp]: "width (word_to_lint (w::'a::len word)) = LENGTH ('a)"
  by (auto simp: word_to_lint_def)

definition is_up' :: "('a::len word \<Rightarrow> 'b::len word) \<Rightarrow> bool"
  where "is_up' c \<longleftrightarrow> source_size c < target_size c"

definition is_down' :: "('a::len word \<Rightarrow> 'b::len word) \<Rightarrow> bool"
  where "is_down' c \<longleftrightarrow> target_size c < source_size c"

lemma is_down': "is_down' c \<longleftrightarrow> len_of TYPE('b) < len_of TYPE('a)"
  for c :: "'a::len word \<Rightarrow> 'b::len word"
  by (simp only: is_down'_def source_size target_size)

lemma is_up': "is_up' c \<longleftrightarrow> len_of TYPE('a) < len_of TYPE('b)"
  for c :: "'a::len word \<Rightarrow> 'b::len word"
  by (simp only: is_up'_def source_size target_size)

lemmas is_down'_imp[simp, intro] = is_down'[THEN iffD1]
lemmas is_up'_imp[simp, intro] = is_up'[THEN iffD1]

lemma is_down'_imp_down[simp, intro]: "is_down' c \<Longrightarrow> is_down c" by (auto simp: is_down is_down')
lemma is_up'_imp_up[simp, intro]: "is_up' c \<Longrightarrow> is_up c" by (auto simp: is_up is_up')

end