theory prop_30
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster append rev *)

hipster append rev
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes  append.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes append.simps)

lemma lemma_ab [thy_expl]: "append (rev x4) (rev y4) = rev (append y4 x4)"
by (hipster_induct_schemes rev.simps append.simps)

lemma lemma_ac [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes rev.simps append.simps)

  theorem x0 :
    "(rev (append (rev x) (Nil2))) = x"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Port of Anthony Fox's HOL4 realisation of John Harrison's paper
   in TPHOLs 2005 on finite cartesian products *)

theory Arrays
imports
  "~~/src/HOL/Main"
  "~~/src/HOL/Library/Numeral_Type"
begin

definition
  has_size :: "'a set => nat => bool" where
   "has_size s n == finite(s) \<and> card(s) = n"

definition
  finite_index :: "nat => 'a::finite" where
  "finite_index ==
     SOME f. ALL x::'a. EX! n. n < CARD('a::finite) & f n = x"

lemma card_image_inj[rule_format]:
  "finite s ==>  (ALL x y. x : s & y : s & f x = f y --> x = y) -->
                 (card (f ` s) = card s)"
apply (erule finite_induct)
apply (simp_all add: card_insert_if)
apply clarsimp
apply blast
done

lemma has_size_image_inj:
  "[| has_size s n ;
      (!!x y. x \<in> s \<and> y \<in> s \<and> f x = f y ==> x = y) |]
   ==>
     has_size (f ` s) n"
apply (simp add: has_size_def card_image_inj)
done

lemma has_size_0[simp]:
  "has_size s 0 = (s = {})"
apply(simp_all add: has_size_def)
apply(rule iffI)
  apply clarsimp
apply simp
done

lemma has_size_suc:
  "has_size s (Suc n) =
     (s ~= {} & (ALL a. a : s --> has_size (s - {a}) n))"
apply (simp add: has_size_def)
apply (case_tac "s = {}", simp_all)
apply (simp add: card_Diff_singleton cong: conj_cong)
apply (case_tac "finite s", simp_all)
apply (subgoal_tac "EX a. a : s")
  apply simp
  apply (subgoal_tac "card s ~= 0")
    apply arith
  apply (erule contrapos_nn)
  apply simp
apply (simp add: ex_in_conv)
done

lemma has_index[rule_format]:
  "ALL s. finite s & card s = n -->
            (EX f. (ALL m. m < n --> f m : s) &
                   (ALL x. x : s --> (EX! m. m < n & f m = x)))"
apply (rule nat.induct)
  apply (simp add: card_eq_0_iff cong: conj_cong)
apply clarsimp
apply (simp add: card_Suc_eq )
apply clarsimp
apply (erule_tac x = "B" in allE)
apply simp
apply clarsimp
apply (rule_tac x = "%n. if n = card B then b else f n" in exI)
apply clarsimp
apply rule
  apply rule
  apply (rule ex_ex1I)
    apply (rule_tac x = "card B" in exI)
    apply simp
  apply (subgoal_tac "m = card B")
    apply (subgoal_tac "y = card B")
      apply simp
    apply (rule ccontr)
    apply (subgoal_tac "y < Suc (card B) & f y = b")
      apply (subgoal_tac "y < card B")
        apply fast
      apply arith
    apply fast
  apply (rule ccontr)
  apply (subgoal_tac "m < Suc (card B) & f m = b")
    apply (subgoal_tac "m < card B")
      apply fast
    apply arith
  apply fast
apply rule
apply (rule ex_ex1I)
  apply (erule_tac x = x in allE)
  apply (erule_tac impE)
    apply simp
  apply (drule ex1_implies_ex)
  apply clarsimp
  apply (rule_tac x = m in exI)
  apply simp
apply (subgoal_tac "b ~= x")
  apply simp
  apply clarsimp
  apply (subgoal_tac "y < card B & m < card B")
    apply clarsimp
    apply blast
  apply arith
apply blast
done

lemma finite_index_works[rule_format]:
  "ALL i :: 'a. EX! n. n < CARD('a::finite) & finite_index n = i"
apply (simp add: finite_index_def)
apply (rule someI_ex[where 'a = "nat => 'a"])
apply (insert has_index[where s = "UNIV :: 'a set"])
apply (simp add: finite)
done

lemma finite_index_inj:
  "[| i < CARD('a::finite); j < CARD('a) |] ==>
   ((finite_index i :: 'a) = finite_index j) = (i = j)"
apply (insert finite_index_works[where i = "finite_index j"])
apply blast
done

lemma forall_finite_index:
  "(ALL k::('a::finite). P k) =
   (ALL i. i < CARD('a) --> P (finite_index i))"
apply rule
  apply simp
apply rule+
apply (insert finite_index_works[where 'a = 'a])
apply (erule_tac x = "k::'a" in meta_allE)
apply blast
done

section {* Finite Cartesian Products *}

typedef ('a,'b) array ("_[_]" [30,0] 31)
  = "UNIV :: ('b::finite => 'a) set"
by simp

lemma array_inject:
  "(Abs_array x = Abs_array y) = (x = y)"
  by (metis Abs_array_inverse UNIV_I)

lemma array_induct:
  "(!!f. P (Abs_array f)) \<Longrightarrow> P x"
apply (drule_tac allI)
apply (drule_tac spec[where ?x = "Rep_array x"])
apply (simp add: Rep_array_inverse)
done

rep_datatype "Abs_array"
  by (auto simp: array_inject intro: array_induct)

(* should add nice syntax for index *)
definition index :: "('a,'b::finite)array => nat => 'a" where
  "index x i == Rep_array x (finite_index i)"

lemma my_ext: "(ALL x. f x = g x) = (f = g)"
apply (rule+, simp+)
done

theorem cart_eq:
  "((x::('a,'b::finite)array) = y) =
      (ALL i. i < CARD('b) --> index x i = index y i)"
apply (rule, simp)
apply (simp add: index_def)
apply (drule forall_finite_index[THEN iffD2])
apply (simp add: my_ext Rep_array_inject)
done

(* should make FCP a binder, and perhaps call it something else.
   Maybe "ARRAY" ? *)
definition FCP :: "(nat => 'a) => ('a,'b::finite) array" where
  "FCP == \<lambda> g.
             SOME f.
               ALL i. i < CARD('b) --> index f i = g i"

definition
  update :: "('a,'b::finite) array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('a,'b) array"
where
  "update f i x \<equiv> FCP ((index f)(i := x))"

definition
  fupdate :: "nat => ('a => 'a) => ('a,'b::finite) array =>
              ('a,'b::finite) array"
where
  "fupdate i f x \<equiv> update x i (f (index x i))"

lemma fcp_beta[rule_format]:
  "ALL i. i < CARD('b::finite) -->
          index (FCP g :: ('a,'b) array) i = g i"
apply (simp add: FCP_def)
apply (rule someI_ex)
apply (rule_tac x =
                "Abs_array (%k. g (SOME i. i < CARD('b) &
                                           finite_index i = k))"
       in exI)
apply (simp add: index_def Abs_array_inverse)
apply rule+
apply (rule arg_cong[where 'a = nat])
apply (rule some_equality)
  apply simp
apply (erule conjE)
apply (rule finite_index_inj[THEN iffD1])
apply simp_all
done

lemma fcp_unique:
  "(ALL i. i < CARD('b::finite) --> (index f i = g i)) =
   (FCP g = (f :: ('a,'b) array))"
  by (fastforce simp: cart_eq fcp_beta)

lemma fcp_eta:
  "FCP (%i. index g i) = g"
  by (simp add: cart_eq fcp_beta)

lemma index_update [simp]:
  "n < CARD('b::finite) \<Longrightarrow> index (update (f::('a,'b) array) n x) n = x"
  by (simp add: update_def fcp_beta)

lemma index_update2 [simp]:
  "\<lbrakk> k < CARD('b::finite); n \<noteq> k \<rbrakk>
   \<Longrightarrow>
    index (update (f::('a,'b) array) n x) k = index f k"
  by (simp add: update_def fcp_beta)

lemma update_update [simp]:
  "update (update f n x) n y = update f n y"
apply(subst cart_eq)
apply clarsimp
apply(case_tac "i=n")
 apply simp+
done

lemma update_comm [simp]:
  "n \<noteq> m \<Longrightarrow> update (update f m v) n v' = update (update f n v') m v"
apply(subst cart_eq)
apply clarsimp
apply(case_tac "i=n")
 apply simp
apply(case_tac "i=m")
 apply simp
apply simp
done

lemma update_index_same [simp]:
  "update v n (index v n) = v"
apply(subst cart_eq)
apply clarsimp
apply(case_tac "i=n")
 apply simp+
done

function
  foldli0 :: "(nat => 'acc => 'a => 'acc) => 'acc => nat => ('a,'index::finite)array => 'acc"
where
  "foldli0 f a i (arr::('a,'index::finite)array) =
     (if CARD('index::finite) <= i then a
      else foldli0 f (f i a (index arr i)) (i+1) arr)"
  by pat_completeness auto

termination
  apply (relation "measure (% (f,a,i,(arr::('b,'c::finite)array)). CARD('c) - i)")
  apply auto
  done

definition
  foldli :: "(nat => 'acc => 'a => 'acc) => 'acc => ('a,'i::finite) array => 'acc"
where
   "foldli f a arr == foldli0 f a 0 arr"

(* for a traditional word presentation, with MSB on the left, you'd
   want a fold that numbered in the reverse direction (with element 0
   on the right rather than the left) *)

end


(*  Title:      HOL/HOLCF/Product_Cpo.thy
    Author:     Franz Regensburger
*)

section \<open>The cpo of cartesian products\<close>

theory Product_Cpo
  imports Adm
begin

default_sort cpo

subsection \<open>Unit type is a pcpo\<close>

instantiation unit :: discrete_cpo
begin

definition below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"

instance
  by standard simp

end

instance unit :: pcpo
  by standard simp

subsection \<open>Product type is a partial order\<close>

instantiation prod :: (below, below) below
begin

definition below_prod_def: "(\<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"

instance ..

end

instance prod :: (po, po) po
proof
  fix x :: "'a \<times> 'b"
  show "x \<sqsubseteq> x"
    by (simp add: below_prod_def)
next
  fix x y :: "'a \<times> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x"
  then show "x = y"
    unfolding below_prod_def prod_eq_iff
    by (fast intro: below_antisym)
next
  fix x y z :: "'a \<times> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z"
  then show "x \<sqsubseteq> z"
    unfolding below_prod_def
    by (fast intro: below_trans)
qed

subsection \<open>Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>

lemma prod_belowI: "fst p \<sqsubseteq> fst q \<Longrightarrow> snd p \<sqsubseteq> snd q \<Longrightarrow> p \<sqsubseteq> q"
  by (simp add: below_prod_def)

lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
  by (simp add: below_prod_def)

text \<open>Pair \<open>(_,_)\<close>  is monotone in both arguments\<close>

lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
  by (simp add: monofun_def)

lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
  by (simp add: monofun_def)

lemma monofun_pair: "x1 \<sqsubseteq> x2 \<Longrightarrow> y1 \<sqsubseteq> y2 \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
  by simp

lemma ch2ch_Pair [simp]: "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
  by (rule chainI, simp add: chainE)

text \<open>\<^term>\<open>fst\<close> and \<^term>\<open>snd\<close> are monotone\<close>

lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
  by (simp add: below_prod_def)

lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
  by (simp add: below_prod_def)

lemma monofun_fst: "monofun fst"
  by (simp add: monofun_def below_prod_def)

lemma monofun_snd: "monofun snd"
  by (simp add: monofun_def below_prod_def)

lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]

lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]

lemma prod_chain_cases:
  assumes chain: "chain Y"
  obtains A B
  where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
proof
  from chain show "chain (\<lambda>i. fst (Y i))"
    by (rule ch2ch_fst)
  from chain show "chain (\<lambda>i. snd (Y i))"
    by (rule ch2ch_snd)
  show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))"
    by simp
qed

subsection \<open>Product type is a cpo\<close>

lemma is_lub_Pair: "range A <<| x \<Longrightarrow> range B <<| y \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
  by (simp add: is_lub_def is_ub_def below_prod_def)

lemma lub_Pair: "chain A \<Longrightarrow> chain B \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
  for A :: "nat \<Rightarrow> 'a::cpo" and B :: "nat \<Rightarrow> 'b::cpo"
  by (fast intro: lub_eqI is_lub_Pair elim: thelubE)

lemma is_lub_prod:
  fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
  assumes "chain S"
  shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
  using assms by (auto elim: prod_chain_cases simp: is_lub_Pair cpo_lubI)

lemma lub_prod: "chain S \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
  for S :: "nat \<Rightarrow> 'a::cpo \<times> 'b::cpo"
  by (rule is_lub_prod [THEN lub_eqI])

instance prod :: (cpo, cpo) cpo
proof
  fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
  assume "chain S"
  then have "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
    by (rule is_lub_prod)
  then show "\<exists>x. range S <<| x" ..
qed

instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
proof
  fix x y :: "'a \<times> 'b"
  show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
    by (simp add: below_prod_def prod_eq_iff)
qed

subsection \<open>Product type is pointed\<close>

lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
  by (simp add: below_prod_def)

instance prod :: (pcpo, pcpo) pcpo
  by intro_classes (fast intro: minimal_prod)

lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
  by (rule minimal_prod [THEN bottomI, symmetric])

lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  by (simp add: inst_prod_pcpo)

lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
  unfolding inst_prod_pcpo by (rule fst_conv)

lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
  unfolding inst_prod_pcpo by (rule snd_conv)

lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
  by simp

lemma split_strict [simp]: "case_prod f \<bottom> = f \<bottom> \<bottom>"
  by (simp add: split_def)

subsection \<open>Continuity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>

lemma cont_pair1: "cont (\<lambda>x. (x, y))"
  apply (rule contI)
  apply (rule is_lub_Pair)
   apply (erule cpo_lubI)
  apply (rule is_lub_const)
  done

lemma cont_pair2: "cont (\<lambda>y. (x, y))"
  apply (rule contI)
  apply (rule is_lub_Pair)
   apply (rule is_lub_const)
  apply (erule cpo_lubI)
  done

lemma cont_fst: "cont fst"
  apply (rule contI)
  apply (simp add: lub_prod)
  apply (erule cpo_lubI [OF ch2ch_fst])
  done

lemma cont_snd: "cont snd"
  apply (rule contI)
  apply (simp add: lub_prod)
  apply (erule cpo_lubI [OF ch2ch_snd])
  done

lemma cont2cont_Pair [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. (f x, g x))"
  apply (rule cont_apply [OF f cont_pair1])
  apply (rule cont_apply [OF g cont_pair2])
  apply (rule cont_const)
  done

lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]

lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]

lemma cont2cont_case_prod:
  assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
  assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
  assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
  unfolding split_def
  apply (rule cont_apply [OF g])
   apply (rule cont_apply [OF cont_fst f2])
   apply (rule cont_apply [OF cont_snd f3])
   apply (rule cont_const)
  apply (rule f1)
  done

lemma prod_contI:
  assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
  assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
  shows "cont f"
proof -
  have "cont (\<lambda>(x, y). f (x, y))"
    by (intro cont2cont_case_prod f1 f2 cont2cont)
  then show "cont f"
    by (simp only: case_prod_eta)
qed

lemma prod_cont_iff: "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
  apply safe
    apply (erule cont_compose [OF _ cont_pair1])
   apply (erule cont_compose [OF _ cont_pair2])
  apply (simp only: prod_contI)
  done

lemma cont2cont_case_prod' [simp, cont2cont]:
  assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. case_prod (f x) (g x))"
  using assms by (simp add: cont2cont_case_prod prod_cont_iff)

text \<open>The simple version (due to Joachim Breitner) is needed if
  either element type of the pair is not a cpo.\<close>

lemma cont2cont_split_simple [simp, cont2cont]:
  assumes "\<And>a b. cont (\<lambda>x. f x a b)"
  shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
  using assms by (cases p) auto

text \<open>Admissibility of predicates on product types.\<close>

lemma adm_case_prod [simp]:
  assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
  shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
  unfolding case_prod_beta using assms .

subsection \<open>Compactness and chain-finiteness\<close>

lemma fst_below_iff: "fst x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
  for x :: "'a \<times> 'b"
  by (simp add: below_prod_def)

lemma snd_below_iff: "snd x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
  for x :: "'a \<times> 'b"
  by (simp add: below_prod_def)

lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
  by (rule compactI) (simp add: fst_below_iff)

lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
  by (rule compactI) (simp add: snd_below_iff)

lemma compact_Pair: "compact x \<Longrightarrow> compact y \<Longrightarrow> compact (x, y)"
  by (rule compactI) (simp add: below_prod_def)

lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
  apply (safe intro!: compact_Pair)
   apply (drule compact_fst, simp)
  apply (drule compact_snd, simp)
  done

instance prod :: (chfin, chfin) chfin
  apply intro_classes
  apply (erule compact_imp_max_in_chain)
  apply (case_tac "\<Squnion>i. Y i", simp)
  done

end


section \<open>Deutsch-Schorr-Waite Marking Algorithm\<close>

theory DSWMark
imports LinkMark
begin

text\<open>
Finally, we construct the Deutsch-Schorr-Waite marking algorithm by assuming that there
are only two pointers ($\mathit{left}$, $\mathit{right}$) from every node. There is also a new variable,
$\mathit{atom}: \mathit{node} \to  \mathit{bool}$ which associates to every node a Boolean value.
The data invariant of this refinement step requires that $\mathit{index}$ has exactly two distinct
elements $none$  and $\mathit{some}$, $\mathit{left} = \mathit{link}\ \mathit{none}$,
$\mathit{right}=\mathit{link}\  \mathit{some}$, and $\mathit{atom}\ x$ is true
if and only if $\mathit{label}\ x = \mathit{some}$.

We use a new locale which fixes the initial values of the variables $\mathit{left}$, $\mathit{right}$, and
$\mathit{atom}$ in $\mathit{left0}$, $\mathit{right0}$, and $\mathit{atom0}$ respectively.
\<close>

datatype Index = none | some

locale classical = node +
  fixes left0  :: "'node \<Rightarrow> 'node"
  fixes right0 :: "'node \<Rightarrow> 'node"
  fixes atom0  :: "'node \<Rightarrow> bool"
  assumes "(nil::'node) = nil"
  begin
    definition
      "link0 i = (if i = (none::Index) then left0 else right0)"

    definition
      "label0 x = (if atom0 x then (some::Index) else none)"
  end

sublocale classical \<subseteq> dsw?: pointer "nil" "root" "none::Index" "link0" "label0"
proof qed auto

context classical
begin

definition
  "gg mrk atom ptr x \<equiv> ptr x \<noteq> nil \<and> ptr x \<notin> mrk \<and> \<not> atom x"

subsection \<open>Transitions\<close>

definition
  "QQ1_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
         root = nil \<and>  p' = nil \<and> t' = nil \<and> mrk' = mrk \<and> left' = left
         \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ2_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
         root \<noteq> nil \<and>  p' = root \<and> t' = nil \<and> mrk' = mrk \<union> {root}
         \<and> left' = left \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ3_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> gg mrk atom left p \<and>
      p' = left p \<and> t' = p \<and> mrk' = mrk \<union> {left p} \<and>
      left' = left(p := t) \<and> right' = right \<and> atom' = atom:]"

definition
  "QQ4_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> gg mrk atom right p \<and>
      p' = right p \<and> t' = p \<and> mrk' = mrk \<union> {right p} \<and>
      left' = left \<and> right' = right(p := t) \<and> atom' = atom(p := True) :]"

definition
  "QQ5_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> \<comment> \<open>not needed in the proof\<close>
      \<not> gg mrk atom left p \<and> \<not> gg mrk atom right p \<and>
      t \<noteq> nil \<and> \<not> atom t \<and>
      p' = t \<and> t' = left t \<and> mrk' = mrk \<and>
      left' = left(t := p) \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ6_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> \<comment> \<open>not needed in the proof\<close>
      \<not> gg mrk atom left p \<and> \<not> gg mrk atom right p \<and>
      t \<noteq> nil \<and> atom t \<and>
      p' = t \<and> t' = right t \<and> mrk' = mrk \<and>
      left' = left \<and> right' = right(t := p) \<and> atom' = atom(t := False) :]"

definition
  "QQ7_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and>
      \<not> gg mrk atom left p \<and> \<not> gg mrk atom right p \<and>
      t = nil \<and>
      p' = nil \<and> t' = t \<and> mrk' = mrk \<and>
      left' = left \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ8_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
     p = nil \<and> p' = p \<and> t' = t \<and> mrk' = mrk \<and> left' = left \<and> right' = right \<and> atom' = atom:]"

section \<open>Data refinement relation\<close>

definition
  "RR_a \<equiv> {: p, t, left, right, atom, mrk \<leadsto> p', t', lnk, lbl, mrk' .
          lnk none = left \<and> lnk some = right \<and>
          lbl = (\<lambda> x . if atom x then some else none) \<and>
          p' = p \<and> t' = t \<and> mrk' = mrk :}"

definition [simp]:
  "R''_a i = RR_a"

definition
  "ClassicMark = (\<lambda> (i, j) . (case (i, j) of
      (I.init, I.loop)  \<Rightarrow> QQ1_a \<sqinter> QQ2_a |
      (I.loop, I.loop)  \<Rightarrow> (QQ3_a \<sqinter> QQ4_a) \<sqinter> ((QQ5_a \<sqinter> QQ6_a) \<sqinter> QQ7_a) |
      (I.loop, I.final) \<Rightarrow> QQ8_a |
       _ \<Rightarrow> \<top>))"

subsection \<open>Data refinement of the transitions\<close>

theorem init1_a [simp]:
  "DataRefinement ({.Init''.} o Q1''_a) RR_a RR_a QQ1_a"
  by (simp add: data_refinement_hoare hoare_demonic angelic_def QQ1_a_def Q1''_a_def RR_a_def
       Init''_def subset_eq)

theorem init2_a [simp]:
  "DataRefinement ({.Init''.} o Q2''_a) RR_a RR_a QQ2_a"
  by (simp add: data_refinement_hoare hoare_demonic angelic_def QQ2_a_def Q2''_a_def RR_a_def
       Init''_def subset_eq)

lemma index_simp:
  "(u = v) = (u none = v none \<and> u some = v some)"
  by (safe, rule ext, case_tac "x", auto)

theorem step1_a [simp]:
  "DataRefinement ({.Loop''.} o Q3''_a) RR_a RR_a QQ3_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def QQ3_a_def  Q3''_a_def RR_a_def
       Loop''_def subset_eq g_def gg_def simp_eq_emptyset)
  apply safe
  apply (rule_tac x="\<lambda> x . if x = some then ab some else (ab none)(a := aa)" in exI)
  apply simp
  apply (rule_tac x="none" in exI)
  apply (simp add: index_simp)
  done

theorem step2_a[simp]:
  "DataRefinement ({.Loop''.} o Q3''_a) RR_a RR_a QQ4_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def QQ4_a_def Q3''_a_def RR_a_def
       Loop''_def subset_eq g_def gg_def simp_eq_emptyset)
  apply safe
  apply (rule_tac x="\<lambda> x . if x = none then ab none else (ab some)(a := aa)" in exI)
  apply simp
  apply (rule_tac x="some" in exI)
  apply (simp add: index_simp)
  apply (rule ext)
  apply auto
  done

theorem step3_a [simp]:
  "DataRefinement ({.Loop''.} o Q4''_a) RR_a RR_a QQ5_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def QQ5_a_def Q4''_a_def RR_a_def
       Loop''_def subset_eq g_def gg_def simp_eq_emptyset)
  apply clarify
  apply (case_tac "i")
  apply auto
  done

lemma if_set_elim: "(x \<in> (if b then A else B)) = ((b \<and> x \<in> A) \<or> (\<not> b \<and> x \<in> B))"
  by auto

theorem step4_a [simp]:
  "DataRefinement ({.Loop''.} o  Q4''_a) RR_a RR_a QQ6_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def RR_a_def QQ6_a_def Q4''_a_def
       Loop''_def subset_eq simp_eq_emptyset g_def gg_def if_set_elim)
  apply (simp add: ext)
  apply safe
  apply (case_tac "i")
  apply simp_all
  apply (case_tac "i")
  apply simp_all
  apply (case_tac "i")
  apply simp_all
  apply (case_tac "i")
  by simp_all

theorem step5_a [simp]:
  "DataRefinement ({.Loop''.} o Q5''_a) RR_a RR_a QQ7_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def Q5''_a_def QQ7_a_def
       Loop''_def subset_eq RR_a_def simp_eq_emptyset)
  apply safe
  apply (simp_all add: g_def gg_def)
  apply (case_tac "i")
  by auto

theorem final_step_a [simp]:
  "DataRefinement ({.Loop''.} o Q6''_a) RR_a RR_a QQ8_a"
  by (simp add: data_refinement_hoare hoare_demonic angelic_def Q6''_a_def QQ8_a_def
       Loop''_def subset_eq RR_a_def simp_eq_emptyset)

subsection \<open>Diagram data refinement\<close>

lemma [simp]: "mono RR_a" by (simp add: RR_a_def)
lemma [simp]: "RR_a \<in> Apply.Disjunctive" by (simp add: RR_a_def)
lemma [simp]: "Disjunctive_fun R''_a" by (simp add: Disjunctive_fun_def)

lemma [simp]: "mono_fun R''_a" by simp

lemma [simp]: "mono Q1''_a" by (simp add: Q1''_a_def)
lemma [simp]: "mono Q2''_a" by (simp add: Q2''_a_def)
lemma [simp]: "mono Q3''_a" by (simp add: Q3''_a_def)
lemma [simp]: "mono Q4''_a" by (simp add: Q4''_a_def)
lemma [simp]: "mono Q5''_a" by (simp add: Q5''_a_def)
lemma [simp]: "mono Q6''_a" by (simp add: Q6''_a_def)

lemma [simp]: "dmono LinkMark"
  apply (unfold dmono_def LinkMark_def)
  by simp

theorem ClassicMark_DataRefinement_a [simp]:
 "DgrDataRefinement2 (R'_a .. (R_a .. SetMarkInv)) LinkMark R''_a ClassicMark"
  apply (rule_tac P = "LinkMarkInv" in DgrDataRefinement_mono)
  apply (simp add: le_fun_def SetMarkInv_def
    angelic_def R1'_a_def R2'_a_def Init''_def Loop''_def Final''_def)
  apply auto
  apply (simp add: DgrDataRefinement2_def dgr_demonic_def ClassicMark_def LinkMark_def
    demonic_sup_inf data_refinement_choice2 assert_comp_choice)
  apply (rule data_refinement_choice2)
  apply simp
  apply (rule data_refinement_choice1)
  apply simp_all
  apply (rule data_refinement_choice2)
  apply simp_all
  apply (rule data_refinement_choice1)
  by simp_all

subsection \<open>Diagram corectness\<close>

theorem ClassicMark_correct_a [simp]:
  "Hoare_dgr  (R''_a .. (R'_a .. (R_a .. SetMarkInv)))  ClassicMark
         ((R''_a .. (R'_a ..(R_a .. SetMarkInv))) \<sqinter> (- grd (step ClassicMark)))"
  apply (rule_tac D = "LinkMark" in Diagram_DataRefinement2)
  apply auto
  by (rule LinkMark_correct)

text \<open>
We have proved the correctness of the final algorithm, but the pre and the post conditions
involve the angelic choice operator and they depend on all data refinement steps we
have used to prove the final diagram. We simplify these conditions and we show that
we obtained indead the corectness of the marking algorithm.

The predicate $\mathit{ClassicInit}$ which is true for the $\mathit{init}$ situation states that initially
the variables $\mathit{left}$, $\mathit{right}$, and $\mathit{atom}$ are equal to their initial values and also
that no node is marked.

The predicate $\mathit{ClassicFinal}$ which is true for the $final$ situation states that at the end
the values of the variables $\mathit{left}$, $\mathit{right}$, and $\mathit{atom}$ are again equal to their initial values
and the variable $mrk$ records all reachable nodes. The reachable nodes are defined using our initial
$\mathit{next}$ relation, however if we unfold all locale interpretations and definitions we see easeily
that a node $x$ is reachable if there is a path from $root$ to $x$ along $\mathit{left}$ and $\mathit{right}$ functions,
and all nodes in this path have the atom bit false.
\<close>

definition
  "ClassicInit = {(p, t, left, right, atom, mrk) .
      atom = atom0 \<and> left = left0 \<and> right = right0 \<and>
      finite (- mrk) \<and> mrk = {}}"

definition
  "ClassicFinal = {(p, t, left, right, atom, mrk) .
       atom = atom0 \<and> left = left0 \<and> right = right0 \<and>
       mrk = reach root}"

theorem [simp]:
  "ClassicInit \<subseteq> (RR_a (R1'_a (R1_a (SetMarkInv init))))"
  apply (simp add: SetMarkInv_def)
  apply (simp add: ClassicInit_def angelic_def RR_a_def R1'_a_def R1_a_def Init_def Init''_def)
  apply safe
  apply (unfold simp_eq_emptyset)
  apply (simp add: link0_def label0_def)
  apply (simp add: fun_eq_iff)
  by (simp add: label0_def)

theorem [simp]:
  "(RR_a (R1'_a (R1_a (SetMarkInv final)))) \<le> ClassicFinal"
  apply (simp add: SetMarkInv_def)
  apply (simp add: ClassicFinal_def angelic_def RR_a_def R1'_a_def R1_a_def
    Final_def Final''_def Init''_def label0_def link0_def)
  apply (simp add: simp_eq_emptyset inf_fun_def)
  apply auto
  by (simp_all add: link0_def)

text\<open>
The indexed predicate $\mathit{ClassicPre}$ is the precondition of the diagram, and since we are only interested
in starting the marking diagram in the $init$ situation we set
$\mathit{ClassicPre} \ loop = \mathit{ClassicPre} \ \mathit{final} = \emptyset$.
\<close>

definition [simp]:
  "ClassicPre i =  (case i of
      I.init  \<Rightarrow> ClassicInit |
      I.loop  \<Rightarrow> {} |
      I.final \<Rightarrow> {})"

text\<open>
We are interested on the other hand that the marking diagram terminates only in the $\mathit{final}$ situation. In order to
achieve this we define the postcondition of the diagram as the indexed predicate $\mathit{ClassicPost}$ which is empty
on every situation except $final$.
\<close>

definition [simp]:
  "ClassicPost i =  (case i of
      I.init  \<Rightarrow> {} |
      I.loop  \<Rightarrow> {} |
      I.final \<Rightarrow> ClassicFinal)"

lemma exists_or:
  "(\<exists> x . p x \<or> q x) = ((\<exists> x . p x) \<or> (\<exists> x . q x))"
  by auto

lemma [simp]:
  "(- grd (step  ClassicMark)) init = {}"
  apply (simp add: grd_def step_def)
  apply safe
  apply simp
  apply (drule_tac x = loop in spec)
  by (simp add: ClassicMark_def QQ1_a_def QQ2_a_def demonic_def)

lemma [simp]: "grd \<top> = \<bottom>"
  by (simp add: grd_def top_fun_def)

lemma [simp]:
  "(- grd (step  ClassicMark)) loop = {}"
  apply safe
  apply simp
  apply (frule_tac x = "final" in spec)
  apply (drule_tac x = "loop" in spec)
  apply (unfold ClassicMark_def QQ1_a_def QQ2_a_def QQ3_a_def QQ4_a_def QQ5_a_def QQ6_a_def QQ7_a_def QQ8_a_def)
  apply simp
  apply (case_tac "a \<noteq> nil")
  by auto

text \<open>
The final theorem states the correctness of the marking diagram with respect to the precondition
$\mathit{ClassicPre}$ and the postcondition $\mathit{ClassicPost}$, that is, if the diagram starts in the initial
situation, then it will terminate in the final situation, and it will mark all reachable nodes.
\<close>

lemma [simp]: "mono QQ1_a" by (simp add: QQ1_a_def)
lemma [simp]: "mono QQ2_a" by (simp add: QQ2_a_def)
lemma [simp]: "mono QQ3_a" by (simp add: QQ3_a_def)
lemma [simp]: "mono QQ4_a" by (simp add: QQ4_a_def)
lemma [simp]: "mono QQ5_a" by (simp add: QQ5_a_def)
lemma [simp]: "mono QQ6_a" by (simp add: QQ6_a_def)
lemma [simp]: "mono QQ7_a" by (simp add: QQ7_a_def)
lemma [simp]: "mono QQ8_a" by (simp add: QQ8_a_def)

lemma [simp]: "dmono ClassicMark"
  apply (unfold dmono_def ClassicMark_def)
  by simp

theorem "\<Turnstile> ClassicPre {| pt ClassicMark |} ClassicPost"
  apply (rule_tac P = "(R''_a .. (R'_a .. (R_a ..SetMarkInv)))" in hoare_pre)
  apply (subst le_fun_def)
  apply simp
  apply (rule_tac Q = "((R''_a .. (R'_a .. (R_a .. SetMarkInv))) \<sqinter> (- grd (step ((ClassicMark)))))" in hoare_mono)
  apply (simp_all add: hoare_dgr_correctness)
  apply (rule le_funI)
  apply (case_tac x)
  apply (simp_all add: inf_fun_def del: uminus_apply)
  apply (rule_tac y = "RR_a (R1'_a (R1_a (SetMarkInv final)))" in order_trans)
  by auto

end

end


(*  Title:      ZF/Bin.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

   The sign Pls stands for an infinite string of leading 0's.
   The sign Min stands for an infinite string of leading 1's.

A number can have multiple representations, namely leading 0's with sign
Pls and leading 1's with sign Min.  See twos-compl.ML/int_of_binary for
the numerical interpretation.

The representation expects that (m mod 2) is 0 or 1, even if m is negative;
For instance, ~5 div 2 = ~3 and ~5 mod 2 = 1; thus ~5 = (~3)*2 + 1
*)

section\<open>Arithmetic on Binary Integers\<close>

theory Bin
imports Int_ZF Datatype_ZF
begin

consts  bin :: i
datatype
  "bin" = Pls
        | Min
        | Bit ("w \<in> bin", "b \<in> bool")     (infixl "BIT" 90)

consts
  integ_of  :: "i=>i"
  NCons     :: "[i,i]=>i"
  bin_succ  :: "i=>i"
  bin_pred  :: "i=>i"
  bin_minus :: "i=>i"
  bin_adder :: "i=>i"
  bin_mult  :: "[i,i]=>i"

primrec
  integ_of_Pls:  "integ_of (Pls)     = $# 0"
  integ_of_Min:  "integ_of (Min)     = $-($#1)"
  integ_of_BIT:  "integ_of (w BIT b) = $#b $+ integ_of(w) $+ integ_of(w)"

    (** recall that cond(1,b,c)=b and cond(0,b,c)=0 **)

primrec (*NCons adds a bit, suppressing leading 0s and 1s*)
  NCons_Pls: "NCons (Pls,b)     = cond(b,Pls BIT b,Pls)"
  NCons_Min: "NCons (Min,b)     = cond(b,Min,Min BIT b)"
  NCons_BIT: "NCons (w BIT c,b) = w BIT c BIT b"

primrec (*successor.  If a BIT, can change a 0 to a 1 without recursion.*)
  bin_succ_Pls:  "bin_succ (Pls)     = Pls BIT 1"
  bin_succ_Min:  "bin_succ (Min)     = Pls"
  bin_succ_BIT:  "bin_succ (w BIT b) = cond(b, bin_succ(w) BIT 0, NCons(w,1))"

primrec (*predecessor*)
  bin_pred_Pls:  "bin_pred (Pls)     = Min"
  bin_pred_Min:  "bin_pred (Min)     = Min BIT 0"
  bin_pred_BIT:  "bin_pred (w BIT b) = cond(b, NCons(w,0), bin_pred(w) BIT 1)"

primrec (*unary negation*)
  bin_minus_Pls:
    "bin_minus (Pls)       = Pls"
  bin_minus_Min:
    "bin_minus (Min)       = Pls BIT 1"
  bin_minus_BIT:
    "bin_minus (w BIT b) = cond(b, bin_pred(NCons(bin_minus(w),0)),
                                bin_minus(w) BIT 0)"

primrec (*sum*)
  bin_adder_Pls:
    "bin_adder (Pls)     = (\<lambda>w\<in>bin. w)"
  bin_adder_Min:
    "bin_adder (Min)     = (\<lambda>w\<in>bin. bin_pred(w))"
  bin_adder_BIT:
    "bin_adder (v BIT x) =
       (\<lambda>w\<in>bin.
         bin_case (v BIT x, bin_pred(v BIT x),
                   %w y. NCons(bin_adder (v) ` cond(x and y, bin_succ(w), w),
                               x xor y),
                   w))"

(*The bin_case above replaces the following mutually recursive function:
primrec
  "adding (v,x,Pls)     = v BIT x"
  "adding (v,x,Min)     = bin_pred(v BIT x)"
  "adding (v,x,w BIT y) = NCons(bin_adder (v, cond(x and y, bin_succ(w), w)),
                                x xor y)"
*)

definition
  bin_add   :: "[i,i]=>i"  where
    "bin_add(v,w) == bin_adder(v)`w"

primrec
  bin_mult_Pls:
    "bin_mult (Pls,w)     = Pls"
  bin_mult_Min:
    "bin_mult (Min,w)     = bin_minus(w)"
  bin_mult_BIT:
    "bin_mult (v BIT b,w) = cond(b, bin_add(NCons(bin_mult(v,w),0),w),
                                 NCons(bin_mult(v,w),0))"

syntax
  "_Int0" :: i  ("#()0")
  "_Int1" :: i  ("#()1")
  "_Int2" :: i  ("#()2")
  "_Neg_Int1" :: i  ("#-()1")
  "_Neg_Int2" :: i  ("#-()2")
translations
  "#0" \<rightleftharpoons> "CONST integ_of(CONST Pls)"
  "#1" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1)"
  "#2" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1 BIT 0)"
  "#-1" \<rightleftharpoons> "CONST integ_of(CONST Min)"
  "#-2" \<rightleftharpoons> "CONST integ_of(CONST Min BIT 0)"

syntax
  "_Int" :: "num_token => i"  ("#_" 1000)
  "_Neg_Int" :: "num_token => i"  ("#-_" 1000)

ML_file "Tools/numeral_syntax.ML"

declare bin.intros [simp,TC]

lemma NCons_Pls_0: "NCons(Pls,0) = Pls"
by simp

lemma NCons_Pls_1: "NCons(Pls,1) = Pls BIT 1"
by simp

lemma NCons_Min_0: "NCons(Min,0) = Min BIT 0"
by simp

lemma NCons_Min_1: "NCons(Min,1) = Min"
by simp

lemma NCons_BIT: "NCons(w BIT x,b) = w BIT x BIT b"
by (simp add: bin.case_eqns)

lemmas NCons_simps [simp] =
    NCons_Pls_0 NCons_Pls_1 NCons_Min_0 NCons_Min_1 NCons_BIT

(** Type checking **)

lemma integ_of_type [TC]: "w \<in> bin ==> integ_of(w) \<in> int"
apply (induct_tac "w")
apply (simp_all add: bool_into_nat)
done

lemma NCons_type [TC]: "[| w \<in> bin; b \<in> bool |] ==> NCons(w,b) \<in> bin"
by (induct_tac "w", auto)

lemma bin_succ_type [TC]: "w \<in> bin ==> bin_succ(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_pred_type [TC]: "w \<in> bin ==> bin_pred(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_minus_type [TC]: "w \<in> bin ==> bin_minus(w) \<in> bin"
by (induct_tac "w", auto)

(*This proof is complicated by the mutual recursion*)
lemma bin_add_type [rule_format,TC]:
     "v \<in> bin ==> \<forall>w\<in>bin. bin_add(v,w) \<in> bin"
apply (unfold bin_add_def)
apply (induct_tac "v")
apply (rule_tac [3] ballI)
apply (rename_tac [3] "w'")
apply (induct_tac [3] "w'")
apply (simp_all add: NCons_type)
done

lemma bin_mult_type [TC]: "[| v \<in> bin; w \<in> bin |] ==> bin_mult(v,w) \<in> bin"
by (induct_tac "v", auto)

subsubsection\<open>The Carry and Borrow Functions,
            @{term bin_succ} and @{term bin_pred}\<close>

(*NCons preserves the integer value of its argument*)
lemma integ_of_NCons [simp]:
     "[| w \<in> bin; b \<in> bool |] ==> integ_of(NCons(w,b)) = integ_of(w BIT b)"
apply (erule bin.cases)
apply (auto elim!: boolE)
done

lemma integ_of_succ [simp]:
     "w \<in> bin ==> integ_of(bin_succ(w)) = $#1 $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

lemma integ_of_pred [simp]:
     "w \<in> bin ==> integ_of(bin_pred(w)) = $- ($#1) $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

subsubsection\<open>@{term bin_minus}: Unary Negation of Binary Integers\<close>

lemma integ_of_minus: "w \<in> bin ==> integ_of(bin_minus(w)) = $- integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac zminus_zadd_distrib  elim!: boolE)
done

subsubsection\<open>@{term bin_add}: Binary Addition\<close>

lemma bin_add_Pls [simp]: "w \<in> bin ==> bin_add(Pls,w) = w"
by (unfold bin_add_def, simp)

lemma bin_add_Pls_right: "w \<in> bin ==> bin_add(w,Pls) = w"
apply (unfold bin_add_def)
apply (erule bin.induct, auto)
done

lemma bin_add_Min [simp]: "w \<in> bin ==> bin_add(Min,w) = bin_pred(w)"
by (unfold bin_add_def, simp)

lemma bin_add_Min_right: "w \<in> bin ==> bin_add(w,Min) = bin_pred(w)"
apply (unfold bin_add_def)
apply (erule bin.induct, auto)
done

lemma bin_add_BIT_Pls [simp]: "bin_add(v BIT x,Pls) = v BIT x"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_Min [simp]: "bin_add(v BIT x,Min) = bin_pred(v BIT x)"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_BIT [simp]:
     "[| w \<in> bin;  y \<in> bool |]
      ==> bin_add(v BIT x, w BIT y) =
          NCons(bin_add(v, cond(x and y, bin_succ(w), w)), x xor y)"
by (unfold bin_add_def, simp)

lemma integ_of_add [rule_format]:
     "v \<in> bin ==>
          \<forall>w\<in>bin. integ_of(bin_add(v,w)) = integ_of(v) $+ integ_of(w)"
apply (erule bin.induct, simp, simp)
apply (rule ballI)
apply (induct_tac "wa")
apply (auto simp add: zadd_ac elim!: boolE)
done

(*Subtraction*)
lemma diff_integ_of_eq:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $- integ_of(w) = integ_of(bin_add (v, bin_minus(w)))"
apply (unfold zdiff_def)
apply (simp add: integ_of_add integ_of_minus)
done

subsubsection\<open>@{term bin_mult}: Binary Multiplication\<close>

lemma integ_of_mult:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(bin_mult(v,w)) = integ_of(v) $* integ_of(w)"
apply (induct_tac "v", simp)
apply (simp add: integ_of_minus)
apply (auto simp add: zadd_ac integ_of_add zadd_zmult_distrib  elim!: boolE)
done

subsection\<open>Computations\<close>

(** extra rules for bin_succ, bin_pred **)

lemma bin_succ_1: "bin_succ(w BIT 1) = bin_succ(w) BIT 0"
by simp

lemma bin_succ_0: "bin_succ(w BIT 0) = NCons(w,1)"
by simp

lemma bin_pred_1: "bin_pred(w BIT 1) = NCons(w,0)"
by simp

lemma bin_pred_0: "bin_pred(w BIT 0) = bin_pred(w) BIT 1"
by simp

(** extra rules for bin_minus **)

lemma bin_minus_1: "bin_minus(w BIT 1) = bin_pred(NCons(bin_minus(w), 0))"
by simp

lemma bin_minus_0: "bin_minus(w BIT 0) = bin_minus(w) BIT 0"
by simp

(** extra rules for bin_add **)

lemma bin_add_BIT_11: "w \<in> bin ==> bin_add(v BIT 1, w BIT 1) =
                     NCons(bin_add(v, bin_succ(w)), 0)"
by simp

lemma bin_add_BIT_10: "w \<in> bin ==> bin_add(v BIT 1, w BIT 0) =
                     NCons(bin_add(v,w), 1)"
by simp

lemma bin_add_BIT_0: "[| w \<in> bin;  y \<in> bool |]
      ==> bin_add(v BIT 0, w BIT y) = NCons(bin_add(v,w), y)"
by simp

(** extra rules for bin_mult **)

lemma bin_mult_1: "bin_mult(v BIT 1, w) = bin_add(NCons(bin_mult(v,w),0), w)"
by simp

lemma bin_mult_0: "bin_mult(v BIT 0, w) = NCons(bin_mult(v,w),0)"
by simp

(** Simplification rules with integer constants **)

lemma int_of_0: "$#0 = #0"
by simp

lemma int_of_succ: "$# succ(n) = #1 $+ $#n"
by (simp add: int_of_add [symmetric] natify_succ)

lemma zminus_0 [simp]: "$- #0 = #0"
by simp

lemma zadd_0_intify [simp]: "#0 $+ z = intify(z)"
by simp

lemma zadd_0_right_intify [simp]: "z $+ #0 = intify(z)"
by simp

lemma zmult_1_intify [simp]: "#1 $* z = intify(z)"
by simp

lemma zmult_1_right_intify [simp]: "z $* #1 = intify(z)"
by (subst zmult_commute, simp)

lemma zmult_0 [simp]: "#0 $* z = #0"
by simp

lemma zmult_0_right [simp]: "z $* #0 = #0"
by (subst zmult_commute, simp)

lemma zmult_minus1 [simp]: "#-1 $* z = $-z"
by (simp add: zcompare_rls)

lemma zmult_minus1_right [simp]: "z $* #-1 = $-z"
apply (subst zmult_commute)
apply (rule zmult_minus1)
done

subsection\<open>Simplification Rules for Comparison of Binary Numbers\<close>
text\<open>Thanks to Norbert Voelker\<close>

(** Equals (=) **)

lemma eq_integ_of_eq:
     "[| v \<in> bin;  w \<in> bin |]
      ==> ((integ_of(v)) = integ_of(w)) \<longleftrightarrow>
          iszero (integ_of (bin_add (v, bin_minus(w))))"
apply (unfold iszero_def)
apply (simp add: zcompare_rls integ_of_add integ_of_minus)
done

lemma iszero_integ_of_Pls: "iszero (integ_of(Pls))"
by (unfold iszero_def, simp)

lemma nonzero_integ_of_Min: "~ iszero (integ_of(Min))"
apply (unfold iszero_def)
apply (simp add: zminus_equation)
done

lemma iszero_integ_of_BIT:
     "[| w \<in> bin; x \<in> bool |]
      ==> iszero (integ_of (w BIT x)) \<longleftrightarrow> (x=0 & iszero (integ_of(w)))"
apply (unfold iszero_def, simp)
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (safe elim!: boolE)
apply (simp_all (asm_lr) add: zcompare_rls zminus_zadd_distrib [symmetric]
                     int_of_add [symmetric])
done

lemma iszero_integ_of_0:
     "w \<in> bin ==> iszero (integ_of (w BIT 0)) \<longleftrightarrow> iszero (integ_of(w))"
by (simp only: iszero_integ_of_BIT, blast)

lemma iszero_integ_of_1: "w \<in> bin ==> ~ iszero (integ_of (w BIT 1))"
by (simp only: iszero_integ_of_BIT, blast)

(** Less-than (<) **)

lemma less_integ_of_eq_neg:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $< integ_of(w)
          \<longleftrightarrow> znegative (integ_of (bin_add (v, bin_minus(w))))"
apply (unfold zless_def zdiff_def)
apply (simp add: integ_of_minus integ_of_add)
done

lemma not_neg_integ_of_Pls: "~ znegative (integ_of(Pls))"
by simp

lemma neg_integ_of_Min: "znegative (integ_of(Min))"
by simp

lemma neg_integ_of_BIT:
     "[| w \<in> bin; x \<in> bool |]
      ==> znegative (integ_of (w BIT x)) \<longleftrightarrow> znegative (integ_of(w))"
apply simp
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (auto elim!: boolE simp add: int_of_add [symmetric]  zcompare_rls)
apply (simp_all add: zminus_zadd_distrib [symmetric] zdiff_def
                     int_of_add [symmetric])
apply (subgoal_tac "$#1 $- $# succ (succ (n #+ n)) = $- $# succ (n #+ n) ")
 apply (simp add: zdiff_def)
apply (simp add: equation_zminus int_of_diff [symmetric])
done

(** Less-than-or-equals (<=) **)

lemma le_integ_of_eq_not_less:
     "(integ_of(x) $\<le> (integ_of(w))) \<longleftrightarrow> ~ (integ_of(w) $< (integ_of(x)))"
by (simp add: not_zless_iff_zle [THEN iff_sym])

(*Delete the original rewrites, with their clumsy conditional expressions*)
declare bin_succ_BIT [simp del]
        bin_pred_BIT [simp del]
        bin_minus_BIT [simp del]
        NCons_Pls [simp del]
        NCons_Min [simp del]
        bin_adder_BIT [simp del]
        bin_mult_BIT [simp del]

(*Hide the binary representation of integer constants*)
declare integ_of_Pls [simp del] integ_of_Min [simp del] integ_of_BIT [simp del]

lemmas bin_arith_extra_simps =
     integ_of_add [symmetric]
     integ_of_minus [symmetric]
     integ_of_mult [symmetric]
     bin_succ_1 bin_succ_0
     bin_pred_1 bin_pred_0
     bin_minus_1 bin_minus_0
     bin_add_Pls_right bin_add_Min_right
     bin_add_BIT_0 bin_add_BIT_10 bin_add_BIT_11
     diff_integ_of_eq
     bin_mult_1 bin_mult_0 NCons_simps

(*For making a minimal simpset, one must include these default simprules
  of thy.  Also include simp_thms, or at least (~False)=True*)
lemmas bin_arith_simps =
     bin_pred_Pls bin_pred_Min
     bin_succ_Pls bin_succ_Min
     bin_add_Pls bin_add_Min
     bin_minus_Pls bin_minus_Min
     bin_mult_Pls bin_mult_Min
     bin_arith_extra_simps

(*Simplification of relational operations*)
lemmas bin_rel_simps =
     eq_integ_of_eq iszero_integ_of_Pls nonzero_integ_of_Min
     iszero_integ_of_0 iszero_integ_of_1
     less_integ_of_eq_neg
     not_neg_integ_of_Pls neg_integ_of_Min neg_integ_of_BIT
     le_integ_of_eq_not_less

declare bin_arith_simps [simp]
declare bin_rel_simps [simp]

(** Simplification of arithmetic when nested to the right **)

lemma add_integ_of_left [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (integ_of(w) $+ z) = (integ_of(bin_add(v,w)) $+ z)"
by (simp add: zadd_assoc [symmetric])

lemma mult_integ_of_left [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $* (integ_of(w) $* z) = (integ_of(bin_mult(v,w)) $* z)"
by (simp add: zmult_assoc [symmetric])

lemma add_integ_of_diff1 [simp]:
    "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (integ_of(w) $- c) = integ_of(bin_add(v,w)) $- (c)"
apply (unfold zdiff_def)
apply (rule add_integ_of_left, auto)
done

lemma add_integ_of_diff2 [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (c $- integ_of(w)) =
          integ_of (bin_add (v, bin_minus(w))) $+ (c)"
apply (subst diff_integ_of_eq [symmetric])
apply (simp_all add: zdiff_def zadd_ac)
done

(** More for integer constants **)

declare int_of_0 [simp] int_of_succ [simp]

lemma zdiff0 [simp]: "#0 $- x = $-x"
by (simp add: zdiff_def)

lemma zdiff0_right [simp]: "x $- #0 = intify(x)"
by (simp add: zdiff_def)

lemma zdiff_self [simp]: "x $- x = #0"
by (simp add: zdiff_def)

lemma znegative_iff_zless_0: "k \<in> int ==> znegative(k) \<longleftrightarrow> k $< #0"
by (simp add: zless_def)

lemma zero_zless_imp_znegative_zminus: "[|#0 $< k; k \<in> int|] ==> znegative($-k)"
by (simp add: zless_def)

lemma zero_zle_int_of [simp]: "#0 $\<le> $# n"
by (simp add: not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])

lemma nat_of_0 [simp]: "nat_of(#0) = 0"
by (simp only: natify_0 int_of_0 [symmetric] nat_of_int_of)

lemma nat_le_int0_lemma: "[| z $\<le> $#0; z \<in> int |] ==> nat_of(z) = 0"
by (auto simp add: znegative_iff_zless_0 [THEN iff_sym] zle_def zneg_nat_of)

lemma nat_le_int0: "z $\<le> $#0 ==> nat_of(z) = 0"
apply (subgoal_tac "nat_of (intify (z)) = 0")
apply (rule_tac [2] nat_le_int0_lemma, auto)
done

lemma int_of_eq_0_imp_natify_eq_0: "$# n = #0 ==> natify(n) = 0"
by (rule not_znegative_imp_zero, auto)

lemma nat_of_zminus_int_of: "nat_of($- $# n) = 0"
by (simp add: nat_of_def int_of_def raw_nat_of zminus image_intrel_int)

lemma int_of_nat_of: "#0 $\<le> z ==> $# nat_of(z) = intify(z)"
apply (rule not_zneg_nat_of_intify)
apply (simp add: znegative_iff_zless_0 not_zless_iff_zle)
done

declare int_of_nat_of [simp] nat_of_zminus_int_of [simp]

lemma int_of_nat_of_if: "$# nat_of(z) = (if #0 $\<le> z then intify(z) else #0)"
by (simp add: int_of_nat_of znegative_iff_zless_0 not_zle_iff_zless)

lemma zless_nat_iff_int_zless: "[| m \<in> nat; z \<in> int |] ==> (m < nat_of(z)) \<longleftrightarrow> ($#m $< z)"
apply (case_tac "znegative (z) ")
apply (erule_tac [2] not_zneg_nat_of [THEN subst])
apply (auto dest: zless_trans dest!: zero_zle_int_of [THEN zle_zless_trans]
            simp add: znegative_iff_zless_0)
done

(** nat_of and zless **)

(*An alternative condition is  @{term"$#0 \<subseteq> w"}  *)
lemma zless_nat_conj_lemma: "$#0 $< z ==> (nat_of(w) < nat_of(z)) \<longleftrightarrow> (w $< z)"
apply (rule iff_trans)
apply (rule zless_int_of [THEN iff_sym])
apply (auto simp add: int_of_nat_of_if simp del: zless_int_of)
apply (auto elim: zless_asym simp add: not_zle_iff_zless)
apply (blast intro: zless_zle_trans)
done

lemma zless_nat_conj: "(nat_of(w) < nat_of(z)) \<longleftrightarrow> ($#0 $< z & w $< z)"
apply (case_tac "$#0 $< z")
apply (auto simp add: zless_nat_conj_lemma nat_le_int0 not_zless_iff_zle)
done

(*This simprule cannot be added unless we can find a way to make eq_integ_of_eq
  unconditional!
  [The condition "True" is a hack to prevent looping.
    Conditional rewrite rules are tried after unconditional ones, so a rule
    like eq_nat_number_of will be tried first to eliminate #mm=#nn.]
  lemma integ_of_reorient [simp]:
       "True ==> (integ_of(w) = x) \<longleftrightarrow> (x = integ_of(w))"
  by auto
*)

lemma integ_of_minus_reorient [simp]:
     "(integ_of(w) = $- x) \<longleftrightarrow> ($- x = integ_of(w))"
by auto

lemma integ_of_add_reorient [simp]:
     "(integ_of(w) = x $+ y) \<longleftrightarrow> (x $+ y = integ_of(w))"
by auto

lemma integ_of_diff_reorient [simp]:
     "(integ_of(w) = x $- y) \<longleftrightarrow> (x $- y = integ_of(w))"
by auto

lemma integ_of_mult_reorient [simp]:
     "(integ_of(w) = x $* y) \<longleftrightarrow> (x $* y = integ_of(w))"
by auto

(** To simplify inequalities involving integer negation and literals,
    such as -x = #3
**)

lemmas [simp] =
  zminus_equation [where y = "integ_of(w)"]
  equation_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zless [where y = "integ_of(w)"]
  zless_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zle [where y = "integ_of(w)"]
  zle_zminus [where x = "integ_of(w)"]
  for w

lemmas [simp] =
  Let_def [where s = "integ_of(w)"] for w

(*** Simprocs for numeric literals ***)

(** Combining of literal coefficients in sums of products **)

lemma zless_iff_zdiff_zless_0: "(x $< y) \<longleftrightarrow> (x$-y $< #0)"
  by (simp add: zcompare_rls)

lemma eq_iff_zdiff_eq_0: "[| x \<in> int; y \<in> int |] ==> (x = y) \<longleftrightarrow> (x$-y = #0)"
  by (simp add: zcompare_rls)

lemma zle_iff_zdiff_zle_0: "(x $\<le> y) \<longleftrightarrow> (x$-y $\<le> #0)"
  by (simp add: zcompare_rls)

(** For combine_numerals **)

lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k"
  by (simp add: zadd_zmult_distrib zadd_ac)

(** For cancel_numerals **)

lemmas rel_iff_rel_0_rls =
  zless_iff_zdiff_zless_0 [where y = "u $+ v"]
  eq_iff_zdiff_eq_0 [where y = "u $+ v"]
  zle_iff_zdiff_zle_0 [where y = "u $+ v"]
  zless_iff_zdiff_zless_0 [where y = n]
  eq_iff_zdiff_eq_0 [where y = n]
  zle_iff_zdiff_zle_0 [where y = n]
  for u v (* FIXME n (!?) *)

lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m = intify(n))"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> (intify(m) = (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $< n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> (m $< (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

lemma le_add_iff1: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $\<le> n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma le_add_iff2: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> (m $\<le> (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

ML_file "int_arith.ML"

subsection \<open>examples:\<close>

text \<open>\<open>combine_numerals_prod\<close> (products of separate literals)\<close>
lemma "#5 $* x $* #3 = y" apply simp oops

schematic_goal "y2 $+ ?x42 = y $+ y2" apply simp oops

lemma "oo : int ==> l $+ (l $+ #2) $+ oo = oo" apply simp oops

lemma "#9$*x $+ y = x$*#23 $+ z" apply simp oops
lemma "y $+ x = x $+ z" apply simp oops

lemma "x : int ==> x $+ y $+ z = x $+ z" apply simp oops
lemma "x : int ==> y $+ (z $+ x) = z $+ x" apply simp oops
lemma "z : int ==> x $+ y $+ z = (z $+ y) $+ (x $+ w)" apply simp oops
lemma "z : int ==> x$*y $+ z = (z $+ y) $+ (y$*x $+ w)" apply simp oops

lemma "#-3 $* x $+ y $\<le> x $* #2 $+ z" apply simp oops
lemma "y $+ x $\<le> x $+ z" apply simp oops
lemma "x $+ y $+ z $\<le> x $+ z" apply simp oops

lemma "y $+ (z $+ x) $< z $+ x" apply simp oops
lemma "x $+ y $+ z $< (z $+ y) $+ (x $+ w)" apply simp oops
lemma "x$*y $+ z $< (z $+ y) $+ (y$*x $+ w)" apply simp oops

lemma "l $+ #2 $+ #2 $+ #2 $+ (l $+ #2) $+ (oo $+ #2) = uu" apply simp oops
lemma "u : int ==> #2 $* u = u" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #15 = y" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #5 = y" apply simp oops

lemma "y $- b $< b" apply simp oops
lemma "y $- (#3 $* b $+ c) $< b $- #2 $* c" apply simp oops

lemma "(#2 $* x $- (u $* v) $+ y) $- v $* #3 $* u = w" apply simp oops
lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u $* #4 = w" apply simp oops
lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u = w" apply simp oops
lemma "u $* v $- (x $* u $* v $+ (u $* v) $* #4 $+ y) = w" apply simp oops

lemma "(i $+ j $+ #12 $+ k) = u $+ #15 $+ y" apply simp oops
lemma "(i $+ j $* #2 $+ #12 $+ k) = j $+ #5 $+ y" apply simp oops

lemma "#2 $* y $+ #3 $* z $+ #6 $* w $+ #2 $* y $+ #3 $* z $+ #2 $* u = #2 $* y' $+ #3 $* z' $+ #6 $* w' $+ #2 $* y' $+ #3 $* z' $+ u $+ vv" apply simp oops

lemma "a $+ $-(b$+c) $+ b = d" apply simp oops
lemma "a $+ $-(b$+c) $- b = d" apply simp oops

text \<open>negative numerals\<close>
lemma "(i $+ j $+ #-2 $+ k) $- (u $+ #5 $+ y) = zz" apply simp oops
lemma "(i $+ j $+ #-3 $+ k) $< u $+ #5 $+ y" apply simp oops
lemma "(i $+ j $+ #3 $+ k) $< u $+ #-6 $+ y" apply simp oops
lemma "(i $+ j $+ #-12 $+ k) $- #15 = y" apply simp oops
lemma "(i $+ j $+ #12 $+ k) $- #-15 = y" apply simp oops
lemma "(i $+ j $+ #-12 $+ k) $- #-15 = y" apply simp oops

text \<open>Multiplying separated numerals\<close>
lemma "#6 $* ($# x $* #2) =  uu" apply simp oops
lemma "#4 $* ($# x $* $# x) $* (#2 $* $# x) =  uu" apply simp oops

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul3_comm12
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (mul3 y x z))"
  oops

end