(* Title:      Containers/Extend_Partial_Order.thy
   Author:     Andreas Lochbihler, KIT *)

theory Extend_Partial_Order
imports Main
begin

section {* Every partial order can be extended to a total order *}

lemma ChainsD: "\<lbrakk> x \<in> C; C \<in> Chains r; y \<in> C \<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r"
by(simp add: Chains_def)

lemma Chains_Field: "\<lbrakk> C \<in> Chains r; x \<in> C \<rbrakk> \<Longrightarrow> x \<in> Field r"
by(auto simp add: Chains_def Field_def)

lemma total_onD:
  "\<lbrakk> total_on A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> x = y \<or> (y, x) \<in> r"
unfolding total_on_def by blast

lemma linear_order_imp_linorder: "linear_order {(A, B). leq A B} \<Longrightarrow> class.linorder leq (\<lambda>x y. leq x y \<and> \<not> leq y x)"
by(unfold_locales)(auto 4 4 simp add: linear_order_on_def partial_order_on_def preorder_on_def dest: refl_onD antisymD transD total_onD)

lemma (in linorder) linear_order: "linear_order {(A, B). A \<le> B}"
by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def total_on_def intro: refl_onI antisymI transI)

definition order_consistent :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
where "order_consistent r s \<longleftrightarrow> (\<forall>a a'. (a, a') \<in> r \<longrightarrow> (a', a) \<in> s \<longrightarrow> a = a')"

lemma order_consistent_sym:
  "order_consistent r s \<Longrightarrow> order_consistent s r"
by(auto simp add: order_consistent_def)

lemma refl_on_trancl:
  assumes "refl_on A r"
  shows "refl_on A (r^+)"
proof(rule refl_onI, safe del: conjI)
  fix a b
  assume "(a, b) \<in> r^+"
  thus "a \<in> A \<and> b \<in> A"
    by induct(blast intro: refl_onD1[OF assms] refl_onD2[OF assms])+
qed(blast dest: refl_onD[OF assms])

lemma total_on_refl_on_consistent_into:
  assumes r: "total_on A r" "refl_on A r"
  and consist: "order_consistent r s"
  and x: "x \<in> A" and y: "y \<in> A" and s: "(x, y) \<in> s"
  shows "(x, y) \<in> r"
proof(cases "x = y")
  case False
  with r x y have "(x, y) \<in> r \<or> (y, x) \<in> r" unfolding total_on_def by blast
  thus ?thesis
  proof
    assume "(y, x) \<in> r"
    with s consist have "x = y" unfolding order_consistent_def by blast
    with False show ?thesis by contradiction
  qed
qed(blast intro: refl_onD r x y)

lemma porder_linorder_tranclpE [consumes 5, case_names base step]:
  assumes r: "partial_order_on A r"
  and s: "linear_order_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B \<subseteq> A"
  and trancl: "(x, y) \<in> (r \<union> s)^+"
  obtains "(x, y) \<in> r"
        | u v where "(x, u) \<in> r" "(u, v) \<in> s" "(v, y) \<in> r"
proof(atomize_elim)
  from r have "refl_on A r" "trans r" by(simp_all add: partial_order_on_def preorder_on_def)
  from s have "refl_on B s" "total_on B s" "trans s"
    by(simp_all add: partial_order_on_def preorder_on_def linear_order_on_def)

  from trancl show "(x, y) \<in> r \<or> (\<exists>u v. (x, u) \<in> r \<and> (u, v) \<in> s \<and> (v, y) \<in> r)"
  proof(induction)
    case (base y)
    thus ?case
    proof
      assume "(x, y) \<in> s"
      with `refl_on B s` have "x \<in> B" "y \<in> B"
        by(blast dest: refl_onD1 refl_onD2)+
      with B_subset_A have "x \<in> A" "y \<in> A" by blast+
      hence "(x, x) \<in> r" "(y, y) \<in> r"
        using `refl_on A r` by(blast intro: refl_onD)+
      with `(x, y) \<in> s` show ?thesis by blast
    qed(simp)
  next
    case (step y z)
    from `(y, z) \<in> r \<union> s` show ?case
    proof
      assume "(y, z) \<in> s"
      with `refl_on B s` have "y \<in> B" "z \<in> B"
        by(blast dest: refl_onD2 refl_onD1)+
      from step.IH show ?thesis
      proof
        assume "(x, y) \<in> r"
        moreover from `z \<in> B` B_subset_A `refl_on A r`
        have "(z, z) \<in> r" by(blast dest: refl_onD)
        ultimately show ?thesis using `(y, z) \<in> s` by blast
      next
        assume "\<exists>u v. (x, u) \<in> r \<and> (u, v) \<in> s \<and> (v, y) \<in> r"
        then obtain u v where "(x, u) \<in> r" "(u, v) \<in> s" "(v, y) \<in> r" by blast
        from `refl_on B s` `(u, v) \<in> s` have "v \<in> B" by(rule refl_onD2)
        with `total_on B s` `refl_on B s` order_consistent_sym[OF consist]
        have "(v, y) \<in> s" using `y \<in> B` `(v, y) \<in> r`
          by(rule total_on_refl_on_consistent_into)
        with `trans s` have "(v, z) \<in> s" using `(y, z) \<in> s` by(rule transD)
        with `trans s` `(u, v) \<in> s` have "(u, z) \<in> s" by(rule transD)
        moreover from `z \<in> B` B_subset_A have "z \<in> A" ..
        with `refl_on A r` have "(z, z) \<in> r" by(rule refl_onD)
        ultimately show ?thesis using `(x, u) \<in> r` by blast
      qed
    next
      assume "(y, z) \<in> r"
      with step.IH show ?thesis
        by(blast intro: transD[OF `trans r`])
    qed
  qed
qed

lemma porder_on_consistent_linorder_on_trancl_antisym:
  assumes r: "partial_order_on A r"
  and s: "linear_order_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B \<subseteq> A"
  shows "antisym ((r \<union> s)^+)"
proof(rule antisymI)
  fix x y
  let ?rs = "(r \<union> s)^+"
  assume "(x, y) \<in> ?rs" "(y, x) \<in> ?rs"
  from r have "antisym r" "trans r" by(simp_all add: partial_order_on_def preorder_on_def)
  from s have "total_on B s" "refl_on B s" "trans s" "antisym s"
    by(simp_all add: partial_order_on_def preorder_on_def linear_order_on_def)

  from r s consist B_subset_A `(x, y) \<in> ?rs`
  show "x = y"
  proof(cases rule: porder_linorder_tranclpE)
    case base
    from r s consist B_subset_A `(y, x) \<in> ?rs`
    show ?thesis
    proof(cases rule: porder_linorder_tranclpE)
      case base
      with `antisym r` `(x, y) \<in> r` show ?thesis by(rule antisymD)
    next
      case (step u v)
      from `(v, x) \<in> r` `(x, y) \<in> r` `(y, u) \<in> r` have "(v, u) \<in> r"
        by(blast intro: transD[OF `trans r`])
      with consist have "v = u" using `(u, v) \<in> s`
        by(simp add: order_consistent_def)
      with `(y, u) \<in> r` `(v, x) \<in> r` have "(y, x) \<in> r"
        by(blast intro: transD[OF `trans r`])
      with `antisym r` `(x, y) \<in> r` show ?thesis by(rule antisymD)
    qed
  next
    case (step u v)
    from r s consist B_subset_A `(y, x) \<in> ?rs`
    show ?thesis
    proof(cases rule: porder_linorder_tranclpE)
      case base
      from `(v, y) \<in> r` `(y, x) \<in> r` `(x, u) \<in> r` have "(v, u) \<in> r"
        by(blast intro: transD[OF `trans r`])
      with consist `(u, v) \<in> s`
      have "u = v" by(auto simp add: order_consistent_def)
      with `(v, y) \<in> r` `(x, u) \<in> r` have "(x, y) \<in> r"
        by(blast intro: transD[OF `trans r`])
      with `antisym r` show ?thesis using `(y, x) \<in> r` by(rule antisymD)
    next
      case (step u' v')
      note r_into_s = total_on_refl_on_consistent_into[OF `total_on B s` `refl_on B s` order_consistent_sym[OF consist]]
      from `refl_on B s` `(u, v) \<in> s` `(u', v') \<in> s`
      have "u \<in> B" "v \<in> B" "u' \<in> B" "v' \<in> B" by(blast dest: refl_onD1 refl_onD2)+
      from `trans r` `(v', x) \<in> r` `(x, u) \<in> r` have "(v', u) \<in> r" by(rule transD)
      with `v' \<in> B` `u \<in> B` have "(v', u) \<in> s" by(rule r_into_s)
      also note `(u, v) \<in> s` also (transD[OF `trans s`])
      from `trans r` `(v, y) \<in> r` `(y, u') \<in> r` have "(v, u') \<in> r" by(rule transD)
      with `v \<in> B` `u' \<in> B` have "(v, u') \<in> s" by(rule r_into_s)
      finally (transD[OF `trans s`])
      have "v' = u'" using `(u', v') \<in> s` by(rule antisymD[OF `antisym s`])
      moreover with `(v, u') \<in> s` `(v', u) \<in> s` have "(v, u) \<in> s"
        by(blast intro: transD[OF `trans s`])
      with `antisym s` `(u, v) \<in> s` have "u = v" by(rule antisymD)
      ultimately have "(x, y) \<in> r" "(y, x) \<in> r"
        using `(x, u) \<in> r` `(v, y) \<in> r` `(y, u') \<in> r` `(v', x) \<in> r`
        by(blast intro: transD[OF `trans r`])+
      with `antisym r` show ?thesis by(rule antisymD)
    qed
  qed
qed

lemma porder_on_linorder_on_tranclp_porder_onI:
  assumes r: "partial_order_on A r"
  and s: "linear_order_on B s"
  and consist: "order_consistent r s"
  and subset: "B \<subseteq> A"
  shows "partial_order_on A ((r \<union> s)^+)"
  unfolding partial_order_on_def preorder_on_def
proof(intro conjI)
  let ?rs = "r \<union> s"
  from r have "refl_on A r" by(simp add: partial_order_on_def preorder_on_def)
  moreover from s have "refl_on B s"
    by(simp add: linear_order_on_def partial_order_on_def preorder_on_def)
  ultimately have "refl_on (A \<union> B) ?rs" by(rule refl_on_Un)
  also from subset have "A \<union> B = A" by blast
  finally show "refl_on A (?rs^+)" by(rule refl_on_trancl)

  show "trans (?rs^+)" by(rule trans_trancl)

  from r s consist subset show "antisym (?rs^+)"
    by(rule porder_on_consistent_linorder_on_trancl_antisym)
qed

lemma porder_extend_to_linorder:
  assumes r: "partial_order_on A r"
  obtains s where "linear_order_on A s" "order_consistent r s"
proof(atomize_elim)
  def S \<equiv> "{s. partial_order_on A s \<and> r \<subseteq> s}"
  from r have r_in_S: "r \<in> S" unfolding S_def by auto

  have "\<exists>y\<in>S. \<forall>x\<in>S. y \<subseteq> x \<longrightarrow> x = y"
  proof(rule Zorn_Lemma2[rule_format])
    fix c
    assume "c \<in> chains S"
    hence "c \<subseteq> S" by(rule chainsD2)

    show "\<exists>y\<in>S. \<forall>x\<in>c. x \<subseteq> y"
    proof(cases "c = {}")
      case True
      with r_in_S show ?thesis by blast
    next
      case False
      then obtain s where "s \<in> c" by blast
      hence s: "partial_order_on A s"
        and r_in_s: "r \<subseteq> s"
        using `c \<subseteq> S` unfolding S_def by blast+

      have "partial_order_on A (\<Union>c)"
        unfolding partial_order_on_def preorder_on_def
      proof(intro conjI)
        show "refl_on A (\<Union>c)"
        proof(rule refl_onI[OF subsetI])
          fix x
          assume "x \<in> \<Union>c"
          then obtain X where "X \<in> c" and "x \<in> X" by blast
          from `X \<in> c` `c \<subseteq> S` have "X \<in> S" ..
          hence "partial_order_on A X" unfolding S_def by simp
          with `x \<in> X` show "x \<in> A \<times> A"
            by(cases x)(auto simp add: partial_order_on_def preorder_on_def dest: refl_onD1 refl_onD2)
        next
          fix x
          assume "x \<in> A"
          with s have "(x, x) \<in> s" unfolding partial_order_on_def preorder_on_def
            by(blast dest: refl_onD)
          with `s \<in> c` show "(x, x) \<in> \<Union>c" by(rule UnionI)
        qed

        show "antisym (\<Union>c)"
        proof(rule antisymI)
          fix x y
          assume "(x, y) \<in> \<Union>c" "(y, x) \<in> \<Union>c"
          then obtain X Y where "X \<in> c" "Y \<in> c" "(x, y) \<in> X" "(y, x) \<in> Y" by blast
          from `X \<in> c` `Y \<in> c` `c \<subseteq> S` have "antisym X" "antisym Y"
            unfolding S_def by(auto simp add: partial_order_on_def)
          moreover from `c \<in> chains S` `X \<in> c` `Y \<in> c`
          have "X \<subseteq> Y \<or> Y \<subseteq> X" by(rule chainsD)
          ultimately show "x = y" using `(x, y) \<in> X` `(y, x) \<in> Y`
            by(auto dest: antisymD)
        qed

        show "trans (\<Union>c)"
        proof(rule transI)
          fix x y z
          assume "(x, y) \<in> \<Union>c" "(y, z) \<in> \<Union>c"
          then obtain X Y where "X \<in> c" "Y \<in> c" "(x, y) \<in> X" "(y, z) \<in> Y" by blast
          from `X \<in> c` `Y \<in> c` `c \<subseteq> S` have "trans X" "trans Y"
            unfolding S_def by(auto simp add: partial_order_on_def preorder_on_def)
          from `c \<in> chains S` `X \<in> c` `Y \<in> c`
          have "X \<subseteq> Y \<or> Y \<subseteq> X" by(rule chainsD)
          thus "(x, z) \<in> \<Union>c"
          proof
            assume "X \<subseteq> Y"
            with `trans Y` `(x, y) \<in> X` `(y, z) \<in> Y`
            have "(x, z) \<in> Y" by(blast dest: transD)
            with `Y \<in> c` show ?thesis by(rule UnionI)
          next
            assume "Y \<subseteq> X"
            with `trans X` `(x, y) \<in> X` `(y, z) \<in> Y`
            have "(x, z) \<in> X" by(blast dest: transD)
            with `X \<in> c` show ?thesis by(rule UnionI)
          qed
        qed
      qed
      moreover
      have "r \<subseteq> \<Union>c" using r_in_s `s \<in> c` by blast
      ultimately have "\<Union>c \<in> S" unfolding S_def by simp
      thus ?thesis by blast
    qed
  qed
  then obtain s where "s \<in> S" and y_max: "\<And>t. \<lbrakk> t \<in> S; s \<subseteq> t \<rbrakk> \<Longrightarrow> s = t" by blast

  have "partial_order_on A s" using `s \<in> S`
    unfolding S_def by simp
  moreover
  have r_in_s: "r \<subseteq> s" using `s \<in> S` unfolding S_def by blast

  have "total_on A s"
    unfolding total_on_def
  proof(intro strip)
    fix x y
    assume "x \<in> A" "y \<in> A" "x \<noteq> y"
    show "(x, y) \<in> s \<or> (y, x) \<in> s"
    proof(rule ccontr)
      assume "\<not> ?thesis"
      hence xy: "(x, y) \<notin> s" "(y, x) \<notin> s" by simp_all

      def s' \<equiv> "{(a, b). a = x \<and> (b = y \<or> b = x) \<or> a = y \<and> b = y}"
      let ?s' = "(s \<union> s')^+"
      note `partial_order_on A s`
      moreover have "linear_order_on {x, y} s'" unfolding s'_def
        by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def total_on_def intro: refl_onI transI antisymI)
      moreover have "order_consistent s s'"
        unfolding s'_def using xy unfolding order_consistent_def by blast
      moreover have "{x, y} \<subseteq> A" using `x \<in> A` `y \<in> A` by blast
      ultimately have "partial_order_on A ?s'"
        by(rule porder_on_linorder_on_tranclp_porder_onI)
      moreover have "r \<subseteq> ?s'" using r_in_s by auto
      ultimately have "?s' \<in> S" unfolding S_def by simp
      moreover have "s \<subseteq> ?s'" by auto
      ultimately have "s = ?s'" by(rule y_max)
      moreover have "(x, y) \<in> ?s'" by(auto simp add: s'_def)
      ultimately show False using `(x, y) \<notin> s` by simp
    qed
  qed
  ultimately have "linear_order_on A s" by(simp add: linear_order_on_def)
  moreover have "order_consistent r s" unfolding order_consistent_def
  proof(intro strip)
    fix a a'
    assume "(a, a') \<in> r" "(a', a) \<in> s"
    from `(a, a') \<in> r` have "(a, a') \<in> s" using r_in_s by blast
    with `partial_order_on A s` `(a', a) \<in> s`
    show "a = a'" unfolding partial_order_on_def by(blast dest: antisymD)
  qed
  ultimately show "\<exists>s. linear_order_on A s \<and> order_consistent r s" by blast
qed

end


(*  Title:      Uint16.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Unsigned words of 16 bits\<close>

theory Uint16 imports
  Code_Target_Word_Base
begin

text \<open>
  Restriction for ML code generation:
  This theory assumes that the ML system provides a Word16
  implementation (mlton does, but PolyML 5.5 does not).
  Therefore, the code setup lives in the target \<open>SML_word\<close>
  rather than \<open>SML\<close>.  This ensures that code generation still
  works as long as \<open>uint16\<close> is not involved.
  For the target \<open>SML\<close> itself, no special code generation
  for this type is set up. Nevertheless, it should work by emulation via @{typ "16 word"}
  if the theory \<open>Code_Target_Bits_Int\<close> is imported.

  Restriction for OCaml code generation:
  OCaml does not provide an int16 type, so no special code generation
  for this type is set up.
\<close>

declare prod.Quotient[transfer_rule]

section \<open>Type definition and primitive operations\<close>

typedef uint16 = "UNIV :: 16 word set" ..

setup_lifting type_definition_uint16

text \<open>Use an abstract type for code generation to disable pattern matching on @{term Abs_uint16}.\<close>
declare Rep_uint16_inverse[code abstype]

declare Quotient_uint16[transfer_rule]

instantiation uint16 :: comm_ring_1
begin
lift_definition zero_uint16 :: uint16 is "0 :: 16 word" .
lift_definition one_uint16 :: uint16 is "1" .
lift_definition plus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(+) :: 16 word \<Rightarrow> _" .
lift_definition minus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(-)" .
lift_definition uminus_uint16 :: "uint16 \<Rightarrow> uint16" is uminus .
lift_definition times_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(*)" .
instance by (standard; transfer) (simp_all add: algebra_simps)
end

instantiation uint16 :: semiring_modulo
begin
lift_definition divide_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(div)" .
lift_definition modulo_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(mod)" .
instance by (standard; transfer) (fact word_mod_div_equality)
end

instantiation uint16 :: linorder begin
lift_definition less_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "(\<le>)" .
instance by (standard; transfer) (simp_all add: less_le_not_le linear)
end

lemmas [code] = less_uint16.rep_eq less_eq_uint16.rep_eq

context
  includes lifting_syntax
  notes
    transfer_rule_of_bool [transfer_rule]
    transfer_rule_numeral [transfer_rule]
begin

lemma transfer_rule_numeral_uint [transfer_rule]:
  "((=) ===> cr_uint16) numeral numeral"
  by transfer_prover

lemma [transfer_rule]:
  \<open>(cr_uint16 ===> (\<longleftrightarrow>)) even ((dvd) 2 :: uint16 \<Rightarrow> bool)\<close>
  by (unfold dvd_def) transfer_prover

end

instantiation uint16 :: semiring_bits
begin

lift_definition bit_uint16 :: \<open>uint16 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .

instance
  by (standard; transfer)
    (fact bit_iff_odd even_iff_mod_2_eq_zero odd_iff_mod_2_eq_one odd_one bits_induct
       bits_div_0 bits_div_by_1 bits_mod_div_trivial even_succ_div_2
       even_mask_div_iff exp_div_exp_eq div_exp_eq mod_exp_eq mult_exp_mod_exp_eq
       div_exp_mod_exp_eq even_mult_exp_div_exp_iff)+

end

instantiation uint16 :: semiring_bit_shifts
begin
lift_definition push_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is push_bit .
lift_definition drop_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is drop_bit .
lift_definition take_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is take_bit .
instance by (standard; transfer)
  (fact push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod)+
end

instantiation uint16 :: ring_bit_operations
begin
lift_definition not_uint16 :: \<open>uint16 \<Rightarrow> uint16\<close> is NOT .
lift_definition and_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(AND)\<close> .
lift_definition or_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(OR)\<close> .
lift_definition xor_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(XOR)\<close> .
lift_definition mask_uint16 :: \<open>nat \<Rightarrow> uint16\<close> is mask .
lift_definition set_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.set_bit\<close> .
lift_definition unset_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>unset_bit\<close> .
lift_definition flip_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>flip_bit\<close> .
instance by (standard; transfer)
  (simp_all add: bit_simps mask_eq_decr_exp minus_eq_not_minus_1 set_bit_def flip_bit_def)
end

lemma [code]:
  \<open>mask (Suc n) = push_bit n (1 :: uint16) OR mask n\<close>
  \<open>mask 0 = (0 :: uint16)\<close>
  by (simp_all add: mask_Suc_exp push_bit_of_1)

lemma [code]:
  \<open>Bit_Operations.set_bit n w = w OR push_bit n 1\<close> for w :: uint16
  by (fact set_bit_eq_or)

lemma [code]:
  \<open>unset_bit n w = w AND NOT (push_bit n 1)\<close> for w :: uint16
  by (fact unset_bit_eq_and_not)

lemma [code]:
  \<open>flip_bit n w = w XOR push_bit n 1\<close> for w :: uint16
  by (fact flip_bit_eq_xor)

instantiation uint16 :: lsb
begin
lift_definition lsb_uint16 :: \<open>uint16 \<Rightarrow> bool\<close> is lsb .
instance by (standard; transfer)
  (fact lsb_odd)
end

instantiation uint16 :: msb
begin
lift_definition msb_uint16 :: \<open>uint16 \<Rightarrow> bool\<close> is msb .
instance ..
end

setup \<open>Context.theory_map (Name_Space.map_naming (Name_Space.qualified_path true \<^binding>\<open>Generic\<close>))\<close>

instantiation uint16 :: set_bit
begin
lift_definition set_bit_uint16 :: \<open>uint16 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint16\<close> is set_bit .
instance
  apply standard
  apply transfer
  apply (simp add: bit_simps)
  done
end

setup \<open>Context.theory_map (Name_Space.map_naming (Name_Space.parent_path))\<close>

instantiation uint16 :: bit_comprehension begin
lift_definition set_bits_uint16 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16" is "set_bits" .
instance by (standard; transfer) (fact set_bits_bit_eq)
end

lemmas [code] = bit_uint16.rep_eq lsb_uint16.rep_eq msb_uint16.rep_eq

instantiation uint16 :: equal begin
lift_definition equal_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint16.rep_eq

instantiation uint16 :: size begin
lift_definition size_uint16 :: "uint16 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint16.rep_eq

lift_definition sshiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" (infixl ">>>" 55) is \<open>\<lambda>w n. signed_drop_bit n w\<close> .

lift_definition uint16_of_int :: "int \<Rightarrow> uint16" is "word_of_int" .

definition uint16_of_nat :: "nat \<Rightarrow> uint16"
where "uint16_of_nat = uint16_of_int \<circ> int"

lift_definition int_of_uint16 :: "uint16 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint16 :: "uint16 \<Rightarrow> nat" is "unat" .

definition integer_of_uint16 :: "uint16 \<Rightarrow> integer"
where "integer_of_uint16 = integer_of_int o int_of_uint16"

text \<open>Use pretty numerals from integer for pretty printing\<close>

context includes integer.lifting begin

lift_definition Uint16 :: "integer \<Rightarrow> uint16" is "word_of_int" .

lemma Rep_uint16_numeral [simp]: "Rep_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def Abs_uint16_inverse numeral.simps plus_uint16_def)

lemma Rep_uint16_neg_numeral [simp]: "Rep_uint16 (- numeral n) = - numeral n"
by(simp only: uminus_uint16_def)(simp add: Abs_uint16_inverse)

lemma numeral_uint16_transfer [transfer_rule]:
  "(rel_fun (=) cr_uint16) numeral numeral"
by(auto simp add: cr_uint16_def)

lemma numeral_uint16 [code_unfold]: "numeral n = Uint16 (numeral n)"
by transfer simp

lemma neg_numeral_uint16 [code_unfold]: "- numeral n = Uint16 (- numeral n)"
by transfer(simp add: cr_uint16_def)

end

lemma Abs_uint16_numeral [code_post]: "Abs_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def numeral.simps plus_uint16_def Abs_uint16_inverse)

lemma Abs_uint16_0 [code_post]: "Abs_uint16 0 = 0"
by(simp add: zero_uint16_def)

lemma Abs_uint16_1 [code_post]: "Abs_uint16 1 = 1"
by(simp add: one_uint16_def)

section \<open>Code setup\<close>

code_printing code_module Uint16 \<rightharpoonup> (SML_word)
\<open>(* Test that words can handle numbers between 0 and 15 *)
val _ = if 4 <= Word.wordSize then () else raise (Fail ("wordSize less than 4"));

structure Uint16 : sig
  val set_bit : Word16.word -> IntInf.int -> bool -> Word16.word
  val shiftl : Word16.word -> IntInf.int -> Word16.word
  val shiftr : Word16.word -> IntInf.int -> Word16.word
  val shiftr_signed : Word16.word -> IntInf.int -> Word16.word
  val test_bit : Word16.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word16.orb (x, mask)
     else Word16.andb (x, Word16.notb mask)
  end

fun shiftl x n =
  Word16.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word16.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word16.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word16.andb (x, Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word16.fromInt 0

end; (* struct Uint16 *)\<close>
code_reserved SML_word Uint16

code_printing code_module Uint16 \<rightharpoonup> (Haskell)
 \<open>module Uint16(Int16, Word16) where

  import Data.Int(Int16)
  import Data.Word(Word16)\<close>
code_reserved Haskell Uint16

text \<open>Scala provides unsigned 16-bit numbers as Char.\<close>

code_printing code_module Uint16 \<rightharpoonup> (Scala)
\<open>object Uint16 {

def set_bit(x: scala.Char, n: BigInt, b: Boolean) : scala.Char =
  if (b)
    (x | (1.toChar << n.intValue)).toChar
  else
    (x & (1.toChar << n.intValue).unary_~).toChar

def shiftl(x: scala.Char, n: BigInt) : scala.Char = (x << n.intValue).toChar

def shiftr(x: scala.Char, n: BigInt) : scala.Char = (x >>> n.intValue).toChar

def shiftr_signed(x: scala.Char, n: BigInt) : scala.Char = (x.toShort >> n.intValue).toChar

def test_bit(x: scala.Char, n: BigInt) : Boolean = (x & (1.toChar << n.intValue)) != 0

} /* object Uint16 */\<close>
code_reserved Scala Uint16

text \<open>
  Avoid @{term Abs_uint16} in generated code, use @{term Rep_uint16'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint16}.

  The new destructor @{term Rep_uint16'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint16} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint16}
  ([code abstract] equations for @{typ uint16} may use @{term Rep_uint16} because
  these instances will be folded away.)

  To convert @{typ "16 word"} values into @{typ uint16}, use @{term "Abs_uint16'"}.
\<close>

definition Rep_uint16' where [simp]: "Rep_uint16' = Rep_uint16"

lemma Rep_uint16'_transfer [transfer_rule]:
  "rel_fun cr_uint16 (=) (\<lambda>x. x) Rep_uint16'"
unfolding Rep_uint16'_def by(rule uint16.rep_transfer)

lift_definition Abs_uint16' :: "16 word \<Rightarrow> uint16" is "\<lambda>x :: 16 word. x" .

lemma Abs_uint16'_code [code]:
  "Abs_uint16' x = Uint16 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint16 \<Rightarrow> _"]]

lemma term_of_uint16_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint16.uint16.Abs_uint16'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]], TR (STR ''Uint16.uint16'') []]))
       (term_of_class.term_of (Rep_uint16' x))"
by(simp add: term_of_anything)

lemma Uin16_code [code abstract]: "Rep_uint16 (Uint16 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint16_def int_of_integer_symbolic_def by(simp add: Abs_uint16_inverse)

code_printing
  type_constructor uint16 \<rightharpoonup>
  (SML_word) "Word16.word" and
  (Haskell) "Uint16.Word16" and
  (Scala) "scala.Char"
| constant Uint16 \<rightharpoonup>
  (SML_word) "Word16.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint16.Word16)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Word16)" and
  (Scala) "_.charValue"
| constant "0 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 0)" and
  (Haskell) "(0 :: Uint16.Word16)" and
  (Scala) "0"
| constant "1 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 1)" and
  (Haskell) "(1 :: Uint16.Word16)" and
  (Scala) "1"
| constant "plus :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toChar"
| constant "uminus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toChar"
| constant "minus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toChar"
| constant "times :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toChar"
| constant "HOL.equal :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "!((_ : Word16.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint16 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) infixl 4 "<="
| constant "less :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) infixl 4 "<"
| constant "NOT :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toChar"
| constant "(AND) :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toChar"
| constant "(OR) :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toChar"
| constant "(XOR) :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toChar"

definition uint16_div :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_div x y = (if y = 0 then undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x div y)"

definition uint16_mod :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_mod x y = (if y = 0 then undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x mod y)"

context includes undefined_transfer begin

lemma div_uint16_code [code]: "x div y = (if y = 0 then 0 else uint16_div x y)"
unfolding uint16_div_def by transfer (simp add: word_div_def)

lemma mod_uint16_code [code]: "x mod y = (if y = 0 then x else uint16_mod x y)"
unfolding uint16_mod_def by transfer (simp add: word_mod_def)

lemma uint16_div_code [code abstract]:
  "Rep_uint16 (uint16_div x y) =
  (if y = 0 then Rep_uint16 (undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x div Rep_uint16 y)"
unfolding uint16_div_def by transfer simp

lemma uint16_mod_code [code abstract]:
  "Rep_uint16 (uint16_mod x y) =
  (if y = 0 then Rep_uint16 (undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x mod Rep_uint16 y)"
unfolding uint16_mod_def by transfer simp

end

code_printing constant uint16_div \<rightharpoonup>
  (SML_word) "Word16.div ((_), (_))" and
  (Haskell) "Prelude.div" and
  (Scala) "(_ '/ _).toChar"
| constant uint16_mod \<rightharpoonup>
  (SML_word) "Word16.mod ((_), (_))" and
  (Haskell) "Prelude.mod" and
  (Scala) "(_ % _).toChar"

definition uint16_test_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint16_test_bit x n =
  (if n < 0 \<or> 15 < n then undefined (bit :: uint16 \<Rightarrow> _) x n
   else bit x (nat_of_integer n))"

lemma test_bit_uint16_code [code]:
  "bit x n \<longleftrightarrow> n < 16 \<and> uint16_test_bit x (integer_of_nat n)"
  including undefined_transfer integer.lifting unfolding uint16_test_bit_def
  by (transfer, simp, transfer, simp)

lemma uint16_test_bit_code [code]:
  "uint16_test_bit w n =
  (if n < 0 \<or> 15 < n then undefined (bit :: uint16 \<Rightarrow> _) w n else bit (Rep_uint16 w) (nat_of_integer n))"
  unfolding uint16_test_bit_def by (simp add: bit_uint16.rep_eq)

code_printing constant uint16_test_bit \<rightharpoonup>
  (SML_word) "Uint16.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint16.test'_bit"

definition uint16_set_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint16"
where [code del]:
  "uint16_set_bit x n b =
  (if n < 0 \<or> 15 < n then undefined (set_bit :: uint16 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint16_code [code]:
  "set_bit x n b = (if n < 16 then uint16_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint16_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint16_set_bit_code [code abstract]:
  "Rep_uint16 (uint16_set_bit w n b) =
  (if n < 0 \<or> 15 < n then Rep_uint16 (undefined (set_bit :: uint16 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint16 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint16_set_bit_def by transfer simp

code_printing constant uint16_set_bit \<rightharpoonup>
  (SML_word) "Uint16.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint16.set'_bit"

lift_definition uint16_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16 \<Rightarrow> nat \<Rightarrow> uint16" is set_bits_aux .

lemma uint16_set_bits_code [code]:
  "uint16_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint16_set_bits f ((push_bit 1 w) OR (if f n' then 1 else 0)) n')"
  apply (transfer fixing: n)
  apply (cases n)
   apply simp_all
  done

lemma set_bits_uint16 [code]:
  "(BITS n. f n) = uint16_set_bits f 0 16"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint16 shows "lsb x \<longleftrightarrow> bit x 0"
  by transfer (simp add: lsb_odd)

definition uint16_shiftl :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftl x n = (if n < 0 \<or> 16 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

lemma shiftl_uint16_code [code]: "push_bit n x = (if n < 16 then uint16_shiftl x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint16_shiftl_def
  by transfer simp

lemma uint16_shiftl_code [code abstract]:
  "Rep_uint16 (uint16_shiftl w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (push_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) w n)
   else push_bit (nat_of_integer n) (Rep_uint16 w))"
  including undefined_transfer unfolding uint16_shiftl_def
  by transfer simp

code_printing constant uint16_shiftl \<rightharpoonup>
  (SML_word) "Uint16.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint16.shiftl"

definition uint16_shiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftr x n = (if n < 0 \<or> 16 \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

lemma shiftr_uint16_code [code]: "drop_bit n x = (if n < 16 then uint16_shiftr x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint16_shiftr_def
  by transfer simp

lemma uint16_shiftr_code [code abstract]:
  "Rep_uint16 (uint16_shiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (drop_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) w n)
   else drop_bit (nat_of_integer n) (Rep_uint16 w))"
including undefined_transfer unfolding uint16_shiftr_def by transfer simp

code_printing constant uint16_shiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint16.shiftr"

definition uint16_sshiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_sshiftr x n =
  (if n < 0 \<or> 16 \<le> n then undefined sshiftr_uint16 x n else sshiftr_uint16 x (nat_of_integer n))"

lemma sshiftr_uint16_code [code]:
  "x >>> n =
  (if n < 16 then uint16_sshiftr x (integer_of_nat n) else if bit x 15 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint16_sshiftr_def
by transfer (simp add: not_less signed_drop_bit_beyond word_size)

lemma uint16_sshiftr_code [code abstract]:
  "Rep_uint16 (uint16_sshiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined sshiftr_uint16 w n)
   else signed_drop_bit (nat_of_integer n) (Rep_uint16 w))"
including undefined_transfer unfolding uint16_sshiftr_def by transfer simp

code_printing constant uint16_sshiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Int16) _)) :: Uint16.Word16)" and
  (Scala) "Uint16.shiftr'_signed"

lemma uint16_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint16) 15"
  by transfer (simp add: msb_word_iff_bit)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint16_test_bit x 15"
  by (simp add: uint16_test_bit_def uint16_msb_test_bit)

lemma uint16_of_int_code [code]: "uint16_of_int i = Uint16 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint16_code [code]:
  "int_of_uint16 x = int_of_integer (integer_of_uint16 x)"
by(simp add: integer_of_uint16_def)

lemma nat_of_uint16_code [code]:
  "nat_of_uint16 x = nat_of_integer (integer_of_uint16 x)"
unfolding integer_of_uint16_def including integer.lifting by transfer simp

lemma integer_of_uint16_code [code]:
  "integer_of_uint16 n = integer_of_int (uint (Rep_uint16' n))"
unfolding integer_of_uint16_def by transfer auto

code_printing
  constant "integer_of_uint16" \<rightharpoonup>
  (SML_word) "Word16.toInt _ : IntInf.int" and
  (Haskell) "Prelude.toInteger" and
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint16_of_natural :: "natural \<Rightarrow> uint16"
where "uint16_of_natural x \<equiv> Uint16 (integer_of_natural x)"

instantiation uint16 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint16 \<equiv> qc_random_cnv uint16_of_natural"
definition "exhaustive_uint16 \<equiv> qc_exhaustive_cnv uint16_of_natural"
definition "full_exhaustive_uint16 \<equiv> qc_full_exhaustive_cnv uint16_of_natural"
instance ..
end

instantiation uint16 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint16 i in (x, 0xFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint16.uint16'') []" .

definition "narrowing_uint16 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint16 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint16 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint16 (infixl ">>>" 55)

end


subsection \<open>Contrived side conditions\<close>

theory Test_Side_Conditions
imports Dict_Construction
begin

ML \<open>
fun assert_alt_total ctxt term = @{assert} (Side_Conditions.is_total ctxt term)
\<close>

fun head where
"head (x # _) = x"

local_setup \<open>snd o Side_Conditions.mk_side @{thms head.simps} NONE\<close>

lemma head_side_eq: "head_side xs \<longleftrightarrow> xs \<noteq> []"
by (cases xs) (auto intro: head_side.intros elim: head_side.cases)

declaration \<open>K (Side_Conditions.set_alt @{term head} @{thm head_side_eq})\<close>

fun map where
"map f [] = []" |
"map f (x # xs) = f x # map f xs"

local_setup \<open>snd o Side_Conditions.mk_side @{thms map.simps} (SOME @{thms map.induct})\<close>
thm map_side.intros

ML \<open>assert_alt_total @{context} @{term map}\<close>

experiment begin

  text \<open>Functions that use partial functions always in their domain are processed correctly.\<close>

  fun tail where
  "tail (_ # xs) = xs"

  local_setup \<open>snd o Side_Conditions.mk_side @{thms tail.simps} NONE\<close>

  lemma tail_side_eq: "tail_side xs \<longleftrightarrow> xs \<noteq> []"
  by (cases xs) (auto intro: tail_side.intros elim: tail_side.cases)

  declaration \<open>K (Side_Conditions.set_alt @{term tail} @{thm tail_side_eq})\<close>

  function map' where
  "map' f xs = (if xs = [] then [] else f (head xs) # map' f (tail xs))"
  by auto

  termination
    apply (relation "measure (size \<circ> snd)")
    apply rule
    subgoal for f xs by (cases xs) auto
    done

  local_setup \<open>snd o Side_Conditions.mk_side @{thms map'.simps} (SOME @{thms map'.induct})\<close>
  thm map'_side.intros

  ML \<open>assert_alt_total @{context} @{term map'}\<close>

end

lemma map_cong:
  assumes "xs = ys" "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "map f xs = map g ys"
unfolding assms(1)
using assms(2)
by (induction ys) auto

definition map_head where
"map_head xs = map head xs"

experiment begin

  declare map_cong[fundef_cong]

  local_setup \<open>snd o Side_Conditions.mk_side @{thms map_head_def} NONE\<close>
  thm map_head_side.intros

  lemma "map_head_side xs \<longleftrightarrow> (\<forall>x \<in> set xs. x \<noteq> [])"
  by (auto intro: map_head_side.intros elim: map_head_side.cases)

  definition map_head' where
  "map_head' xss = map (map head) xss"

  local_setup \<open>snd o Side_Conditions.mk_side @{thms map_head'_def} NONE\<close>
  thm map_head'_side.intros

  lemma "map_head'_side xss \<longleftrightarrow> (\<forall>xs \<in> set xss. \<forall>x \<in> set xs. x \<noteq> [])"
  by (auto intro: map_head'_side.intros elim: map_head'_side.cases)

end

experiment begin

  local_setup \<open>snd o Side_Conditions.mk_side @{thms map_head_def} NONE\<close>
  term map_head_side
  thm map_head_side.intros

  lemma "\<not> map_head_side xs"
  by (auto elim: map_head_side.cases)

end

definition head_known where
"head_known xs = head (3 # xs)"

local_setup \<open>snd o Side_Conditions.mk_side @{thms head_known_def} NONE\<close>
thm head_known_side.intros

ML\<open>assert_alt_total @{context} @{term head_known}\<close>

fun odd :: "nat \<Rightarrow> bool" and even where
"odd 0 \<longleftrightarrow> False" |
"even 0 \<longleftrightarrow> True" |
"odd (Suc n) \<longleftrightarrow> even n" |
"even (Suc n) \<longleftrightarrow> odd n"

local_setup \<open>snd o Side_Conditions.mk_side @{thms odd.simps even.simps} (SOME @{thms odd_even.induct})\<close>
thm odd_side_even_side.intros

ML\<open>assert_alt_total @{context} @{term odd}\<close>
ML\<open>assert_alt_total @{context} @{term even}\<close>

definition odd_known where
"odd_known = odd (Suc 0)"

local_setup \<open>snd o Side_Conditions.mk_side @{thms odd_known_def} NONE\<close>
thm odd_known_side.intros

ML\<open>assert_alt_total @{context} @{term odd_known}\<close>

end