section \<open>Nameful WS1S Formulas\<close>

(*<*)
theory WS1S_Nameful
imports WS1S_Formula
begin
(*>*)

declare [[coercion "of_char :: char \<Rightarrow> nat", coercion_enabled]]

definition is_upper :: "char \<Rightarrow> bool" where [simp]: "is_upper c = (c \<in> {65..90 :: nat})"
definition is_lower :: "char \<Rightarrow> bool" where [simp]: "is_lower c = (c \<in> {97..122 :: nat})"

(*nonempty string starting with lower case*)
typedef fo = "{s. s \<noteq> [] \<and> is_lower (hd s)}" by (auto intro!: exI[of _ "''x''"])
(*nonempty string starting with upper case*)
typedef so = "{s. s \<noteq> [] \<and> is_upper (hd s)}" by (auto intro!: exI[of _ "''X''"])

datatype ws1s =
    T | F | Or ws1s ws1s | And ws1s ws1s | Not ws1s
  | Ex1 fo ws1s | Ex2 so ws1s | All1 fo ws1s | All2 so ws1s
  | Lt fo fo
  | In fo so
  | Eq_Const fo nat
  | Eq_Presb so nat
  | Eq_FO fo fo
  | Eq_FO_Offset fo fo nat
  | Eq_SO so so
  | Eq_SO_Inc so so
  | Eq_Max fo so
  | Eq_Min fo so
  | Empty so
  | Singleton so
  | Subset so so
  | Disjoint so so
  | Eq_Union so so so
  | Eq_Inter so so so
  | Eq_Diff so so so

(*standard WS1S semantics, finiteness captured by the type fset*)
primrec satisfies :: "(fo \<Rightarrow> nat) \<Rightarrow> (so \<Rightarrow> nat fset) \<Rightarrow> ws1s \<Rightarrow> bool" where
  "satisfies I1 I2 T = True"
| "satisfies I1 I2 F = False"
| "satisfies I1 I2 (Or \<phi> \<psi>) = (satisfies I1 I2 \<phi> \<or> satisfies I1 I2 \<psi>)"
| "satisfies I1 I2 (And \<phi> \<psi>) = (satisfies I1 I2 \<phi> \<and> satisfies I1 I2 \<psi>)"
| "satisfies I1 I2 (Not \<phi>) = (\<not> satisfies I1 I2 \<phi>)"
| "satisfies I1 I2 (Ex1 x \<phi>) = (\<exists>n. satisfies (I1(x := n)) I2 \<phi>)"
| "satisfies I1 I2 (Ex2 X \<phi>) = (\<exists>N. satisfies I1 (I2(X := N)) \<phi>)"
| "satisfies I1 I2 (All1 x \<phi>) = (\<forall>n. satisfies (I1(x := n)) I2 \<phi>)"
| "satisfies I1 I2 (All2 X \<phi>) = (\<forall>N. satisfies I1 (I2(X := N)) \<phi>)"

| "satisfies I1 I2 (Lt x y) = (I1 x < I1 y)"
| "satisfies I1 I2 (In x X) = (I1 x |\<in>| I2 X)"
| "satisfies I1 I2 (Eq_Const x n) = (I1 x = n)"
| "satisfies I1 I2 (Eq_Presb X n) = ((\<Sum>x \<in> fset (I2 X). 2 ^ x) = n)"
| "satisfies I1 I2 (Eq_FO x y) = (I1 x = I1 y)"
| "satisfies I1 I2 (Eq_FO_Offset x y n) = (I1 x = I1 y + n)"
| "satisfies I1 I2 (Eq_SO X Y) = (I2 X = I2 Y)"
| "satisfies I1 I2 (Eq_SO_Inc X Y) = (I2 X = Suc |`| I2 Y)"
| "satisfies I1 I2 (Eq_Max x X) = (let Z = I2 X in Z \<noteq> {||} \<and> I1 x = fMax Z)"
| "satisfies I1 I2 (Eq_Min x X) = (let Z = I2 X in Z \<noteq> {||} \<and> I1 x = fMin Z)"
| "satisfies I1 I2 (Empty X) = (I2 X = {||})"
| "satisfies I1 I2 (Singleton X) = (\<exists>x. I2 X = {|x|})"
| "satisfies I1 I2 (Subset X Y) = (I2 X |\<subseteq>| I2 Y)"
| "satisfies I1 I2 (Disjoint X Y) = (I2 X |\<inter>| I2 Y = {||})"
| "satisfies I1 I2 (Eq_Union X Y Z) = (I2 X = I2 Y |\<union>| I2 Z)"
| "satisfies I1 I2 (Eq_Inter X Y Z) = (I2 X = I2 Y |\<inter>| I2 Z)"
| "satisfies I1 I2 (Eq_Diff X Y Z) = (I2 X = I2 Y |-| I2 Z)"

primrec fos where
  "fos T = []"
| "fos F = []"
| "fos (Or \<phi> \<psi>) = List.union (fos \<phi>) (fos \<psi>)"
| "fos (And \<phi> \<psi>) = List.union (fos \<phi>) (fos \<psi>)"
| "fos (Not \<phi>) = fos \<phi>"
| "fos (Ex1 x \<phi>) = List.remove1 x (fos \<phi>)"
| "fos (Ex2 X \<phi>) = fos \<phi>"
| "fos (All1 x \<phi>) = List.remove1 x (fos \<phi>)"
| "fos (All2 X \<phi>) = fos \<phi>"
| "fos (Lt x y) = remdups [x, y]"
| "fos (In x X) = [x]"
| "fos (Eq_Const x n) = [x]"
| "fos (Eq_Presb X n) = []"
| "fos (Eq_FO x y) = remdups [x, y]"
| "fos (Eq_FO_Offset x y n) = remdups [x, y]"
| "fos (Eq_SO X Y) = []"
| "fos (Eq_SO_Inc X Y) = []"
| "fos (Eq_Max x X) = [x]"
| "fos (Eq_Min x X) = [x]"
| "fos (Empty X) = []"
| "fos (Singleton X) = []"
| "fos (Subset X Y) = []"
| "fos (Disjoint X Y) = []"
| "fos (Eq_Union X Y Z) = []"
| "fos (Eq_Inter X Y Z) = []"
| "fos (Eq_Diff X Y Z) = []"

primrec sos where
  "sos T = []"
| "sos F = []"
| "sos (Or \<phi> \<psi>) = List.union (sos \<phi>) (sos \<psi>)"
| "sos (And \<phi> \<psi>) = List.union (sos \<phi>) (sos \<psi>)"
| "sos (Not \<phi>) = sos \<phi>"
| "sos (Ex1 x \<phi>) = sos \<phi>"
| "sos (Ex2 X \<phi>) = List.remove1 X (sos \<phi>)"
| "sos (All1 x \<phi>) = sos \<phi>"
| "sos (All2 X \<phi>) = List.remove1 X (sos \<phi>)"
| "sos (Lt x y) = []"
| "sos (In x X) = [X]"
| "sos (Eq_Const x n) = []"
| "sos (Eq_Presb X n) = [X]"
| "sos (Eq_FO x y) = []"
| "sos (Eq_FO_Offset x y n) = []"
| "sos (Eq_SO X Y) = remdups [X, Y]"
| "sos (Eq_SO_Inc X Y) = remdups [X, Y]"
| "sos (Eq_Max x X) = [X]"
| "sos (Eq_Min x X) = [X]"
| "sos (Empty X) = [X]"
| "sos (Singleton X) = [X]"
| "sos (Subset X Y) = remdups [X, Y]"
| "sos (Disjoint X Y) = remdups [X, Y]"
| "sos (Eq_Union X Y Z) = remdups [X, Y, Z]"
| "sos (Eq_Inter X Y Z) = remdups [X, Y, Z]"
| "sos (Eq_Diff X Y Z) = remdups [X, Y, Z]"

lemma distinct_fos[simp]: "distinct (fos \<phi>)" by (induct \<phi>) auto
lemma distinct_sos[simp]: "distinct (sos \<phi>)" by (induct \<phi>) auto

primrec \<epsilon> where
  "\<epsilon> bs1 bs2 T = FBool True"
| "\<epsilon> bs1 bs2 F = FBool False"
| "\<epsilon> bs1 bs2 (Or \<phi> \<psi>) = FOr (\<epsilon> bs1 bs2 \<phi>) (\<epsilon> bs1 bs2 \<psi>)"
| "\<epsilon> bs1 bs2 (And \<phi> \<psi>) = FAnd (\<epsilon> bs1 bs2 \<phi>) (\<epsilon> bs1 bs2 \<psi>)"
| "\<epsilon> bs1 bs2 (Not \<phi>) = FNot (\<epsilon> bs1 bs2 \<phi>)"
| "\<epsilon> bs1 bs2 (Ex1 x \<phi>) = FEx FO (\<epsilon> (x # bs1) bs2 \<phi>)"
| "\<epsilon> bs1 bs2 (Ex2 X \<phi>) = FEx SO (\<epsilon> bs1 (X # bs2) \<phi>)"
| "\<epsilon> bs1 bs2 (All1 x \<phi>) = FAll FO (\<epsilon> (x # bs1) bs2 \<phi>)"
| "\<epsilon> bs1 bs2 (All2 X \<phi>) = FAll SO (\<epsilon> bs1 (X # bs2) \<phi>)"
| "\<epsilon> bs1 bs2 (Lt x y) = FBase (Less None (index bs1 x) (index bs1 y))"
| "\<epsilon> bs1 bs2 (In x X) = FBase (WS1S_Formula.In False (index bs1 x) (index bs2 X))"
| "\<epsilon> bs1 bs2 (Eq_Const x n) = FBase (WS1S_Formula.Eq_Const None (index bs1 x) n)"
| "\<epsilon> bs1 bs2 (Eq_Presb X n) = FBase (WS1S_Formula.Eq_Presb None (index bs2 X) n)"
| "\<epsilon> bs1 bs2 (Eq_FO x y) = FBase (WS1S_Formula.Eq_FO False (index bs1 x) (index bs1 y))"
| "\<epsilon> bs1 bs2 (Eq_FO_Offset x y n) = FBase (WS1S_Formula.Plus_FO None (index bs1 x) (index bs1 y) n)"
| "\<epsilon> bs1 bs2 (Eq_SO X Y) = FBase (WS1S_Formula.Eq_SO (index bs2 X) (index bs2 Y))"
| "\<epsilon> bs1 bs2 (Eq_SO_Inc X Y) = FBase (WS1S_Formula.Suc_SO False False (index bs2 X) (index bs2 Y))"
| "\<epsilon> bs1 bs2 (Eq_Max x X) = FBase (WS1S_Formula.Eq_Max False (index bs1 x) (index bs2 X))"
| "\<epsilon> bs1 bs2 (Eq_Min x X) = FBase (WS1S_Formula.Eq_Min False (index bs1 x) (index bs2 X))"
| "\<epsilon> bs1 bs2 (Empty X) = FBase (WS1S_Formula.Empty (index bs2 X))"
| "\<epsilon> bs1 bs2 (Singleton X) = FBase (WS1S_Formula.Singleton (index bs2 X))"
| "\<epsilon> bs1 bs2 (Subset X Y) = FBase (WS1S_Formula.Subset (index bs2 X) (index bs2 Y))"
| "\<epsilon> bs1 bs2 (Disjoint X Y) = FBase (WS1S_Formula.Disjoint (index bs2 X) (index bs2 Y))"
| "\<epsilon> bs1 bs2 (Eq_Union X Y Z) = FBase (WS1S_Formula.Eq_Union (index bs2 X) (index bs2 Y) (index bs2 Z))"
| "\<epsilon> bs1 bs2 (Eq_Inter X Y Z) = FBase (WS1S_Formula.Eq_Inter (index bs2 X) (index bs2 Y) (index bs2 Z))"
| "\<epsilon> bs1 bs2 (Eq_Diff X Y Z) = FBase (WS1S_Formula.Eq_Diff(index bs2 X) (index bs2 Y) (index bs2 Z))"

lift_definition mk_I ::
  "(fo \<Rightarrow> nat) \<Rightarrow> (so \<Rightarrow> nat fset) \<Rightarrow> fo list \<Rightarrow> so list \<Rightarrow> interp" is
  "\<lambda>I1 I2 fs ss. let I1s = map (\<lambda>x. {|I1 x|}) fs; I2s = map I2 ss in (MSB (I1s @ I2s), I1s, I2s)"
  by (auto simp: Let_def)

definition dec_I1 :: "interp \<Rightarrow> fo list \<Rightarrow> fo \<Rightarrow> nat" where "dec_I1 \<AA> fs x = fMin (index fs x\<^bsup>\<AA>\<^esup>FO)"
definition dec_I2 :: "interp \<Rightarrow> so list \<Rightarrow> so \<Rightarrow> nat fset" where "dec_I2 \<AA> ss X = index ss X\<^bsup>\<AA>\<^esup>SO"

lemma nvars_mk_I[simp]: "#\<^sub>V (mk_I I1 I2 fs ss) = Abs_idx (length fs, length ss)"
  by transfer (auto simp: Let_def)

lemma assigns_mk_I_FO[simp]:
  "m\<^bsup>mk_I I1 I2 bs1 bs2\<^esup>FO = (if m < length bs1 then {|I1 (bs1 ! m)|} else {||})"
  by transfer (auto simp: Let_def)

lemma assigns_mk_I_SO[simp]:
  "m\<^bsup>mk_I I1 I2 bs1 bs2\<^esup>SO = (if m < length bs2 then I2 (bs2 ! m) else {||})"
  by transfer (auto simp: Let_def)

lemma satisfies_cong:
  "\<lbrakk>\<forall>x \<in> set (fos \<phi>). I1 x = J1 x; \<forall>X \<in> set (sos \<phi>). I2 X = J2 X\<rbrakk> \<Longrightarrow>
  satisfies I1 I2 \<phi> \<longleftrightarrow> satisfies J1 J2 \<phi>"
proof (induct \<phi> arbitrary: I1 I2 J1 J2)
  case (Or \<phi> \<psi>) from Or.hyps[of I1 J1 I2 J2] Or.prems show ?case by auto
next
  case (And \<phi> \<psi>) from And.hyps[of I1 J1 I2 J2] And.prems show ?case by auto
next
  case (Ex1 x \<phi>) with Ex1.hyps[of "I1(x := y)" "J1(x := y)" I2 J2 for y, cong] show ?case by auto
next
  case (Ex2 X \<phi>) with Ex2.hyps[of I1 J1 "I2(X := Y)" "J2(X := Y)" for Y, cong] show ?case by auto
next
  case (All1 x \<phi>) with All1.hyps[of "I1(x := y)" "J1(x := y)" I2 J2 for y, cong] show ?case by auto
next
  case (All2 X \<phi>) with All2.hyps[of I1 J1 "I2(X := Y)" "J2(X := Y)" for Y, cong] show ?case by auto
qed simp_all

lemma dec_I_mk_I_satisfies_cong:
  "\<lbrakk>set (fos \<phi>) \<subseteq> set bs1; set (sos \<phi>) \<subseteq> set bs2; \<AA> = mk_I I1 I2 bs1 bs2\<rbrakk> \<Longrightarrow>
  satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) \<phi> \<longleftrightarrow> satisfies I1 I2 \<phi>"
  by (rule satisfies_cong) (auto simp: dec_I1_def dec_I2_def)

definition "ok_I \<AA> fs = (\<forall>x \<in> set fs. index fs x\<^bsup>\<AA>\<^esup>FO \<noteq> {||})"

lemma ok_I_mk_I[simp]: "ok_I (mk_I I1 I2 bs1 bs2) bs1"
  unfolding ok_I_def by transfer (auto simp: Let_def)

lemma in_FV_\<epsilon>D[dest]: "\<lbrakk>v \<in> FV (\<epsilon> bs1 bs2 \<phi>) FO;
  set (fos \<phi>) \<subseteq> set bs1; set (sos \<phi>) \<subseteq> set bs2\<rbrakk> \<Longrightarrow>
  (\<exists>y \<in> set bs1. v = index bs1 y)"
proof (induct \<phi> arbitrary: bs1 bs2 v)
  case (Ex1 x \<phi>) from Ex1.hyps[of "Suc v" "x # bs1" bs2] Ex1.prems show ?case
    by (auto simp: Diff_subset_conv split: if_splits)
next
  case (Ex2 X \<phi>) from Ex2.hyps[of v bs1 "X # bs2"] Ex2.prems show ?case
    by (auto simp: Diff_subset_conv split: if_splits)
next
  case (All1 x \<phi>) from All1.hyps[of "Suc v" "x # bs1" bs2] All1.prems show ?case
    by (auto simp: Diff_subset_conv split: if_splits)
next
  case (All2 X \<phi>) from All2.hyps[of v bs1 "X # bs2"] All2.prems show ?case
    by (auto simp: Diff_subset_conv split: if_splits)
qed (auto split: if_splits)

lemma dec_I1_Extend_FO[simp]:
  "dec_I1 (Extend FO 0 \<AA> P) (x # bs1) = (dec_I1 \<AA> bs1)(x := fMin P)"
  by (auto simp: dec_I1_def)

lemma dec_I1_Extend_SO[simp]: "dec_I1 (Extend SO i \<AA> P) bs1 = dec_I1 \<AA> bs1"
  by (auto simp: dec_I1_def)

lemma dec_I2_Extend_FO[simp]: "dec_I2 (Extend FO i \<AA> P) bs2 = dec_I2 \<AA> bs2"
  by (auto simp: dec_I2_def)

lemma dec_I2_Extend_SO[simp]:
  "dec_I2 (Extend SO 0 \<AA> P) (X # bs2) = (dec_I2 \<AA> bs2)(X := P)"
  by (auto simp: dec_I2_def fun_eq_iff)

lemma sat_\<epsilon>: "\<lbrakk>set (fos \<phi>) \<subseteq> set bs1; set (sos \<phi>) \<subseteq> set bs2; ok_I \<AA> bs1\<rbrakk> \<Longrightarrow>
  WS1S.sat \<AA> (\<epsilon> bs1 bs2 \<phi>) \<longleftrightarrow>
  satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) \<phi>"
proof (induct \<phi> arbitrary: \<AA> bs1 bs2)
  case (Or \<phi> \<psi>) from Or.hyps[of bs1 bs2 \<AA>] Or.prems show ?case
    unfolding WS1S.sat_def
    by (auto simp: restrict_def ok_I_def split: order.splits)
next
  case (And \<phi> \<psi>) from And.hyps[of bs1 bs2 \<AA>] And.prems show ?case
    unfolding WS1S.sat_def
    by (auto simp: restrict_def ok_I_def split: order.splits)
next
  case (Not \<phi>) from Not.hyps[of bs1 bs2 \<AA>] Not.prems show ?case
    unfolding WS1S.sat_def
    by (auto simp: restrict_def ok_I_def split: order.splits)
next
  case (Ex1 x \<phi>)
  { fix P :: "nat fset" assume "P \<noteq> {||}"
    with Ex1.prems have "WS1S.sat (Extend FO 0 \<AA> P) (\<epsilon> (x # bs1) bs2 \<phi>) \<longleftrightarrow>
      satisfies (dec_I1 (Extend FO 0 \<AA> P) (x # bs1)) (dec_I2 (Extend FO 0 \<AA> P) bs2) \<phi>"
      by (intro Ex1.hyps) (auto simp: ok_I_def)
  } note IH = this
  show ?case
  proof
    assume "WS1S.sat \<AA> (\<epsilon> bs1 bs2 (Ex1 x \<phi>))"
    then obtain P where "P \<noteq> {||}" "WS1S.sat (Extend FO 0 \<AA> P) (\<epsilon> (x # bs1) bs2 \<phi>)"
      unfolding WS1S.sat_def by (auto simp: restrict_def split: order.splits)
    then have "satisfies (dec_I1 (Extend FO 0 \<AA> P) (x # bs1)) (dec_I2 (Extend FO 0 \<AA> P) bs2) \<phi>"
      by (auto simp: IH)
    then show "satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) (Ex1 x \<phi>)" by auto
  next
    assume "satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) (Ex1 x \<phi>)"
    then obtain n where "satisfies (dec_I1 (Extend FO 0 \<AA> {|n|}) (x # bs1))
      (dec_I2 (Extend FO 0 \<AA> {|n|}) bs2) \<phi>" by auto
    then have "WS1S.sat (Extend FO 0 \<AA> {|n|}) (\<epsilon> (x # bs1) bs2 \<phi>)"
      by (auto simp: IH)
    then show "WS1S.sat \<AA> (\<epsilon> bs1 bs2 (Ex1 x \<phi>))" unfolding WS1S.sat_def
      by (auto simp: restrict_def split: order.splits)
  qed
next
  case (Ex2 X \<phi>)
  { fix P :: "nat fset"
    from Ex2.prems have "WS1S.sat (Extend SO 0 \<AA> P) (\<epsilon> bs1 (X # bs2) \<phi>) \<longleftrightarrow>
      satisfies (dec_I1 (Extend SO 0 \<AA> P) bs1) (dec_I2 (Extend SO 0 \<AA> P) (X # bs2)) \<phi>"
      by (intro Ex2.hyps) (auto simp: ok_I_def)
  } note IH = this
  show ?case
  proof -
    have "WS1S.sat \<AA> (\<epsilon> bs1 bs2 (Ex2 X \<phi>)) \<longleftrightarrow>
      (\<exists>P. WS1S.sat (Extend SO 0 \<AA> P) (\<epsilon> bs1 (X # bs2) \<phi>))"
      unfolding WS1S.sat_def by (auto simp: restrict_def split: order.splits)
    also have "\<dots> \<longleftrightarrow> (\<exists>P. satisfies (dec_I1 (Extend SO 0 \<AA> P) bs1)
      (dec_I2 (Extend SO 0 \<AA> P) (X # bs2)) \<phi>)" by (auto simp: IH)
    also have "\<dots> \<longleftrightarrow> satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) (Ex2 X \<phi>)" by simp
    finally show ?thesis .
  qed
next
  case (All1 x \<phi>)
  { fix P :: "nat fset" assume "P \<noteq> {||}"
    with All1.prems have "WS1S.sat (Extend FO 0 \<AA> P) (\<epsilon> (x # bs1) bs2 \<phi>) \<longleftrightarrow>
      satisfies (dec_I1 (Extend FO 0 \<AA> P) (x # bs1)) (dec_I2 (Extend FO 0 \<AA> P) bs2) \<phi>"
      by (intro All1.hyps) (auto simp: ok_I_def)
  } note IH = this
  show ?case
  proof
    assume L: "WS1S.sat \<AA> (\<epsilon> bs1 bs2 (All1 x \<phi>))"
    { fix n :: "nat"
      from L have "WS1S.sat (Extend FO 0 \<AA> {|n|}) (\<epsilon> (x # bs1) bs2 \<phi>)"
        unfolding WS1S.sat_def by (auto simp: restrict_def split: order.splits)
      then have "satisfies (dec_I1 (Extend FO 0 \<AA> {|n|}) (x # bs1))
        (dec_I2 (Extend FO 0 \<AA> {|n|}) bs2) \<phi>" by (auto simp: IH)
    }
    then show "satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) (All1 x \<phi>)" by simp
  next
    assume R: "satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) (All1 x \<phi>)"
    { fix P :: "nat fset" assume "P \<noteq> {||}"
      with R have "satisfies (dec_I1 (Extend FO 0 \<AA> P) (x # bs1))
        (dec_I2 (Extend FO 0 \<AA> P) bs2) \<phi>" by auto
      with \<open>P \<noteq> {||}\<close> have "WS1S.sat (Extend FO 0 \<AA> P) (\<epsilon> (x # bs1) bs2 \<phi>)"
        by (auto simp: IH)
    }
    with All1.prems in_FV_\<epsilon>D[of _ "x # bs1" bs2 \<phi>]
      show "WS1S.sat \<AA> (\<epsilon> bs1 bs2 (All1 x \<phi>))" unfolding WS1S.sat_def
      by (auto 0 3 simp: restrict_def ok_I_def split: if_splits order.splits)
  qed
next
  case (All2 X \<phi>)
  { fix P :: "nat fset"
    from All2.prems have "WS1S.sat (Extend SO 0 \<AA> P) (\<epsilon> bs1 (X # bs2) \<phi>) \<longleftrightarrow>
      satisfies (dec_I1 (Extend SO 0 \<AA> P) bs1) (dec_I2 (Extend SO 0 \<AA> P) (X # bs2)) \<phi>"
      by (intro All2.hyps) (auto simp: ok_I_def)
  } note IH = this
  show ?case
  proof -
    have "WS1S.sat \<AA> (\<epsilon> bs1 bs2 (All2 X \<phi>)) \<longleftrightarrow>
      (\<forall>P. WS1S.sat (Extend SO 0 \<AA> P) (\<epsilon> bs1 (X # bs2) \<phi>))"
      unfolding WS1S.sat_def by (auto simp: restrict_def split: order.splits)
    also have "\<dots> \<longleftrightarrow> (\<forall>P. satisfies (dec_I1 (Extend SO 0 \<AA> P) bs1)
      (dec_I2 (Extend SO 0 \<AA> P) (X # bs2)) \<phi>)" by (auto simp: IH)
    also have "\<dots> \<longleftrightarrow> satisfies (dec_I1 \<AA> bs1) (dec_I2 \<AA> bs2) (All2 X \<phi>)" by simp
    finally show ?thesis .
  qed
qed (auto simp: WS1S.sat_def Let_def dec_I1_def dec_I2_def ok_I_def
  restrict_def split: if_splits order.splits)

definition "eqv \<phi> \<psi> =
  (let fs = List.union (fos \<phi>) (fos \<psi>); ss = List.union (sos \<phi>) (sos \<psi>)
  in check_eqv (Abs_idx (length fs, length ss)) (\<epsilon> fs ss \<phi>) (\<epsilon> fs ss \<psi>))"

lemma eqv_sound: "eqv \<phi> \<psi> \<Longrightarrow> satisfies I1 I2 \<phi> \<longleftrightarrow> satisfies I1 I2 \<psi>"
  unfolding eqv_def Let_def
  by (drule check_eqv_sound[rotated, of _ _ _
    "mk_I I1 I2 (List.union (fos \<phi>) (fos \<psi>)) (List.union (sos \<phi>) (sos \<psi>))"])
    (auto simp: sat_\<epsilon> dec_I_mk_I_satisfies_cong)

definition "Thm \<phi> = eqv \<phi> T"

lemma "Thm \<Phi> \<Longrightarrow> satisfies I1 I2 \<Phi>"
  unfolding Thm_def by (drule eqv_sound[of _ _ I1 I2]) simp

setup_lifting type_definition_fo
setup_lifting type_definition_so

instantiation fo :: equal
begin
  lift_definition equal_fo :: "fo \<Rightarrow> fo \<Rightarrow> bool" is "(=)" .
  instance by (standard, transfer) simp
end

instantiation so :: equal
begin
  lift_definition equal_so :: "so \<Rightarrow> so \<Rightarrow> bool" is "(=)" .
  instance by (standard, transfer) simp
end

(*<*)
end
(*>*)


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


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


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


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


(*  Title:       Signed Syntactic Ordinals in Cantor Normal Form
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Author:      Mathias Fleury <mfleury at mpi-inf.mpg.de>, 2016
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Signed Syntactic Ordinals in Cantor Normal Form\<close>

theory Signed_Syntactic_Ordinal
imports Signed_Hereditary_Multiset Syntactic_Ordinal
begin

subsection \<open>Natural (Hessenberg) Product\<close>

instantiation zhmultiset :: comm_ring_1
begin

abbreviation \<omega>\<^sub>z_exp :: "hmultiset \<Rightarrow> zhmultiset" ("\<omega>\<^sub>z^") where
  "\<omega>\<^sub>z^ \<equiv> \<lambda>m. ZHMSet {#m#}\<^sub>z"

lift_definition one_zhmultiset :: zhmultiset is "{#0#}\<^sub>z" .

abbreviation \<omega>\<^sub>z :: zhmultiset where
  "\<omega>\<^sub>z \<equiv> \<omega>\<^sub>z^1"

lemma \<omega>\<^sub>z_as_\<omega>: "\<omega>\<^sub>z = zhmset_of \<omega>"
  by simp

lift_definition times_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> zhmultiset" is
  "\<lambda>M N.
       zmset_of (hmsetmset (HMSet (mset_pos M) * HMSet (mset_pos N)))
     - zmset_of (hmsetmset (HMSet (mset_pos M) * HMSet (mset_neg N)))
     + zmset_of (hmsetmset (HMSet (mset_neg M) * HMSet (mset_neg N)))
     - zmset_of (hmsetmset (HMSet (mset_neg M) * HMSet (mset_pos N)))" .

lemmas zhmsetmset_times = times_zhmultiset.rep_eq

instance
proof (intro_classes, goal_cases mult_assoc mult_comm mult_1 distrib zero_neq_one)
  case (mult_assoc a b c)
  show ?case
    by (transfer,
      simp add: algebra_simps zmset_of_plus[symmetric] hmsetmset_plus[symmetric] HMSet_diff,
      rule triple_cross_mult_hmset)
next
  case (mult_comm a b)
  show ?case
    by transfer (auto simp: algebra_simps)
next
  case (mult_1 a)
  show ?case
    by transfer (auto simp: algebra_simps mset_pos_neg_partition[symmetric])
next
  case (distrib a b c)

  show ?case
    by (simp add: times_zhmultiset_def ZHMSet_plus[symmetric] zmset_of_plus[symmetric]
        hmsetmset_plus[symmetric] algebra_simps hmset_pos_plus hmset_neg_plus)
     (simp add: mult.commute[of _ "hmset_pos c"] mult.commute[of _ "hmset_neg c"]
        add.commute[of "hmset_neg c * M" "hmset_pos c * N" for M N]
        add.assoc[symmetric] ring_distribs(1)[symmetric] hmset_pos_neg_dual)
next
  case zero_neq_one
  show ?case
    unfolding zero_zhmultiset_def one_zhmultiset_def by simp
qed

end

lemma zhmset_of_1: "zhmset_of 1 = 1"
  by (simp add: one_hmultiset_def one_zhmultiset_def)

lemma zhmset_of_times: "zhmset_of (A * B) = zhmset_of A * zhmset_of B"
  by transfer simp

lemma zhmset_of_prod_list:
  "zhmset_of (prod_list Ms) = prod_list (map zhmset_of Ms)"
  by (induct Ms) (auto simp: one_hmultiset_def one_zhmultiset_def zhmset_of_times)

subsection \<open>Embedding of Natural Numbers\<close>

lemma of_nat_zhmset: "of_nat n = zhmset_of (of_nat n)"
  by (induct n) (auto simp: zero_zhmultiset_def zhmset_of_plus zhmset_of_1)

lemma of_nat_inject_zhmset[simp]: "(of_nat m :: zhmultiset) = of_nat n \<longleftrightarrow> m = n"
  unfolding of_nat_zhmset by simp

lemma plus_of_nat_plus_of_nat_zhmset:
  "k + of_nat m + of_nat n = k + of_nat (m + n)" for k :: zhmultiset
  by simp

lemma plus_of_nat_minus_of_nat_zhmset:
  fixes k :: zhmultiset
  assumes "n \<le> m"
  shows "k + of_nat m - of_nat n = k + of_nat (m - n)"
  using assms by (simp add: of_nat_diff)

lemma of_nat_lt_\<omega>\<^sub>z[simp]: "of_nat n < \<omega>\<^sub>z"
  unfolding \<omega>\<^sub>z_as_\<omega> using of_nat_lt_\<omega> of_nat_zhmset zhmset_of_less by presburger

lemma of_nat_ne_\<omega>\<^sub>z[simp]: "of_nat n \<noteq> \<omega>\<^sub>z"
  by (metis of_nat_lt_\<omega>\<^sub>z mset_le_asym mset_lt_single_iff)

subsection \<open>Embedding of Extended Natural Numbers\<close>

primrec zhmset_of_enat :: "enat \<Rightarrow> zhmultiset" where
  "zhmset_of_enat (enat n) = of_nat n"
| "zhmset_of_enat \<infinity> = \<omega>\<^sub>z"

lemma zhmset_of_enat_0[simp]: "zhmset_of_enat 0 = 0"
  by (simp add: zero_enat_def)

lemma zhmset_of_enat_1[simp]: "zhmset_of_enat 1 = 1"
  by (simp add: one_enat_def del: One_nat_def)

lemma zhmset_of_enat_of_nat[simp]: "zhmset_of_enat (of_nat n) = of_nat n"
  using of_nat_eq_enat by auto

lemma zhmset_of_enat_numeral[simp]: "zhmset_of_enat (numeral n) = numeral n"
  by (simp add: numeral_eq_enat)

lemma zhmset_of_enat_le_\<omega>\<^sub>z[simp]: "zhmset_of_enat n \<le> \<omega>\<^sub>z"
  using of_nat_lt_\<omega>\<^sub>z[THEN less_imp_le] by (cases n) auto

lemma zhmset_of_enat_eq_\<omega>\<^sub>z_iff[simp]: "zhmset_of_enat n = \<omega>\<^sub>z \<longleftrightarrow> n = \<infinity>"
  by (cases n) auto

subsection \<open>Inequalities and Some (Dis)equalities\<close>

instance zhmultiset :: zero_less_one
  by (intro_classes, transfer, transfer, auto)

instantiation zhmultiset :: linordered_idom
begin

definition sgn_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset" where
  "sgn_zhmultiset M = (if M = 0 then 0 else if M > 0 then 1 else -1)"

definition abs_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset" where
  "abs_zhmultiset M = (if M < 0 then - M else M)"

lemma gt_0_times_gt_0_imp:
  fixes a b :: zhmultiset
  assumes a_gt0: "a > 0" and b_gt0: "b > 0"
  shows "a * b > 0"
proof -
  show ?thesis
    using a_gt0 b_gt0
    by (subst (asm) (2 4) zhmset_pos_neg_partition, simp, transfer,
        simp del: HMSet_less add: algebra_simps zmset_of_plus[symmetric] hmsetmset_plus[symmetric]
        zmset_of_less HMSet_less[symmetric])
      (rule mono_cross_mult_less_hmset)
qed

instance
proof intro_classes
  fix a b c :: zhmultiset

  assume
    a_lt_b: "a < b" and
    zero_lt_c: "0 < c"

  have "c * b < c * b + c * (b - a)"
    using gt_0_times_gt_0_imp by (simp add: a_lt_b zero_lt_c)
  hence "c * a + c * (b - a) < c * b + c * (b - a)"
    by (simp add: right_diff_distrib')
  thus "c * a < c * b"
    by simp
qed (auto simp: sgn_zhmultiset_def abs_zhmultiset_def)

end

lemma zhmset_of_nonneg[simp]: "zhmset_of M \<ge> 0"
  by (metis hmsetmset_0 zero_le_hmset zero_zhmultiset_def zhmset_of_le zmset_of_empty)

lemma
  fixes n :: zhmultiset
  assumes "0 \<le> m"
  shows
    le_add1_hmset: "n \<le> n + m" and
    le_add2_hmset: "n \<le> m + n"
  using assms by simp+

lemma less_iff_add1_le_zhmset: "m < n \<longleftrightarrow> m + 1 \<le> n" for m n :: zhmultiset
proof
  assume m_lt_n: "m < n"
  show "m + 1 \<le> n"
  proof -
    obtain hh :: hmultiset and zz :: zhmultiset and hha :: hmultiset where
      f1: "m = zhmset_of hh + zz \<and> n = zhmset_of hha + zz \<and> hh < hha"
      using less_hmset_zhmsetE[OF m_lt_n] by metis
    hence "zhmset_of (hh + 1) \<le> zhmset_of hha"
      by (metis (no_types) less_iff_add1_le_hmset zhmset_of_le)
    thus ?thesis
      using f1 by (simp add: zhmset_of_1 zhmset_of_plus)
  qed
qed simp

lemma gt_0_lt_mult_gt_1_zhmset:
  fixes m n :: zhmultiset
  assumes "m > 0" and "n > 1"
  shows "m < m * n"
  using assms by simp

lemma zero_less_iff_1_le_zhmset: "0 < n \<longleftrightarrow> 1 \<le> n" for n :: zhmultiset
  by (rule less_iff_add1_le_zhmset[of 0, simplified])

lemma less_add_1_iff_le_hmset: "m < n + 1 \<longleftrightarrow> m \<le> n" for m n :: zhmultiset
  by (rule less_iff_add1_le_zhmset[of m "n + 1", simplified])

lemma nonneg_le_mult_right_mono_zhmset:
  fixes x y z :: zhmultiset
  assumes x: "0 \<le> x" and y: "0 < y" and z: "x \<le> z"
  shows "x \<le> y * z"
  using x zero_less_iff_1_le_zhmset[THEN iffD1, OF y] z
  by (meson dual_order.trans leD mult_less_cancel_right2 not_le_imp_less)

instance hmultiset :: ordered_cancel_comm_semiring
  by intro_classes

instance hmultiset :: linordered_semiring_1_strict
  by intro_classes

instance hmultiset :: bounded_lattice_bot
  by intro_classes

instance hmultiset :: zero_less_one
  by intro_classes

instance hmultiset :: linordered_nonzero_semiring
  by intro_classes

instance hmultiset :: semiring_no_zero_divisors
  by intro_classes

lemma zero_lt_\<omega>\<^sub>z[simp]: "0 < \<omega>\<^sub>z"
  by (metis of_nat_lt_\<omega>\<^sub>z of_nat_0)

lemma one_lt_\<omega>[simp]: "1 < \<omega>\<^sub>z"
  by (metis enat_defs(2) zhmset_of_enat.simps(1) zhmset_of_enat_1 of_nat_lt_\<omega>\<^sub>z)

lemma numeral_lt_\<omega>\<^sub>z[simp]: "numeral n < \<omega>\<^sub>z"
  using zhmset_of_enat_numeral[symmetric] zhmset_of_enat.simps(1) of_nat_lt_\<omega>\<^sub>z numeral_eq_enat
  by presburger

lemma one_le_\<omega>\<^sub>z[simp]: "1 \<le> \<omega>\<^sub>z"
  by (simp add: less_imp_le)

lemma of_nat_le_\<omega>\<^sub>z[simp]: "of_nat n \<le> \<omega>\<^sub>z"
  by (simp add: le_less)

lemma numeral_le_\<omega>\<^sub>z[simp]: "numeral n \<le> \<omega>\<^sub>z"
  by (simp add: less_imp_le)

lemma not_\<omega>\<^sub>z_lt_1[simp]: "\<not> \<omega>\<^sub>z < 1"
  by (simp add: not_less)

lemma not_\<omega>\<^sub>z_lt_of_nat[simp]: "\<not> \<omega>\<^sub>z < of_nat n"
  by (simp add: not_less)

lemma not_\<omega>\<^sub>z_lt_numeral[simp]: "\<not> \<omega>\<^sub>z < numeral n"
  by (simp add: not_less)

lemma not_\<omega>\<^sub>z_le_1[simp]: "\<not> \<omega>\<^sub>z \<le> 1"
  by (simp add: not_le)

lemma not_\<omega>\<^sub>z_le_of_nat[simp]: "\<not> \<omega>\<^sub>z \<le> of_nat n"
  by (simp add: not_le)

lemma not_\<omega>\<^sub>z_le_numeral[simp]: "\<not> \<omega>\<^sub>z \<le> numeral n"
  by (simp add: not_le)

lemma zero_ne_\<omega>\<^sub>z[simp]: "0 \<noteq> \<omega>\<^sub>z"
  using zero_lt_\<omega>\<^sub>z by linarith

lemma one_ne_\<omega>\<^sub>z[simp]: "1 \<noteq> \<omega>\<^sub>z"
  using not_\<omega>\<^sub>z_le_1 by force

lemma numeral_ne_\<omega>\<^sub>z[simp]: "numeral n \<noteq> \<omega>\<^sub>z"
  by (metis not_\<omega>\<^sub>z_le_numeral numeral_le_\<omega>\<^sub>z)

lemma
  \<omega>\<^sub>z_ne_0[simp]: "\<omega>\<^sub>z \<noteq> 0" and
  \<omega>\<^sub>z_ne_1[simp]: "\<omega>\<^sub>z \<noteq> 1" and
  \<omega>\<^sub>z_ne_of_nat[simp]: "\<omega>\<^sub>z \<noteq> of_nat m" and
  \<omega>\<^sub>z_ne_numeral[simp]: "\<omega>\<^sub>z \<noteq> numeral n"
  using zero_ne_\<omega>\<^sub>z one_ne_\<omega>\<^sub>z of_nat_ne_\<omega>\<^sub>z numeral_ne_\<omega>\<^sub>z by metis+

lemma
  zhmset_of_enat_inject[simp]: "zhmset_of_enat m = zhmset_of_enat n \<longleftrightarrow> m = n" and
  zhmset_of_enat_lt_iff_lt[simp]: "zhmset_of_enat m < zhmset_of_enat n \<longleftrightarrow> m < n" and
  zhmset_of_enat_le_iff_le[simp]: "zhmset_of_enat m \<le> zhmset_of_enat n \<longleftrightarrow> m \<le> n"
  by (cases m; cases n; simp)+

lemma of_nat_lt_zhmset_of_enat_iff: "of_nat m < zhmset_of_enat n \<longleftrightarrow> enat m < n"
  by (metis zhmset_of_enat.simps(1) zhmset_of_enat_lt_iff_lt)

lemma of_nat_le_zhmset_of_enat_iff: "of_nat m \<le> zhmset_of_enat n \<longleftrightarrow> enat m \<le> n"
  by (metis zhmset_of_enat.simps(1) zhmset_of_enat_le_iff_le)

lemma zhmset_of_enat_lt_iff_ne_infinity: "zhmset_of_enat x < \<omega>\<^sub>z \<longleftrightarrow> x \<noteq> \<infinity>"
  by (cases x; simp)

subsection \<open>An Example\<close>

text \<open>
A new proof of @{thm ludwig_waldmann_less}:
\<close>

lemma
  fixes \<alpha>1 \<alpha>2 \<beta>1 \<beta>2 \<gamma> \<delta> :: hmultiset
  assumes
    \<alpha>\<beta>2\<gamma>_lt_\<alpha>\<beta>1\<gamma>: "\<alpha>2 + \<beta>2 * \<gamma> < \<alpha>1 + \<beta>1 * \<gamma>" and
    \<beta>2_le_\<beta>1: "\<beta>2 \<le> \<beta>1" and
    \<gamma>_lt_\<delta>: "\<gamma> < \<delta>"
  shows "\<alpha>2 + \<beta>2 * \<delta> < \<alpha>1 + \<beta>1 * \<delta>"
proof -
  let ?z = zhmset_of

  note \<alpha>\<beta>2\<gamma>_lt_\<alpha>\<beta>1\<gamma>' = \<alpha>\<beta>2\<gamma>_lt_\<alpha>\<beta>1\<gamma>[THEN zhmset_of_less[THEN iffD2],
    simplified zhmset_of_plus zhmset_of_times]
  note \<beta>2_le_\<beta>1' = \<beta>2_le_\<beta>1[THEN zhmset_of_le[THEN iffD2]]
  note \<gamma>_lt_\<delta>' = \<gamma>_lt_\<delta>[THEN zhmset_of_less[THEN iffD2]]

  have "?z \<alpha>2 + ?z \<beta>2 * ?z \<delta> < ?z \<alpha>1 + ?z \<beta>1 * ?z \<gamma> + ?z \<beta>2 * (?z \<delta> - ?z \<gamma>)"
    using \<alpha>\<beta>2\<gamma>_lt_\<alpha>\<beta>1\<gamma>' by (simp add: algebra_simps)
  also have "\<dots> \<le> ?z \<alpha>1 + ?z \<beta>1 * ?z \<gamma> + ?z \<beta>1 * (?z \<delta> - ?z \<gamma>)"
    using \<beta>2_le_\<beta>1' \<gamma>_lt_\<delta>' by simp
  finally show ?thesis
    by (simp add: zmset_of_less zhmset_of_times[symmetric] zhmset_of_plus[symmetric] algebra_simps)
qed

end


(* Title:        Clausal Logic
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Mathias Fleury <mathias.fleury at mpi-inf.mpg.de>, 2014
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Clausal Logic\<close>

theory Clausal_Logic
  imports Nested_Multisets_Ordinals.Multiset_More
begin

text \<open>
Resolution operates of clauses, which are disjunctions of literals. The material formalized here
corresponds roughly to Sections 2.1 (``Formulas and Clauses'') of Bachmair and Ganzinger, excluding
the formula and term syntax.
\<close>

subsection \<open>Literals\<close>

text \<open>
Literals consist of a polarity (positive or negative) and an atom, of type @{typ 'a}.
\<close>

datatype 'a literal =
  is_pos: Pos (atm_of: 'a)
| Neg (atm_of: 'a)

abbreviation is_neg :: "'a literal \<Rightarrow> bool" where
  "is_neg L \<equiv> \<not> is_pos L"

lemma Pos_atm_of_iff[simp]: "Pos (atm_of L) = L \<longleftrightarrow> is_pos L"
  by (cases L) simp+

lemma Neg_atm_of_iff[simp]: "Neg (atm_of L) = L \<longleftrightarrow> is_neg L"
  by (cases L) simp+

lemma set_literal_atm_of: "set_literal L = {atm_of L}"
  by (cases L) simp+

lemma ex_lit_cases: "(\<exists>L. P L) \<longleftrightarrow> (\<exists>A. P (Pos A) \<or> P (Neg A))"
  by (metis literal.exhaust)

instantiation literal :: (type) uminus
begin

definition uminus_literal :: "'a literal \<Rightarrow> 'a literal" where
  "uminus L = (if is_pos L then Neg else Pos) (atm_of L)"

instance ..

end

lemma
  uminus_Pos[simp]: "- Pos A = Neg A" and
  uminus_Neg[simp]: "- Neg A = Pos A"
  unfolding uminus_literal_def by simp_all

lemma atm_of_uminus[simp]: "atm_of (-L) = atm_of L"
  by (case_tac L, auto)

lemma uminus_of_uminus_id[simp]: "- (- (x :: 'v literal)) = x"
  by (simp add: uminus_literal_def)

lemma uminus_not_id[simp]: "x \<noteq> - (x:: 'v literal)"
  by (case_tac x) auto

lemma uminus_not_id'[simp]: "- x \<noteq> (x:: 'v literal)"
  by (case_tac x, auto)

lemma uminus_eq_inj[iff]: "- (a::'v literal) = - b \<longleftrightarrow> a = b"
  by (case_tac a; case_tac b) auto+

lemma uminus_lit_swap: "(a::'a literal) = - b \<longleftrightarrow> - a = b"
  by auto

lemma is_pos_neg_not_is_pos: "is_pos (- L) \<longleftrightarrow> \<not> is_pos L"
  by (cases L) auto

instantiation literal :: (preorder) preorder
begin

definition less_literal :: "'a literal \<Rightarrow> 'a literal \<Rightarrow> bool" where
  "less_literal L M \<longleftrightarrow> atm_of L < atm_of M \<or> atm_of L \<le> atm_of M \<and> is_neg L < is_neg M"

definition less_eq_literal :: "'a literal \<Rightarrow> 'a literal \<Rightarrow> bool" where
  "less_eq_literal L M \<longleftrightarrow> atm_of L < atm_of M \<or> atm_of L \<le> atm_of M \<and> is_neg L \<le> is_neg M"

instance
  apply intro_classes
  unfolding less_literal_def less_eq_literal_def by (auto intro: order_trans simp: less_le_not_le)

end

instantiation literal :: (order) order
begin

instance
  by intro_classes (auto simp: less_eq_literal_def intro: literal.expand)

end

lemma pos_less_neg[simp]: "Pos A < Neg A"
  unfolding less_literal_def by simp

lemma pos_less_pos_iff[simp]: "Pos A < Pos B \<longleftrightarrow> A < B"
  unfolding less_literal_def by simp

lemma pos_less_neg_iff[simp]: "Pos A < Neg B \<longleftrightarrow> A \<le> B"
  unfolding less_literal_def by (auto simp: less_le_not_le)

lemma neg_less_pos_iff[simp]: "Neg A < Pos B \<longleftrightarrow> A < B"
  unfolding less_literal_def by simp

lemma neg_less_neg_iff[simp]: "Neg A < Neg B \<longleftrightarrow> A < B"
  unfolding less_literal_def by simp

lemma pos_le_neg[simp]: "Pos A \<le> Neg A"
  unfolding less_eq_literal_def by simp

lemma pos_le_pos_iff[simp]: "Pos A \<le> Pos B \<longleftrightarrow> A \<le> B"
  unfolding less_eq_literal_def by (auto simp: less_le_not_le)

lemma pos_le_neg_iff[simp]: "Pos A \<le> Neg B \<longleftrightarrow> A \<le> B"
  unfolding less_eq_literal_def by (auto simp: less_imp_le)

lemma neg_le_pos_iff[simp]: "Neg A \<le> Pos B \<longleftrightarrow> A < B"
  unfolding less_eq_literal_def by simp

lemma neg_le_neg_iff[simp]: "Neg A \<le> Neg B \<longleftrightarrow> A \<le> B"
  unfolding less_eq_literal_def by (auto simp: less_imp_le)

lemma leq_imp_less_eq_atm_of: "L \<le> M \<Longrightarrow> atm_of L \<le> atm_of M"
  unfolding less_eq_literal_def using less_imp_le by blast

instantiation literal :: (linorder) linorder
begin

instance
  apply intro_classes
  unfolding less_eq_literal_def less_literal_def by auto

end

instantiation literal :: (wellorder) wellorder
begin

instance
proof intro_classes
  fix P :: "'a literal \<Rightarrow> bool" and L :: "'a literal"
  assume ih: "\<And>L. (\<And>M. M < L \<Longrightarrow> P M) \<Longrightarrow> P L"
  have "\<And>x. (\<And>y. y < x \<Longrightarrow> P (Pos y) \<and> P (Neg y)) \<Longrightarrow> P (Pos x) \<and> P (Neg x)"
    by (rule conjI[OF ih ih])
      (auto simp: less_literal_def atm_of_def split: literal.splits intro: ih)
  then have "\<And>A. P (Pos A) \<and> P (Neg A)"
    by (rule less_induct) blast
  then show "P L"
    by (cases L) simp+
qed

end

subsection \<open>Clauses\<close>

text \<open>
Clauses are (finite) multisets of literals.
\<close>

type_synonym 'a clause = "'a literal multiset"

abbreviation map_clause :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a clause \<Rightarrow> 'b clause" where
  "map_clause f \<equiv> image_mset (map_literal f)"

abbreviation rel_clause :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a clause \<Rightarrow> 'b clause \<Rightarrow> bool" where
  "rel_clause R \<equiv> rel_mset (rel_literal R)"

abbreviation poss :: "'a multiset \<Rightarrow> 'a clause" where "poss AA \<equiv> {#Pos A. A \<in># AA#}"
abbreviation negs :: "'a multiset \<Rightarrow> 'a clause" where "negs AA \<equiv> {#Neg A. A \<in># AA#}"

lemma Max_in_lits: "C \<noteq> {#} \<Longrightarrow> Max_mset C \<in># C"
  by simp

lemma Max_atm_of_set_mset_commute: "C \<noteq> {#} \<Longrightarrow> Max (atm_of ` set_mset C) = atm_of (Max_mset C)"
  by (rule mono_Max_commute[symmetric]) (auto simp: mono_def less_eq_literal_def)

lemma Max_pos_neg_less_multiset:
  assumes max: "Max_mset C = Pos A" and neg: "Neg A \<in># D"
  shows "C < D"
proof -
  have "Max_mset C < Neg A"
    using max by simp
  then show ?thesis
    using neg by (metis (no_types) Max_less_iff empty_iff ex_gt_imp_less_multiset finite_set_mset)
qed

lemma pos_Max_imp_neg_notin: "Max_mset C = Pos A \<Longrightarrow> Neg A \<notin># C"
  using Max_pos_neg_less_multiset by blast

lemma less_eq_Max_lit: "C \<noteq> {#} \<Longrightarrow> C \<le> D \<Longrightarrow> Max_mset C \<le> Max_mset D"
proof (unfold less_eq_multiset\<^sub>H\<^sub>O)
  assume
    ne: "C \<noteq> {#}" and
    ex_gt: "\<forall>x. count D x < count C x \<longrightarrow> (\<exists>y > x. count C y < count D y)"
  from ne have "Max_mset C \<in># C"
    by (fast intro: Max_in_lits)
  then have "\<exists>l. l \<in># D \<and> \<not> l < Max_mset C"
    using ex_gt by (metis count_greater_zero_iff count_inI less_not_sym)
  then have "\<not> Max_mset D < Max_mset C"
    by (metis Max.coboundedI[OF finite_set_mset] le_less_trans)
  then show ?thesis
    by simp
qed

definition atms_of :: "'a clause \<Rightarrow> 'a set" where
  "atms_of C = atm_of ` set_mset C"

lemma atms_of_empty[simp]: "atms_of {#} = {}"
  unfolding atms_of_def by simp

lemma atms_of_singleton[simp]: "atms_of {#L#} = {atm_of L}"
  unfolding atms_of_def by auto

lemma atms_of_add_mset[simp]: "atms_of (add_mset a A) = insert (atm_of a) (atms_of A)"
  unfolding atms_of_def by auto

lemma atms_of_union_mset[simp]: "atms_of (A \<union># B) = atms_of A \<union> atms_of B"
  unfolding atms_of_def by auto

lemma finite_atms_of[iff]: "finite (atms_of C)"
  by (simp add: atms_of_def)

lemma atm_of_lit_in_atms_of: "L \<in># C \<Longrightarrow> atm_of L \<in> atms_of C"
  by (simp add: atms_of_def)

lemma atms_of_plus[simp]: "atms_of (C + D) = atms_of C \<union> atms_of D"
  unfolding atms_of_def by auto

lemma in_atms_of_minusD: "x \<in> atms_of (A - B) \<Longrightarrow> x \<in> atms_of A"
  by (auto simp: atms_of_def dest: in_diffD)

lemma pos_lit_in_atms_of: "Pos A \<in># C \<Longrightarrow> A \<in> atms_of C"
  unfolding atms_of_def by force

lemma neg_lit_in_atms_of: "Neg A \<in># C \<Longrightarrow> A \<in> atms_of C"
  unfolding atms_of_def by force

lemma atm_imp_pos_or_neg_lit: "A \<in> atms_of C \<Longrightarrow> Pos A \<in># C \<or> Neg A \<in># C"
  unfolding atms_of_def image_def mem_Collect_eq by (metis Neg_atm_of_iff Pos_atm_of_iff)

lemma atm_iff_pos_or_neg_lit: "A \<in> atms_of L \<longleftrightarrow> Pos A \<in># L \<or> Neg A \<in># L"
  by (auto intro: pos_lit_in_atms_of neg_lit_in_atms_of dest: atm_imp_pos_or_neg_lit)

lemma atm_of_eq_atm_of: "atm_of L = atm_of L' \<longleftrightarrow> (L = L' \<or> L = -L')"
  by (cases L; cases L') auto

lemma atm_of_in_atm_of_set_iff_in_set_or_uminus_in_set: "atm_of L \<in> atm_of ` I \<longleftrightarrow> (L \<in> I \<or> -L \<in> I)"
  by (auto intro: rev_image_eqI simp: atm_of_eq_atm_of)

lemma lits_subseteq_imp_atms_subseteq: "set_mset C \<subseteq> set_mset D \<Longrightarrow> atms_of C \<subseteq> atms_of D"
  unfolding atms_of_def by blast

lemma atms_empty_iff_empty[iff]: "atms_of C = {} \<longleftrightarrow> C = {#}"
  unfolding atms_of_def image_def Collect_empty_eq by auto

lemma
  atms_of_poss[simp]: "atms_of (poss AA) = set_mset AA" and
  atms_of_negs[simp]: "atms_of (negs AA) = set_mset AA"
  unfolding atms_of_def image_def by auto

lemma less_eq_Max_atms_of: "C \<noteq> {#} \<Longrightarrow> C \<le> D \<Longrightarrow> Max (atms_of C) \<le> Max (atms_of D)"
  unfolding atms_of_def
  by (metis Max_atm_of_set_mset_commute leq_imp_less_eq_atm_of less_eq_Max_lit
      less_eq_multiset_empty_right)

lemma le_multiset_Max_in_imp_Max:
  "Max (atms_of D) = A \<Longrightarrow> C \<le> D \<Longrightarrow> A \<in> atms_of C \<Longrightarrow> Max (atms_of C) = A"
  by (metis Max.coboundedI[OF finite_atms_of] atms_of_def empty_iff eq_iff image_subsetI
      less_eq_Max_atms_of set_mset_empty subset_Compl_self_eq)

lemma atm_of_Max_lit[simp]: "C \<noteq> {#} \<Longrightarrow> atm_of (Max_mset C) = Max (atms_of C)"
  unfolding atms_of_def Max_atm_of_set_mset_commute ..

lemma Max_lit_eq_pos_or_neg_Max_atm:
  "C \<noteq> {#} \<Longrightarrow> Max_mset C = Pos (Max (atms_of C)) \<or> Max_mset C = Neg (Max (atms_of C))"
  by (metis Neg_atm_of_iff Pos_atm_of_iff atm_of_Max_lit)

lemma atms_less_imp_lit_less_pos: "(\<And>B. B \<in> atms_of C \<Longrightarrow> B < A) \<Longrightarrow> L \<in># C \<Longrightarrow> L < Pos A"
  unfolding atms_of_def less_literal_def by force

lemma atms_less_eq_imp_lit_less_eq_neg: "(\<And>B. B \<in> atms_of C \<Longrightarrow> B \<le> A) \<Longrightarrow> L \<in># C \<Longrightarrow> L \<le> Neg A"
  unfolding less_eq_literal_def by (simp add: atm_of_lit_in_atms_of)

end


(*  Author:  Florian Haftmann, TUM
*)

section \<open>Proof of concept for purely algebraically founded lists of bits\<close>

theory Bit_Operations
  imports
    "HOL-Library.Boolean_Algebra"
    Main
begin

subsection \<open>Bit operations in suitable algebraic structures\<close>

class semiring_bit_operations = semiring_bit_shifts +
  fixes "and" :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>AND\<close> 64)
    and or :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>OR\<close>  59)
    and xor :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>XOR\<close> 59)
  assumes bit_and_iff: \<open>\<And>n. bit (a AND b) n \<longleftrightarrow> bit a n \<and> bit b n\<close>
    and bit_or_iff: \<open>\<And>n. bit (a OR b) n \<longleftrightarrow> bit a n \<or> bit b n\<close>
    and bit_xor_iff: \<open>\<And>n. bit (a XOR b) n \<longleftrightarrow> bit a n \<noteq> bit b n\<close>
begin

text \<open>
  We want the bitwise operations to bind slightly weaker
  than \<open>+\<close> and \<open>-\<close>.
  For the sake of code generation
  the operations \<^const>\<open>and\<close>, \<^const>\<open>or\<close> and \<^const>\<open>xor\<close>
  are specified as definitional class operations.
\<close>

sublocale "and": semilattice \<open>(AND)\<close>
  by standard (auto simp add: bit_eq_iff bit_and_iff)

sublocale or: semilattice_neutr \<open>(OR)\<close> 0
  by standard (auto simp add: bit_eq_iff bit_or_iff)

sublocale xor: comm_monoid \<open>(XOR)\<close> 0
  by standard (auto simp add: bit_eq_iff bit_xor_iff)

lemma even_and_iff:
  \<open>even (a AND b) \<longleftrightarrow> even a \<or> even b\<close>
  using bit_and_iff [of a b 0] by auto

lemma even_or_iff:
  \<open>even (a OR b) \<longleftrightarrow> even a \<and> even b\<close>
  using bit_or_iff [of a b 0] by auto

lemma even_xor_iff:
  \<open>even (a XOR b) \<longleftrightarrow> (even a \<longleftrightarrow> even b)\<close>
  using bit_xor_iff [of a b 0] by auto

lemma zero_and_eq [simp]:
  "0 AND a = 0"
  by (simp add: bit_eq_iff bit_and_iff)

lemma and_zero_eq [simp]:
  "a AND 0 = 0"
  by (simp add: bit_eq_iff bit_and_iff)

lemma one_and_eq [simp]:
  "1 AND a = a mod 2"
  by (simp add: bit_eq_iff bit_and_iff) (auto simp add: bit_1_iff)

lemma and_one_eq [simp]:
  "a AND 1 = a mod 2"
  using one_and_eq [of a] by (simp add: ac_simps)

lemma one_or_eq:
  "1 OR a = a + of_bool (even a)"
  by (simp add: bit_eq_iff bit_or_iff add.commute [of _ 1] even_bit_succ_iff) (auto simp add: bit_1_iff)

lemma or_one_eq:
  "a OR 1 = a + of_bool (even a)"
  using one_or_eq [of a] by (simp add: ac_simps)

lemma one_xor_eq:
  "1 XOR a = a + of_bool (even a) - of_bool (odd a)"
  by (simp add: bit_eq_iff bit_xor_iff add.commute [of _ 1] even_bit_succ_iff) (auto simp add: bit_1_iff odd_bit_iff_bit_pred elim: oddE)

lemma xor_one_eq:
  "a XOR 1 = a + of_bool (even a) - of_bool (odd a)"
  using one_xor_eq [of a] by (simp add: ac_simps)

lemma take_bit_and [simp]:
  \<open>take_bit n (a AND b) = take_bit n a AND take_bit n b\<close>
  by (auto simp add: bit_eq_iff bit_take_bit_iff bit_and_iff)

lemma take_bit_or [simp]:
  \<open>take_bit n (a OR b) = take_bit n a OR take_bit n b\<close>
  by (auto simp add: bit_eq_iff bit_take_bit_iff bit_or_iff)

lemma take_bit_xor [simp]:
  \<open>take_bit n (a XOR b) = take_bit n a XOR take_bit n b\<close>
  by (auto simp add: bit_eq_iff bit_take_bit_iff bit_xor_iff)

definition mask :: \<open>nat \<Rightarrow> 'a\<close>
  where mask_eq_exp_minus_1: \<open>mask n = 2 ^ n - 1\<close>

lemma bit_mask_iff:
  \<open>bit (mask m) n \<longleftrightarrow> 2 ^ n \<noteq> 0 \<and> n < m\<close>
  by (simp add: mask_eq_exp_minus_1 bit_mask_iff)

lemma even_mask_iff:
  \<open>even (mask n) \<longleftrightarrow> n = 0\<close>
  using bit_mask_iff [of n 0] by auto

lemma mask_0 [simp, code]:
  \<open>mask 0 = 0\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma mask_Suc_exp [code]:
  \<open>mask (Suc n) = 2 ^ n OR mask n\<close>
  by (rule bit_eqI)
    (auto simp add: bit_or_iff bit_mask_iff bit_exp_iff not_less le_less_Suc_eq)

lemma mask_Suc_double:
  \<open>mask (Suc n) = 2 * mask n OR 1\<close>
proof (rule bit_eqI)
  fix q
  assume \<open>2 ^ q \<noteq> 0\<close>
  show \<open>bit (mask (Suc n)) q \<longleftrightarrow> bit (2 * mask n OR 1) q\<close>
    by (cases q)
      (simp_all add: even_mask_iff even_or_iff bit_or_iff bit_mask_iff bit_exp_iff bit_double_iff not_less le_less_Suc_eq bit_1_iff, auto simp add: mult_2)
qed

lemma take_bit_eq_mask [code]:
  \<open>take_bit n a = a AND mask n\<close>
  by (rule bit_eqI)
    (auto simp add: bit_take_bit_iff bit_and_iff bit_mask_iff)

end

class ring_bit_operations = semiring_bit_operations + ring_parity +
  fixes not :: \<open>'a \<Rightarrow> 'a\<close>  (\<open>NOT\<close>)
  assumes bit_not_iff: \<open>\<And>n. bit (NOT a) n \<longleftrightarrow> 2 ^ n \<noteq> 0 \<and> \<not> bit a n\<close>
  assumes minus_eq_not_minus_1: \<open>- a = NOT (a - 1)\<close>
begin

text \<open>
  For the sake of code generation \<^const>\<open>not\<close> is specified as
  definitional class operation.  Note that \<^const>\<open>not\<close> has no
  sensible definition for unlimited but only positive bit strings
  (type \<^typ>\<open>nat\<close>).
\<close>

lemma bits_minus_1_mod_2_eq [simp]:
  \<open>(- 1) mod 2 = 1\<close>
  by (simp add: mod_2_eq_odd)

lemma not_eq_complement:
  \<open>NOT a = - a - 1\<close>
  using minus_eq_not_minus_1 [of \<open>a + 1\<close>] by simp

lemma minus_eq_not_plus_1:
  \<open>- a = NOT a + 1\<close>
  using not_eq_complement [of a] by simp

lemma bit_minus_iff:
  \<open>bit (- a) n \<longleftrightarrow> 2 ^ n \<noteq> 0 \<and> \<not> bit (a - 1) n\<close>
  by (simp add: minus_eq_not_minus_1 bit_not_iff)

lemma even_not_iff [simp]:
  "even (NOT a) \<longleftrightarrow> odd a"
  using bit_not_iff [of a 0] by auto

lemma bit_not_exp_iff:
  \<open>bit (NOT (2 ^ m)) n \<longleftrightarrow> 2 ^ n \<noteq> 0 \<and> n \<noteq> m\<close>
  by (auto simp add: bit_not_iff bit_exp_iff)

lemma bit_minus_1_iff [simp]:
  \<open>bit (- 1) n \<longleftrightarrow> 2 ^ n \<noteq> 0\<close>
  by (simp add: bit_minus_iff)

lemma bit_minus_exp_iff:
  \<open>bit (- (2 ^ m)) n \<longleftrightarrow> 2 ^ n \<noteq> 0 \<and> n \<ge> m\<close>
  oops

lemma bit_minus_2_iff [simp]:
  \<open>bit (- 2) n \<longleftrightarrow> 2 ^ n \<noteq> 0 \<and> n > 0\<close>
  by (simp add: bit_minus_iff bit_1_iff)

lemma not_one [simp]:
  "NOT 1 = - 2"
  by (simp add: bit_eq_iff bit_not_iff) (simp add: bit_1_iff)

sublocale "and": semilattice_neutr \<open>(AND)\<close> \<open>- 1\<close>
  apply standard
  apply (simp add: bit_eq_iff bit_and_iff)
  apply (auto simp add: exp_eq_0_imp_not_bit bit_exp_iff)
  done

sublocale bit: boolean_algebra \<open>(AND)\<close> \<open>(OR)\<close> NOT 0 \<open>- 1\<close>
  rewrites \<open>bit.xor = (XOR)\<close>
proof -
  interpret bit: boolean_algebra \<open>(AND)\<close> \<open>(OR)\<close> NOT 0 \<open>- 1\<close>
    apply standard
         apply (simp_all add: bit_eq_iff bit_and_iff bit_or_iff bit_not_iff)
      apply (auto simp add: exp_eq_0_imp_not_bit bit_exp_iff)
    done
  show \<open>boolean_algebra (AND) (OR) NOT 0 (- 1)\<close>
    by standard
  show \<open>boolean_algebra.xor (AND) (OR) NOT = (XOR)\<close>
    apply (auto simp add: fun_eq_iff bit.xor_def bit_eq_iff bit_and_iff bit_or_iff bit_not_iff bit_xor_iff)
         apply (simp_all add: bit_exp_iff, simp_all add: bit_def)
        apply (metis local.bit_exp_iff local.bits_div_by_0)
       apply (metis local.bit_exp_iff local.bits_div_by_0)
    done
qed

lemma and_eq_not_not_or:
  \<open>a AND b = NOT (NOT a OR NOT b)\<close>
  by simp

lemma or_eq_not_not_and:
  \<open>a OR b = NOT (NOT a AND NOT b)\<close>
  by simp

lemma push_bit_minus:
  \<open>push_bit n (- a) = - push_bit n a\<close>
  by (simp add: push_bit_eq_mult)

lemma take_bit_not_take_bit:
  \<open>take_bit n (NOT (take_bit n a)) = take_bit n (NOT a)\<close>
  by (auto simp add: bit_eq_iff bit_take_bit_iff bit_not_iff)

lemma take_bit_not_iff:
  "take_bit n (NOT a) = take_bit n (NOT b) \<longleftrightarrow> take_bit n a = take_bit n b"
  apply (simp add: bit_eq_iff bit_not_iff bit_take_bit_iff)
  apply (simp add: bit_exp_iff)
  apply (use local.exp_eq_0_imp_not_bit in blast)
  done

definition set_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where \<open>set_bit n a = a OR 2 ^ n\<close>

definition unset_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where \<open>unset_bit n a = a AND NOT (2 ^ n)\<close>

definition flip_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where \<open>flip_bit n a = a XOR 2 ^ n\<close>

lemma bit_set_bit_iff:
  \<open>bit (set_bit m a) n \<longleftrightarrow> bit a n \<or> (m = n \<and> 2 ^ n \<noteq> 0)\<close>
  by (auto simp add: set_bit_def bit_or_iff bit_exp_iff)

lemma even_set_bit_iff:
  \<open>even (set_bit m a) \<longleftrightarrow> even a \<and> m \<noteq> 0\<close>
  using bit_set_bit_iff [of m a 0] by auto

lemma bit_unset_bit_iff:
  \<open>bit (unset_bit m a) n \<longleftrightarrow> bit a n \<and> m \<noteq> n\<close>
  by (auto simp add: unset_bit_def bit_and_iff bit_not_iff bit_exp_iff exp_eq_0_imp_not_bit)

lemma even_unset_bit_iff:
  \<open>even (unset_bit m a) \<longleftrightarrow> even a \<or> m = 0\<close>
  using bit_unset_bit_iff [of m a 0] by auto

lemma bit_flip_bit_iff:
  \<open>bit (flip_bit m a) n \<longleftrightarrow> (m = n \<longleftrightarrow> \<not> bit a n) \<and> 2 ^ n \<noteq> 0\<close>
  by (auto simp add: flip_bit_def bit_xor_iff bit_exp_iff exp_eq_0_imp_not_bit)

lemma even_flip_bit_iff:
  \<open>even (flip_bit m a) \<longleftrightarrow> \<not> (even a \<longleftrightarrow> m = 0)\<close>
  using bit_flip_bit_iff [of m a 0] by auto

lemma set_bit_0 [simp]:
  \<open>set_bit 0 a = 1 + 2 * (a div 2)\<close>
proof (rule bit_eqI)
  fix m
  assume *: \<open>2 ^ m \<noteq> 0\<close>
  then show \<open>bit (set_bit 0 a) m = bit (1 + 2 * (a div 2)) m\<close>
    by (simp add: bit_set_bit_iff bit_double_iff even_bit_succ_iff)
      (cases m, simp_all add: bit_Suc)
qed

lemma set_bit_Suc:
  \<open>set_bit (Suc n) a = a mod 2 + 2 * set_bit n (a div 2)\<close>
proof (rule bit_eqI)
  fix m
  assume *: \<open>2 ^ m \<noteq> 0\<close>
  show \<open>bit (set_bit (Suc n) a) m \<longleftrightarrow> bit (a mod 2 + 2 * set_bit n (a div 2)) m\<close>
  proof (cases m)
    case 0
    then show ?thesis
      by (simp add: even_set_bit_iff)
  next
    case (Suc m)
    with * have \<open>2 ^ m \<noteq> 0\<close>
      using mult_2 by auto
    show ?thesis
      by (cases a rule: parity_cases)
        (simp_all add: bit_set_bit_iff bit_double_iff even_bit_succ_iff *,
        simp_all add: Suc \<open>2 ^ m \<noteq> 0\<close> bit_Suc)
  qed
qed

lemma unset_bit_0 [simp]:
  \<open>unset_bit 0 a = 2 * (a div 2)\<close>
proof (rule bit_eqI)
  fix m
  assume *: \<open>2 ^ m \<noteq> 0\<close>
  then show \<open>bit (unset_bit 0 a) m = bit (2 * (a div 2)) m\<close>
    by (simp add: bit_unset_bit_iff bit_double_iff)
      (cases m, simp_all add: bit_Suc)
qed

lemma unset_bit_Suc:
  \<open>unset_bit (Suc n) a = a mod 2 + 2 * unset_bit n (a div 2)\<close>
proof (rule bit_eqI)
  fix m
  assume *: \<open>2 ^ m \<noteq> 0\<close>
  then show \<open>bit (unset_bit (Suc n) a) m \<longleftrightarrow> bit (a mod 2 + 2 * unset_bit n (a div 2)) m\<close>
  proof (cases m)
    case 0
    then show ?thesis
      by (simp add: even_unset_bit_iff)
  next
    case (Suc m)
    show ?thesis
      by (cases a rule: parity_cases)
        (simp_all add: bit_unset_bit_iff bit_double_iff even_bit_succ_iff *,
         simp_all add: Suc bit_Suc)
  qed
qed

lemma flip_bit_0 [simp]:
  \<open>flip_bit 0 a = of_bool (even a) + 2 * (a div 2)\<close>
proof (rule bit_eqI)
  fix m
  assume *: \<open>2 ^ m \<noteq> 0\<close>
  then show \<open>bit (flip_bit 0 a) m = bit (of_bool (even a) + 2 * (a div 2)) m\<close>
    by (simp add: bit_flip_bit_iff bit_double_iff even_bit_succ_iff)
      (cases m, simp_all add: bit_Suc)
qed

lemma flip_bit_Suc:
  \<open>flip_bit (Suc n) a = a mod 2 + 2 * flip_bit n (a div 2)\<close>
proof (rule bit_eqI)
  fix m
  assume *: \<open>2 ^ m \<noteq> 0\<close>
  show \<open>bit (flip_bit (Suc n) a) m \<longleftrightarrow> bit (a mod 2 + 2 * flip_bit n (a div 2)) m\<close>
  proof (cases m)
    case 0
    then show ?thesis
      by (simp add: even_flip_bit_iff)
  next
    case (Suc m)
    with * have \<open>2 ^ m \<noteq> 0\<close>
      using mult_2 by auto
    show ?thesis
      by (cases a rule: parity_cases)
        (simp_all add: bit_flip_bit_iff bit_double_iff even_bit_succ_iff,
        simp_all add: Suc \<open>2 ^ m \<noteq> 0\<close> bit_Suc)
  qed
qed

end

subsubsection \<open>Instance \<^typ>\<open>int\<close>\<close>

instantiation int :: ring_bit_operations
begin

definition not_int :: \<open>int \<Rightarrow> int\<close>
  where \<open>not_int k = - k - 1\<close>

lemma not_int_rec:
  "NOT k = of_bool (even k) + 2 * NOT (k div 2)" for k :: int
  by (auto simp add: not_int_def elim: oddE)

lemma even_not_iff_int:
  \<open>even (NOT k) \<longleftrightarrow> odd k\<close> for k :: int
  by (simp add: not_int_def)

lemma not_int_div_2:
  \<open>NOT k div 2 = NOT (k div 2)\<close> for k :: int
  by (simp add: not_int_def)

lemma bit_not_int_iff:
  \<open>bit (NOT k) n \<longleftrightarrow> \<not> bit k n\<close>
    for k :: int
  by (induction n arbitrary: k) (simp_all add: not_int_div_2 even_not_iff_int bit_Suc)

function and_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>(k::int) AND l = (if k \<in> {0, - 1} \<and> l \<in> {0, - 1}
    then - of_bool (odd k \<and> odd l)
    else of_bool (odd k \<and> odd l) + 2 * ((k div 2) AND (l div 2)))\<close>
  by auto

termination
  by (relation \<open>measure (\<lambda>(k, l). nat (\<bar>k\<bar> + \<bar>l\<bar>))\<close>) auto

declare and_int.simps [simp del]

lemma and_int_rec:
  \<open>k AND l = of_bool (odd k \<and> odd l) + 2 * ((k div 2) AND (l div 2))\<close>
    for k l :: int
proof (cases \<open>k \<in> {0, - 1} \<and> l \<in> {0, - 1}\<close>)
  case True
  then show ?thesis
    by auto (simp_all add: and_int.simps)
next
  case False
  then show ?thesis
    by (auto simp add: ac_simps and_int.simps [of k l])
qed

lemma bit_and_int_iff:
  \<open>bit (k AND l) n \<longleftrightarrow> bit k n \<and> bit l n\<close> for k l :: int
proof (induction n arbitrary: k l)
  case 0
  then show ?case
    by (simp add: and_int_rec [of k l])
next
  case (Suc n)
  then show ?case
    by (simp add: and_int_rec [of k l] bit_Suc)
qed

lemma even_and_iff_int:
  \<open>even (k AND l) \<longleftrightarrow> even k \<or> even l\<close> for k l :: int
  using bit_and_int_iff [of k l 0] by auto

definition or_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>k OR l = NOT (NOT k AND NOT l)\<close> for k l :: int

lemma or_int_rec:
  \<open>k OR l = of_bool (odd k \<or> odd l) + 2 * ((k div 2) OR (l div 2))\<close>
  for k l :: int
  using and_int_rec [of \<open>NOT k\<close> \<open>NOT l\<close>]
  by (simp add: or_int_def even_not_iff_int not_int_div_2)
    (simp add: not_int_def)

lemma bit_or_int_iff:
  \<open>bit (k OR l) n \<longleftrightarrow> bit k n \<or> bit l n\<close> for k l :: int
  by (simp add: or_int_def bit_not_int_iff bit_and_int_iff)

definition xor_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>k XOR l = k AND NOT l OR NOT k AND l\<close> for k l :: int

lemma xor_int_rec:
  \<open>k XOR l = of_bool (odd k \<noteq> odd l) + 2 * ((k div 2) XOR (l div 2))\<close>
  for k l :: int
  by (simp add: xor_int_def or_int_rec [of \<open>k AND NOT l\<close> \<open>NOT k AND l\<close>] even_and_iff_int even_not_iff_int)
    (simp add: and_int_rec [of \<open>NOT k\<close> \<open>l\<close>] and_int_rec [of \<open>k\<close> \<open>NOT l\<close>] not_int_div_2)

lemma bit_xor_int_iff:
  \<open>bit (k XOR l) n \<longleftrightarrow> bit k n \<noteq> bit l n\<close> for k l :: int
  by (auto simp add: xor_int_def bit_or_int_iff bit_and_int_iff bit_not_int_iff)

instance proof
  fix k l :: int and n :: nat
  show \<open>- k = NOT (k - 1)\<close>
    by (simp add: not_int_def)
  show \<open>bit (k AND l) n \<longleftrightarrow> bit k n \<and> bit l n\<close>
    by (fact bit_and_int_iff)
  show \<open>bit (k OR l) n \<longleftrightarrow> bit k n \<or> bit l n\<close>
    by (fact bit_or_int_iff)
  show \<open>bit (k XOR l) n \<longleftrightarrow> bit k n \<noteq> bit l n\<close>
    by (fact bit_xor_int_iff)
qed (simp_all add: bit_not_int_iff)

end

lemma not_nonnegative_int_iff [simp]:
  \<open>NOT k \<ge> 0 \<longleftrightarrow> k < 0\<close> for k :: int
  by (simp add: not_int_def)

lemma not_negative_int_iff [simp]:
  \<open>NOT k < 0 \<longleftrightarrow> k \<ge> 0\<close> for k :: int
  by (subst Not_eq_iff [symmetric]) (simp add: not_less not_le)

lemma and_nonnegative_int_iff [simp]:
  \<open>k AND l \<ge> 0 \<longleftrightarrow> k \<ge> 0 \<or> l \<ge> 0\<close> for k l :: int
proof (induction k arbitrary: l rule: int_bit_induct)
  case zero
  then show ?case
    by simp
next
  case minus
  then show ?case
    by simp
next
  case (even k)
  then show ?case
    using and_int_rec [of \<open>k * 2\<close> l] by (simp add: pos_imp_zdiv_nonneg_iff)
next
  case (odd k)
  from odd have \<open>0 \<le> k AND l div 2 \<longleftrightarrow> 0 \<le> k \<or> 0 \<le> l div 2\<close>
    by simp
  then have \<open>0 \<le> (1 + k * 2) div 2 AND l div 2 \<longleftrightarrow> 0 \<le> (1 + k * 2) div 2\<or> 0 \<le> l div 2\<close>
    by simp
  with and_int_rec [of \<open>1 + k * 2\<close> l]
  show ?case
    by auto
qed

lemma and_negative_int_iff [simp]:
  \<open>k AND l < 0 \<longleftrightarrow> k < 0 \<and> l < 0\<close> for k l :: int
  by (subst Not_eq_iff [symmetric]) (simp add: not_less)

lemma or_nonnegative_int_iff [simp]:
  \<open>k OR l \<ge> 0 \<longleftrightarrow> k \<ge> 0 \<and> l \<ge> 0\<close> for k l :: int
  by (simp only: or_eq_not_not_and not_nonnegative_int_iff) simp

lemma or_negative_int_iff [simp]:
  \<open>k OR l < 0 \<longleftrightarrow> k < 0 \<or> l < 0\<close> for k l :: int
  by (subst Not_eq_iff [symmetric]) (simp add: not_less)

lemma xor_nonnegative_int_iff [simp]:
  \<open>k XOR l \<ge> 0 \<longleftrightarrow> (k \<ge> 0 \<longleftrightarrow> l \<ge> 0)\<close> for k l :: int
  by (simp only: bit.xor_def or_nonnegative_int_iff) auto

lemma xor_negative_int_iff [simp]:
  \<open>k XOR l < 0 \<longleftrightarrow> (k < 0) \<noteq> (l < 0)\<close> for k l :: int
  by (subst Not_eq_iff [symmetric]) (auto simp add: not_less)

lemma set_bit_nonnegative_int_iff [simp]:
  \<open>set_bit n k \<ge> 0 \<longleftrightarrow> k \<ge> 0\<close> for k :: int
  by (simp add: set_bit_def)

lemma set_bit_negative_int_iff [simp]:
  \<open>set_bit n k < 0 \<longleftrightarrow> k < 0\<close> for k :: int
  by (simp add: set_bit_def)

lemma unset_bit_nonnegative_int_iff [simp]:
  \<open>unset_bit n k \<ge> 0 \<longleftrightarrow> k \<ge> 0\<close> for k :: int
  by (simp add: unset_bit_def)

lemma unset_bit_negative_int_iff [simp]:
  \<open>unset_bit n k < 0 \<longleftrightarrow> k < 0\<close> for k :: int
  by (simp add: unset_bit_def)

lemma flip_bit_nonnegative_int_iff [simp]:
  \<open>flip_bit n k \<ge> 0 \<longleftrightarrow> k \<ge> 0\<close> for k :: int
  by (simp add: flip_bit_def)

lemma flip_bit_negative_int_iff [simp]:
  \<open>flip_bit n k < 0 \<longleftrightarrow> k < 0\<close> for k :: int
  by (simp add: flip_bit_def)

subsubsection \<open>Instance \<^typ>\<open>nat\<close>\<close>

instantiation nat :: semiring_bit_operations
begin

definition and_nat :: \<open>nat \<Rightarrow> nat \<Rightarrow> nat\<close>
  where \<open>m AND n = nat (int m AND int n)\<close> for m n :: nat

definition or_nat :: \<open>nat \<Rightarrow> nat \<Rightarrow> nat\<close>
  where \<open>m OR n = nat (int m OR int n)\<close> for m n :: nat

definition xor_nat :: \<open>nat \<Rightarrow> nat \<Rightarrow> nat\<close>
  where \<open>m XOR n = nat (int m XOR int n)\<close> for m n :: nat

instance proof
  fix m n q :: nat
  show \<open>bit (m AND n) q \<longleftrightarrow> bit m q \<and> bit n q\<close>
    by (auto simp add: and_nat_def bit_and_iff less_le bit_eq_iff)
  show \<open>bit (m OR n) q \<longleftrightarrow> bit m q \<or> bit n q\<close>
    by (auto simp add: or_nat_def bit_or_iff less_le bit_eq_iff)
  show \<open>bit (m XOR n) q \<longleftrightarrow> bit m q \<noteq> bit n q\<close>
    by (auto simp add: xor_nat_def bit_xor_iff less_le bit_eq_iff)
qed

end

lemma and_nat_rec:
  \<open>m AND n = of_bool (odd m \<and> odd n) + 2 * ((m div 2) AND (n div 2))\<close> for m n :: nat
  by (simp add: and_nat_def and_int_rec [of \<open>int m\<close> \<open>int n\<close>] zdiv_int nat_add_distrib nat_mult_distrib)

lemma or_nat_rec:
  \<open>m OR n = of_bool (odd m \<or> odd n) + 2 * ((m div 2) OR (n div 2))\<close> for m n :: nat
  by (simp add: or_nat_def or_int_rec [of \<open>int m\<close> \<open>int n\<close>] zdiv_int nat_add_distrib nat_mult_distrib)

lemma xor_nat_rec:
  \<open>m XOR n = of_bool (odd m \<noteq> odd n) + 2 * ((m div 2) XOR (n div 2))\<close> for m n :: nat
  by (simp add: xor_nat_def xor_int_rec [of \<open>int m\<close> \<open>int n\<close>] zdiv_int nat_add_distrib nat_mult_distrib)

lemma Suc_0_and_eq [simp]:
  \<open>Suc 0 AND n = n mod 2\<close>
  using one_and_eq [of n] by simp

lemma and_Suc_0_eq [simp]:
  \<open>n AND Suc 0 = n mod 2\<close>
  using and_one_eq [of n] by simp

lemma Suc_0_or_eq:
  \<open>Suc 0 OR n = n + of_bool (even n)\<close>
  using one_or_eq [of n] by simp

lemma or_Suc_0_eq:
  \<open>n OR Suc 0 = n + of_bool (even n)\<close>
  using or_one_eq [of n] by simp

lemma Suc_0_xor_eq:
  \<open>Suc 0 XOR n = n + of_bool (even n) - of_bool (odd n)\<close>
  using one_xor_eq [of n] by simp

lemma xor_Suc_0_eq:
  \<open>n XOR Suc 0 = n + of_bool (even n) - of_bool (odd n)\<close>
  using xor_one_eq [of n] by simp

subsubsection \<open>Instances for \<^typ>\<open>integer\<close> and \<^typ>\<open>natural\<close>\<close>

unbundle integer.lifting natural.lifting

context
  includes lifting_syntax
begin

lemma transfer_rule_bit_integer [transfer_rule]:
  \<open>((pcr_integer :: int \<Rightarrow> integer \<Rightarrow> bool) ===> (=)) bit bit\<close>
  by (unfold bit_def) transfer_prover

lemma transfer_rule_bit_natural [transfer_rule]:
  \<open>((pcr_natural :: nat \<Rightarrow> natural \<Rightarrow> bool) ===> (=)) bit bit\<close>
  by (unfold bit_def) transfer_prover

end

instantiation integer :: ring_bit_operations
begin

lift_definition not_integer :: \<open>integer \<Rightarrow> integer\<close>
  is not .

lift_definition and_integer :: \<open>integer \<Rightarrow> integer \<Rightarrow> integer\<close>
  is \<open>and\<close> .

lift_definition or_integer :: \<open>integer \<Rightarrow> integer \<Rightarrow> integer\<close>
  is or .

lift_definition xor_integer ::  \<open>integer \<Rightarrow> integer \<Rightarrow> integer\<close>
  is xor .

instance proof
  fix k l :: \<open>integer\<close> and n :: nat
  show \<open>- k = NOT (k - 1)\<close>
    by transfer (simp add: minus_eq_not_minus_1)
  show \<open>bit (NOT k) n \<longleftrightarrow> (2 :: integer) ^ n \<noteq> 0 \<and> \<not> bit k n\<close>
    by transfer (fact bit_not_iff)
  show \<open>bit (k AND l) n \<longleftrightarrow> bit k n \<and> bit l n\<close>
    by transfer (fact bit_and_iff)
  show \<open>bit (k OR l) n \<longleftrightarrow> bit k n \<or> bit l n\<close>
    by transfer (fact bit_or_iff)
  show \<open>bit (k XOR l) n \<longleftrightarrow> bit k n \<noteq> bit l n\<close>
    by transfer (fact bit_xor_iff)
qed

end

instantiation natural :: semiring_bit_operations
begin

lift_definition and_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>and\<close> .

lift_definition or_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is or .

lift_definition xor_natural ::  \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is xor .

instance proof
  fix m n :: \<open>natural\<close> and q :: nat
  show \<open>bit (m AND n) q \<longleftrightarrow> bit m q \<and> bit n q\<close>
    by transfer (fact bit_and_iff)
  show \<open>bit (m OR n) q \<longleftrightarrow> bit m q \<or> bit n q\<close>
    by transfer (fact bit_or_iff)
  show \<open>bit (m XOR n) q \<longleftrightarrow> bit m q \<noteq> bit n q\<close>
    by transfer (fact bit_xor_iff)
qed

end

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

subsection \<open>Key ideas of bit operations\<close>

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

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

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

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

  \<^item> From this idea follows that

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

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

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

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

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

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

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

  \<^item> Typical operations are characterized as follows:

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

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

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

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

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

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

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

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

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

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

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

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

end


theory Indexed_Typed_Predicate_Language
  imports Primed_Typed_Predicate_Language
begin

text \<open>
Extend the predicate language with a concept of indexed variables
\<close>

type_synonym ('var,'val) iexp = "(nat\<times>'var,'val) exp"
type_synonym ('var,'val) ipred = "(nat\<times>'var,'val) pred"

definition merge (infixr "\<Oplus>" 50)
  where "merge m\<^sub>1 m\<^sub>2 \<equiv> \<lambda>(n,x). (case (n::nat) of 0 \<Rightarrow> m\<^sub>1 x | Suc m \<Rightarrow> m\<^sub>2 (m,x))"

abbreviation orig_var ("_\<^sup>0" [1000] 1000)
  where "x\<^sup>0 \<equiv> (0,x)"

abbreviation prime_var ("_\<^sup>1" [1000] 1000)
  where "x\<^sup>1 \<equiv> (Suc 0,x)"

definition prime
  where "prime P ign \<equiv> map\<^sub>o (\<lambda>x. if snd x \<in> ign \<and> fst x = 0 then (Suc (fst x), snd x) else x)
                       (map\<^sub>p (\<lambda>x. if snd x \<in> ign \<and> fst x = 0 then x else (Suc (fst x), snd x)) P)"

definition unprime
  where "unprime P \<equiv> map\<^sub>p (\<lambda>x. case x of (0,v) \<Rightarrow> (0,v) | (Suc n,v) \<Rightarrow> (n, v)) P"

definition exp\<^sub>0 :: "('Var,'Val) exp \<Rightarrow> ('Var,'Val) iexp"
  where "exp\<^sub>0 P = map\<^sub>e (\<lambda>x. (0,x)) P"

definition pred\<^sub>0 :: "('Var,'Val) pred \<Rightarrow> ('Var,'Val) ipred"
  where "pred\<^sub>0 P = map\<^sub>p (\<lambda>x. (0,x)) P"

definition pred\<^sub>r :: "('Var,'Val) rpred \<Rightarrow> ('Var,'Val) ipred"
  where "pred\<^sub>r P \<equiv> map\<^sub>p (case_Primed (Pair 0) (Pair 1)) P"

definition asn :: "('var,'val) Mem \<Rightarrow> 'var Type \<Rightarrow> ('var,'val) ipred \<Rightarrow> bool"
  where "asn m \<Gamma> P \<equiv> \<forall>m' \<Gamma>'. test (m \<Oplus> m') (\<Gamma> \<Oplus> \<Gamma>') P"

definition mergei
  where "mergei m\<^sub>1 i m\<^sub>2 \<equiv> \<lambda>(n,x). if x \<in> i \<and> n = 0 then m\<^sub>1 (x) else m\<^sub>2 (n,x)"

lemma prime [simp]:
  "test (m' \<Oplus> m'') (\<Gamma>' \<Oplus> \<Gamma>'') (prime Q i) = test (mergei m' i m'') (\<Gamma>'') Q"
proof -
  let ?\<Gamma>="(\<lambda>x. if snd x \<in> i \<and> fst x = 0 then \<Gamma>'' x else (\<Gamma>' \<Oplus> \<Gamma>'') x)"

  have a: "test (mergei m' i m'') \<Gamma>'' Q = test (m' \<Oplus> m'') ?\<Gamma> (map\<^sub>p (\<lambda>x. if snd x \<in> i \<and> fst x = 0 then x else (Suc (fst x), snd x)) Q)"
    unfolding prime_def
    apply (intro allI map\<^sub>p_vars_det)
    by (auto simp: merge_def mergei_def split: nat.splits)
  have b: "test (m' \<Oplus> m'') ?\<Gamma> (map\<^sub>p (\<lambda>x. if snd x \<in> i \<and> fst x = 0 then x else (Suc (fst x), snd x)) Q) =
           test (m' \<Oplus> m'') (\<Gamma>' \<Oplus> \<Gamma>'') (map\<^sub>o (\<lambda>x. if snd x \<in> i \<and> fst x = 0 then (Suc (fst x), snd x) else x) (map\<^sub>p (\<lambda>x. if snd x \<in> i \<and> fst x = 0 then x else (Suc (fst x), snd x)) Q))"
    apply (intro allI map\<^sub>o_vars_det)
    by (auto simp: merge_def mergei_def split: nat.splits)

  show ?thesis
    unfolding prime_def
    using a b
    by blast
qed

lemma test_pred\<^sub>r [simp]:
  "test (m \<Oplus> m' \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma>' \<Oplus> \<Gamma>h) (pred\<^sub>r R) = test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') R"
proof -
  have "test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') R = test (m \<Oplus> m' \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma>' \<Oplus> \<Gamma>h) (pred\<^sub>r R)"
    unfolding pred\<^sub>r_def
    apply (intro map\<^sub>p_vars_det)
    by (auto simp: merge_def split: nat.splits Primed.splits)
  thus ?thesis by blast
qed

lemma test_pred\<^sub>r_alt:
  "(\<forall>mh \<Gamma>h. test (m \<Oplus> m' \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma>' \<Oplus> \<Gamma>h) (pred\<^sub>r R)) = test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') R"
  by (simp)

lemma merge_split:
  obtains m' mh' where "mh = (m' \<Oplus> mh')"
proof -
  have "\<forall>y. mh y = ((\<lambda>x. mh (0,x)) \<Oplus> (\<lambda>(n,x). mh (Suc n,x))) y"
    by (auto simp: merge_def split: nat.splits)
  hence "mh = ((\<lambda>x. mh (0,x)) \<Oplus> (\<lambda>(n,x). mh (Suc n,x)))" by blast
  thus ?thesis using that by auto
qed

lemma test_pred\<^sub>r' [elim!]:
  assumes "test mh \<Gamma>h (pred\<^sub>r R)"
  obtains m \<Gamma> m' \<Gamma>' mh' \<Gamma>h' where "test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') R" "mh = (m \<Oplus> m' \<Oplus> mh')" "\<Gamma>h = (\<Gamma> \<Oplus> \<Gamma>' \<Oplus> \<Gamma>h')"
proof -
  obtain m \<Gamma> mh' \<Gamma>h' where s: "mh = (m \<Oplus> mh')" "\<Gamma>h = (\<Gamma> \<Oplus> \<Gamma>h')" using merge_split by smt
  obtain m' \<Gamma>' mh'' \<Gamma>h'' where s': "mh' = (m' \<Oplus> mh'')" "\<Gamma>h' = (\<Gamma>' \<Oplus> \<Gamma>h'')" using merge_split by smt
  show ?thesis using that assms unfolding s s' by (auto simp add: )
qed

lemma asn_unprime [simp]:
  "asn m \<Gamma> (unprime G) = (\<forall>mh \<Gamma>h. test (m \<Oplus> m \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma> \<Oplus> \<Gamma>h) G)"
proof -
  have "\<forall>mh \<Gamma>h. test (m \<Oplus> m \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma> \<Oplus> \<Gamma>h) G =
              (test (m \<Oplus> mh) (\<Gamma> \<Oplus> \<Gamma>h) (map\<^sub>p (\<lambda>(a, v). case a of 0 \<Rightarrow> v\<^sup>0 | Suc n \<Rightarrow> (n, v)) G))"
    apply (intro allI map\<^sub>p_vars_det)
    by (auto simp: merge_def split: nat.splits)
  thus ?thesis unfolding asn_def unprime_def by blast
qed

lemma eval_exp\<^sub>0 [simp]:
  "eval (m \<Oplus> mh) (exp\<^sub>0 ( e)) = eval m ( e)"
proof -
  have "eval m ( e) = eval (m \<Oplus> mh) (exp\<^sub>0 ( e))"
    by (auto intro!: map\<^sub>e_vars_det simp: exp\<^sub>0_def merge_def)
  thus ?thesis by auto
qed

lemma test_pred\<^sub>0 [simp]:
  "test (m \<Oplus> m') (\<Gamma> \<Oplus> \<Gamma>') (pred\<^sub>0 P) = test m \<Gamma> P"
proof -
  have "test m \<Gamma> P = test (m \<Oplus> m') (\<Gamma> \<Oplus> \<Gamma>')  (pred\<^sub>0 P)"
    by (auto intro!: map\<^sub>p_vars_det simp: pred\<^sub>0_def merge_def)
  thus ?thesis by auto
qed

lemma asn_pred\<^sub>0[simp]:
  "asn m \<Gamma> (pred\<^sub>0 (P :: ('a, 'b) pred)) = test m \<Gamma> P"
  unfolding asn_def by simp

lemma [simp]:
  "asn m \<Gamma> (pred\<^sub>0 P \<longrightarrow>\<^sub>p Q) = (test m \<Gamma> P \<longrightarrow> asn m \<Gamma> Q)"
  unfolding asn_def by simp

lemma merge_0[simp]:
  "(m \<Oplus> m')(x\<^sup>0 := e) = (m(x := e) \<Oplus> m')" (is "?l = ?r")
proof -
  have "\<forall>y. ?l y = ?r y" by (auto simp: merge_def split: nat.splits)
  thus ?thesis by blast
qed

lemma merge_1[simp]:
  "(m \<Oplus> m' \<Oplus> mh)(x\<^sup>1 := e) = (m \<Oplus> m'(x := e) \<Oplus> mh)" (is "?l = ?r")
proof -
  have "\<forall>y. ?l y = ?r y" by (auto simp: merge_def split: nat.splits)
  thus ?thesis by blast
qed

lemma asn_subst\<^sub>\<Gamma>[simp]:
  "asn m \<Gamma> (subst\<^sub>\<Gamma> Q x\<^sup>0 (pred\<^sub>0 e)) = asn m (\<Gamma>(x := test m \<Gamma> e)) Q"
  unfolding asn_def by simp

lemma asn_subst\<^sub>p[simp]:
  "asn m \<Gamma> (subst\<^sub>p Q x\<^sup>0 (exp\<^sub>0 e)) = asn (m(x := eval m e)) \<Gamma> Q"
  unfolding asn_def by simp

lemma merge_eq [simp]:
  "( (m1 \<Oplus> m1') = (m2 \<Oplus> m2') ) = (m1 = m2 \<and> m1' = m2')"
proof
  assume "(m1 \<Oplus> m1') = (m2 \<Oplus> m2')"
  hence "\<forall>x. (m1 \<Oplus> m1') (0,x) = (m2 \<Oplus> m2') (0,x)"
        "\<forall>x n. (m1 \<Oplus> m1') (Suc n,x) = (m2 \<Oplus> m2') (Suc n,x)" by auto
  thus "m1 = m2 \<and> m1' = m2'" by (auto simp: merge_def)
qed auto

lemma pred\<^sub>0_entail [intro]:
  assumes "P \<turnstile>\<^sub>p Q"
  shows "pred\<^sub>0 P \<turnstile>\<^sub>p pred\<^sub>0 Q"
  unfolding entail_def
proof (clarsimp)
  fix mh \<Gamma>h assume "test mh \<Gamma>h (pred\<^sub>0 P :: ('a,'b) ipred)"
  moreover obtain m \<Gamma> mh' \<Gamma>h' where "mh = (m \<Oplus> mh')" "\<Gamma>h = (\<Gamma> \<Oplus> \<Gamma>h')" using merge_split by smt
  ultimately show "test mh \<Gamma>h (pred\<^sub>0 Q)" using assms by (simp add: entail_def)
qed

abbreviation wp\<^sub>a
  where "wp\<^sub>a x e t Q \<equiv> subst\<^sub>\<Gamma> (subst\<^sub>p Q x\<^sup>0 (exp\<^sub>0 e)) x\<^sup>0 (pred\<^sub>0 t)"

abbreviation wp\<^sub>b
  where "wp\<^sub>b b Q \<equiv> pred\<^sub>0 b \<longrightarrow>\<^sub>p Q"

definition wp\<^sub>l
  where "wp\<^sub>l x i e t \<equiv> foldi 0 (\<lambda>j v. wp\<^sub>a v (Ternary (Const j) i e (Var v)) (PTer (Const j) i t (Low v))) x"

text \<open>Show that wpl is the weakest precondition for a list store\<close>
lemma asn_foldi_nop [simp]:
  assumes "eval m i < k"
  shows "asn m \<Gamma> (foldi k (\<lambda>j v Q. subst\<^sub>\<Gamma> (subst\<^sub>p Q v\<^sup>0 (exp\<^sub>0 (Ternary (Const j) i e (Var v)))) v\<^sup>0 (pred\<^sub>0 (PTer (Const j) i t (Low v)))) x Q) = asn m \<Gamma> Q"
  using assms by (induct x arbitrary: k Q) simp+

lemma wp\<^sub>l [simp]:
  assumes "eval m i < length x"
  assumes "set x \<inter> vars\<^sub>e i = {}"
  shows "asn m \<Gamma> (wp\<^sub>l x i e t Q) = asn (m(x ! eval m i := eval m e)) (\<Gamma>(x ! eval m i := test m \<Gamma> t)) Q"
proof -
  have "\<And>k Q. k \<le> eval m i \<Longrightarrow> eval m i - k < length x \<Longrightarrow> set x \<inter> vars\<^sub>e i = {} \<Longrightarrow> asn m \<Gamma> (foldi k (\<lambda>j v. wp\<^sub>a v (Ternary (Const j) i e (Var v)) (PTer (Const j) i t (Low v))) x Q) = asn (m(x ! (eval m i - k) := eval m e)) (\<Gamma>(x ! (eval m i - k) := test m \<Gamma> t)) Q"
  proof (induct x)
    case (Cons a x)
    then show ?case
    proof (cases "eval m i = k")
      case True
      moreover have "m(a := eval m e) = (\<lambda>b. if b = a then eval m e else m b)" by auto
      moreover have "\<Gamma>(a := test m \<Gamma> t) = (\<lambda>x. (x = a \<longrightarrow> test m \<Gamma> t) \<and> (x \<noteq> a \<longrightarrow> \<Gamma> x))" by auto
      ultimately show ?thesis by auto
    next
      case False
      have "asn m \<Gamma> (foldi (Suc k) (\<lambda>j v. wp\<^sub>a v (Ternary (Const j) i e (Var v)) (PTer (Const j) i t (Low v))) x (subst\<^sub>\<Gamma> (subst\<^sub>p Q a\<^sup>0 (exp\<^sub>0 (Ternary (Const k) i e (Var a)))) a\<^sup>0 (pred\<^sub>0 (PTer (Const k) i t (Low a))))) =
            asn (m(x ! (eval m i -(Suc k)) := eval m e)) (\<Gamma>(x ! (eval m i - (Suc k)) := test m \<Gamma> t)) (subst\<^sub>\<Gamma> (subst\<^sub>p Q a\<^sup>0 (exp\<^sub>0 (Ternary (Const k) i e (Var a)))) a\<^sup>0 (pred\<^sub>0 (PTer (Const k) i t (Low a))))"
        using False Cons(2,3,4) by (intro Cons(1)) auto
      also have "... = asn (m((a # x) ! (eval m i - k) := eval m e)) (\<Gamma>((a # x) ! (eval m i - k) := test m \<Gamma> t)) Q"
      proof -
        have noMod: "eval (m(x ! (eval m i - Suc k) := eval m e)) i = eval m i"
        proof (intro eval_vars_det ballI impI)
          fix v assume a: "v \<in> vars\<^sub>e i"
          have "x ! (eval m i - Suc k) \<in> set x" using Cons False by auto
          hence "v \<noteq> x ! (eval m i - Suc k)" using Cons(4) a by auto
          thus "(m(x ! (eval m i - Suc k) := eval m e)) v = m v" by auto
        qed
        have "(a # x) ! (eval m i - k) = x ! (eval m i - Suc k)" using Cons(2) False by auto
        thus ?thesis using noMod False by (auto simp: fun_upd_twist)
      qed
      finally show ?thesis by fastforce
    qed
  qed simp
  thus ?thesis using assms by (auto simp: wp\<^sub>l_def)
qed

end