section \<open> Example: Summing a List \<close>

theory sum_list
  imports "../utp_easy_parser"
begin

text \<open> This theory exemplifies the use of the Isabelle/UTP Hoare logic verification component.
  We first create a state space with the variables the program needs. \<close>

alphabet st_sum_list =
  i   :: nat
  xs  :: "int list"
  ans :: int

text \<open> Next, we define the program as by a homogeneous relation over the state-space type. \<close>

abbreviation Sum_List :: "st_sum_list hrel" where
  "Sum_List \<equiv>
  i := 0 ;;
  ans := 0 ;;
  while (i < #xs) invr (ans = list_sum(take(i, xs)))
  do
    ans := ans + xs[i] ;;
    i := i + 1
  od"

text \<open> Next, we symbolically evaluate some examples. \<close>

lemma "TRY([&xs \<mapsto>\<^sub>s \<guillemotleft>[4,3,7,1,12,8]\<guillemotright>] \<Turnstile> Sum_List)"
  apply (sym_eval) oops

text \<open> Finally, we verify the program. \<close>

theorem Sum_List_sums:
  "{{xs = \<guillemotleft>XS\<guillemotright>}} Sum_List {{ans = list_sum(xs)}}"
  by (hoare_auto, metis add.foldr_snoc take_Suc_conv_app_nth)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_SSortSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun ssortminimum1 :: "int => int list => int" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if y1 <= x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

(*fun did not finish the proof*)
function ssort :: "int list => int list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: int = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: int) => % (x2 :: int) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "ordered (ssort xs)"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_72
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = Z"
| "t2 (S z2) (Z) = S z2"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((rev (drop i xs)) = (take (t2 (len xs) i) (rev xs)))"
  oops

end


theory Logic
  imports Main
begin

chapter \<open>Propositional formulae\<close>
text \<open>
  This theory contains syntax and semantics of propositional formulae.
  Furthermore, it contains a function that converts a formula into
  disjunctive normal form. This conversion is justified
  with a proof term.
\<close>

datatype (atoms: 'a) fm =
  is_Atom: Atom 'a | And "'a fm" "'a fm" | Or "'a fm" "'a fm" |
  Neg "'a fm"

fun amap_fm :: "('a \<Rightarrow> 'b fm) \<Rightarrow> 'a fm \<Rightarrow> 'b fm" ("amap\<^sub>f\<^sub>m") where
  "amap\<^sub>f\<^sub>m h (Atom a) = h a" |
  "amap\<^sub>f\<^sub>m h (And \<phi>\<^sub>1 \<phi>\<^sub>2) = And (amap\<^sub>f\<^sub>m h \<phi>\<^sub>1) (amap\<^sub>f\<^sub>m h \<phi>\<^sub>2)" |
  "amap\<^sub>f\<^sub>m h (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = Or (amap\<^sub>f\<^sub>m h \<phi>\<^sub>1) (amap\<^sub>f\<^sub>m h \<phi>\<^sub>2)" |
  "amap\<^sub>f\<^sub>m h (Neg \<phi>) = Neg (amap\<^sub>f\<^sub>m h \<phi>)"

fun dnf_and_fm :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
  "dnf_and_fm (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<psi> = Or (dnf_and_fm \<phi>\<^sub>1 \<psi>) (dnf_and_fm \<phi>\<^sub>2 \<psi>)" |
  "dnf_and_fm \<psi> (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = Or (dnf_and_fm \<psi> \<phi>\<^sub>1) (dnf_and_fm \<psi> \<phi>\<^sub>2)" |
  "dnf_and_fm \<phi>\<^sub>1 \<phi>\<^sub>2 = And \<phi>\<^sub>1 \<phi>\<^sub>2"

fun dnf_fm :: "'a fm \<Rightarrow> 'a fm" where
  "dnf_fm (And \<phi>\<^sub>1 \<phi>\<^sub>2) = dnf_and_fm (dnf_fm \<phi>\<^sub>1) (dnf_fm \<phi>\<^sub>2)" |
  "dnf_fm (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = Or (dnf_fm \<phi>\<^sub>1) (dnf_fm \<phi>\<^sub>2)" |
  "dnf_fm x = x"

fun conj_list :: "'a fm \<Rightarrow> 'a list" where
  "conj_list (And \<phi>\<^sub>1 \<phi>\<^sub>2) = conj_list \<phi>\<^sub>1 @ conj_list \<phi>\<^sub>2" |
  "conj_list (Atom a) = [a]"

fun disj_conj_list :: "'a fm \<Rightarrow> 'a list list" where
  "disj_conj_list (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = disj_conj_list \<phi>\<^sub>1 @ disj_conj_list \<phi>\<^sub>2" |
  "disj_conj_list (And \<phi>\<^sub>1 \<phi>\<^sub>2) = [conj_list (And \<phi>\<^sub>1 \<phi>\<^sub>2)]" |
  "disj_conj_list (Atom a) = [[a]]"

definition "dnf \<equiv> disj_conj_list o dnf_fm"

lemma dnf_and_fm_induct[case_names DistribR DistribL NoDistrib]:
  fixes \<phi>\<^sub>1 \<phi>\<^sub>2 :: "'a fm"
  assumes "\<And>\<phi>\<^sub>1 \<phi>\<^sub>2 \<psi>. \<lbrakk>P \<phi>\<^sub>1 \<psi>; P \<phi>\<^sub>2 \<psi>\<rbrakk> \<Longrightarrow> P (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<psi>"
  assumes "\<And>\<psi> \<phi>\<^sub>1 \<phi>\<^sub>2. \<lbrakk>P \<psi> \<phi>\<^sub>1; P \<psi> \<phi>\<^sub>2; \<nexists>x y. \<psi> = Or x y\<rbrakk> \<Longrightarrow> P \<psi> (Or \<phi>\<^sub>1 \<phi>\<^sub>2)"
  assumes "\<And>\<phi>\<^sub>1 \<phi>\<^sub>2. \<lbrakk>\<nexists>x y. \<phi>\<^sub>1 = Or x y; \<nexists>x y. \<phi>\<^sub>2 = Or x y\<rbrakk> \<Longrightarrow> P \<phi>\<^sub>1 \<phi>\<^sub>2"
  shows "P \<phi>\<^sub>1 \<phi>\<^sub>2"
  apply(induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm.induct)
  using assms by simp_all

fun is_conj :: "'a fm \<Rightarrow> bool" where
  "is_conj (And \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> is_conj \<phi>\<^sub>1 \<and> is_conj \<phi>\<^sub>2" |
  "is_conj (Or _ _) \<longleftrightarrow> False" |
  "is_conj (Neg _) \<longleftrightarrow> False" |
  "is_conj (Atom _) \<longleftrightarrow> True"

fun dnormal :: "'a fm \<Rightarrow> bool" where
  "dnormal (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> dnormal \<phi>\<^sub>1 \<and> dnormal \<phi>\<^sub>2" |
  "dnormal (And \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> is_conj (And \<phi>\<^sub>1 \<phi>\<^sub>2)" |
  "dnormal (Neg _) \<longleftrightarrow> False" |
  "dnormal _ \<longleftrightarrow> True"

fun nfree :: "'a fm \<Rightarrow> bool" where
  "nfree (Atom \<phi>) \<longleftrightarrow> True" |
  "nfree (And \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> nfree \<phi>\<^sub>1 \<and> nfree \<phi>\<^sub>2" |
  "nfree (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> nfree \<phi>\<^sub>1 \<and> nfree \<phi>\<^sub>2" |
  "nfree (Neg _) \<longleftrightarrow> False"

lemma atoms_amap\<^sub>f\<^sub>m: "atoms (amap\<^sub>f\<^sub>m f \<phi>) = (\<Union>a \<in> atoms \<phi>. atoms (f a))"
  by (induction \<phi>) auto

lemma atoms_dnf_and_fm[simp]: "atoms (dnf_and_fm \<phi>\<^sub>1 \<phi>\<^sub>2) = atoms (And \<phi>\<^sub>1 \<phi>\<^sub>2)"
  by (induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm.induct) auto

lemma atoms_dnf_fm[simp]: "atoms (dnf_fm \<phi>) = atoms \<phi>"
  using atoms_dnf_and_fm
  by (induction \<phi>) auto

lemma atoms_conj_list: "is_conj \<phi> \<Longrightarrow> set (conj_list \<phi>) = atoms \<phi>"
  by (induction \<phi>) auto

lemma atoms_disj_conj_list: "dnormal \<phi> \<Longrightarrow> (\<Union>A \<in> set (disj_conj_list \<phi>). set A) = atoms \<phi>"
  by (induction \<phi>) (auto simp: atoms_conj_list)

lemma nfree_amap\<^sub>f\<^sub>m: "(\<And>x. nfree (f x)) \<Longrightarrow> nfree (amap\<^sub>f\<^sub>m f \<phi>) = nfree \<phi>"
  by (induction \<phi>) auto

lemma nfree_amap\<^sub>f\<^sub>mI: "(\<And>x. nfree (f x)) \<Longrightarrow> nfree \<phi> \<Longrightarrow> nfree (amap\<^sub>f\<^sub>m f \<phi>)"
  using nfree_amap\<^sub>f\<^sub>m by blast

lemma nfree_dnf_and_fm[simp]: "nfree (dnf_and_fm \<phi>\<^sub>1 \<phi>\<^sub>2) = nfree (And \<phi>\<^sub>1 \<phi>\<^sub>2)"
  apply(induction "\<phi>\<^sub>1" "\<phi>\<^sub>2" rule: dnf_and_fm.induct)
  by auto

lemma nfree_dnf_fm[simp]: "nfree (dnf_fm \<phi>) = nfree \<phi>"
  apply(induction \<phi>)
  by auto

lemma dnormal_conj: "is_conj \<phi> \<Longrightarrow> dnormal \<phi>"
  apply(induction \<phi>)
  by auto

lemma dnormal_dnf_and_fm:
  assumes "nfree \<phi>\<^sub>1" "nfree \<phi>\<^sub>2"
    and "dnormal \<phi>\<^sub>1" "dnormal \<phi>\<^sub>2"
  shows "dnormal (dnf_and_fm \<phi>\<^sub>1 \<phi>\<^sub>2)"
  using assms
proof(induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm_induct)
  case (DistribL \<psi> \<phi>\<^sub>1 \<phi>\<^sub>2)
  then show ?case
    apply(cases \<psi>) by auto
next
  case (NoDistrib \<phi>\<^sub>1 \<phi>\<^sub>2)
  then show ?case
    apply(cases \<phi>\<^sub>1; cases \<phi>\<^sub>2) by auto
qed simp

lemma dnormal_dnf_fm[intro]: "nfree \<phi> \<Longrightarrow> dnormal (dnf_fm \<phi>)"
  apply(induction \<phi>) by (auto simp: dnormal_dnf_and_fm)

fun "interp" :: "('model \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'model \<Rightarrow> 'a fm \<Rightarrow> bool" where
  "interp I\<^sub>a M (Atom a) = I\<^sub>a M a" |
  "interp I\<^sub>a M (And \<phi>\<^sub>1 \<phi>\<^sub>2) = (interp I\<^sub>a M \<phi>\<^sub>1 \<and> interp I\<^sub>a M \<phi>\<^sub>2)" |
  "interp I\<^sub>a M (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = (interp I\<^sub>a M \<phi>\<^sub>1 \<or> interp I\<^sub>a M \<phi>\<^sub>2)" |
  "interp I\<^sub>a M (Neg \<phi>) = (\<not> interp I\<^sub>a M \<phi>)"

locale ATOM =
  fixes I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool"
begin

abbreviation I where "I \<equiv> interp I\<^sub>a"

lemma I_amap\<^sub>f\<^sub>m: "\<forall>x. I M (h x) = I\<^sub>a M x \<Longrightarrow> I M (amap\<^sub>f\<^sub>m h \<phi>) = I M \<phi>"
  by (induction \<phi>) auto

lemma I_dnf_and_fm: "nfree \<phi>\<^sub>1 \<Longrightarrow> nfree \<phi>\<^sub>2 \<Longrightarrow> I M (dnf_and_fm \<phi>\<^sub>1 \<phi>\<^sub>2) = I M (And \<phi>\<^sub>1 \<phi>\<^sub>2)"
  apply(induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm.induct)
  by auto

lemma I_dnf_fm: "nfree \<phi> \<Longrightarrow> I M (dnf_fm \<phi>) = I M \<phi>"
  apply(induction \<phi>)
  by (auto simp: I_dnf_and_fm)

lemma I_conj_list: "is_conj \<phi> \<Longrightarrow> (\<forall>a \<in> set (conj_list \<phi>). I\<^sub>a M a) = I M \<phi>"
  apply(induction \<phi>)
  by auto

lemma I_disj_conj_list: "dnormal \<phi> \<Longrightarrow>
  (\<exists>as \<in> set (disj_conj_list \<phi>). \<forall>a \<in> set as. I\<^sub>a M a) = I M \<phi>"
proof(induction \<phi>)
  case (And \<phi>1 \<phi>2)
  hence "is_conj (And \<phi>1 \<phi>2)" by simp
  from I_conj_list[OF this] show ?case by simp
qed auto

lemma I_dnf: "nfree \<phi> \<Longrightarrow> (\<exists>as \<in> set (dnf \<phi>). \<forall>a \<in> set as. I\<^sub>a M a) = I M \<phi>"
  unfolding dnf_def
  using I_disj_conj_list[OF dnormal_dnf_fm] I_dnf_fm by simp

end

locale nnf = ATOM I\<^sub>a for I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes aneg :: "'a \<Rightarrow> 'a fm"
  assumes nfree_aneg: "nfree (aneg a)"
  assumes I\<^sub>a_aneg: "interp I\<^sub>a M (aneg a) = (\<not> I\<^sub>a M a)"
begin

fun nnf :: "'a fm \<Rightarrow> 'a fm" where
  "nnf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = And (nnf \<phi>\<^sub>1) (nnf \<phi>\<^sub>2)" |
  "nnf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = Or (nnf \<phi>\<^sub>1) (nnf \<phi>\<^sub>2)" |
  "nnf (Neg (Neg \<phi>)) = (nnf \<phi>)" |
  "nnf (Neg (And \<phi>\<^sub>1 \<phi>\<^sub>2)) = (Or (nnf (Neg \<phi>\<^sub>1)) (nnf (Neg \<phi>\<^sub>2)))" |
  "nnf (Neg (Or \<phi>\<^sub>1 \<phi>\<^sub>2)) = (And (nnf (Neg \<phi>\<^sub>1)) (nnf (Neg \<phi>\<^sub>2)))" |
  "nnf (Neg (Atom a)) = aneg a" |
  "nnf \<phi> = \<phi>"

lemma nfree_nnf: "nfree (nnf \<phi>)"
  apply(induction \<phi> rule: nnf.induct)
  using nfree_aneg by auto

lemma I_nnf: "I M (nnf \<phi>) = I M \<phi>"
  by (induction rule: nnf.induct) (simp_all add: I\<^sub>a_aneg)

end

type_synonym var = int

datatype trm = Const String.literal | App trm trm | Var var

datatype prf_trm =
  PThm String.literal |
  Appt prf_trm trm |
  AppP prf_trm prf_trm |
  AbsP trm prf_trm |
  Bound trm |
  Conv trm prf_trm prf_trm

abbreviation "AppPs p ps \<equiv> foldl AppP p ps"
abbreviation "AppPThm s \<equiv> AppP (PThm s)"
abbreviation "ApptThm s \<equiv> Appt (PThm s)"
abbreviation "AppPThms s ps \<equiv> AppPs (PThm s) ps"

abbreviation "AtomConv \<equiv> AppPThm (STR ''atom_conv'')"
abbreviation "NegAtomConv \<equiv> AppPThm (STR ''neg_atom_conv'')"
abbreviation "BinopConv c1 c2 \<equiv>
  AppPThms (STR ''combination_conv'') [AppPThm (STR ''arg_conv'') c1, c2]"
abbreviation "ArgConv \<equiv> AppPThm (STR ''arg_conv'')"
abbreviation "NegNegConv \<equiv> PThm (STR ''not_not_conv'')"
abbreviation "NegAndConv \<equiv> PThm (STR ''de_Morgan_conj_conv'')"
abbreviation "NegOrConv \<equiv> PThm (STR ''de_Morgan_disj_conv'')"
abbreviation "ConjDisjDistribRConv \<equiv> PThm (STR ''conj_disj_distribR_conv'')"
abbreviation "ConjDisjDistribLConv \<equiv> PThm (STR ''conj_disj_distribL_conv'')"
abbreviation "ThenConv c1 c2 \<equiv> AppPThms (STR ''then_conv'') [c1, c2]"
abbreviation "AllConv \<equiv> PThm (STR ''all_conv'')"

fun trm_of_fm :: "('a \<Rightarrow> trm) \<Rightarrow> 'a fm \<Rightarrow> trm" where
"trm_of_fm f (Atom a) = f a" |
"trm_of_fm f (And \<phi>\<^sub>1 \<phi>\<^sub>2) = App (App (Const (STR ''conj'')) (trm_of_fm f \<phi>\<^sub>1)) (trm_of_fm f \<phi>\<^sub>2)" |
"trm_of_fm f (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = App (App (Const (STR ''disj'')) (trm_of_fm f \<phi>\<^sub>1)) (trm_of_fm f \<phi>\<^sub>2)" |
"trm_of_fm f (Neg \<phi>) = App (Const (STR ''Not'')) (trm_of_fm f \<phi>)"

fun thm_free :: "String.literal \<Rightarrow> prf_trm \<Rightarrow> bool" where
"thm_free a (PThm n) \<longleftrightarrow> a \<noteq> n" |
"thm_free a (AppP p1 p2) \<longleftrightarrow> thm_free a p1 \<and> thm_free a p2" |
"thm_free a (Appt p _) \<longleftrightarrow> thm_free a p"

abbreviation "a_conv_free \<equiv> thm_free (STR ''atom_conv'')"
abbreviation "aneg_conv_free \<equiv> thm_free (STR ''neg_atom_conv'')"

locale fm_conv_system = ATOM I\<^sub>a for I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes M :: 'model
  fixes a_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool"
  fixes aneg_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool"
begin

inductive convs :: "prf_trm \<Rightarrow> 'a fm \<Rightarrow> 'a fm \<Rightarrow> bool"
  ("_ : _ \<equiv>\<^sub>f\<^sub>m _" [] 60) where
  andC[simplified]: "p1 : A \<equiv>\<^sub>f\<^sub>m C \<Longrightarrow> p2 : B \<equiv>\<^sub>f\<^sub>m D \<Longrightarrow> BinopConv p1 p2 : And A B \<equiv>\<^sub>f\<^sub>m And C D" |
  orC[simplified]: "p1 : A \<equiv>\<^sub>f\<^sub>m C \<Longrightarrow> p2 : B \<equiv>\<^sub>f\<^sub>m D  \<Longrightarrow> BinopConv p1 p2 : Or A B \<equiv>\<^sub>f\<^sub>m Or C D" |
  negC: "p : A \<equiv>\<^sub>f\<^sub>m B  \<Longrightarrow> ArgConv p : Neg A \<equiv>\<^sub>f\<^sub>m Neg B" |
  negNegC: "NegNegConv : Neg (Neg A) \<equiv>\<^sub>f\<^sub>m A" |
  negAndC: "NegAndConv : Neg (And A B) \<equiv>\<^sub>f\<^sub>m Or (Neg A) (Neg B)" |
  negOrC: "NegOrConv : Neg (Or A B) \<equiv>\<^sub>f\<^sub>m And (Neg A) (Neg B)" |
  AtomC: "a_convs p a B\<Longrightarrow> AtomConv p : Atom a \<equiv>\<^sub>f\<^sub>m B" |
  negAtomC: "aneg_convs p a B \<Longrightarrow> NegAtomConv p : Neg (Atom a) \<equiv>\<^sub>f\<^sub>m B" |
  conjDisjDistribRC: "ConjDisjDistribRConv : And (Or A B) C \<equiv>\<^sub>f\<^sub>m Or (And A C) (And B C)" |
  conjDisjDistribLC: "ConjDisjDistribLConv : And A (Or B C) \<equiv>\<^sub>f\<^sub>m Or (And A B) (And A C)" |
  thenC[simplified]: "p1 : A \<equiv>\<^sub>f\<^sub>m B \<Longrightarrow> p2 : B \<equiv>\<^sub>f\<^sub>m C \<Longrightarrow> ThenConv p1 p2 : A \<equiv>\<^sub>f\<^sub>m C" |
  allC: "AllConv : A \<equiv>\<^sub>f\<^sub>m A"

lemma convs_sound:
  assumes "p : \<phi> \<equiv>\<^sub>f\<^sub>m \<psi>"
  assumes "\<And>ap a \<phi>\<^sub>a. a_convs ap a \<phi>\<^sub>a \<Longrightarrow> I\<^sub>a M a = I M \<phi>\<^sub>a"
  assumes "\<And>ap a \<phi>\<^sub>a. aneg_convs ap a \<phi>\<^sub>a \<Longrightarrow> \<not> (I\<^sub>a M a) = I M \<phi>\<^sub>a"
  shows "I M \<phi> = I M \<psi>"
  using assms
  apply(induction p \<phi> \<psi> rule: convs.induct) by auto

lemma convs_aneg_conv_free_sound:
  assumes "p : \<phi> \<equiv>\<^sub>f\<^sub>m \<psi>"
  assumes "aneg_conv_free p" "\<And>ap a \<phi>\<^sub>a. a_convs ap a \<phi>\<^sub>a \<Longrightarrow> I\<^sub>a M a = I M \<phi>\<^sub>a"
  shows "I M \<phi> = I M \<psi>"
  using assms
  apply (induction p \<phi> \<psi> rule: convs.induct) by auto

lemma convs_a_conv_free_sound:
  assumes "p : \<phi> \<equiv>\<^sub>f\<^sub>m \<psi>"
  assumes "a_conv_free p" "\<And>ap a \<phi>\<^sub>a. aneg_convs ap a \<phi>\<^sub>a \<Longrightarrow> \<not> (I\<^sub>a M a) = I M \<phi>\<^sub>a"
  shows "I M \<phi> = I M \<psi>"
  using assms
  apply(induction p \<phi> \<psi> rule: convs.induct) by auto

lemma convs_atom_conv_free_sound:
  assumes "p : \<phi> \<equiv>\<^sub>f\<^sub>m \<psi>"
  assumes "a_conv_free p" "aneg_conv_free p"
  shows "I M \<phi> = I M \<psi>"
  using assms
  apply(induction p \<phi> \<psi> rule: convs.induct) by auto

end

locale fm_conv = fm_conv_system I\<^sub>a M a_convs aneg_convs for
  I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" and
  M :: 'model and
  a_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" and
  aneg_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" +

  fixes conv :: "'a fm \<Rightarrow> 'a fm"
  fixes conv_prf :: "'a fm \<Rightarrow> prf_trm"
  assumes conv_convs: "conv_prf \<phi> : \<phi> \<equiv>\<^sub>f\<^sub>m (conv \<phi>) \<Longrightarrow> I M \<phi> = I M (conv \<phi>)"
begin
end

fun amap\<^sub>f\<^sub>m_prf :: "('a \<Rightarrow> prf_trm) \<Rightarrow> 'a fm \<Rightarrow> prf_trm" where
"amap\<^sub>f\<^sub>m_prf ap (Atom a) = AtomConv (ap a)" |
"amap\<^sub>f\<^sub>m_prf ap (And \<phi>\<^sub>1 \<phi>\<^sub>2) = BinopConv (amap\<^sub>f\<^sub>m_prf ap \<phi>\<^sub>1) (amap\<^sub>f\<^sub>m_prf ap \<phi>\<^sub>2)" |
"amap\<^sub>f\<^sub>m_prf ap (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = BinopConv (amap\<^sub>f\<^sub>m_prf ap \<phi>\<^sub>1) (amap\<^sub>f\<^sub>m_prf ap \<phi>\<^sub>2)" |
"amap\<^sub>f\<^sub>m_prf ap (Neg \<phi>) = ArgConv (amap\<^sub>f\<^sub>m_prf ap \<phi>)"

locale amap\<^sub>f\<^sub>m_conv = fm_conv_system I\<^sub>a M a_convs aneg_convs for
  I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" and
  M :: 'model and
  a_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" and
  aneg_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" +

  fixes atom_conv :: "'a \<Rightarrow> 'a fm"
  fixes atom_conv_prf :: "'a \<Rightarrow> prf_trm"
  assumes atom_conv_sound: "I M (atom_conv a) = I\<^sub>a M a"
  assumes aneg_conv_free_atom_conv_prf: "aneg_conv_free (atom_conv_prf a)"
  assumes atom_conv_prf_convs: "a_convs (atom_conv_prf a) a (atom_conv a)"
begin

lemma aneg_conv_free_amap\<^sub>f\<^sub>m_prf: "aneg_conv_free (amap\<^sub>f\<^sub>m_prf atom_conv_prf \<phi>)"
  using aneg_conv_free_atom_conv_prf by (induction \<phi>) auto

lemma amap\<^sub>f\<^sub>m_conv_convs: "amap\<^sub>f\<^sub>m_prf atom_conv_prf A : A \<equiv>\<^sub>f\<^sub>m amap\<^sub>f\<^sub>m atom_conv A"
  apply (induction A)
  using atom_conv_prf_convs AtomC andC orC negC by fastforce+

lemma I_amap\<^sub>f\<^sub>m_conv: "I M (amap\<^sub>f\<^sub>m atom_conv A) = I M A"
  by (simp add: ATOM.I_amap\<^sub>f\<^sub>m atom_conv_sound)

sublocale fm_conv: fm_conv I\<^sub>a M a_convs aneg_convs "amap\<^sub>f\<^sub>m atom_conv" "amap\<^sub>f\<^sub>m_prf atom_conv_prf"
  using I_amap\<^sub>f\<^sub>m_conv by unfold_locales blast

end

fun dnf_and_fm_prf :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> prf_trm" where
  "dnf_and_fm_prf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<psi> = ThenConv ConjDisjDistribRConv
    (BinopConv (dnf_and_fm_prf \<phi>\<^sub>1 \<psi>) (dnf_and_fm_prf \<phi>\<^sub>2 \<psi>))" |
  "dnf_and_fm_prf \<psi> (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = ThenConv ConjDisjDistribLConv
    (BinopConv (dnf_and_fm_prf \<psi> \<phi>\<^sub>1) (dnf_and_fm_prf \<psi> \<phi>\<^sub>2))" |
  "dnf_and_fm_prf \<phi>\<^sub>1 \<phi>\<^sub>2 = AllConv"

fun dnf_fm_prf :: "'a fm \<Rightarrow> prf_trm" where
  "dnf_fm_prf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = ThenConv (BinopConv (dnf_fm_prf \<phi>\<^sub>1) (dnf_fm_prf \<phi>\<^sub>2))
    (dnf_and_fm_prf (dnf_fm \<phi>\<^sub>1) (dnf_fm \<phi>\<^sub>2))" |
  "dnf_fm_prf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = BinopConv (dnf_fm_prf \<phi>\<^sub>1) (dnf_fm_prf \<phi>\<^sub>2)" |
  "dnf_fm_prf _ = AllConv"

locale dnf_fm_conv = fm_conv_system
begin

lemma dnf_and_fm_convs: "dnf_and_fm_prf \<phi>\<^sub>1 \<phi>\<^sub>2 : And \<phi>\<^sub>1 \<phi>\<^sub>2 \<equiv>\<^sub>f\<^sub>m dnf_and_fm \<phi>\<^sub>1 \<phi>\<^sub>2"
proof (induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm_induct)
  case (DistribR \<phi>\<^sub>1 \<phi>\<^sub>2 \<psi>)
  then show ?case
    using thenC[OF conjDisjDistribRC orC[OF DistribR.IH]] by simp
next
  case (DistribL \<psi> \<phi>\<^sub>1 \<phi>\<^sub>2)
  then show ?case
    using thenC[OF conjDisjDistribLC orC[OF DistribL.IH]] by (cases \<psi>) simp_all
next
  case (NoDistrib \<phi>\<^sub>1 \<phi>\<^sub>2)
  then show ?case
    apply(cases \<phi>\<^sub>1; cases \<phi>\<^sub>2) by (simp_all add: allC)
qed

lemma a_conv_free_dnf_and_fm_prf: "a_conv_free (dnf_and_fm_prf \<phi>\<^sub>1 \<phi>\<^sub>2)"
  by (induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm_prf.induct) auto

lemma aneg_conv_free_dnf_and_fm_prf: "aneg_conv_free (dnf_and_fm_prf \<phi>\<^sub>1 \<phi>\<^sub>2)"
  by (induction \<phi>\<^sub>1 \<phi>\<^sub>2 rule: dnf_and_fm_prf.induct) auto

lemma dnf_fm_convs: "dnf_fm_prf \<phi> : \<phi> \<equiv>\<^sub>f\<^sub>m dnf_fm \<phi>"
proof(induction \<phi>)
  case (And \<phi>1 \<phi>2)
  then show ?case
    using thenC[where ?B="And (dnf_fm \<phi>1) (dnf_fm \<phi>2)", OF andC]
    by (simp add: dnf_and_fm_convs)
qed (auto simp: convs.intros)

lemma a_conv_free_dnf_fm_prf: "a_conv_free (dnf_fm_prf \<phi>)"
  using a_conv_free_dnf_and_fm_prf
  by (induction \<phi> rule: dnf_fm_prf.induct) auto

lemma aneg_conv_free_dnf_fm_prf: "aneg_conv_free (dnf_fm_prf \<phi>)"
  using aneg_conv_free_dnf_and_fm_prf
  by (induction \<phi> rule: dnf_fm_prf.induct) auto

sublocale fm_conv: fm_conv I\<^sub>a M a_convs aneg_convs dnf_fm dnf_fm_prf
  apply(unfold_locales)
  using convs_atom_conv_free_sound[OF _ a_conv_free_dnf_fm_prf aneg_conv_free_dnf_fm_prf] .

end

locale nnf_conv = nnf I\<^sub>a aneg + fm_conv_system I\<^sub>a M a_convs aneg_convs for
  I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" and aneg :: "'a \<Rightarrow> 'a fm" and
  M :: 'model and
  a_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" and
  aneg_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" +

  fixes aneg_prf :: "'a \<Rightarrow> prf_trm"
  assumes a_conv_free_aneg_prf: "a_conv_free (aneg_prf a)"
  assumes aneg_convs: "aneg_convs (aneg_prf a) a (aneg a)"
  assumes a_convs_sound: "aneg_convs p a A \<Longrightarrow> (\<not> I\<^sub>a M a) = I M A"
begin

fun nnf_prf :: "'a fm \<Rightarrow> prf_trm" where
  "nnf_prf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = BinopConv (nnf_prf \<phi>\<^sub>1) (nnf_prf \<phi>\<^sub>2)" |
  "nnf_prf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = BinopConv (nnf_prf \<phi>\<^sub>1) (nnf_prf \<phi>\<^sub>2)" |
  "nnf_prf (Neg (Neg \<phi>)) = ThenConv NegNegConv (nnf_prf \<phi>)" |
  "nnf_prf (Neg (And \<phi>\<^sub>1 \<phi>\<^sub>2)) = ThenConv NegAndConv
    (BinopConv (nnf_prf (Neg \<phi>\<^sub>1)) (nnf_prf (Neg \<phi>\<^sub>2)))" |
  "nnf_prf (Neg (Or \<phi>\<^sub>1 \<phi>\<^sub>2)) = ThenConv NegOrConv
    (BinopConv (nnf_prf (Neg \<phi>\<^sub>1)) (nnf_prf (Neg \<phi>\<^sub>2)))" |
  "nnf_prf (Neg (Atom a)) = NegAtomConv (aneg_prf a)" |
  "nnf_prf \<phi> = AllConv"

lemma a_conv_free_nnf_prf: "a_conv_free (nnf_prf \<phi>)"
  using a_conv_free_aneg_prf
  apply(induction \<phi> rule: nnf_prf.induct) by auto

sublocale fm_conv: fm_conv I\<^sub>a M a_convs aneg_convs nnf nnf_prf
  using a_convs_sound a_conv_free_nnf_prf
  apply(unfold_locales)
  by (simp add: I_nnf)

lemma nnf_convs: "nnf_prf \<phi> : \<phi> \<equiv>\<^sub>f\<^sub>m nnf \<phi>"
proof(induction \<phi> rule: nnf.induct)
  case (3 \<phi>)
  then show ?case
    by (auto simp: convs.intros intro: thenC[where ?B=\<phi>])
next
  case (4 \<phi>\<^sub>1 \<phi>\<^sub>2)
  then show ?case
    by (auto simp: convs.intros intro: thenC[where ?B="Or (Neg \<phi>\<^sub>1) (Neg \<phi>\<^sub>2)"])
next
  case (5 \<phi>\<^sub>1 \<phi>\<^sub>2)
  then show ?case
    by (auto simp: convs.intros intro: thenC[where ?B="And (Neg \<phi>\<^sub>1) (Neg \<phi>\<^sub>2)"])
qed (auto simp: aneg_convs convs.intros)

end

definition "Atoms A \<equiv> {a |a. Atom a \<in> A}"

lemma Atoms_Un[simp]: "Atoms (A \<union> B) = Atoms A \<union> Atoms B"
  unfolding Atoms_def by auto

lemma Atoms_mono: "A \<subseteq> B \<Longrightarrow> Atoms A \<subseteq> Atoms B"
  unfolding Atoms_def by auto

abbreviation "ConjE trm_of c d p \<equiv>
  AppPThms (STR ''conjE'') [Bound (trm_of (And c d)), AbsP (trm_of c) (AbsP (trm_of d) p)]"
abbreviation "DisjE trm_of c d p1 p2 \<equiv>
  AppPThms (STR ''disjE'') [Bound (trm_of (Or c d)), AbsP (trm_of c) p1, AbsP (trm_of d) p2]"

locale prop_fm_system = fm_conv_system I\<^sub>a M a_convs aneg_convs for
    I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" and
    M :: 'model and
    a_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" and
    aneg_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" +

  fixes atom_proves :: "'a set \<Rightarrow> prf_trm \<Rightarrow> 'a fm \<Rightarrow> bool"
  fixes trm_of_atom :: "'a \<Rightarrow> trm"
  assumes atom_proves_sound: "atom_proves A ap \<phi> \<Longrightarrow> \<forall>a \<in> A. I\<^sub>a M a \<Longrightarrow> I M \<phi>"
  assumes atom_proves_weaken: "atom_proves A ap \<phi> \<Longrightarrow> A \<subseteq> B \<Longrightarrow> atom_proves B ap \<phi>"
  assumes convs_sound: "convs cp \<phi> \<psi> \<Longrightarrow> I M \<phi> = I M \<psi>"
begin

abbreviation "trm_of \<equiv> trm_of_fm trm_of_atom"

inductive proves :: "'a fm set \<Rightarrow> prf_trm \<Rightarrow> 'a fm \<Rightarrow> bool"
  ("_ \<turnstile> _ : _" [] 50) where
  conjE[simplified]: "And c d \<in> A \<Longrightarrow> insert c (insert d A) \<turnstile> p : \<phi>
    \<Longrightarrow> A \<turnstile> ConjE trm_of c d p : \<phi>" |
  disjE[simplified]: "Or c d \<in> A \<Longrightarrow> insert c A \<turnstile> p1 : \<phi> \<Longrightarrow> insert d A \<turnstile> p2 : \<phi>
    \<Longrightarrow> A \<turnstile> DisjE trm_of c d p1 p2 : \<phi>" |
  conv[simplified]: "c \<in> A \<Longrightarrow> cp : c \<equiv>\<^sub>f\<^sub>m d \<Longrightarrow> insert d A \<turnstile> p : \<phi>
    \<Longrightarrow> A \<turnstile> Conv (trm_of c) cp p : \<phi>" |
  lift: "atom_proves (Atoms A) p \<phi> \<Longrightarrow> A \<turnstile> p : \<phi>"

lemma lift2: "atom_proves A p \<phi> \<Longrightarrow> Atom ` A \<turnstile> p : \<phi>"
  using proves.lift unfolding Atoms_def
  by (simp add: atom_proves_weaken subsetI)

lemma proves_sound: "A \<turnstile> p : \<phi> \<Longrightarrow> \<forall>\<alpha> \<in> A. I M \<alpha> \<Longrightarrow> I M \<phi>"
proof(induction A p \<phi> rule: proves.induct)
  case (conv c A d cp p \<phi>)
  then show ?case using convs_sound by fastforce
next
  case (lift A p a)
  then show ?case using atom_proves_sound unfolding Atoms_def by fastforce
qed fastforce+

lemma proves_contr:
  assumes "A \<turnstile> p : \<phi>"
  assumes "\<not> I M \<phi>"
  obtains \<psi> where "\<psi> \<in> A" "\<not> I M \<psi>"
  using assms proves_sound by blast

lemma proves_weaken_Un: "A \<turnstile> p : \<phi> \<Longrightarrow> A \<union> B \<turnstile> p : \<phi>"
proof(induction A p \<phi> arbitrary: B rule: proves.induct)
  case (lift A p \<phi>)
  then have "atom_proves (Atoms (A \<union> B)) p \<phi>"
    unfolding Atoms_def
    using atom_proves_weaken[where ?B="{a |a. Atom a \<in> A \<union> B}"] by auto
  then show ?case by (auto simp: proves.lift)
qed (fastforce intro: proves.intros)+

lemma proves_weaken: "A \<turnstile> p : \<phi> \<Longrightarrow> A \<subseteq> B \<Longrightarrow> B \<turnstile> p : \<phi>"
  using proves_weaken_Un unfolding subset_Un_eq by metis

end

context
  fixes trm_of_atom :: "'a \<Rightarrow> trm"
begin

fun from_conj_prf :: "prf_trm \<Rightarrow> 'a fm \<Rightarrow> prf_trm" where
"from_conj_prf p (And a b) = ConjE (trm_of_fm trm_of_atom) a b (from_conj_prf (from_conj_prf p b) a)" |
"from_conj_prf p (Atom a) = p"

end

context
  fixes trm_of_atom :: "'a \<Rightarrow> trm"
  fixes contr_atom_prf :: "'a list \<Rightarrow> prf_trm option"
begin

fun contr_fm_prf :: "'a fm \<Rightarrow> prf_trm option" where
"contr_fm_prf (Or c d) =
  (case contr_fm_prf c of
    Some p1 \<Rightarrow> map_option (DisjE (trm_of_fm trm_of_atom) c d p1) (contr_fm_prf d)
  | _ \<Rightarrow> None)" |
"contr_fm_prf (And a b) =
  (case contr_atom_prf (conj_list (And a b)) of
    None \<Rightarrow> None
  | Some p \<Rightarrow> Some (from_conj_prf trm_of_atom p (And a b)))" |
"contr_fm_prf (Atom a) = contr_atom_prf [a]"

end

lemma (in prop_fm_system) from_conj_prf_proves:
  assumes "is_conj \<phi>"
  assumes proves_conj_list: "Atom ` set (conj_list \<phi>) \<union> A \<turnstile> p : \<psi>"
  shows "insert \<phi> A \<turnstile> from_conj_prf trm_of_atom p \<phi> : \<psi>"
  using assms
proof(induction p \<phi> arbitrary: A rule: from_conj_prf.induct[of _ trm_of_atom])
  case (1 p a b)
  from "1.IH"[where ?A="Atom ` set (conj_list a) \<union> A"] "1.prems"
  have "Atom ` set (conj_list a) \<union> insert b A \<turnstile> from_conj_prf trm_of_atom p b : \<psi>"
    by (simp add: image_Un Un_commute sup_left_commute)
  from "1.IH"(2)[OF _ this] "1.prems"
  have "insert a (insert b (insert (And a b) A))
    \<turnstile> from_conj_prf trm_of_atom (from_conj_prf trm_of_atom p b) a : \<psi>"
    using proves_weaken[where ?B="insert a (insert b (insert (And a b) A))"]
    by auto
  with "1.prems" show ?case using proves.conjE by simp
next
  case (2 p a)
  then show ?case
    using proves_weaken_Un[where ?B="A" and ?A="{Atom a}"] by simp
qed simp_all

locale contr_fm = prop_fm_system I\<^sub>a M a_convs aneg_convs atom_proves for
    I\<^sub>a :: "'model \<Rightarrow> 'a \<Rightarrow> bool" and
    M :: 'model and
    a_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" and
    aneg_convs :: "prf_trm \<Rightarrow> 'a \<Rightarrow> 'a fm \<Rightarrow> bool" and
    atom_proves :: "'a set \<Rightarrow> prf_trm \<Rightarrow> 'a fm \<Rightarrow> bool" +

  fixes contr_atom_prf :: "'a list \<Rightarrow> prf_trm option"
  fixes Fls :: 'a
  assumes I\<^sub>a_Fls: "\<not> I\<^sub>a M Fls"
  assumes contr_atom_prf_proves: "contr_atom_prf A = Some p \<Longrightarrow> atom_proves (set A) p (Atom Fls)"
begin

lemma contr_fm_prf_proves:
  assumes "dnormal \<phi>"
  assumes "contr_fm_prf trm_of_atom contr_atom_prf \<phi> = Some p"
  shows "insert \<phi> A \<turnstile> p : Atom Fls"
  using assms
proof(induction \<phi> arbitrary: p)
  case (Atom x)
  then show ?case
    using contr_atom_prf_proves[THEN lift2] proves_weaken_Un by fastforce
next
  case (And \<phi>1 \<phi>2)
  then obtain pa where
    p: "p = from_conj_prf trm_of_atom pa (And \<phi>1 \<phi>2)" and
    pa: "contr_atom_prf (conj_list (And \<phi>1 \<phi>2)) = Some pa"
    by (auto split: option.splits)
  with contr_atom_prf_proves[OF pa]
  have "Atom ` set (conj_list (And \<phi>1 \<phi>2)) \<union> A \<turnstile> pa : (Atom Fls)"
    using lift2 proves_weaken_Un by blast
  from from_conj_prf_proves[OF _ this] \<open>dnormal (And \<phi>1 \<phi>2)\<close> show ?case
    unfolding p by simp
next
  case (Or \<phi>1 \<phi>2)
  then obtain p1 p2 where
    p: "p = DisjE trm_of \<phi>1 \<phi>2 p1 p2" and
    "insert \<phi>1 A \<turnstile> p1 : Atom Fls" "insert \<phi>2 A \<turnstile> p2 : Atom Fls"
    by (auto split: option.splits)
  then have
    "insert \<phi>1 (insert (Or \<phi>1 \<phi>2) A) \<turnstile> p1 : Atom Fls"
    "insert \<phi>2 (insert (Or \<phi>1 \<phi>2) A) \<turnstile> p2 : Atom Fls"
    by (metis insert_commute proves_weaken subset_insertI)+
  from proves.disjE[OF insertI1 this] p show ?case by simp
qed simp

lemma contr_fm_prf_sound:
  assumes "dnormal \<phi>"
  assumes "contr_fm_prf trm_of_atom contr_atom_prf \<phi> = Some p"
  shows "\<not> I M \<phi>"
  using contr_fm_prf_proves[OF assms] I\<^sub>a_Fls proves_sound by fastforce

lemma contr_dnf_fm_prf_proves:
  assumes "nfree \<phi>"
  assumes "map_option (Conv (trm_of_fm trm_of_atom \<phi>) (dnf_fm_prf \<phi>))
    (contr_fm_prf trm_of_atom contr_atom_prf (dnf_fm \<phi>)) = Some p"
  shows "insert \<phi> A \<turnstile> p: Atom Fls"
  using assms
  using contr_fm_prf_proves conv[OF _ dnf_fm_conv.dnf_fm_convs]
  by blast

end

lemma (in ATOM) Ex_conj_contr_atom_prf_None:
  assumes "dnormal \<phi>"
  assumes "contr_fm_prf trm_of_atom contr_atom_prf \<phi> = None"
  shows "\<exists>A \<in> set (disj_conj_list \<phi>). contr_atom_prf A = None"
  using assms
  by (induction \<phi>) (auto split: option.splits)

lemma (in ATOM) I_fm_if_I_conj:
  assumes "dnormal \<phi>"
  assumes "A \<in> set (disj_conj_list \<phi>)" "\<forall>a \<in> set A. I\<^sub>a M a"
  shows "I M \<phi>"
  using assms
proof(induction \<phi>)
  case (And \<phi>1 \<phi>2)
  then show ?case using I_disj_conj_list by blast
qed auto

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_BSortPermutes
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "Nat list => Nat list => Nat list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "Nat list => Nat list => Nat list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

(*fun did not finish the proof*)
function bmerge :: "Nat list => Nat list => Nat list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: Nat list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "Nat list => Nat list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (bsort xs) xs"
  oops

end


theory Int_State_Monad_Fib
imports
  Main
  "~~/src/HOL/Library/State_Monad"
begin
section\<open>Proof of the fibonacci function using a monad\<close>
text\<open>Definition of the functions to interact with the monad\<close>
definition return:: "'a \<Rightarrow> ('b, 'a) state" where "return = State_Monad.return"
definition get:: "(nat, nat) state" where "get = State (\<lambda>x. (x,x))"
definition put:: "nat \<Rightarrow> (nat, unit) state" where "put x = State (\<lambda>_. ((),x))"
definition skip:: "(nat, unit) state" where "skip = State (\<lambda>x. ((),x))"

subsection\<open>Fibonacci function definitions\<close>
fun fibacc :: "nat \<Rightarrow> nat => nat \<Rightarrow> nat" where
fa1: "fibacc 0 a b = a"|
fa2: "fibacc (Suc 0) a b = b"|
fa3: "fibacc (Suc (Suc n)) a b = fibacc (Suc n) b (a+b)"

definition fib_wrap:: "nat \<Rightarrow> nat" where
"fib_wrap n = fibacc n 0 1"

fun fib :: "nat => nat" where
  "fib 0 = 0"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc x)) = fib x + fib (Suc x)"

text\<open>This is the monadic function. It stores the previous fibonacci-number in the monad\<close>
fun monfibacc :: "nat \<Rightarrow> nat => (nat, unit) state" where
m1:  "monfibacc 0 a =  do{put a}"|
m2:  "monfibacc (Suc 0) a = do{b \<leftarrow> get; put b}"|
m3:  "monfibacc (Suc n) a  = do{b \<leftarrow> get; new_b \<leftarrow> return (a + b); put new_b; monfibacc n b}"

value \<open>fibacc 10 0 1 = 55\<close>
value \<open>fib 5\<close>
value "snd (run_state (monfibacc 5 0) (1::nat))"
value \<open>snd (run_state (monfibacc 10 0) (1::nat)) = 55\<close>
value \<open>fib 10 = 55\<close>
value \<open>snd (run_state (monfib_wrap 9) (1::nat))\<close>
value \<open>snd (run_state (monfib_wrap 2) (0::nat))\<close>
value \<open>snd (run_state (monfib_wrap 0) (snd (run_state (monfib_wrap 7) 1)))\<close>
value \<open>snd (run_state (monfib_wrap 7) 1)\<close>

lemma fib_aux: "fibacc n b (a + b) = fibacc (Suc n) a b"
  apply(induction n)
   apply(simp_all)
  done

lemma fib_aux1: "fibacc (Suc (Suc n)) a b = fibacc n a b + fibacc (Suc n) a b"
  apply(induction n arbitrary: a b)
   apply(simp)
    apply(simp)
    apply (simp only: fib_aux)
  done

lemma fibwrap_main: "fib_wrap n = fibacc n 0 1"
  apply(induction n rule: nat.induct)
   apply(simp_all add: fib_wrap_def)
  done

lemma fib_main1: "fib n = fibacc n 0 1"
  apply(induction n rule: fib.induct)
    apply(simp)
    apply(simp)
    apply (simp only: fib_aux1)
  by (simp)

lemma fib_main: "fib_wrap n = fib n"
  apply(induction n rule: nat.induct)
    apply(simp_all add: fib_main1 fibwrap_main)
  done

lemma monfib_aux: "snd (run_state(monfibacc n b) (a + b)) = snd (run_state(monfibacc (Suc n) a) (b))"
  apply (induction n arbitrary: a b rule: nat.induct)
   apply (simp_all add: snd_def put_def get_def return_def)
  done

value\<open>snd (run_state(monfibacc 7 0) 1) + snd (run_state(monfibacc (Suc 7) 0) 1) =snd (run_state(monfibacc (Suc (Suc 7)) 0) 1)\<close>

lemma monfib_aux1: "snd (run_state(monfibacc (Suc (Suc n)) a) b) = snd (run_state(monfibacc n a) b) + snd (run_state(monfibacc (Suc n) a) b)"
  apply(simp add: snd_def put_def get_def return_def)
  apply(induction n arbitrary: a b)
   apply(simp add: snd_def put_def get_def return_def)
    apply(simp add: monfib_aux)
    apply(simp only: put_def get_def return_def)
    apply(simp)
  by (metis monfib_aux snd_def)

lemma fib_m_main: "snd (run_state (monfibacc n 0) 1) = fib n"
  apply (induction n rule:fib.induct)
    apply(simp add: snd_def put_def get_def return_def)
    apply(simp add: snd_def put_def get_def return_def)
    apply(simp only: monfib_aux1)
  by(simp)

lemma fib_mon_main: "snd (run_state (monfibacc n a) b) = fibacc n a b"
  apply(simp add: snd_def put_def get_def return_def)
  apply (induction n arbitrary: a b rule:fib.induct)
  apply(simp add: snd_def put_def get_def return_def)
  apply(simp)
  by(simp_all add: snd_def put_def get_def return_def)

end


section \<open>Auxiliaries\<close>

theory Term_Aux
  imports
    Subterm_and_Context
    "HOL-Library.Multiset"
begin

text \<open>
  This theory contains material about terms that is required for KBO,
  but does not belong to @{theory Knuth_Bendix_Order.Subterm_and_Context}.

  We plan to merge this material into the theory @{theory First_Order_Terms.Term}
  at some point.
\<close>

text \<open>The variables of a term as multiset.\<close>
fun vars_term_ms :: "('f, 'v) term \<Rightarrow> 'v multiset"
  where
    "vars_term_ms (Var x) = {#x#}" |
    "vars_term_ms (Fun f ts) = \<Sum>\<^sub># (mset (map vars_term_ms ts))"

lemma vars_term_ms_subst [simp]:
  "vars_term_ms (t \<cdot> \<sigma>) =
    \<Sum>\<^sub># (image_mset (\<lambda> x. vars_term_ms (\<sigma> x)) (vars_term_ms t))" (is "_ = ?V t")
proof (induct t)
  case (Fun f ts)
  have IH: "map (\<lambda> t. vars_term_ms (t \<cdot> \<sigma>)) ts = map (\<lambda> t. ?V t) ts"
    by (rule map_cong[OF refl Fun])
  show ?case by (simp add: o_def IH, induct ts, auto)
qed simp

lemma vars_term_ms_subst_mono:
  assumes "vars_term_ms s \<subseteq># vars_term_ms t"
  shows "vars_term_ms (s \<cdot> \<sigma>) \<subseteq># vars_term_ms (t \<cdot> \<sigma>)"
proof -
  from assms[unfolded mset_subset_eq_exists_conv] obtain u where t: "vars_term_ms t = vars_term_ms s + u" by auto
  show ?thesis unfolding vars_term_ms_subst unfolding t by auto
qed

lemma set_mset_vars_term_ms [simp]:
  "set_mset (vars_term_ms t) = vars_term t"
  by (induct t) auto

text \<open>A term is called \<^emph>\<open>ground\<close> if it does not contain any variables.\<close>
fun ground :: "('f, 'v) term \<Rightarrow> bool"
  where
    "ground (Var x) \<longleftrightarrow> False" |
    "ground (Fun f ts) \<longleftrightarrow> (\<forall>t \<in> set ts. ground t)"

lemma ground_vars_term_empty:
  "ground t \<longleftrightarrow> vars_term t = {}"
  by (induct t) simp_all

lemma ground_subst [simp]:
  "ground (t \<cdot> \<sigma>) \<longleftrightarrow> (\<forall>x \<in> vars_term t. ground (\<sigma> x))"
  by (induct t) simp_all

lemma ground_subst_apply:
  assumes "ground t"
  shows "t \<cdot> \<sigma> = t"
proof -
  have "t = t \<cdot> Var" by simp
  also have "\<dots> = t \<cdot> \<sigma>"
    by (rule term_subst_eq, insert assms[unfolded ground_vars_term_empty], auto)
  finally show ?thesis by simp
qed

text \<open>
  A \<^emph>\<open>signature\<close> is a set of function symbol/arity pairs, where the arity of a function symbol,
  denotes the number of arguments it expects.
\<close>
type_synonym 'f sig = "('f \<times> nat) set"

text \<open>The set of all function symbol/ arity pairs occurring in a term.\<close>
fun funas_term :: "('f, 'v) term \<Rightarrow> 'f sig"
  where
    "funas_term (Var _) = {}" |
    "funas_term (Fun f ts) = {(f, length ts)} \<union> \<Union>(set (map funas_term ts))"

lemma supt_imp_funas_term_subset:
  assumes "s \<rhd> t"
  shows "funas_term t \<subseteq> funas_term s"
  using assms by (induct) auto

lemma supteq_imp_funas_term_subset[simp]:
  assumes "s \<unrhd> t"
  shows "funas_term t \<subseteq> funas_term s"
  using assms by (induct) auto

text \<open>The set of all function symbol/arity pairs occurring in a context.\<close>
fun funas_ctxt :: "('f, 'v) ctxt \<Rightarrow> 'f sig"
  where
    "funas_ctxt Hole = {}" |
    "funas_ctxt (More f ss1 D ss2) = {(f, Suc (length (ss1 @ ss2)))}
     \<union> funas_ctxt D \<union> \<Union>(set (map funas_term (ss1 @ ss2)))"

lemma funas_term_ctxt_apply [simp]:
  "funas_term (C\<langle>t\<rangle>) = funas_ctxt C \<union> funas_term t"
proof (induct t)
  case (Var x) show ?case by (induct C) auto
next
  case (Fun f ts) show ?case by (induct C arbitrary: f ts) auto
qed

lemma funas_term_subst:
  "funas_term (t \<cdot> \<sigma>) = funas_term t \<union> \<Union>(funas_term ` \<sigma> ` vars_term t)"
  by (induct t) auto

lemma funas_ctxt_compose [simp]:
  "funas_ctxt (C \<circ>\<^sub>c D) = funas_ctxt C \<union> funas_ctxt D"
  by (induct C) auto

lemma funas_ctxt_subst [simp]:
  "funas_ctxt (C \<cdot>\<^sub>c \<sigma>) = funas_ctxt C \<union> \<Union>(funas_term ` \<sigma> ` vars_ctxt C)"
  by (induct C, auto simp: funas_term_subst)

end


(* General executable permutations *)

theory GPerm
imports
  "~~/src/HOL/Library/Quotient_Syntax"
  "~~/src/HOL/Library/Product_ord"
  "~~/src/HOL/Library/List_lexord"
begin

definition perm_apply where
  "perm_apply l e = (case [a\<leftarrow>l . fst a = e] of [] \<Rightarrow> e | x # xa \<Rightarrow> snd x)"

lemma perm_apply_simps[simp]:
  "perm_apply (h # t) e = (if fst h = e then snd h else perm_apply t e)"
  "perm_apply [] e = e"
  by (auto simp add: perm_apply_def)

definition valid_perm where
  "valid_perm p \<longleftrightarrow> distinct (map fst p) \<and> fst ` set p = snd ` set p"

lemma valid_perm_zero[simp]:
  "valid_perm []"
  by (simp add: valid_perm_def)

lemma length_eq_card_distinct:
  "length l = card (set l) \<longleftrightarrow> distinct l"
  using card_distinct distinct_card by force

lemma len_set_eq_distinct:
  assumes "length l = length m" "set l = set m"
  shows "distinct l = distinct m"
  using assms
  by (simp add: length_eq_card_distinct[symmetric])

lemma valid_perm_distinct_snd: "valid_perm a \<Longrightarrow> distinct (map snd a)"
  by (metis valid_perm_def image_set length_map len_set_eq_distinct)

definition
  perm_eq :: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list \<Rightarrow> bool"
where
  "perm_eq x y \<longleftrightarrow> valid_perm x \<and> valid_perm y \<and> (perm_apply x = perm_apply y)"

lemma perm_eq_sym[sym]:
  "perm_eq x y \<Longrightarrow> perm_eq y x"
  by (auto simp add: perm_eq_def)

lemma perm_eq_equivp:
  "part_equivp perm_eq"
  by (auto intro!: part_equivpI sympI transpI exI[of _ "[]"] simp add: perm_eq_def)

quotient_type
  'a gperm = "('a \<times> 'a) list" / partial: "perm_eq"
  by (rule perm_eq_equivp)

definition perm_add_raw where
  "perm_add_raw p q = map (map_prod id (perm_apply p)) q @ [a\<leftarrow>p. fst a \<notin> fst ` set q]"

lemma perm_apply_del[simp]:
  "e \<noteq> b \<Longrightarrow> perm_apply [a\<leftarrow>l. fst a \<noteq> b] e = perm_apply l e"
  "e \<noteq> b \<Longrightarrow> e \<noteq> c \<Longrightarrow> perm_apply [a\<leftarrow>l . fst a \<noteq> b \<and> fst a \<noteq> c] e = perm_apply l e"
  by (induct l) auto

lemma perm_apply_appendl:
  "perm_apply a e = perm_apply b e \<Longrightarrow> perm_apply (c @ a) e = perm_apply (c @ b) e"
  by (induct c) auto

lemma perm_apply_filterP:
  "b \<noteq> e \<Longrightarrow> perm_apply [a\<leftarrow>l . fst a \<noteq> b \<and> P a] e = perm_apply [a\<leftarrow>l . P a] e"
  by (induct l) auto

lemma perm_add_apply:
  shows "perm_apply (perm_add_raw p q) e = perm_apply p (perm_apply q e)"
  by (rule sym, induct q)
     (auto simp add: perm_add_raw_def perm_apply_filterP intro!: perm_apply_appendl)

definition swap_pair where
  "swap_pair a = (snd a, fst a)"

definition uminus_perm_raw where
  [simp]: "uminus_perm_raw = map swap_pair"

lemma map_fst_minus_perm[simp]:
  "map fst (uminus_perm_raw x) = map snd x"
  "map snd (uminus_perm_raw x) = map fst x"
  by (induct x) (auto simp add: swap_pair_def)

lemma fst_snd_set_minus_perm[simp]:
  "fst ` set (uminus_perm_raw x) = snd ` set x"
  "snd ` set (uminus_perm_raw x) = fst ` set x"
  by (induct x) (auto simp add: swap_pair_def)

lemma fst_snd_swap_pair[simp]:
  "fst (swap_pair x) = snd x"
  "snd (swap_pair x) = fst x"
  by (auto simp add: swap_pair_def)

lemma fst_snd_swap_pair_set[simp]:
  "fst ` swap_pair ` set l = snd ` set l"
  "snd ` swap_pair ` set l = fst ` set l"
  by (induct l) (auto simp add: swap_pair_def)

lemma valid_perm_minus[simp]:
  assumes "valid_perm x"
  shows "valid_perm (map swap_pair x)"
  using assms unfolding valid_perm_def
  by (simp add: valid_perm_distinct_snd[OF assms] o_def)

lemma swap_pair_id[simp]:
  "swap_pair (swap_pair x) = x"
  unfolding swap_pair_def by simp

lemma perm_apply_minus_minus[simp]:
  "perm_apply (uminus_perm_raw (uminus_perm_raw x)) = perm_apply x"
  by (simp add: o_def)

lemma filter_eq_nil:
  "[a\<leftarrow>a. fst a = e] = [] \<longleftrightarrow> e \<notin> fst ` set a"
  "[a\<leftarrow>a. snd a = e] = [] \<longleftrightarrow> e \<notin> snd ` set a"
  by (induct a) auto

lemma filter_rev_eq_nil: "[a\<leftarrow>map swap_pair a. fst a = e] = [] \<longleftrightarrow> e \<notin> snd ` set a"
  by (induct a) (auto simp add: swap_pair_def)

lemma filter_fst_eq:
  "[a\<leftarrow>a . fst a = e] = (l, r) # list \<Longrightarrow> l = e"
  "[a\<leftarrow>a . snd a = e] = (l, r) # list \<Longrightarrow> r = e"
  by (drule filter_eq_ConsD, auto)+

lemma filter_map_swap_pair:
  "[a\<leftarrow>map swap_pair a. fst a = e] = map swap_pair [a\<leftarrow>a. snd a = e]"
  by (induct a) auto

lemma forget_tl:
  "[a\<leftarrow>l . P a] = a # b \<Longrightarrow> a \<in> set l"
  by (metis Cons_eq_filter_iff in_set_conv_decomp)

lemma valid_perm_lookup_fst_eq_snd:
  "[a\<leftarrow>l . fst a = f] = (f, s) # l1 \<Longrightarrow> [a\<leftarrow>l . snd a = s] = (f2, s) # l2 \<Longrightarrow> valid_perm l \<Longrightarrow> f2 = f"
  apply (drule forget_tl valid_perm_distinct_snd)+
  apply (case_tac "f2 = f")
  apply (auto simp add: in_set_conv_nth swap_pair_def)
  apply (case_tac "i = ia")
  apply auto
  by (metis length_map nth_eq_iff_index_eq nth_map snd_conv)

lemma valid_perm_add_minus: "valid_perm a \<Longrightarrow> perm_apply (map swap_pair a) (perm_apply a e) = e"
  apply (auto simp add: filter_map_swap_pair filter_eq_nil filter_rev_eq_nil perm_apply_def split: list.split)
  apply (metis filter_eq_nil(2) neq_Nil_conv valid_perm_def)
  apply (metis list.sel(1) hd_in_set image_eqI list.simps(2) member_project project_set snd_conv)
  apply (frule filter_fst_eq(1))
  apply (frule filter_fst_eq(2))
  apply (auto simp add: swap_pair_def)
  apply (erule valid_perm_lookup_fst_eq_snd)
  apply assumption+
  done

lemma perm_apply_minus: "valid_perm x \<Longrightarrow> perm_apply (map swap_pair x) a = b \<longleftrightarrow> perm_apply x b = a"
  using valid_perm_add_minus[symmetric] valid_perm_minus
  by (metis uminus_perm_raw_def)

lemma uminus_perm_raw_rsp[simp]:
  "perm_eq x y \<Longrightarrow> perm_eq (map swap_pair x) (map swap_pair y)"
  by (auto simp add: fun_eq_iff perm_apply_minus[symmetric] perm_eq_def)

lemma fst_snd_map_prod[simp]:
  "fst ` map_prod f g ` set l = f ` fst ` set l"
  "snd ` map_prod f g ` set l = g ` snd ` set l"
  by (induct l) auto

lemma fst_diff[simp]:
  shows "fst ` {xa \<in> set x. fst xa \<notin> fst ` set y} = fst ` set x - fst ` set y"
  by auto

lemma pair_perm_apply:
  "distinct (map fst x) \<Longrightarrow> (a, b) \<in> set x \<Longrightarrow> perm_apply x a = b"
  by (induct x) (auto, metis fst_conv image_eqI)

lemma valid_perm_apply:
  "valid_perm x \<Longrightarrow> (a, b) \<in> set x \<Longrightarrow> perm_apply x a = b"
  unfolding valid_perm_def using pair_perm_apply by auto

lemma in_perm_apply:
  "valid_perm x \<Longrightarrow> (a, b) \<in> set x \<Longrightarrow> a \<in> c \<Longrightarrow> b \<in> perm_apply x ` c"
  by (metis imageI valid_perm_apply)

lemma snd_set_not_in_perm_apply[simp]:
  assumes "valid_perm x"
  shows "snd ` {xa \<in> set x. fst xa \<notin> fst ` set y} = perm_apply x ` (fst ` set x - fst ` set y)"
proof auto
  fix a b
  assume a: "(a, b) \<in> set x" " a \<notin> fst ` set y"
  then have "a \<in> fst ` set x - fst ` set y"
    by simp (metis fst_conv image_eqI)
  with a show "b \<in> perm_apply x ` (fst ` set x - fst ` set y)"
    by (simp add: in_perm_apply assms)
next
  fix a b
  assume a: "a \<notin> fst ` set y" "(a, b) \<in> set x"
  then have "perm_apply x a = b"
    by (simp add: valid_perm_apply assms)
  with a show "perm_apply x a \<in> snd ` {xa \<in> set x. fst xa \<notin> fst ` set y}"
    by (metis (lifting) CollectI fst_conv image_eqI snd_conv)
qed

lemma perm_apply_set:
  "valid_perm x \<Longrightarrow> perm_apply x ` fst ` set x = fst ` set x"
  by (auto simp add: valid_perm_def)
     (metis (hide_lams, no_types) image_iff pair_perm_apply snd_eqD surjective_pairing)+

lemma perm_apply_outset: "a \<notin> fst ` set x \<Longrightarrow> perm_apply x a = a"
  by (induct x) auto

lemma perm_apply_subset: "valid_perm x \<Longrightarrow> fst ` set x \<subseteq> s \<Longrightarrow> perm_apply x ` s = s"
  apply auto
  apply (case_tac [!] "xa \<in> fst ` set x")
  apply (metis imageI perm_apply_set subsetD)
  apply (metis perm_apply_outset)
  apply (metis image_mono perm_apply_set subsetD)
  by (metis imageI perm_apply_outset)

lemma valid_perm_add_raw[simp]:
  assumes "valid_perm x" "valid_perm y"
  shows "valid_perm (perm_add_raw x y)"
  using assms
  apply (simp (no_asm) add: valid_perm_def)
  apply (intro conjI)
  apply (auto simp add: perm_add_raw_def valid_perm_def fst_def[symmetric])[1]
  apply (simp add: distinct_map inj_on_def)
  apply (metis imageI snd_conv)
  apply (simp add: perm_add_raw_def image_Un)
  apply (simp add: image_Un[symmetric])
  apply (auto simp add: perm_apply_subset valid_perm_def)
  done

lemma perm_add_raw_rsp[simp]:
  "perm_eq x y \<Longrightarrow> perm_eq xa ya \<Longrightarrow> perm_eq (perm_add_raw x xa) (perm_add_raw y ya)"
  by (simp add: fun_eq_iff perm_add_apply perm_eq_def)

instantiation gperm :: (type) group_add
begin

lift_definition zero_gperm :: "'a gperm" is "[]" by simp

lift_definition uminus_gperm :: "'a gperm \<Rightarrow> 'a gperm" is uminus_perm_raw
  by (auto simp add: fun_eq_iff perm_apply_minus[symmetric] perm_eq_def)

lift_definition plus_gperm :: "'a gperm \<Rightarrow> 'a gperm \<Rightarrow> 'a gperm" is perm_add_raw
  by simp

definition
  minus_perm_def: "(p1::'a gperm) - p2 = p1 + - p2"

instance
  apply default
  unfolding minus_perm_def
  by (transfer,simp add: perm_add_apply perm_eq_def fun_eq_iff valid_perm_add_minus)+

end

definition "mk_perm_raw l = (if valid_perm l then l else [])"

lift_definition mk_perm :: "('a \<times> 'a) list \<Rightarrow> 'a gperm" is "mk_perm_raw"
  by (simp add: mk_perm_raw_def)

definition "dest_perm_raw p = sort [x\<leftarrow>p. fst x \<noteq> snd x]"

lemma distinct_fst_distinct[simp]: "distinct (map fst x) \<Longrightarrow> distinct x"
  by (induct x) auto

lemma perm_apply_in_set:
  "a \<noteq> b \<Longrightarrow> perm_apply y a = b \<Longrightarrow> (a, b) \<in> set y"
  by (induct y) (auto split: if_splits)

lemma perm_eq_not_eq_same:
  "perm_eq x y \<Longrightarrow> {xa \<in> set x. fst xa \<noteq> snd xa} = {x \<in> set y. fst x \<noteq> snd x}"
  unfolding perm_eq_def set_eq_iff
  apply auto
  apply (subgoal_tac "perm_apply x a = b")
  apply (simp add: perm_apply_in_set)
  apply (erule valid_perm_apply)
  apply simp
  apply (subgoal_tac "perm_apply y a = b")
  apply (simp add: perm_apply_in_set)
  apply (erule valid_perm_apply)
  apply simp
  done

lemma [simp]: "distinct (map fst (sort x)) = distinct (map fst x)"
  by (rule len_set_eq_distinct) simp_all

lemma valid_perm_sort[simp]:
  "valid_perm x \<Longrightarrow> valid_perm (sort x)"
  unfolding valid_perm_def by simp

lemma same_not_in_dpr:
  "valid_perm x \<Longrightarrow> (b, b) \<in> set x \<Longrightarrow> b \<notin> fst ` set (dest_perm_raw x)"
  unfolding dest_perm_raw_def valid_perm_def
  by auto (metis pair_perm_apply)

lemma in_set_in_dpr:
  "valid_perm x \<Longrightarrow> a \<noteq> b \<Longrightarrow> (a, b) \<in> set x \<longleftrightarrow> (a, b) \<in> set (dest_perm_raw x)"
  unfolding dest_perm_raw_def valid_perm_def
  by simp

lemma in_set_in_dpr2:
  "a \<noteq> b \<Longrightarrow> (dest_perm_raw x = dest_perm_raw y) \<Longrightarrow> valid_perm x \<Longrightarrow> valid_perm y \<Longrightarrow> (a, b) \<in> set x \<longleftrightarrow> (a, b) \<in> set y"
  using in_set_in_dpr by metis

lemma in_set_in_dpr3:
  "(dest_perm_raw x = dest_perm_raw y) \<Longrightarrow> valid_perm x \<Longrightarrow> valid_perm y \<Longrightarrow> perm_apply x a = perm_apply y a"
  by (metis in_set_in_dpr2 pair_perm_apply perm_apply_in_set valid_perm_def)

lemma dest_perm_raw_eq[simp]:
  "valid_perm x \<Longrightarrow> valid_perm y \<Longrightarrow> (dest_perm_raw x = dest_perm_raw y) = perm_eq x y"
  apply (auto simp add: perm_eq_def)
  apply (metis in_set_in_dpr3 fun_eq_iff)
  unfolding dest_perm_raw_def
  by (rule sorted_distinct_set_unique)
     (simp_all add: distinct_filter valid_perm_def perm_eq_not_eq_same[simplified perm_eq_def, simplified])

lift_definition dest_perm :: "('a :: linorder) gperm \<Rightarrow> ('a \<times> 'a) list"
  is "dest_perm_raw"
  by (simp add: perm_eq_def)

lemma dest_perm_mk_perm[simp]:
  "dest_perm (mk_perm xs) = sort [x\<leftarrow>mk_perm_raw xs. fst x \<noteq> snd x]"
  by transfer (simp add: dest_perm_raw_def)

lemma valid_perm_filter_id[simp]:
  "valid_perm p \<Longrightarrow> valid_perm [x\<leftarrow>p. fst x \<noteq> snd x]"
proof (simp (no_asm) add: valid_perm_def, intro conjI)
  show "valid_perm p \<Longrightarrow> distinct (map fst [x\<Colon>'a \<times> 'a\<leftarrow>p . fst x \<noteq> snd x])"
    by (auto simp add: distinct_map inj_on_def valid_perm_def)
  assume a: "valid_perm p"
  then show "fst ` {x\<Colon>'a \<times> 'a \<in> set p. fst x \<noteq> snd x} = snd ` {x\<Colon>'a \<times> 'a \<in> set p. fst x \<noteq> snd x}"
    apply -
    apply (frule valid_perm_distinct_snd)
    apply (simp add: valid_perm_def)
    apply auto
    apply (subgoal_tac "a \<in> snd ` set p")
    apply auto
    apply (subgoal_tac "(aa, ba) \<in> {x \<in> set p. fst x \<noteq> snd x}")
    apply (metis (lifting) image_eqI snd_conv)
    apply (metis (lifting, mono_tags) fst_conv mem_Collect_eq snd_conv pair_perm_apply)
    apply (metis fst_conv imageI)
    apply (drule sym)
    apply (subgoal_tac "b \<in> fst ` set p")
    apply auto
    apply (subgoal_tac "(aa, ba) \<in> {x \<in> set p. fst x \<noteq> snd x}")
    apply (metis (lifting) image_eqI fst_conv)
    apply simp
    apply (metis valid_perm_add_minus valid_perm_apply valid_perm_def)
    apply (metis snd_conv imageI)
    done
qed

lemma valid_perm_dest_pair_raw[simp]:
  assumes "valid_perm x"
  shows "valid_perm (dest_perm_raw x)"
  using valid_perm_filter_id valid_perm_sort assms
  unfolding dest_perm_raw_def
  by simp

lemma dest_perm_raw_repeat[simp]:
  "dest_perm_raw (dest_perm_raw p) = dest_perm_raw p"
  unfolding dest_perm_raw_def
  by simp (rule sorted_sort_id[OF sorted_sort])

lemma valid_dest_perm_raw_eq[simp]:
  "valid_perm p \<Longrightarrow> perm_eq (dest_perm_raw p) p"
  "valid_perm p \<Longrightarrow> perm_eq p (dest_perm_raw p)"
  by (simp_all add: dest_perm_raw_eq[symmetric])

lemma mk_perm_dest_perm[code abstype]:
  "mk_perm (dest_perm p) = p"
  by transfer
     (auto simp add: mk_perm_raw_def)

instantiation gperm :: (linorder) equal begin

definition equal_gperm_def: "equal_gperm a b \<longleftrightarrow> dest_perm a = dest_perm b"

instance
  apply default
  unfolding equal_gperm_def
  by transfer simp

end

lemma [code abstract]:
  "dest_perm 0 = []"
  by transfer (simp add: dest_perm_raw_def)

lemma [code abstract]:
  "dest_perm (-a) = dest_perm_raw (uminus_perm_raw (dest_perm a))"
  by transfer auto

lemma [code abstract]:
  "dest_perm (a + b) = dest_perm_raw (perm_add_raw (dest_perm a) (dest_perm b))"
  by transfer auto

lift_definition gpermute :: "'a gperm \<Rightarrow> 'a \<Rightarrow> 'a"
  is perm_apply
  by (simp add: perm_eq_def)

lemma gpermute_zero[simp]:
  "gpermute 0 x = x"
  by transfer simp

lemma gpermute_add[simp]:
  "gpermute (p + q) x = gpermute p (gpermute q x)"
  by transfer (simp add: perm_add_apply)

definition [simp]: "swap_raw a b = (if a = b then [] else [(a, b), (b, a)])"

lift_definition gswap :: "'a \<Rightarrow> 'a \<Rightarrow> 'a gperm" is swap_raw
  by (auto simp add: valid_perm_def)

lemma [code abstract]:
  "dest_perm (gswap a b) = (if (a, b) \<le> (b, a) then swap_raw a b else swap_raw b a)"
  by transfer (auto simp add: dest_perm_raw_def)

lemma swap_self [simp]:
  "gswap a a = 0"
  by transfer simp

lemma [simp]: "a \<noteq> b \<Longrightarrow> valid_perm [(a, b), (b, a)]"
  unfolding valid_perm_def by auto

lemma swap_cancel [simp]:
  "gswap a b + gswap a b = 0"
  "gswap a b + gswap b a = 0"
  by (transfer, auto simp add: perm_eq_def perm_add_apply)+

lemma minus_swap [simp]:
  "- gswap a b = gswap a b"
  by transfer (auto simp add: perm_eq_def)

lemma swap_commute:
  "gswap a b = gswap b a"
  by transfer (auto simp add: perm_eq_def)

lemma swap_triple:
  assumes "a \<noteq> b" "c \<noteq> b"
  shows "gswap a c + gswap b c + gswap a c = gswap a b"
  using assms
  by transfer (auto simp add: perm_eq_def fun_eq_iff perm_add_apply)

lemma gpermute_gswap[simp]:
  "b \<noteq> a \<Longrightarrow> gpermute (gswap a b) b = a"
  "a \<noteq> b \<Longrightarrow> gpermute (gswap a b) a = b"
  "c \<noteq> b \<Longrightarrow> c \<noteq> a \<Longrightarrow> gpermute (gswap a b) c = c"
  by (transfer, auto)+

lemma gperm_eq:
  "(p = q) = (\<forall>a. gpermute p a = gpermute q a)"
  by transfer (auto simp add: perm_eq_def)

lemma finite_gpermute_neq:
  "finite {a. gpermute p a \<noteq> a}"
  apply transfer
  apply (rule_tac B="fst ` set p" in finite_subset)
  apply auto
  by (metis perm_apply_outset)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Restricted_Equality\<close>
theory Restricted_Equality
  imports
    Binary_Relations_Order_Base
    Binary_Relation_Functions
    Equivalence_Relations
    Partial_Orders
begin

paragraph \<open>Summary\<close>
text \<open>Introduces the concept of restricted equalities.
An equality @{term "(=)"} can be restricted to only apply to a subset of its
elements. The restriction can be formulated, for example, by a predicate or a
set.\<close>

consts eq_restrict :: "'a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool"

bundle eq_restrict_syntax
begin
syntax
  "_eq_restrict" :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("(_) =(\<^bsub>_\<^esub>) (_)" [51,51,51] 50)
notation eq_restrict ("'(=(\<^bsub>_\<^esub>)')")
end
bundle no_eq_restrict_syntax
begin
no_syntax
  "_eq_restrict" :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("(_) =(\<^bsub>_\<^esub>) (_)" [51,51,51] 50)
no_notation eq_restrict ("'(=(\<^bsub>_\<^esub>)')")
end
unbundle eq_restrict_syntax

translations
  "x =\<^bsub>P\<^esub> y" \<rightleftharpoons> "CONST eq_restrict P x y"

overloading
  eq_restrict_pred \<equiv> "eq_restrict :: ('a \<Rightarrow>  bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
begin
  definition "eq_restrict_pred (P :: 'a \<Rightarrow> bool) \<equiv> ((=) :: 'a \<Rightarrow> _)\<restriction>\<^bsub>P\<^esub>"
end

lemma eq_restrict_eq_eq_restrict_left: "((=\<^bsub>P :: 'a \<Rightarrow> bool\<^esub>) :: 'a \<Rightarrow> _) = (=)\<restriction>\<^bsub>P\<^esub>"
  unfolding eq_restrict_pred_def by simp

lemma eq_restrictI [intro]:
  assumes "x = y"
  and "P x"
  shows "x =\<^bsub>P\<^esub> y"
  unfolding eq_restrict_eq_eq_restrict_left using assms by auto

lemma eq_restrictE [elim]:
  assumes "x =\<^bsub>P\<^esub> y"
  obtains "P x" "y = x"
  using assms unfolding eq_restrict_eq_eq_restrict_left by auto

lemma eq_restrict_iff: "x =\<^bsub>P\<^esub> y \<longleftrightarrow> y = x \<and> P x" by auto

lemma eq_restrict_le_eq: "((=\<^bsub>P :: 'a \<Rightarrow> bool\<^esub>) :: 'a \<Rightarrow> _) \<le> (=)"
  by (intro le_relI) auto

lemma eq_restrict_top_eq_eq [simp]: "(=\<^bsub>\<top> :: 'a \<Rightarrow> bool\<^esub>) = ((=) :: 'a \<Rightarrow> _)"
  unfolding eq_restrict_eq_eq_restrict_left by simp

lemma in_dom_eq_restrict_eq [simp]: "in_dom (=\<^bsub>P\<^esub>) = P" by auto
lemma in_codom_eq_restrict_eq [simp]: "in_codom (=\<^bsub>P\<^esub>) = P" by auto
lemma in_field_eq_restrict_eq [simp]: "in_field (=\<^bsub>P\<^esub>) = P" by auto

paragraph \<open>Order Properties\<close>

context
  fixes P :: "'a \<Rightarrow> bool"
begin

context
begin
lemma reflexive_on_eq_restrict: "reflexive_on P ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)" by auto
lemma transitive_eq_restrict: "transitive ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)" by auto
lemma symmetric_eq_restrict: "symmetric ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)" by auto
lemma antisymmetric_eq_restrict: "antisymmetric ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)" by auto
end

context
begin
lemma preorder_on_eq_restrict: "preorder_on P ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)"
  using reflexive_on_eq_restrict transitive_eq_restrict by auto
lemma partial_equivalence_rel_eq_restrict: "partial_equivalence_rel ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)"
  using symmetric_eq_restrict transitive_eq_restrict by auto
end

lemma partial_order_on_eq_restrict: "partial_order_on P ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)"
  using preorder_on_eq_restrict antisymmetric_eq_restrict by auto
lemma equivalence_rel_on_eq_restrict: "equivalence_rel_on P ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)"
  using partial_equivalence_rel_eq_restrict reflexive_on_eq_restrict by blast
end

end


subsection \<open>Fixed-width Word Theories\<close>

theory ValueThms
  imports Values
begin

(* declare [[show_types=true]] *)

subsubsection \<open>Support Lemmas for Upper/Lower Bounds\<close>

(* these two were weirdly hard to prove given it should be by definition *)
lemma size32: "size v = 32" for v :: "32 word"
  using size_word.rep_eq
  using One_nat_def add.right_neutral add_Suc_right len_of_numeral_defs(2) len_of_numeral_defs(3) mult.right_neutral mult_Suc_right numeral_2_eq_2 numeral_Bit0
  by (smt (verit, del_insts) mult.commute)

lemma size64: "size v = 64" for v :: "64 word"
  using size_word.rep_eq
  using One_nat_def add.right_neutral add_Suc_right len_of_numeral_defs(2) len_of_numeral_defs(3) mult.right_neutral mult_Suc_right numeral_2_eq_2 numeral_Bit0
  by (smt (verit, del_insts) mult.commute)

(* Nb. Word.sint_ge and sint_lt subsume these lemmas.
lemma signed_int_bottom32: "-(((2::int) ^ 31)) \<le> sint (v::int32)"
  using sint_range_size size32
  by (smt (verit, ccfv_SIG) One_nat_def Suc_pred add_Suc add_Suc_right eval_nat_numeral(3) nat.inject numeral_2_eq_2 numeral_Bit0 numeral_Bit1 zero_less_numeral)

lemma signed_int_top32: "(2 ^ 31) - 1 \<ge> sint (v::int32)"
  using sint_range_size size32
  by (smt (verit, ccfv_SIG) One_nat_def Suc_pred add_Suc add_Suc_right eval_nat_numeral(3) nat.inject numeral_2_eq_2 numeral_Bit0 numeral_Bit1 zero_less_numeral)
*)

lemma lower_bounds_equiv:
  assumes "0 < N"
  shows "-(((2::int) ^ (N-1))) = (2::int) ^ N div 2 * - 1"
  by (simp add: assms int_power_div_base)

lemma upper_bounds_equiv:
  assumes "0 < N"
  shows "(2::int) ^ (N-1) = (2::int) ^ N div 2"
  by (simp add: assms int_power_div_base)

text \<open>Some min/max bounds for 64-bit words\<close>

lemma bit_bounds_min64: "((fst (bit_bounds 64))) \<le> (sint (v::int64))"
  unfolding bit_bounds.simps fst_def
  using sint_ge[of v] by simp

lemma bit_bounds_max64: "((snd (bit_bounds 64))) \<ge> (sint (v::int64))"
  unfolding bit_bounds.simps fst_def
  using sint_lt[of v] by simp

text \<open>Extend these min/max bounds to extracting smaller signed words using $signed\_take\_bit$.\<close>

text \<open>Note: we could use signed to convert between bit-widths, instead of
  signed\_take\_bit.  But that would have to be done separately for each bit-width type.\<close>

value "sint(signed_take_bit 7 (128 :: int8))"

ML_val \<open>@{thm signed_take_bit_decr_length_iff}\<close>
declare [[show_types=true]]
ML_val \<open>@{thm signed_take_bit_int_less_exp}\<close>

lemma signed_take_bit_int_less_exp_word:
  fixes ival :: "'a :: len word"
  assumes "n < LENGTH('a)"
  shows "sint(signed_take_bit n ival) < (2::int) ^ n"
  apply transfer
  by (smt (verit, best) not_take_bit_negative signed_take_bit_eq_take_bit_shift
     signed_take_bit_int_less_exp take_bit_int_greater_self_iff)

lemma signed_take_bit_int_greater_eq_minus_exp_word:
  fixes ival :: "'a :: len word"
  assumes "n < LENGTH('a)"
  shows "- (2 ^ n) \<le> sint(signed_take_bit n ival)"
  apply transfer
  by (smt (verit, best) signed_take_bit_int_greater_eq_minus_exp
     signed_take_bit_int_greater_eq_self_iff signed_take_bit_int_less_exp)

lemma signed_take_bit_range:
  fixes ival :: "'a :: len word"
  assumes "n < LENGTH('a)"
  assumes "val = sint(signed_take_bit n ival)"
  shows "- (2 ^ n) \<le> val \<and> val < 2 ^ n"
  using signed_take_bit_int_greater_eq_minus_exp_word signed_take_bit_int_less_exp_word
  using assms by blast

text \<open>A $bit\_bounds$ version of the above lemma.\<close>

lemma signed_take_bit_bounds:
  fixes ival :: "'a :: len word"
  assumes "n \<le> LENGTH('a)"
  assumes "0 < n"
  assumes "val = sint(signed_take_bit (n - 1) ival)"
  shows "fst (bit_bounds n) \<le> val \<and> val \<le> snd (bit_bounds n)"
  using assms signed_take_bit_range lower_bounds_equiv upper_bounds_equiv
  by (metis bit_bounds.simps fst_conv less_imp_diff_less nat_less_le sint_ge sint_lt snd_conv zle_diff1_eq)

(* It is helpful to have the 64-bit instance of the above, to avoid uninstantiated types
   when apply it backwards. *)
lemma signed_take_bit_bounds64:
  fixes ival :: "int64"
  assumes "n \<le> 64"
  assumes "0 < n"
  assumes "val = sint(signed_take_bit (n - 1) ival)"
  shows "fst (bit_bounds n) \<le> val \<and> val \<le> snd (bit_bounds n)"
  using assms signed_take_bit_bounds
  by (metis size64 word_size)

lemma int_signed_value_bounds:
  assumes "b1 \<le> 64"
  assumes "0 < b1"
  shows "fst (bit_bounds b1) \<le> int_signed_value b1 v2 \<and>
         int_signed_value b1 v2 \<le> snd (bit_bounds b1)"
  using assms int_signed_value.simps signed_take_bit_bounds64 by blast

lemma int_signed_value_range:
  fixes ival :: "int64"
  assumes "val = int_signed_value n ival"
  shows "- (2 ^ (n - 1)) \<le> val \<and> val < 2 ^ (n - 1)"
  using signed_take_bit_range assms
  by (smt (verit, ccfv_SIG) One_nat_def diff_less int_signed_value.elims len_gt_0 len_num1 power_less_imp_less_exp power_strict_increasing sint_greater_eq sint_less)

text \<open>Some lemmas about unsigned words smaller than 64-bit, for zero-extend operators.\<close>

lemma take_bit_smaller_range:
  fixes ival :: "'a :: len word"
  assumes "n < LENGTH('a)"
  assumes "val = sint(take_bit n ival)"
  shows "0 \<le> val \<and> val < (2::int) ^ n"
  by (simp add: assms signed_take_bit_eq)

lemma take_bit_same_size_nochange:
  fixes ival :: "'a :: len word"
  assumes "n = LENGTH('a)"
  shows "ival = take_bit n ival"
  by (simp add: assms)

text \<open>A simplification lemma for $new\_int$, showing that upper bits can be ignored.\<close>

lemma take_bit_redundant[simp]:
  fixes ival :: "'a :: len word"
  assumes "0 < n"
  assumes "n < LENGTH('a)"
  shows "signed_take_bit (n - 1) (take_bit n ival) = signed_take_bit (n - 1) ival"
proof -
  have "\<not> (n \<le> n - 1)" using assms by arith
  then have "\<And>i . signed_take_bit (n - 1) (take_bit n i) = signed_take_bit (n-1) i"
    using signed_take_bit_take_bit by (metis (mono_tags))
  then show ?thesis
    by blast
qed

lemma take_bit_same_size_range:
  fixes ival :: "'a :: len word"
  assumes "n = LENGTH('a)"
  assumes "ival2 = take_bit n ival"
  shows "- (2 ^ n div 2) \<le> sint ival2 \<and> sint ival2 < 2 ^ n div 2"
  using assms lower_bounds_equiv sint_ge sint_lt by auto

lemma take_bit_same_bounds:
  fixes ival :: "'a :: len word"
  assumes "n = LENGTH('a)"
  assumes "ival2 = take_bit n ival"
  shows "fst (bit_bounds n) \<le> sint ival2 \<and> sint ival2 \<le> snd (bit_bounds n)"
  unfolding bit_bounds.simps
  using assms take_bit_same_size_range
  by force

text \<open>Next we show that casting a word to a wider word preserves any upper/lower bounds.
  (These lemmas may not be needed any more, since we are not using scast now?)\<close>

lemma scast_max_bound:
  assumes "sint (v :: 'a :: len word) < M"
  assumes "LENGTH('a) < LENGTH('b)"
  shows "sint ((scast v) :: 'b :: len word) < M"
  unfolding Word.scast_eq Word.sint_sbintrunc'
  using Bit_Operations.signed_take_bit_int_eq_self_iff
  by (smt (verit, best) One_nat_def assms(1) assms(2) decr_length_less_iff linorder_not_le power_strict_increasing_iff signed_take_bit_int_less_self_iff sint_greater_eq)
(* helpful thms?
  Word.scast_eq: scast (?w::?'b word) = word_of_int (sint ?w)
  Word.sint_lt: sint (?x::?'a word) < (2::int) ^ (LENGTH(?'a) - (1::nat)
  Word.sint_uint: sint (w::'a word) = signed_take_bit (LENGTH('a) - Suc (0::nat)) (uint w)
  Word.sint_sbintrunc' :  sint (word_of_int (?bin::int)) = signed_take_bit (LENGTH(?'a) - (1::nat)) ?bin
  Word.int_word_sint   - moves up, takes mod, then moves down
  Bit_Operations.signed_take_bit_int_eq_self_iff:
    (signed_take_bit (?n::nat) (?k::int) = ?k) = (- ((2::int) ^ ?n) \<sqsubseteq> ?k \<and> ?k < (2::int) ^ ?n)
  Bit_Operations.signed_take_bit_int_eq_self:
    - ((2::int) ^ (?n::nat)) \<sqsubseteq> (?k::int) \<Longrightarrow> ?k < (2::int) ^ ?n \<Longrightarrow> signed_take_bit ?n ?k = ?k
*)

lemma scast_min_bound:
  assumes "M \<le> sint (v :: 'a :: len word)"
  assumes "LENGTH('a) < LENGTH('b)"
  shows "M \<le> sint ((scast v) :: 'b :: len word)"
  unfolding Word.scast_eq Word.sint_sbintrunc'
  using Bit_Operations.signed_take_bit_int_eq_self_iff
  by (smt (verit) One_nat_def Suc_pred assms(1) assms(2) len_gt_0 less_Suc_eq order_less_le order_less_le_trans power_le_imp_le_exp signed_take_bit_int_greater_eq_self_iff sint_lt)

lemma scast_bigger_max_bound:
  assumes "(result :: 'b :: len word) = scast (v :: 'a :: len word)"
  shows "sint result < 2 ^ LENGTH('a) div 2"
  using sint_lt upper_bounds_equiv scast_max_bound
  by (smt (verit, best) assms(1) len_gt_0 signed_scast_eq signed_take_bit_int_greater_self_iff sint_ge sint_less upper_bounds_equiv)

lemma scast_bigger_min_bound:
  assumes "(result :: 'b :: len word) = scast (v :: 'a :: len word)"
  shows "- (2 ^ LENGTH('a) div 2) \<le> sint result"
  using sint_ge lower_bounds_equiv scast_min_bound
  by (smt (verit) assms len_gt_0 nat_less_le not_less scast_max_bound)

lemma scast_bigger_bit_bounds:
  assumes "(result :: 'b :: len word) = scast (v :: 'a :: len word)"
  shows "fst (bit_bounds (LENGTH('a))) \<le> sint result \<and> sint result \<le> snd (bit_bounds (LENGTH('a)))"
  using assms scast_bigger_min_bound scast_bigger_max_bound
  by auto

text \<open>Results about $new\_int$.\<close>

(* may be too trivial? *)
lemma new_int_take_bits:
  assumes "IntVal b val = new_int b ival"
  shows "take_bit b val = val"
  using assms by force

subsubsection \<open>Support lemmas for take bit and signed take bit.\<close>

text \<open>Lemmas for removing redundant take\_bit wrappers.\<close>

lemma take_bit_dist_addL[simp]:
  fixes x :: "'a :: len word"
  shows "take_bit b (take_bit b x + y) = take_bit b (x + y)"
proof (induction b)
  case 0
  then show ?case
    by simp
next
  case (Suc b)
  then show ?case
    by (simp add: add.commute mask_eqs(2) take_bit_eq_mask)
qed

lemma take_bit_dist_addR[simp]:
  fixes x :: "'a :: len word"
  shows "take_bit b (x + take_bit b y) = take_bit b (x + y)"
  using take_bit_dist_addL by (metis add.commute)

lemma take_bit_dist_subL[simp]:
  fixes x :: "'a :: len word"
  shows "take_bit b (take_bit b x - y) = take_bit b (x - y)"
  by (metis take_bit_dist_addR uminus_add_conv_diff)

lemma take_bit_dist_subR[simp]:
  fixes x :: "'a :: len word"
  shows "take_bit b (x - take_bit b y) = take_bit b (x - y)"
  using take_bit_dist_subL
  by (metis (no_types, opaque_lifting) diff_add_cancel diff_right_commute diff_self)

lemma take_bit_dist_neg[simp]:
  fixes ix :: "'a :: len word"
  shows "take_bit b (- take_bit b (ix)) = take_bit b (- ix)"
  by (metis diff_0 take_bit_dist_subR)

lemma signed_take_take_bit[simp]:
  fixes x :: "'a :: len word"
  assumes "0 < b"
  shows "signed_take_bit (b - 1) (take_bit b x) = signed_take_bit (b - 1) x"
  by (smt (verit, best) Suc_diff_1 assms lessI linorder_not_less signed_take_bit_take_bit)

lemma mod_larger_ignore:
  fixes a :: int
  fixes m n :: nat
  assumes "n < m"
  shows "(a mod 2 ^ m) mod 2 ^ n = a mod 2 ^ n"
  by (smt (verit, del_insts) assms exp_mod_exp linorder_not_le mod_0_imp_dvd mod_mod_cancel mod_self order_less_imp_le)

lemma mod_dist_over_add:
  fixes a b c :: int64  (* "'a :: len word" *)
  fixes n :: nat
  assumes 1: "0 < n"
  assumes 2: "n < 64"
  shows "(a mod 2^n + b) mod 2^n = (a + b) mod 2^n"
proof -
  have 3: "(0 :: int64) < 2 ^ n"
    using assms by (simp add: size64 word_2p_lem)
  then show ?thesis
    unfolding word_mod_2p_is_mask[OF 3]
    apply transfer
    by (metis (no_types, opaque_lifting) and.right_idem take_bit_add take_bit_eq_mask)
qed

end