(*

Formalization of Many-Valued Logics - Isabelle Partiality.thy

Anders Schlichtkrull & Jørgen Villadsen, DTU Compute, Denmark

*)

theory Partiality imports Main begin

section \<open>Syntax and Semantics\<close>

text \<open>Syntax of propositional logic with strings as identifiers in atomic formulas\<close>

type_synonym id = string

datatype fm = Pro id | Truth | Neg' fm | Con fm fm | Eql fm fm | Eql' fm fm

text \<open>Semantics of propositional logic with determinate and indeterminate truth values\<close>

datatype tv = Det bool | is_indet: Indet (get_indet: nat)

abbreviation (input)
  "eval_neg p \<equiv>
    (
      case p of
        Det False \<Rightarrow> Det True |
        Det True \<Rightarrow> Det False |
        Indet n \<Rightarrow> Indet n
    )"

fun
  eval :: "(id \<Rightarrow> tv) \<Rightarrow> fm \<Rightarrow> tv"
where
  "eval i (Pro s) = i s" |
  "eval i Truth = Det True" |
  "eval i (Neg' p) = eval_neg (eval i p)" |
  "eval i (Con p q) =
    (
      if eval i p = eval i q then eval i p else
      if eval i p = Det True then eval i q else
      if eval i q = Det True then eval i p else Det False
    )" |
  "eval i (Eql p q) =
    (
      if eval i p = eval i q then Det True else Det False
    )" |
  "eval i (Eql' p q) =
    (
      if eval i p = eval i q then Det True else
        (
          case (eval i p, eval i q) of
            (Det True, _) \<Rightarrow> eval i q |
            (_, Det True) \<Rightarrow> eval i p |
            (Det False, _) \<Rightarrow> eval_neg (eval i q) |
            (_, Det False) \<Rightarrow> eval_neg (eval i p) |
            _ \<Rightarrow> Det False
        )
    )"

text \<open>Proofs of key properties\<close>

proposition "eval i (Eql p q) = Det (eval i p = eval i q)"
  by simp

theorem eval_negation:
  "eval i (Neg' p) =
    (
      if eval i p = Det False then Det True else
      if eval i p = Det True then Det False else
      eval i p
    )"
  by (cases "eval i p") simp_all

theorem eval_equality:
  "eval i (Eql' p q) =
    (
      if eval i p = eval i q then Det True else
      if eval i p = Det True then eval i q else
      if eval i q = Det True then eval i p else
      if eval i p = Det False then eval i (Neg' q) else
      if eval i q = Det False then eval i (Neg' p) else
      Det False
    )"
  by (cases "eval i p"; cases "eval i q") simp_all

text \<open>Additional operators\<close>

abbreviation "Falsity \<equiv> Neg' Truth"

abbreviation "Dis p q \<equiv> Neg' (Con (Neg' p) (Neg' q))"

abbreviation "Imp p q \<equiv> Eql p (Con p q)"

abbreviation "Imp' p q \<equiv> Eql' p (Con p q)"

abbreviation "Box p \<equiv> (Eql p Truth)"

abbreviation "Neg p \<equiv> Neg' (Box p)"

text \<open>Validity\<close>

definition
  valid :: "fm \<Rightarrow> bool"
where
  "valid p \<equiv> \<forall>i. eval i p = Det True"

text \<open>Key equalities\<close>

proposition "valid (Eql p (Neg' (Neg' p)))"
  unfolding valid_def
  using eval_negation
  by simp

proposition "valid (Eql Truth (Neg' Falsity))"
  unfolding valid_def
  by simp

proposition "valid (Eql Falsity (Neg' Truth))"
  unfolding valid_def
  by simp

proposition "valid (Eql p (Con p p))"
  unfolding valid_def
  by simp

proposition "valid (Eql p (Con Truth p))"
  unfolding valid_def
  by simp

proposition "valid (Eql p (Con p Truth))"
  unfolding valid_def
  by simp

proposition "valid (Eql Truth (Eql' p p))"
  unfolding valid_def
  by simp

proposition "valid (Eql p (Eql' Truth p))"
  unfolding valid_def
  by simp

proposition "valid (Eql p (Eql' p Truth))"
  unfolding valid_def
proof
  fix i
  show "eval i (Eql p (Eql' p Truth)) = Det True"
    by (cases "eval i p") simp_all
qed

proposition "valid (Eql (Neg' p) (Eql' Falsity p))"
  unfolding valid_def
proof
  fix i
  show "eval i (Eql (Neg' p) (Eql' (Neg' Truth) p)) = Det True"
    by (cases "eval i p") simp_all
qed

proposition "valid (Eql (Neg' p) (Eql' p Falsity))"
  unfolding valid_def
  using eval.simps eval_equality eval_negation
  by metis

text \<open>Selected theorems\<close>

theorem double_negation: "valid (Neg' (Neg' p)) \<longleftrightarrow> valid p"
  unfolding valid_def
  using eval_negation
  by auto

theorem conjunction: "valid (Con p q) \<longleftrightarrow> valid p \<and> valid q"
  unfolding valid_def
  by auto

corollary "valid (Con p q) \<Longrightarrow> valid p"
  using conjunction
  by simp

corollary "valid (Con p q) \<Longrightarrow> valid q"
  using conjunction
  by simp

proposition "valid p \<Longrightarrow> valid (Imp p q) \<Longrightarrow> valid q"
  unfolding valid_def
  using eval.simps tv.inject
  by (metis (full_types))

proposition "valid p \<Longrightarrow> valid (Imp' p q) \<Longrightarrow> valid q"
  unfolding valid_def
  using eval.simps eval_equality
  by (metis (full_types))

section \<open>Truth Tables\<close>

definition
  tv_pair_row :: "tv list \<Rightarrow> tv \<Rightarrow> (tv * tv) list"
where
  "tv_pair_row tvs tv = map (\<lambda>x. (tv, x)) tvs"

definition
  tv_pair_table :: "tv list \<Rightarrow> (tv * tv) list list"
where
  "tv_pair_table tvs \<equiv> map (tv_pair_row tvs) tvs"

definition
  map_row :: "(tv \<Rightarrow> tv \<Rightarrow> tv) \<Rightarrow> (tv * tv) list \<Rightarrow> tv list"
where
  "map_row f tvtvs = map (\<lambda>(x,y). f x y) tvtvs"

definition
  map_table :: "(tv \<Rightarrow> tv \<Rightarrow> tv) \<Rightarrow> (tv * tv) list list \<Rightarrow> tv list list"
where
  "map_table f tvtvss = map (map_row f) tvtvss"

definition
  unary_truth_table :: "fm \<Rightarrow> tv list \<Rightarrow> tv list"
where
  "unary_truth_table p tvs =
      map (\<lambda>x. eval ((\<lambda>x. Det undefined)(''p'' := x)) p) tvs"

definition
  binary_truth_table :: "fm \<Rightarrow> tv list \<Rightarrow> tv list list"
where
  "binary_truth_table p tvs =
      map_table (\<lambda>x y. eval ((\<lambda>x. Det undefined)(''p'' := x, ''q'' := y)) p)
          (tv_pair_table tvs)"

fun
  string_of_nat :: "nat \<Rightarrow> string"
where
  "string_of_nat n = (if n < 10 then [char_of_nat (48 + n)] else
      string_of_nat (n div 10) @ [char_of_nat (48 + (n mod 10))])"

fun
  string_tv :: "tv \<Rightarrow> string"
where
  "string_tv (Det True) = ''*'' " |
  "string_tv (Det False) = ''o'' " |
  "string_tv (Indet n) = string_of_nat n"

definition
  appends :: "string list \<Rightarrow> string"
where
  "appends strs = foldr append strs []"

definition
  appends_nl :: "string list \<Rightarrow> string"
where
  "appends_nl strs = ''\<newline>  '' @
      foldr (\<lambda>x y. x @ ''\<newline>  '' @ y) (butlast strs) (last strs) @ ''\<newline>''"

definition
  string_table :: "tv list list \<Rightarrow> string list list"
where
  "string_table tvss = map (map string_tv) tvss"

definition
  string_table_string :: "string list list \<Rightarrow> string"
where
  "string_table_string strss = appends_nl (map appends strss)"

definition
  unary :: "fm \<Rightarrow> tv list \<Rightarrow> string"
where
  "unary p tvs = appends_nl (map string_tv (unary_truth_table p tvs))"

definition
  binary :: "fm \<Rightarrow> tv list \<Rightarrow> string"
where
  "binary p tvs = string_table_string (string_table (binary_truth_table p tvs))"

proposition
  "binary (Con (Pro ''p'') (Pro ''q''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  *o12
  oooo
  1o1o
  2oo2
'' "
  by code_simp

proposition
  "binary (Dis (Pro ''p'') (Pro ''q''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  ****
  *o12
  *11*
  *2*2
'' "
  by code_simp

proposition
  "unary (Neg' (Pro ''p''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  o
  *
  1
  2
'' "
  by code_simp

proposition
  "binary (Eql (Pro ''p'') (Pro ''q''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  *ooo
  o*oo
  oo*o
  ooo*
'' "
  by code_simp

proposition
  "binary (Imp (Pro ''p'') (Pro ''q''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  *ooo
  ****
  *o*o
  *oo*
'' "
  by code_simp

proposition
  "unary (Box (Pro ''p''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  *
  o
  o
  o
'' "
  by code_simp

proposition
  "binary (Eql' (Pro ''p'') (Pro ''q''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  *o12
  o*12
  11*o
  22o*
'' "
  by code_simp

proposition
  "binary (Imp' (Pro ''p'') (Pro ''q''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  *o12
  ****
  *1*1
  *22*
'' "
  by code_simp

proposition
  "unary (Neg (Pro ''p''))
      [Det True, Det False, Indet 1, Indet 2] = ''
  o
  *
  *
  *
'' "
  by code_simp

section \<open>Smaller Domains and Paraconsistency\<close>

definition
  domain :: "nat set \<Rightarrow> tv set"
where
  "domain U \<equiv> {Det True, Det False} \<union> Indet ` U"

theorem universal_domain: "domain {n. True} = {x. True}"
proof -
  have "\<forall>x. x = Det True \<or> x = Det False \<or> x \<in> range Indet"
    using range_eqI tv.collapse tv.inject
    by metis
  then show ?thesis
    unfolding domain_def
    by blast
qed

definition
  valid_in :: "nat set \<Rightarrow> fm \<Rightarrow> bool"
where
  "valid_in U p \<equiv> \<forall>i. range i \<subseteq> domain U \<longrightarrow> eval i p = Det True"

proposition "valid p \<longleftrightarrow> valid_in {n. True} p"
  unfolding valid_def valid_in_def
  using universal_domain
  by simp

theorem double_negation_in: "valid_in U (Neg' (Neg' p)) \<longleftrightarrow> valid_in U p"
  unfolding valid_in_def
  using eval_negation
  by auto

theorem conjunction_in: "valid_in U (Con p q) \<longleftrightarrow> valid_in U p \<and> valid_in U q"
  unfolding valid_in_def
  by auto

corollary "valid_in U (Con p q) \<Longrightarrow> valid_in U p"
  using conjunction_in
  by simp

corollary "valid_in U (Con p q) \<Longrightarrow> valid_in U q"
  using conjunction_in
  by simp

proposition "valid_in U p \<Longrightarrow> valid_in U (Imp p q) \<Longrightarrow> valid_in U q"
  unfolding valid_in_def
  using eval.simps tv.inject
  by (metis (full_types))

proposition "valid_in U p \<Longrightarrow> valid_in U (Imp' p q) \<Longrightarrow> valid_in U q"
  unfolding valid_in_def
  using eval.simps eval_equality
  by (metis (full_types))

lemma paraconsistency:
  "\<not> valid_in {1} (Imp' (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q''))"
proof -
  let ?i = "(\<lambda>s. Det False)(''P'' := Indet 1, ''Q'' := Det False)"
  have "range ?i \<subseteq> domain {1}"
    unfolding domain_def
    by auto
  moreover have "eval ?i (Imp' (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q'')) = Indet 1"
    by simp
  moreover have "Indet 1 \<noteq> Det True"
    by simp
  ultimately show ?thesis
    unfolding valid_in_def
    by metis
qed

theorem transfer: "\<not> valid_in U p \<Longrightarrow> \<not> valid p"
  unfolding valid_in_def valid_def
  by metis

proposition "\<not> valid (Imp' (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q''))"
  using paraconsistency transfer
  by simp

proposition "\<not> valid (Imp (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q''))"
  using paraconsistency transfer eval.simps tv.simps
  unfolding valid_in_def
  (* by smt OK *)
proof -
  assume *: "\<not> (\<forall>i. range i \<subseteq> domain U \<longrightarrow> eval i p = Det True) \<Longrightarrow> \<not> valid p" for U p
  assume "\<not> (\<forall>i. range i \<subseteq> domain {1} \<longrightarrow>
      eval i (Imp' (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q'')) = Det True)"
  then obtain i where
    **: "range i \<subseteq> domain {1} \<and>
        eval i (Imp' (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q'')) \<noteq> Det True"
    by blast
  then have "eval i (Con (Pro ''P'') (Neg' (Pro ''P''))) \<noteq>
      eval i (Con (Con (Pro ''P'') (Neg' (Pro ''P''))) (Pro ''Q''))"
    by force
  then show ?thesis
    using * **
    by force
qed

section \<open>Example: Contraposition\<close>

abbreviation (input)
  "contrapos P Q \<equiv> Eql' (Imp' P Q) (Imp' (Neg' Q) (Neg' P))"

proposition "valid_in {} (contrapos (Pro ''P'') (Pro ''Q''))"
  unfolding valid_in_def
proof (rule; rule)
  fix i :: "id \<Rightarrow> tv"
  assume "range i \<subseteq> domain {}"
  then have
      "i ''P'' \<in> {Det True, Det False}"
      "i ''Q'' \<in> {Det True, Det False}"
    unfolding domain_def
    by auto
  then show "eval i (contrapos (Pro ''P'') (Pro ''Q'')) = Det True"
    by (cases "i ''P''"; cases "i ''Q''") auto
qed

proposition "valid_in {1} (contrapos (Pro ''P'') (Pro ''Q''))"
  unfolding valid_in_def
proof (rule; rule)
  fix i :: "id \<Rightarrow> tv"
  assume "range i \<subseteq> domain {1}"
  then have
      "i ''P'' \<in> {Det True, Det False, Indet 1}"
      "i ''Q'' \<in> {Det True, Det False, Indet 1}"
    unfolding domain_def
    by auto
  then show "eval i (contrapos (Pro ''P'') (Pro ''Q'')) = Det True"
    by (cases "i ''P''"; cases "i ''Q''") auto
qed

proposition "\<not> valid_in {1,2} (contrapos (Pro ''P'') (Pro ''Q''))"
proof -
  let ?i = "(\<lambda>s. Det False)(''P'' := Indet 1, ''Q'' := Indet 2)"
  have "range ?i \<subseteq> domain {1, 2}"
    unfolding domain_def
    by auto
  moreover have "eval ?i (contrapos (Pro ''P'') (Pro ''Q'')) = Det False"
    by simp
  moreover have "Det False \<noteq> Det True"
    by simp
  ultimately show ?thesis
    unfolding valid_in_def
    by metis
qed

section \<open>Four Truth Values Are Not Enough\<close>

abbreviation (input)
  "ternary P Q R \<equiv>
      Imp' (Neg' (Imp' Q P))
          (Imp' (Neg' (Dis (Neg' R) (Imp' R Q))) (Imp' P Q))"

proposition "valid_in {} (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R''))"
  unfolding valid_in_def
proof (rule; rule)
  fix i :: "id \<Rightarrow> tv"
  assume "range i \<subseteq> domain {}"
  then have
      "i ''P'' \<in> {Det True, Det False}"
      "i ''Q'' \<in> {Det True, Det False}"
      "i ''R'' \<in> {Det True, Det False}"
    unfolding domain_def
    by auto
  then show "eval i (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R'')) = Det True"
    by (cases "i ''P''"; cases "i ''Q''"; cases "i ''R''") auto
qed

proposition "valid_in {1} (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R''))"
  unfolding valid_in_def
proof (rule; rule)
  fix i :: "id \<Rightarrow> tv"
  assume "range i \<subseteq> domain {1}"
  then have
      "i ''P'' \<in> {Det True, Det False, Indet 1}"
      "i ''Q'' \<in> {Det True, Det False, Indet 1}"
      "i ''R'' \<in> {Det True, Det False, Indet 1}"
    unfolding domain_def
    by auto
  then show "eval i (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R'')) = Det True"
    by (cases "i ''P''"; cases "i ''Q''"; cases "i ''R''") auto
qed

proposition "valid_in {1,2} (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R''))"
  unfolding valid_in_def
proof (rule; rule)
  fix i :: "id \<Rightarrow> tv"
  assume "range i \<subseteq> domain {1,2}"
  then have
      "i ''P'' \<in> {Det True, Det False, Indet 1, Indet 2}"
      "i ''Q'' \<in> {Det True, Det False, Indet 1, Indet 2}"
      "i ''R'' \<in> {Det True, Det False, Indet 1, Indet 2}"
    unfolding domain_def
    by auto
  then show "eval i (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R'')) = Det True"
    by (cases "i ''P''"; cases "i ''Q''"; cases "i ''R''") auto
qed

proposition "\<not> valid_in {1,2,3} (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R''))"
proof -
  let ?i = "(\<lambda>s. Det False)(''P'' := Indet 2, ''Q'' := Indet 1, ''R'' := Indet 3)"
  have "range ?i \<subseteq> domain {1, 2, 3}"
    unfolding domain_def
    by auto
  moreover have "eval ?i (ternary (Pro ''P'') (Pro ''Q'') (Pro ''R'')) = Indet 1"
    by simp
  moreover have "Indet 1 \<noteq> Det True"
    by simp
  ultimately show ?thesis
    unfolding valid_in_def
    by metis
qed

section \<open>Meta-Theorems\<close>

theorem valid_valid_in:
  assumes "valid p"
  shows "valid_in U p"
  using assms transfer
  by blast

fun
  props :: "fm \<Rightarrow> id set"
where
  "props Truth = {}" |
  "props (Pro s) = {s}" |
  "props (Neg' p) = props p" |
  "props (Con p q) = props p \<union> props q" |
  "props (Eql p q) = props p \<union> props q" |
  "props (Eql' p q) = props p \<union> props q"

lemma relevant_props:
  assumes "\<forall>s \<in> props p. i1 s = i2 s"
  shows "eval i1 p = eval i2 p"
  using assms
  by (induct p) (simp_all, metis)

fun
  change_tv :: "(nat \<Rightarrow> nat) \<Rightarrow> tv \<Rightarrow> tv"
where
  "change_tv f (Det b) = Det b" |
  "change_tv f (Indet n) = Indet (f n)"

lemma change_tv_injection:
  assumes "inj f"
  shows "inj (change_tv f)"
proof -
  {
    fix tv1 tv2
    have "inj f \<Longrightarrow> change_tv f tv1 = change_tv f tv2 \<Longrightarrow> tv1 = tv2"
      by (cases tv1; cases tv2) (simp_all add: inj_eq)
  }
  then show ?thesis
    using assms
    by (simp add: injI)
qed

definition
  change_int :: "(nat \<Rightarrow> nat) \<Rightarrow> (id \<Rightarrow> tv) \<Rightarrow> (id \<Rightarrow> tv)"
where
  "change_int f i \<equiv> \<lambda>s. change_tv f (i s)"

lemma eval_change_int_change_tv:
  assumes "inj f"
  shows "eval (change_int f i) p = change_tv f (eval i p)"
proof (induct p)
  fix p
  assume a: "eval (change_int f i) p = change_tv f (eval i p)"
  have "eval_neg (eval (change_int f i) p) = eval_neg (change_tv f (eval i p))"
    using assms a
    by auto
  then have "eval_neg (eval (change_int f i) p) = change_tv f (eval_neg (eval i p))"
    by (cases "eval i p") (auto simp add: case_bool_if)
  then show "eval (change_int f i) (Neg' p) = change_tv f (eval i (Neg' p))"
    by auto
next
  fix p1 p2
  assume ih1: "eval (change_int f i) p1 = change_tv f (eval i p1)"
  assume ih2: "eval (change_int f i) p2 = change_tv f (eval i p2)"
  show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
  proof (cases "eval i p1 = eval i p2")
    assume a: "eval i p1 = eval i p2"
    then have yes: "eval i (Con p1 p2) = eval i p1"
      by auto
    from a have "change_tv f (eval i p1) = change_tv f (eval i p2)"
      by auto
    then have "eval (change_int f i) p1 = eval (change_int f i) p2"
      using ih1 ih2
      by auto
    then have "eval (change_int f i) (Con p1 p2) = eval (change_int f i) p1"
      by auto
    then show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
      using yes ih1
      by auto
  next
    assume a': "eval i p1 \<noteq> eval i p2"
    from a' have b': "eval (change_int f i) p1 \<noteq> eval (change_int f i) p2"
      using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f
      by metis
    show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
    proof (cases "eval i p1 = Det True")
      assume a: "eval i p1 = Det True"
      from a a' have "eval i (Con p1 p2) = eval i p2"
        by auto
      then have c: "change_tv f (eval i (Con p1 p2)) = change_tv f (eval i p2)"
        by auto
      from a have b: "eval (change_int f i) p1 = Det True"
        using ih1
        by auto
      from b b' have "eval (change_int f i) (Con p1 p2) = eval (change_int f i) p2"
        by auto
      then show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
        using c ih2
        by auto
    next
      assume a'': "eval i p1 \<noteq> Det True"
      from a'' have b'': "eval (change_int f i) p1 \<noteq> Det True"
        using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
        by metis
      show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
      proof (cases "eval i p2 = Det True")
        assume a: "eval i p2 = Det True"
        from a a' a'' have "eval i (Con p1 p2) = eval i p1"
          by auto
        then have c: "change_tv f (eval i (Con p1 p2)) = change_tv f (eval i p1)"
          by auto
        from a have b: "eval (change_int f i) p2 = Det True"
          using ih2
          by auto
        from b b' b'' have "eval (change_int f i) (Con p1 p2) = eval (change_int f i) p1"
          by auto
        then show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
          using c ih1
          by auto
      next
        assume a''': "eval i p2 \<noteq> Det True"
        from a' a'' a''' have "eval i (Con p1 p2) = Det False"
          by auto
        then have c: "change_tv f (eval i (Con p1 p2)) = Det False"
          by auto
        from a''' have b''': "eval (change_int f i) p2 \<noteq> Det True"
          using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
          by metis
        from b' b'' b''' have "eval (change_int f i) (Con p1 p2) = Det False"
          by auto
        then show "eval (change_int f i) (Con p1 p2) = change_tv f (eval i (Con p1 p2))"
          using c
          by auto
      qed
    qed
  qed
next
  fix p1 p2
  assume ih1: "eval (change_int f i) p1 = change_tv f (eval i p1)"
  assume ih2: "eval (change_int f i) p2 = change_tv f (eval i p2)"
  have "Det (eval (change_int f i) p1 = eval (change_int f i) p2) =
      Det (change_tv f (eval i p1) = change_tv f (eval i p2))"
    using ih1 ih2
    by auto
  also have "... = Det ((eval i p1) = (eval i p2))"
    using assms change_tv_injection
    by (simp add: inj_eq)
  also have "... = change_tv f (Det (eval i p1 = eval i p2))"
    by auto
  finally
  show "eval (change_int f i) (Eql p1 p2) = change_tv f (eval i (Eql p1 p2))"
    using eval_equality
    by auto
next
  fix p1 p2
  assume ih1: "eval (change_int f i) p1 = change_tv f (eval i p1)"
  assume ih2: "eval (change_int f i) p2 = change_tv f (eval i p2)"
  show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
  proof (cases "eval i p1 = eval i p2")
    assume a: "eval i p1 = eval i p2"
    then have yes: "eval i (Eql' p1 p2) = Det True"
      by auto
    from a have "change_tv f (eval i p1) = change_tv f (eval i p2)"
      by auto
    then have "eval (change_int f i) p1 = eval (change_int f i) p2"
      using ih1 ih2
      by auto
    then have "eval (change_int f i) (Eql' p1 p2) = Det True"
      by auto
    then show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
      using yes ih1
      by auto
  next
    assume a': "eval i p1 \<noteq> eval i p2"
    show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
    proof (cases "eval i p1 = Det True")
      assume a: "eval i p1 = Det True"
      from a a' have yes: "eval i (Eql' p1 p2) = eval i p2"
        by auto
      from a have "change_tv f (eval i p1) = Det True"
        by auto
      then have b: "eval (change_int f i) p1 = Det True"
        using ih1
        by auto
      from a' have b': "eval (change_int f i) p1 \<noteq> eval (change_int f i) p2"
        using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
        by metis
      from b b' have "eval (change_int f i) (Eql' p1 p2) = eval (change_int f i) p2"
        by auto
      then show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
        using ih2 yes
        by auto
    next
      assume a'': "eval i p1 \<noteq> Det True"
      show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
      proof (cases "eval i p2 = Det True")
        assume a: "eval i p2 = Det True"
        from a a' a'' have yes: "eval i (Eql' p1 p2) = eval i p1"
          using eval_equality[of i p1 p2]
          by auto
        from a have "change_tv f (eval i p2) = Det True"
          by auto
        then have b: "eval (change_int f i) p2 = Det True"
          using ih2
          by auto
        from a' have b': "eval (change_int f i) p1 \<noteq> eval (change_int f i) p2"
          using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
          by metis
        from a'' have b'': "eval (change_int f i) p1 \<noteq> Det True"
          using b b'
          by auto
        from b b' b'' have "eval (change_int f i) (Eql' p1 p2) = eval (change_int f i) p1"
          using eval_equality[of "change_int f i" p1 p2]
          by auto
        then show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
          using ih1 yes
          by auto
      next
        assume a''': "eval i p2 \<noteq> Det True"
        show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
        proof (cases "eval i p1 = Det False")
          assume a: "eval i p1 = Det False"
          from a a' a'' a''' have yes: "eval i (Eql' p1 p2) = eval i (Neg' p2)"
            using eval_equality[of i p1 p2]
            by auto
          from a have "change_tv f (eval i p1) = Det False"
            by auto
          then have b: "eval (change_int f i) p1 = Det False"
            using ih1
             by auto
          from a' have b': "eval (change_int f i) p1 \<noteq> eval (change_int f i) p2"
            using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
            by metis
          from a'' have b'': "eval (change_int f i) p1 \<noteq> Det True"
            using b b'
            by auto
          from a''' have b''': "eval (change_int f i) p2 \<noteq> Det True"
            using b b' b''
            by (metis assms change_tv.simps(1) change_tv_injection inj_eq ih2)
          from b b' b'' b'''
          have "eval (change_int f i) (Eql' p1 p2) = eval (change_int f i) (Neg' p2)"
            using eval_equality[of "change_int f i" p1 p2]
            by auto
          then show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
            using ih2 yes a a' a''' b b' b''' eval_negation
            by metis
        next
          assume a'''': "eval i p1 \<noteq> Det False"
          show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
          proof (cases "eval i p2 = Det False")
            assume a: "eval i p2 = Det False"
            from a a' a'' a''' a'''' have yes: "eval i (Eql' p1 p2) = eval i (Neg' p1)"
              using eval_equality[of i p1 p2]
              by auto
            from a have "change_tv f (eval i p2) = Det False"
              by auto
            then have b: "eval (change_int f i) p2 = Det False"
              using ih2
              by auto
            from a' have b': "eval (change_int f i) p1 \<noteq> eval (change_int f i) p2"
              using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
              by metis
            from a'' have b'': "eval (change_int f i) p1 \<noteq> Det True"
              using change_tv.elims ih1 tv.simps(4)
              by auto
            from a''' have b''': "eval (change_int f i) p2 \<noteq> Det True"
              using b b' b''
              by (metis assms change_tv.simps(1) change_tv_injection inj_eq ih2)
            from a'''' have b'''': "eval (change_int f i) p1 \<noteq> Det False"
              using b b'
              by auto
            from b b' b'' b''' b''''
            have "eval (change_int f i) (Eql' p1 p2) = eval (change_int f i) (Neg' p1)"
              using eval_equality[of "change_int f i" p1 p2]
              by auto
            then show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
              using ih1 yes a a' a''' a'''' b b' b''' b'''' eval_negation a'' b''
              by metis
          next
            assume a''''': "eval i p2 \<noteq> Det False"
            from a' a'' a''' a'''' a''''' have yes: "eval i (Eql' p1 p2) = Det False"
              using eval_equality[of i p1 p2]
              by auto
            from a''''' have "change_tv f (eval i p2) \<noteq> Det False"
              using change_tv_injection inj_eq \<open>inj f\<close> change_tv.simps
              by metis
            then have b: "eval (change_int f i) p2 \<noteq> Det False"
              using ih2
              by auto
            from a' have b': "eval (change_int f i) p1 \<noteq> eval (change_int f i) p2"
              using \<open>inj f\<close> ih1 ih2 change_tv_injection the_inv_f_f change_tv.simps
              by metis
            from a'' have b'': "eval (change_int f i) p1 \<noteq> Det True"
              using change_tv.elims ih1 tv.simps(4)
              by auto
            from a''' have b''': "eval (change_int f i) p2 \<noteq> Det True"
              using b b' b''
              by (metis assms change_tv.simps(1) change_tv_injection the_inv_f_f ih2)
            from a'''' have b'''': "eval (change_int f i) p1 \<noteq> Det False"
              by (metis a'' change_tv.simps(2) ih1 string_tv.cases tv.distinct(1))
            from b b' b'' b''' b'''' have "eval (change_int f i) (Eql' p1 p2) = Det False"
              using eval_equality[of "change_int f i" p1 p2]
              by auto
            then show "eval (change_int f i) (Eql' p1 p2) = change_tv f (eval i (Eql' p1 p2))"
              using ih1 yes a' a''' a'''' b b' b''' b'''' eval_negation a'' b''
              by auto
          qed
        qed
      qed
    qed
  qed
qed (simp_all add: change_int_def)

theorem valid_in_valid:
  assumes "card U \<ge> card (props p)"
  assumes "valid_in U p"
  shows "valid p"
proof -
  have "finite U \<Longrightarrow> card (props p) \<le> card U \<Longrightarrow> valid_in U p \<Longrightarrow> valid p" for U p
  proof -
    assume assms: "finite U" "card (props p) \<le> card U" "valid_in U p"
    show "valid p"
      unfolding valid_def
    proof
      fix i
      obtain f where f_p: "(change_int f i) ` (props p) \<subseteq> (domain U) \<and> inj f"
      proof -
        have "finite U \<Longrightarrow> card (props p) \<le> card U \<Longrightarrow>
            \<exists>f. change_int f i ` props p \<subseteq> domain U \<and> inj f" for U p
        proof -
          assume assms: "finite U" "card (props p) \<le> card U"
          show ?thesis
          proof -
            let ?X = "(get_indet ` ((i ` props p) \<inter> {tv. is_indet tv}))"
            have d: "finite (props p)"
              by (induct p) auto
            then have f: "finite ?X"
              by auto
            have cx: "card ?X \<le> card U"
              using assms
              by (metis Int_lower1 d card_image_le card_mono finite_Int finite_imageI le_trans)
            obtain f where f_p: "(\<forall>n \<in> ?X. f n \<in> U) \<and> (inj f)"
            proof -
              have "finite X \<Longrightarrow> finite Y \<Longrightarrow> card X \<le> card Y \<Longrightarrow> \<exists>f. (\<forall>n\<in>X. f n \<in> Y) \<and> inj f"
                  for X Y :: "nat set"
              proof -
                assume assms: "finite X" "finite Y" "card X \<le> card Y"
                show ?thesis
                proof -
                  from assms obtain Z where "Z \<subseteq> Y \<and> card Z = card X"
                    by (metis card_image card_le_inj)
                  then obtain f where "bij_betw f X Z"
                    by (metis assms(1) assms(2) finite_same_card_bij infinite_super)
                  then have f_p: "(\<forall>n \<in> X. f n \<in> Y) \<and> inj_on f X"
                    using \<open>Z \<subseteq> Y \<and> card Z = card X\<close> bij_betwE bij_betw_imp_inj_on
                    by blast
                  obtain f' where f': "f' = (\<lambda>n. if n \<in> X then f n else n + Suc (Max Y + n))"
                    by simp
                  have "inj f'"
                    unfolding f' inj_on_def
                    using assms(2) f_p le_add2 trans_le_add2 not_less_eq_eq
                    by (simp, metis Max_ge add.commute inj_on_eq_iff)
                  moreover have "(\<forall>n \<in> X. f' n \<in> Y)"
                    unfolding f'
                    using f_p
                    by auto
                  ultimately show ?thesis
                    by metis
                qed
              qed
              then show "(\<And>f. (\<forall>n \<in> get_indet ` (i ` props p \<inter> {tv. is_indet tv}). f n \<in> U)
                  \<and> inj f \<Longrightarrow> thesis) \<Longrightarrow> thesis"
                using assms cx f
                unfolding inj_on_def
                by metis
            qed
            have "(change_int f i) ` (props p) \<subseteq> (domain U)"
            proof
              fix x
              assume "x \<in> change_int f i ` props p"
              then obtain s where s_p: "s \<in> props p \<and> change_int f i s = x"
                by auto
              then have "change_int f i s \<in> {Det True, Det False} \<union> Indet ` U"
              proof (cases "change_int f i s \<in> {Det True, Det False}")
                case True
                then show ?thesis
                  by auto
              next
                case False
                then obtain n' where "change_int f i s = Indet n'"
                  by (cases "change_int f i s") auto
                then have p: "change_tv f (i s) = Indet n'"
                  by (simp add: change_int_def)
                moreover
                {
                  obtain n'' where "f n'' = n'"
                    using calculation change_tv.elims
                    by blast
                  moreover have "s \<in> props p \<and> i s = (Indet n'')"
                    using p calculation change_tv.simps change_tv_injection the_inv_f_f f_p s_p
                    by metis
                  then have "(Indet n'') \<in> i ` props p"
                    using image_iff
                    by metis
                  then have "(Indet n'') \<in> i ` props p \<and> is_indet (Indet n'') \<and>
                      get_indet (Indet n'') = n''"
                    by auto
                  then have "n'' \<in> ?X"
                    using Int_Collect image_iff
                    by metis
                  ultimately have "n' \<in> U"
                    using f_p
                    by auto
                }
                ultimately have "change_tv f (i s) \<in> Indet ` U"
                  by auto
                then have "change_int f i s \<in> Indet ` U"
                  unfolding change_int_def
                  by auto
                then show ?thesis
                  by auto
              qed
              then show "x \<in> domain U"
                unfolding domain_def
                using s_p
                by simp
            qed
            then have "(change_int f i) ` (props p) \<subseteq> (domain U) \<and> (inj f)"
              unfolding domain_def
              using f_p
              by simp
            then show ?thesis
              using f_p
              by metis
          qed
        qed
        then show "(\<And>f. change_int f i ` props p \<subseteq> domain U \<and> inj f \<Longrightarrow> thesis) \<Longrightarrow> thesis"
          using assms
          by metis
      qed
      obtain i2 where i2: "i2 = (\<lambda>s. if s \<in> props p then (change_int f i) s else Det True)"
        by simp
      then have i2_p: "\<forall>s \<in> props p. i2 s = (change_int f i) s"
            "\<forall>s \<in> - props p. i2 s = Det True"
        by auto
      then have "range i2 \<subseteq> (domain U)"
        using i2 f_p
        unfolding domain_def
        by auto
      then have "eval i2 p = Det True"
        using assms
        unfolding valid_in_def
        by auto
      then have "eval (change_int f i) p = Det True"
        using relevant_props[of p i2 "change_int f i"] i2_p
        by auto
      then have "change_tv f (eval i p) = Det True"
        using eval_change_int_change_tv f_p
        by auto
      then show "eval i p = Det True"
        by (cases "eval i p") auto
    qed
  qed
  then show ?thesis
    using assms subsetI sup_bot.comm_neutral image_is_empty subsetCE UnCI valid_in_def
        Un_insert_left card.empty card.infinite finite.intros(1)
    unfolding domain_def
    by metis
qed

proposition "valid p \<longleftrightarrow> valid_in {1..card (props p)} p"
  using valid_in_valid transfer
  by force

end


theory Example_A
  imports "../Classifying_Markov_Chain_States"
begin

section \<open>Example A\<close> text_raw \<open>\label{ex:A}\<close>

text \<open>

We formalize the following Markov chain:

\begin{center}
\begin{tikzpicture}[thick]

  \path [fill, color = gray!30] (0, 0) circle(0.6) ;

  \path [fill, color = gray!30] (1, 1) circle(0.6) ;

  \path [fill, color = gray!30] (4.5, 0.66) ellipse(2 and 1.9) ;

  \node (bot)  at (-1, 0) {} ;

  \node[draw,circle] (A)  at (0, 0) {$A$} ;

  \node[draw,circle] (B)  at (1, 1) {$B$} ;

  \node[draw,circle] (C1) at (3, 0) {$C_1$} ;

  \node[draw,circle] (C2) at (6, 0) {$C_2$} ;

  \node[draw,circle] (C3) at (4.5, 2) {$C_3$} ;

  \path[->, >=latex]
    (bot) edge (A)
    (A)   edge                node [above] {$\frac{1}{2}$} (B)
          edge                node [below] {$\frac{1}{2}$} (C1)
    (B)   edge [loop above]   node [left]  {$\frac{1}{2}$} (B)
          edge [out = 0]      node [above] {$\frac{1}{2}$} (C1)
    (C1)  edge [loop above]   node [above] {$\frac{1}{3}$} (C1)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C2)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C3)
    (C2)  edge [loop right]   node [above] {$\frac{1}{3}$} (C2)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C1)
          edge [bend left=15] node [above] {$\frac{1}{3}$} (C3)
    (C3)  edge [loop right]   node [above] {$\frac{1}{2}$} (C3)
          edge [bend left=15] node [above] {$\frac{1}{4}$} (C1)
          edge [bend left=15] node [above] {$\frac{1}{4}$} (C2) ;

\end{tikzpicture}
\end{center}

First we define the state space as its own type:

\<close>

datatype state = A | B | C1 | C2 | C3

text \<open>Now the state space is \<open>UNIV :: state set\<close>\<close>

lemma UNIV_state: "UNIV = {A, B, C1, C2, C3}"
  using state.nchotomy by auto

instance state :: finite
  by standard (simp add: UNIV_state)

text \<open>The transition function \<open>tau\<close> is easily defined using the case statement, this allows
us to give a sparse specification as all \<open>0\<close> cases are collected at the end.\<close>

definition tau :: "state \<Rightarrow> state \<Rightarrow> real" where
  "tau s t = (case (s, t) of
      (A,  B)  \<Rightarrow> 1 / 2 | (A,  C1) \<Rightarrow> 1 / 2
    | (B,  B)  \<Rightarrow> 1 / 2 | (B,  C1) \<Rightarrow> 1 / 2
    | (C1, C1) \<Rightarrow> 1 / 3 | (C1, C2) \<Rightarrow> 1 / 3 | (C1, C3) \<Rightarrow> 1 / 3
    | (C2, C1) \<Rightarrow> 1 / 3 | (C2, C2) \<Rightarrow> 1 / 3 | (C2, C3) \<Rightarrow> 1 / 3
    | (C3, C1) \<Rightarrow> 1 / 4 | (C3, C2) \<Rightarrow> 1 / 4 | (C3, C3) \<Rightarrow> 1 / 2
    | _ \<Rightarrow> 0)"

lift_definition K :: "state \<Rightarrow> state pmf" is tau
  by (auto simp: tau_def nn_integral_count_space_finite UNIV_state split: state.split simp del: ennreal_plus)

text \<open>We use the \<open>finite_pmf\<close>-locale which introduces the point measure \<open>tau.M\<close>, and
  provides us with the necessary simplifier setup.\<close>

interpretation A: MC_syntax K .

subsection \<open>The essential classs @{term "{C1, C2, C3}"}\<close>

context
begin

interpretation pmf_as_function .

lemma A_E_eq:
  "set_pmf (K x) = (case x of A \<Rightarrow> {B, C1} | B \<Rightarrow> {B, C1} | _ \<Rightarrow> {C1, C2, C3})"
  using state.nchotomy by transfer (auto simp: tau_def split: prod.split state.split)

lemma A_essential: "A.essential_class {C1, C2, C3}"
  by (rule A.essential_classI2) (auto simp: A_E_eq)

lemma A_aperiodic: "A.aperiodic {C1, C2, C3}"
  unfolding A.aperiodic_def
proof safe
  have eq: "\<And>x'. (if x' = C1 then 1 else 0) = indicator {C1} x'" by auto

  show "{C1, C2, C3} \<in> UNIV // A.communicating"
    using A_essential by (simp add: A.essential_class_def)
  then have "A.period {C1, C2, C3} = Gcd (A.period_set C1)"
    by (rule A.period_eq) simp
  also have "\<dots> = 1"
    by (rule Gcd_nat_eq_one) (simp add: A_E_eq A.period_set_def A.p_Suc' A.p_0 eq measure_pmf_single pmf_positive)
  finally show "A.period {C1, C2, C3} = 1" .
qed

subsection \<open>The stationary distribution \<open>n\<close>\<close>

text \<open>Similar to \<open>tau\<close> we introduce \<open>n\<close> using the \<open>finite_pmf\<close>-locale.\<close>

lift_definition n :: "state pmf" is "\<lambda>C1 \<Rightarrow> 0.3 | C2 \<Rightarrow> 0.3 | C3 \<Rightarrow> 0.4 | _ \<Rightarrow> 0"
  by (auto simp: UNIV_state nn_integral_count_space_finite split: state.split)

lemma stationary_distribution_N: "A.stationary_distribution n"
  unfolding A.stationary_distribution_def
  apply (auto intro!: pmf_eqI simp: pmf_bind integral_measure_pmf[of UNIV])
  apply transfer
  apply (auto simp: UNIV_state tau_def split: state.split)
  done

lemma exclusive_N[simp]: "set_pmf n = {C1, C2, C3}"
  using state.nchotomy by transfer (auto split: state.splits)

end

lemma n_is_limit:
  assumes x: "x \<in> {C1, C2, C3}" and y: "y \<in> {C1, C2, C3}"
  shows "(A.p x y) \<longlonglongrightarrow> pmf n y"
  using A.stationary_distribution_imp_p_limit[OF A_aperiodic A_essential _ stationary_distribution_N _ x y]
  by simp

lemma C_is_pos_recurrent: "x \<in> {C1, C2, C3} \<Longrightarrow> A.pos_recurrent x"
  using A.stationary_distributionD(1)[OF A_essential _ stationary_distribution_N] by auto

lemma C_recurrence_time:
  assumes x: "x \<in> {C1, C2, C3}"
  shows "A.U' x x = 1 / pmf n x"
proof -
  from A.stationary_distributionD(2)[OF A_essential _ stationary_distribution_N _]
  have "A.stat {C1, C2, C3} = n" by simp
  with x have "1 / pmf n x = 1 / emeasure (A.stat {C1, C2, C3}) {x}"
    by (simp add: emeasure_pmf_single pmf_positive divide_ennreal ennreal_1[symmetric] del: ennreal_1)
  also have "\<dots> = A.U' x x"
    unfolding A.stat_def using x
    by (subst emeasure_point_measure_finite) (simp_all add:  A.U'_def)
  finally show ?thesis ..
qed

end


theory transitive_closure_star
imports Main
begin
(*
Relation = if x \in X, y \in Y when we have R x y \<longleftrightarrow> (x,y) \<in> X \<times> Y.
Reflexive = self loops  in the graph. e.g. \<forall>x \<in> X, (x,x) \in X \<times> X
Transitive = if there is a path from x to y and from y to z then there is one from
x to z. if R x y, R y z \<Longrightarrow> R x z.
Reflexive closure = smallest relation that is reflexive and contains R.
  r(R) := R \<union> Diagonal.
Transitive closure t(r) := R \<and> Transitive \<and> Smallest

Transitive closure :=
tr(r) := R \<and> Reflexive \<and> Transitive \<and> Smallest

transitive closure
transitive closure relation means it must be reflexive and transitive.
So if we have R then tr(R) = R* is a new relation that is reflexive and transitive.
Note the * operator maps relations to it’s transitive closure
i.e. *(R) = R* for short hand.

*)
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl: "star r x x"|
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

(* By definition star r is reflexive. *)

lemma star_reflexive: "star r x x" by (rule refl)

(* It is also transitive, but we need rule induction to prove that: *)

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply assumption
  by (simp add: star.step)

lemma
  shows "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
proof (induction rule: star.induct)
case (refl x)
  then show ?case by assumption
next
  case (step x y z)
  then show ?case by (simp add: star.step)
qed

end


(*  Title:      FOL/ex/Classical.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Classical Predicate Calculus Problems\<close>

theory Classical
imports FOL
begin

lemma \<open>(P \<longrightarrow> Q \<or> R) \<longrightarrow> (P \<longrightarrow> Q) \<or> (P \<longrightarrow> R)\<close>
  by blast

subsubsection \<open>If and only if\<close>

lemma \<open>(P \<longleftrightarrow> Q) \<longleftrightarrow> (Q \<longleftrightarrow> P)\<close>
  by blast

lemma \<open>\<not> (P \<longleftrightarrow> \<not> P)\<close>
  by blast

subsection \<open>Pelletier's examples\<close>

text \<open>
  Sample problems from

    \<^item> F. J. Pelletier,
    Seventy-Five Problems for Testing Automatic Theorem Provers,
    J. Automated Reasoning 2 (1986), 191-216.
    Errata, JAR 4 (1988), 236-236.

  The hardest problems -- judging by experience with several theorem
  provers, including matrix ones -- are 34 and 43.
\<close>

text\<open>1\<close>
lemma \<open>(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> \<not> P)\<close>
  by blast

text\<open>2\<close>
lemma \<open>\<not> \<not> P \<longleftrightarrow> P\<close>
  by blast

text\<open>3\<close>
lemma \<open>\<not> (P \<longrightarrow> Q) \<longrightarrow> (Q \<longrightarrow> P)\<close>
  by blast

text\<open>4\<close>
lemma \<open>(\<not> P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> P)\<close>
  by blast

text\<open>5\<close>
lemma \<open>((P \<or> Q) \<longrightarrow> (P \<or> R)) \<longrightarrow> (P \<or> (Q \<longrightarrow> R))\<close>
  by blast

text\<open>6\<close>
lemma \<open>P \<or> \<not> P\<close>
  by blast

text\<open>7\<close>
lemma \<open>P \<or> \<not> \<not> \<not> P\<close>
  by blast

text\<open>8. Peirce's law\<close>
lemma \<open>((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P\<close>
  by blast

text\<open>9\<close>
lemma \<open>((P \<or> Q) \<and> (\<not> P \<or> Q) \<and> (P \<or> \<not> Q)) \<longrightarrow> \<not> (\<not> P \<or> \<not> Q)\<close>
  by blast

text\<open>10\<close>
lemma \<open>(Q \<longrightarrow> R) \<and> (R \<longrightarrow> P \<and> Q) \<and> (P \<longrightarrow> Q \<or> R) \<longrightarrow> (P \<longleftrightarrow> Q)\<close>
  by blast

text\<open>11. Proved in each direction (incorrectly, says Pelletier!!)\<close>
lemma \<open>P \<longleftrightarrow> P\<close>
  by blast

text\<open>12. "Dijkstra's law"\<close>
lemma \<open>((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))\<close>
  by blast

text\<open>13. Distributive law\<close>
lemma \<open>P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)\<close>
  by blast

text\<open>14\<close>
lemma \<open>(P \<longleftrightarrow> Q) \<longleftrightarrow> ((Q \<or> \<not> P) \<and> (\<not> Q \<or> P))\<close>
  by blast

text\<open>15\<close>
lemma \<open>(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)\<close>
  by blast

text\<open>16\<close>
lemma \<open>(P \<longrightarrow> Q) \<or> (Q \<longrightarrow> P)\<close>
  by blast

text\<open>17\<close>
lemma \<open>((P \<and> (Q \<longrightarrow> R)) \<longrightarrow> S) \<longleftrightarrow> ((\<not> P \<or> Q \<or> S) \<and> (\<not> P \<or> \<not> R \<or> S))\<close>
  by blast

subsection \<open>Classical Logic: examples with quantifiers\<close>

lemma \<open>(\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> (\<forall>x. P(x)) \<and> (\<forall>x. Q(x))\<close>
  by blast

lemma \<open>(\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))\<close>
  by blast

lemma \<open>(\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q\<close>
  by blast

lemma \<open>(\<forall>x. P(x)) \<or> Q \<longleftrightarrow> (\<forall>x. P(x) \<or> Q)\<close>
  by blast

text\<open>Discussed in Avron, Gentzen-Type Systems, Resolution and Tableaux,
  JAR 10 (265-281), 1993.  Proof is trivial!\<close>
lemma \<open>\<not> ((\<exists>x. \<not> P(x)) \<and> ((\<exists>x. P(x)) \<or> (\<exists>x. P(x) \<and> Q(x))) \<and> \<not> (\<exists>x. P(x)))\<close>
  by blast

subsection \<open>Problems requiring quantifier duplication\<close>

text\<open>Theorem B of Peter Andrews, Theorem Proving via General Matings,
  JACM 28 (1981).\<close>
lemma \<open>(\<exists>x. \<forall>y. P(x) \<longleftrightarrow> P(y)) \<longrightarrow> ((\<exists>x. P(x)) \<longleftrightarrow> (\<forall>y. P(y)))\<close>
  by blast

text\<open>Needs multiple instantiation of ALL.\<close>
lemma \<open>(\<forall>x. P(x) \<longrightarrow> P(f(x))) \<and> P(d) \<longrightarrow> P(f(f(f(d))))\<close>
  by blast

text\<open>Needs double instantiation of the quantifier\<close>
lemma \<open>\<exists>x. P(x) \<longrightarrow> P(a) \<and> P(b)\<close>
  by blast

lemma \<open>\<exists>z. P(z) \<longrightarrow> (\<forall>x. P(x))\<close>
  by blast

lemma \<open>\<exists>x. (\<exists>y. P(y)) \<longrightarrow> P(x)\<close>
  by blast

text\<open>V. Lifschitz, What Is the Inverse Method?, JAR 5 (1989), 1--23. NOT PROVED.\<close>
lemma
  \<open>\<exists>x x'. \<forall>y. \<exists>z z'.
    (\<not> P(y,y) \<or> P(x,x) \<or> \<not> S(z,x)) \<and>
    (S(x,y) \<or> \<not> S(y,z) \<or> Q(z',z')) \<and>
    (Q(x',y) \<or> \<not> Q(y,z') \<or> S(x',x'))\<close>
  oops

subsection \<open>Hard examples with quantifiers\<close>

text\<open>18\<close>
lemma \<open>\<exists>y. \<forall>x. P(y) \<longrightarrow> P(x)\<close>
  by blast

text\<open>19\<close>
lemma \<open>\<exists>x. \<forall>y z. (P(y) \<longrightarrow> Q(z)) \<longrightarrow> (P(x) \<longrightarrow> Q(x))\<close>
  by blast

text\<open>20\<close>
lemma \<open>(\<forall>x y. \<exists>z. \<forall>w. (P(x) \<and> Q(y) \<longrightarrow> R(z) \<and> S(w)))
  \<longrightarrow> (\<exists>x y. P(x) \<and> Q(y)) \<longrightarrow> (\<exists>z. R(z))\<close>
  by blast

text\<open>21\<close>
lemma \<open>(\<exists>x. P \<longrightarrow> Q(x)) \<and> (\<exists>x. Q(x) \<longrightarrow> P) \<longrightarrow> (\<exists>x. P \<longleftrightarrow> Q(x))\<close>
  by blast

text\<open>22\<close>
lemma \<open>(\<forall>x. P \<longleftrightarrow> Q(x)) \<longrightarrow> (P \<longleftrightarrow> (\<forall>x. Q(x)))\<close>
  by blast

text\<open>23\<close>
lemma \<open>(\<forall>x. P \<or> Q(x)) \<longleftrightarrow> (P \<or> (\<forall>x. Q(x)))\<close>
  by blast

text\<open>24\<close>
lemma
  \<open>\<not> (\<exists>x. S(x) \<and> Q(x)) \<and> (\<forall>x. P(x) \<longrightarrow> Q(x) \<or> R(x)) \<and>
    (\<not> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))) \<and> (\<forall>x. Q(x) \<or> R(x) \<longrightarrow> S(x))
    \<longrightarrow> (\<exists>x. P(x) \<and> R(x))\<close>
  by blast

text\<open>25\<close>
lemma
  \<open>(\<exists>x. P(x)) \<and>
    (\<forall>x. L(x) \<longrightarrow> \<not> (M(x) \<and> R(x))) \<and>
    (\<forall>x. P(x) \<longrightarrow> (M(x) \<and> L(x))) \<and>
    ((\<forall>x. P(x) \<longrightarrow> Q(x)) \<or> (\<exists>x. P(x) \<and> R(x)))
    \<longrightarrow> (\<exists>x. Q(x) \<and> P(x))\<close>
  by blast

text\<open>26\<close>
lemma
  \<open>((\<exists>x. p(x)) \<longleftrightarrow> (\<exists>x. q(x))) \<and>
    (\<forall>x. \<forall>y. p(x) \<and> q(y) \<longrightarrow> (r(x) \<longleftrightarrow> s(y)))
  \<longrightarrow> ((\<forall>x. p(x) \<longrightarrow> r(x)) \<longleftrightarrow> (\<forall>x. q(x) \<longrightarrow> s(x)))\<close>
  by blast

text\<open>27\<close>
lemma
  \<open>(\<exists>x. P(x) \<and> \<not> Q(x)) \<and>
    (\<forall>x. P(x) \<longrightarrow> R(x)) \<and>
    (\<forall>x. M(x) \<and> L(x) \<longrightarrow> P(x)) \<and>
    ((\<exists>x. R(x) \<and> \<not> Q(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> \<not> R(x)))
  \<longrightarrow> (\<forall>x. M(x) \<longrightarrow> \<not> L(x))\<close>
  by blast

text\<open>28. AMENDED\<close>
lemma
  \<open>(\<forall>x. P(x) \<longrightarrow> (\<forall>x. Q(x))) \<and>
    ((\<forall>x. Q(x) \<or> R(x)) \<longrightarrow> (\<exists>x. Q(x) \<and> S(x))) \<and>
    ((\<exists>x. S(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> M(x)))
  \<longrightarrow> (\<forall>x. P(x) \<and> L(x) \<longrightarrow> M(x))\<close>
  by blast

text\<open>29. Essentially the same as Principia Mathematica *11.71\<close>
lemma
  \<open>(\<exists>x. P(x)) \<and> (\<exists>y. Q(y))
    \<longrightarrow> ((\<forall>x. P(x) \<longrightarrow> R(x)) \<and> (\<forall>y. Q(y) \<longrightarrow> S(y)) \<longleftrightarrow>
      (\<forall>x y. P(x) \<and> Q(y) \<longrightarrow> R(x) \<and> S(y)))\<close>
  by blast

text\<open>30\<close>
lemma
  \<open>(\<forall>x. P(x) \<or> Q(x) \<longrightarrow> \<not> R(x)) \<and>
    (\<forall>x. (Q(x) \<longrightarrow> \<not> S(x)) \<longrightarrow> P(x) \<and> R(x))
    \<longrightarrow> (\<forall>x. S(x))\<close>
  by blast

text\<open>31\<close>
lemma
  \<open>\<not> (\<exists>x. P(x) \<and> (Q(x) \<or> R(x))) \<and>
    (\<exists>x. L(x) \<and> P(x)) \<and>
    (\<forall>x. \<not> R(x) \<longrightarrow> M(x))
  \<longrightarrow> (\<exists>x. L(x) \<and> M(x))\<close>
  by blast

text\<open>32\<close>
lemma
  \<open>(\<forall>x. P(x) \<and> (Q(x) \<or> R(x)) \<longrightarrow> S(x)) \<and>
    (\<forall>x. S(x) \<and> R(x) \<longrightarrow> L(x)) \<and>
    (\<forall>x. M(x) \<longrightarrow> R(x))
  \<longrightarrow> (\<forall>x. P(x) \<and> M(x) \<longrightarrow> L(x))\<close>
  by blast

text\<open>33\<close>
lemma
  \<open>(\<forall>x. P(a) \<and> (P(x) \<longrightarrow> P(b)) \<longrightarrow> P(c)) \<longleftrightarrow>
    (\<forall>x. (\<not> P(a) \<or> P(x) \<or> P(c)) \<and> (\<not> P(a) \<or> \<not> P(b) \<or> P(c)))\<close>
  by blast

text\<open>34. AMENDED (TWICE!!). Andrews's challenge.\<close>
lemma
  \<open>((\<exists>x. \<forall>y. p(x) \<longleftrightarrow> p(y)) \<longleftrightarrow> ((\<exists>x. q(x)) \<longleftrightarrow> (\<forall>y. p(y)))) \<longleftrightarrow>
    ((\<exists>x. \<forall>y. q(x) \<longleftrightarrow> q(y)) \<longleftrightarrow> ((\<exists>x. p(x)) \<longleftrightarrow> (\<forall>y. q(y))))\<close>
  by blast

text\<open>35\<close>
lemma \<open>\<exists>x y. P(x,y) \<longrightarrow> (\<forall>u v. P(u,v))\<close>
  by blast

text\<open>36\<close>
lemma
  \<open>(\<forall>x. \<exists>y. J(x,y)) \<and>
    (\<forall>x. \<exists>y. G(x,y)) \<and>
    (\<forall>x y. J(x,y) \<or> G(x,y) \<longrightarrow> (\<forall>z. J(y,z) \<or> G(y,z) \<longrightarrow> H(x,z)))
  \<longrightarrow> (\<forall>x. \<exists>y. H(x,y))\<close>
  by blast

text\<open>37\<close>
lemma
  \<open>(\<forall>z. \<exists>w. \<forall>x. \<exists>y.
    (P(x,z) \<longrightarrow> P(y,w)) \<and> P(y,z) \<and> (P(y,w) \<longrightarrow> (\<exists>u. Q(u,w)))) \<and>
    (\<forall>x z. \<not> P(x,z) \<longrightarrow> (\<exists>y. Q(y,z))) \<and>
    ((\<exists>x y. Q(x,y)) \<longrightarrow> (\<forall>x. R(x,x)))
  \<longrightarrow> (\<forall>x. \<exists>y. R(x,y))\<close>
  by blast

text\<open>38\<close>
lemma
  \<open>(\<forall>x. p(a) \<and> (p(x) \<longrightarrow> (\<exists>y. p(y) \<and> r(x,y))) \<longrightarrow>
    (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z)))  \<longleftrightarrow>
    (\<forall>x. (\<not> p(a) \<or> p(x) \<or> (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z))) \<and>
      (\<not> p(a) \<or> \<not> (\<exists>y. p(y) \<and> r(x,y)) \<or>
      (\<exists>z. \<exists>w. p(z) \<and> r(x,w) \<and> r(w,z))))\<close>
  by blast

text\<open>39\<close>
lemma \<open>\<not> (\<exists>x. \<forall>y. F(y,x) \<longleftrightarrow> \<not> F(y,y))\<close>
  by blast

text\<open>40. AMENDED\<close>
lemma
  \<open>(\<exists>y. \<forall>x. F(x,y) \<longleftrightarrow> F(x,x)) \<longrightarrow>
    \<not> (\<forall>x. \<exists>y. \<forall>z. F(z,y) \<longleftrightarrow> \<not> F(z,x))\<close>
  by blast

text\<open>41\<close>
lemma
  \<open>(\<forall>z. \<exists>y. \<forall>x. f(x,y) \<longleftrightarrow> f(x,z) \<and> \<not> f(x,x))
    \<longrightarrow> \<not> (\<exists>z. \<forall>x. f(x,z))\<close>
  by blast

text\<open>42\<close>
lemma \<open>\<not> (\<exists>y. \<forall>x. p(x,y) \<longleftrightarrow> \<not> (\<exists>z. p(x,z) \<and> p(z,x)))\<close>
  by blast

text\<open>43\<close>
lemma
  \<open>(\<forall>x. \<forall>y. q(x,y) \<longleftrightarrow> (\<forall>z. p(z,x) \<longleftrightarrow> p(z,y)))
    \<longrightarrow> (\<forall>x. \<forall>y. q(x,y) \<longleftrightarrow> q(y,x))\<close>
  by blast

text \<open>
  Other proofs: Can use \<open>auto\<close>, which cheats by using rewriting!
  \<open>Deepen_tac\<close> alone requires 253 secs.  Or
  \<open>by (mini_tac 1 THEN Deepen_tac 5 1)\<close>.
\<close>

text\<open>44\<close>
lemma
  \<open>(\<forall>x. f(x) \<longrightarrow> (\<exists>y. g(y) \<and> h(x,y) \<and> (\<exists>y. g(y) \<and> \<not> h(x,y)))) \<and>
    (\<exists>x. j(x) \<and> (\<forall>y. g(y) \<longrightarrow> h(x,y)))
  \<longrightarrow> (\<exists>x. j(x) \<and> \<not> f(x))\<close>
  by blast

text\<open>45\<close>
lemma
  \<open>(\<forall>x. f(x) \<and> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> j(x,y))
      \<longrightarrow> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> k(y))) \<and>
      \<not> (\<exists>y. l(y) \<and> k(y)) \<and>
      (\<exists>x. f(x) \<and> (\<forall>y. h(x,y) \<longrightarrow> l(y)) \<and> (\<forall>y. g(y) \<and> h(x,y) \<longrightarrow> j(x,y)))
      \<longrightarrow> (\<exists>x. f(x) \<and> \<not> (\<exists>y. g(y) \<and> h(x,y)))\<close>
  by blast

text\<open>46\<close>
lemma
  \<open>(\<forall>x. f(x) \<and> (\<forall>y. f(y) \<and> h(y,x) \<longrightarrow> g(y)) \<longrightarrow> g(x)) \<and>
      ((\<exists>x. f(x) \<and> \<not> g(x)) \<longrightarrow>
       (\<exists>x. f(x) \<and> \<not> g(x) \<and> (\<forall>y. f(y) \<and> \<not> g(y) \<longrightarrow> j(x,y)))) \<and>
      (\<forall>x y. f(x) \<and> f(y) \<and> h(x,y) \<longrightarrow> \<not> j(y,x))
      \<longrightarrow> (\<forall>x. f(x) \<longrightarrow> g(x))\<close>
  by blast

subsection \<open>Problems (mainly) involving equality or functions\<close>

text\<open>48\<close>
lemma \<open>(a = b \<or> c = d) \<and> (a = c \<or> b = d) \<longrightarrow> a = d \<or> b = c\<close>
  by blast

text\<open>49. NOT PROVED AUTOMATICALLY. Hard because it involves substitution for
  Vars; the type constraint ensures that x,y,z have the same type as a,b,u.\<close>
lemma
  \<open>(\<exists>x y::'a. \<forall>z. z = x \<or> z = y) \<and> P(a) \<and> P(b) \<and> a \<noteq> b \<longrightarrow> (\<forall>u::'a. P(u))\<close>
  apply safe
  apply (rule_tac x = \<open>a\<close> in allE, assumption)
  apply (rule_tac x = \<open>b\<close> in allE, assumption)
  apply fast  \<comment> \<open>blast's treatment of equality can't do it\<close>
  done

text\<open>50. (What has this to do with equality?)\<close>
lemma \<open>(\<forall>x. P(a,x) \<or> (\<forall>y. P(x,y))) \<longrightarrow> (\<exists>x. \<forall>y. P(x,y))\<close>
  by blast

text\<open>51\<close>
lemma
  \<open>(\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
    (\<exists>z. \<forall>x. \<exists>w. (\<forall>y. P(x,y) \<longleftrightarrow> y=w) \<longleftrightarrow> x = z)\<close>
  by blast

text\<open>52\<close>
text\<open>Almost the same as 51.\<close>
lemma
  \<open>(\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
    (\<exists>w. \<forall>y. \<exists>z. (\<forall>x. P(x,y) \<longleftrightarrow> x = z) \<longleftrightarrow> y = w)\<close>
  by blast

text\<open>55\<close>
text\<open>Non-equational version, from Manthey and Bry, CADE-9 (Springer, 1988).
  fast DISCOVERS who killed Agatha.\<close>
schematic_goal
  \<open>lives(agatha) \<and> lives(butler) \<and> lives(charles) \<and>
   (killed(agatha,agatha) \<or> killed(butler,agatha) \<or> killed(charles,agatha)) \<and>
   (\<forall>x y. killed(x,y) \<longrightarrow> hates(x,y) \<and> \<not> richer(x,y)) \<and>
   (\<forall>x. hates(agatha,x) \<longrightarrow> \<not> hates(charles,x)) \<and>
   (hates(agatha,agatha) \<and> hates(agatha,charles)) \<and>
   (\<forall>x. lives(x) \<and> \<not> richer(x,agatha) \<longrightarrow> hates(butler,x)) \<and>
   (\<forall>x. hates(agatha,x) \<longrightarrow> hates(butler,x)) \<and>
   (\<forall>x. \<not> hates(x,agatha) \<or> \<not> hates(x,butler) \<or> \<not> hates(x,charles)) \<longrightarrow>
    killed(?who,agatha)\<close>
  by fast  \<comment> \<open>MUCH faster than blast\<close>

text\<open>56\<close>
lemma \<open>(\<forall>x. (\<exists>y. P(y) \<and> x = f(y)) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> P(f(x)))\<close>
  by blast

text\<open>57\<close>
lemma
  \<open>P(f(a,b), f(b,c)) \<and> P(f(b,c), f(a,c)) \<and>
    (\<forall>x y z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<longrightarrow> P(f(a,b), f(a,c))\<close>
  by blast

text\<open>58  NOT PROVED AUTOMATICALLY\<close>
lemma \<open>(\<forall>x y. f(x) = g(y)) \<longrightarrow> (\<forall>x y. f(f(x)) = f(g(y)))\<close>
  by (slow elim: subst_context)

text\<open>59\<close>
lemma \<open>(\<forall>x. P(x) \<longleftrightarrow> \<not> P(f(x))) \<longrightarrow> (\<exists>x. P(x) \<and> \<not> P(f(x)))\<close>
  by blast

text\<open>60\<close>
lemma \<open>\<forall>x. P(x,f(x)) \<longleftrightarrow> (\<exists>y. (\<forall>z. P(z,y) \<longrightarrow> P(z,f(x))) \<and> P(x,y))\<close>
  by blast

text\<open>62 as corrected in JAR 18 (1997), page 135\<close>
lemma
  \<open>(\<forall>x. p(a) \<and> (p(x) \<longrightarrow> p(f(x))) \<longrightarrow> p(f(f(x)))) \<longleftrightarrow>
    (\<forall>x. (\<not> p(a) \<or> p(x) \<or> p(f(f(x)))) \<and>
      (\<not> p(a) \<or> \<not> p(f(x)) \<or> p(f(f(x)))))\<close>
  by blast

text \<open>From Davis, Obvious Logical Inferences, IJCAI-81, 530-531
  fast indeed copes!\<close>
lemma
  \<open>(\<forall>x. F(x) \<and> \<not> G(x) \<longrightarrow> (\<exists>y. H(x,y) \<and> J(y))) \<and>
    (\<exists>x. K(x) \<and> F(x) \<and> (\<forall>y. H(x,y) \<longrightarrow> K(y))) \<and>
    (\<forall>x. K(x) \<longrightarrow> \<not> G(x)) \<longrightarrow> (\<exists>x. K(x) \<and> J(x))\<close>
  by fast

text \<open>From Rudnicki, Obvious Inferences, JAR 3 (1987), 383-393.
  It does seem obvious!\<close>
lemma
  \<open>(\<forall>x. F(x) \<and> \<not> G(x) \<longrightarrow> (\<exists>y. H(x,y) \<and> J(y))) \<and>
    (\<exists>x. K(x) \<and> F(x) \<and> (\<forall>y. H(x,y) \<longrightarrow> K(y))) \<and>
    (\<forall>x. K(x) \<longrightarrow> \<not> G(x)) \<longrightarrow> (\<exists>x. K(x) \<longrightarrow> \<not> G(x))\<close>
  by fast

text \<open>Halting problem: Formulation of Li Dafa (AAR Newsletter 27, Oct 1994.)
  author U. Egly.\<close>
lemma
  \<open>((\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z)))) \<longrightarrow>
     (\<exists>w. C(w) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(w,y,z)))))
    \<and>
    (\<forall>w. C(w) \<and> (\<forall>u. C(u) \<longrightarrow> (\<forall>v. D(w,u,v))) \<longrightarrow>
          (\<forall>y z.
              (C(y) \<and> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,g)) \<and>
              (C(y) \<and> \<not> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,b))))
    \<and>
    (\<forall>w. C(w) \<and>
      (\<forall>y z.
          (C(y) \<and> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,g)) \<and>
          (C(y) \<and> \<not> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,b))) \<longrightarrow>
      (\<exists>v. C(v) \<and>
            (\<forall>y. ((C(y) \<and> Q(w,y,y)) \<and> OO(w,g) \<longrightarrow> \<not> P(v,y)) \<and>
                    ((C(y) \<and> Q(w,y,y)) \<and> OO(w,b) \<longrightarrow> P(v,y) \<and> OO(v,b)))))
     \<longrightarrow> \<not> (\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z))))\<close>
  by (blast 12)
    \<comment> \<open>Needed because the search for depths below 12 is very slow.\<close>

text \<open>
  Halting problem II: credited to M. Bruschi by Li Dafa in JAR 18(1),
  p. 105.
\<close>
lemma
  \<open>((\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z)))) \<longrightarrow>
     (\<exists>w. C(w) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(w,y,z)))))
    \<and>
    (\<forall>w. C(w) \<and> (\<forall>u. C(u) \<longrightarrow> (\<forall>v. D(w,u,v))) \<longrightarrow>
          (\<forall>y z.
              (C(y) \<and> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,g)) \<and>
              (C(y) \<and> \<not> P(y,z) \<longrightarrow> Q(w,y,z) \<and> OO(w,b))))
    \<and>
    ((\<exists>w. C(w) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> Q(w,y,y) \<and> OO(w,g)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> Q(w,y,y) \<and> OO(w,b))))
     \<longrightarrow>
     (\<exists>v. C(v) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,g)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,b)))))
    \<longrightarrow>
    ((\<exists>v. C(v) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,g)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> P(v,y) \<and> OO(v,b))))
     \<longrightarrow>
     (\<exists>u. C(u) \<and> (\<forall>y. (C(y) \<and> P(y,y) \<longrightarrow> \<not> P(u,y)) \<and>
                           (C(y) \<and> \<not> P(y,y) \<longrightarrow> P(u,y) \<and> OO(u,b)))))
     \<longrightarrow> \<not> (\<exists>x. A(x) \<and> (\<forall>y. C(y) \<longrightarrow> (\<forall>z. D(x,y,z))))\<close>
  by blast

text \<open>Challenge found on info-hol.\<close>
lemma \<open>\<forall>x. \<exists>v w. \<forall>y z. P(x) \<and> Q(y) \<longrightarrow> (P(v) \<or> R(w)) \<and> (R(z) \<longrightarrow> Q(v))\<close>
  by blast

text \<open>
  Attributed to Lewis Carroll by S. G. Pulman. The first or last assumption
  can be deleted.\<close>
lemma
  \<open>(\<forall>x. honest(x) \<and> industrious(x) \<longrightarrow> healthy(x)) \<and>
    \<not> (\<exists>x. grocer(x) \<and> healthy(x)) \<and>
    (\<forall>x. industrious(x) \<and> grocer(x) \<longrightarrow> honest(x)) \<and>
    (\<forall>x. cyclist(x) \<longrightarrow> industrious(x)) \<and>
    (\<forall>x. \<not> healthy(x) \<and> cyclist(x) \<longrightarrow> \<not> honest(x))
    \<longrightarrow> (\<forall>x. grocer(x) \<longrightarrow> \<not> cyclist(x))\<close>
  by blast

(*Runtimes for old versions of this file:
Thu Jul 23 1992: loaded in 467s using iffE [on SPARC2]
Mon Nov 14 1994: loaded in 144s [on SPARC10, with deepen_tac]
Wed Nov 16 1994: loaded in 138s [after addition of norm_term_skip]
Mon Nov 21 1994: loaded in 131s [DEPTH_FIRST suppressing repetitions]

Further runtimes on a Sun-4
Tue Mar  4 1997: loaded in 93s (version 94-7)
Tue Mar  4 1997: loaded in 89s
Thu Apr  3 1997: loaded in 44s--using mostly Blast_tac
Thu Apr  3 1997: loaded in 96s--addition of two Halting Probs
Thu Apr  3 1997: loaded in 98s--using lim-1 for all haz rules
Tue Dec  2 1997: loaded in 107s--added 46; new equalSubst
Fri Dec 12 1997: loaded in 91s--faster proof reconstruction
Thu Dec 18 1997: loaded in 94s--two new "obvious theorems" (??)
*)

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_rotate_structural_mod
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 rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 z22 xs1) =
     rotate z2 (x xs1 (cons2 z22 (nil2)))"

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

fun minus :: "Nat => Nat => Nat" where
"minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun take :: "Nat => 'a list => 'a list" where
"take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun go :: "Nat => Nat => Nat => Nat" where
"go y z (Z) = Z"
| "go (Z) (Z) (S x2) = Z"
| "go (Z) (S x5) (S x2) = minus (S x2) (S x5)"
| "go (S x3) (Z) (S x2) = go x3 x2 (S x2)"
| "go (S x3) (S x4) (S x2) = go x3 x4 (S x2)"

fun modstructural :: "Nat => Nat => Nat" where
"modstructural y z = go y Z z"

fun drop :: "Nat => 'a list => 'a list" where
"drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

theorem property0 :
  "((rotate n xs) =
      (x (drop (modstructural n (length xs)) xs)
         (take (modstructural n (length xs)) xs)))"
  oops

end


(* Author: Tobias Nipkow *)

section "Skew Heap Analysis"

theory Skew_Heap_Analysis
imports
  Complex_Main
  Skew_Heap.Skew_Heap
  Amortized_Framework
  Priority_Queue_ops_merge
begin

text\<open>The following proof is a simplified version of the one by Kaldewaij and
Schoenmakers~\cite{KaldewaijS-IPL91}.\<close>

text \<open>right-heavy:\<close>
definition rh :: "'a tree => 'a tree => nat" where
"rh l r = (if size l < size r then 1 else 0)"

text \<open>Function \<open>\<Gamma>\<close> in \cite{KaldewaijS-IPL91}: number of right-heavy nodes on left spine.\<close>
fun lrh :: "'a tree \<Rightarrow> nat" where
"lrh Leaf = 0" |
"lrh (Node l _ r) = rh l r + lrh l"

text \<open>Function \<open>\<Delta>\<close> in \cite{KaldewaijS-IPL91}: number of not-right-heavy nodes on right spine.\<close>
fun rlh :: "'a tree \<Rightarrow> nat" where
"rlh Leaf = 0" |
"rlh (Node l _ r) = (1 - rh l r) + rlh r"

lemma Gexp: "2 ^ lrh t \<le> size t + 1"
by (induction t) (auto simp: rh_def)

corollary Glog: "lrh t \<le> log 2 (size1 t)"
by (metis Gexp le_log2_of_power size1_size)

lemma Dexp: "2 ^ rlh t \<le> size t + 1"
by (induction t) (auto simp: rh_def)

corollary Dlog: "rlh t \<le> log 2 (size1 t)"
by (metis Dexp le_log2_of_power size1_size)

function T_merge :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_merge Leaf t = 1" |
"T_merge t Leaf = 1" |
"T_merge (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then T_merge (Node l2 a2 r2) r1 else T_merge (Node l1 a1 r1) r2) + 1"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

fun \<Phi> :: "'a tree \<Rightarrow> int" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + rh l r"

lemma \<Phi>_nneg: "\<Phi> t \<ge> 0"
by (induction t) auto

lemma plus_log_le_2log_plus: "\<lbrakk> x > 0; y > 0; b > 1 \<rbrakk>
  \<Longrightarrow> log b x + log b y \<le> 2 * log b (x + y)"
by(subst mult_2; rule add_mono; auto)

lemma rh1: "rh l r \<le> 1"
by(simp add: rh_def)

lemma amor_le_long:
  "T_merge t1 t2 + \<Phi> (merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   lrh(merge t1 t2) + rlh t1 + rlh t2 + 1"
proof (induction t1 t2 rule: merge.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 l1 a1 r1 l2 a2 r2)
  show ?case
  proof (cases "a1 \<le> a2")
    case True
    let ?t1 = "Node l1 a1 r1" let ?t2 = "Node l2 a2 r2" let ?m = "merge ?t2 r1"
    have "T_merge ?t1 ?t2 + \<Phi> (merge ?t1 ?t2) - \<Phi> ?t1 - \<Phi> ?t2
          = T_merge ?t2 r1 + 1 + \<Phi> ?m + \<Phi> l1 + rh ?m l1 - \<Phi> ?t1 - \<Phi> ?t2"
      using True by (simp)
    also have "\<dots> = T_merge ?t2 r1 + 1 + \<Phi> ?m + rh ?m l1 - \<Phi> r1 - rh l1 r1 - \<Phi> ?t2"
      by simp
    also have "\<dots> \<le> lrh ?m + rlh ?t2 + rlh r1 + rh ?m l1 + 2 - rh l1 r1"
      using "3.IH"(1)[OF True] by linarith
    also have "\<dots> = lrh ?m + rlh ?t2 + rlh r1 + rh ?m l1 + 1 + (1 - rh l1 r1)"
      using rh1[of l1 r1] by (simp)
    also have "\<dots> = lrh ?m + rlh ?t2 + rlh ?t1 + rh ?m l1 + 1"
      by (simp)
    also have "\<dots> = lrh (merge ?t1 ?t2) + rlh ?t1 + rlh ?t2 + 1"
      using True by(simp)
    finally show ?thesis .
  next
    case False with 3 show ?thesis by auto
  qed
qed

lemma amor_le:
  "T_merge t1 t2 + \<Phi> (merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   lrh(merge t1 t2) + rlh t1 + rlh t2 + 1"
by(induction t1 t2 rule: merge.induct)(auto)

lemma a_merge:
  "T_merge t1 t2 + \<Phi>(merge t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   3 * log 2 (size1 t1 + size1 t2) + 1" (is "?l \<le> _")
proof -
  have "?l \<le> lrh(merge t1 t2) + rlh t1 + rlh t2 + 1" using amor_le[of t1 t2] by arith
  also have "\<dots> = real(lrh(merge t1 t2)) + rlh t1 + rlh t2 + 1" by simp
  also have "\<dots> = real(lrh(merge t1 t2)) + (real(rlh t1) + rlh t2) + 1" by simp
  also have "rlh t1 \<le> log 2 (size1 t1)" by(rule Dlog)
  also have "rlh t2 \<le> log 2 (size1 t2)" by(rule Dlog)
  also have "lrh (merge t1 t2) \<le> log 2 (size1(merge t1 t2))" by(rule Glog)
  also have "size1(merge t1 t2) = size1 t1 + size1 t2 - 1" by(simp add: size1_size size_merge)
  also have "log 2 (size1 t1 + size1 t2 - 1) \<le> log 2 (size1 t1 + size1 t2)" by(simp add: size1_size)
  also have "log 2 (size1 t1) + log 2 (size1 t2) \<le> 2 * log 2 (real(size1 t1) + (size1 t2))"
    by(rule plus_log_le_2log_plus) (auto simp: size1_size)
  finally show ?thesis by(simp)
qed

definition T_insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> int" where
"T_insert a t = T_merge (Node Leaf a Leaf) t + 1"

lemma a_insert: "T_insert a t + \<Phi>(skew_heap.insert a t) - \<Phi> t \<le> 3 * log 2 (size1 t + 2) + 2"
using a_merge[of "Node Leaf a Leaf" "t"]
by (simp add: numeral_eq_Suc T_insert_def rh_def)

definition T_del_min :: "('a::linorder) tree \<Rightarrow> int" where
"T_del_min t = (case t of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> T_merge t1 t2 + 1)"

lemma a_del_min: "T_del_min t + \<Phi>(skew_heap.del_min t) - \<Phi> t \<le> 3 * log 2 (size1 t + 2) + 2"
proof (cases t)
  case Leaf thus ?thesis by (simp add: T_del_min_def)
next
  case (Node t1 _ t2)
  have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
                log 2 (4 + (real (size t1) + real (size t2)))" by simp
  from Node show ?thesis using a_merge[of t1 t2]
    by (simp add: size1_size T_del_min_def rh_def)
qed

subsubsection "Instantiation of Amortized Framework"

lemma T_merge_nneg: "T_merge t1 t2 \<ge> 0"
by(induction t1 t2 rule: T_merge.induct) auto

fun exec :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec (Insert a) [t] = skew_heap.insert a t" |
"exec Del_min [t] = skew_heap.del_min t" |
"exec Merge [t1,t2] = merge t1 t2"

fun cost :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
"cost Empty [] = 1" |
"cost (Insert a) [t] = T_merge (Node Leaf a Leaf) t + 1" |
"cost Del_min [t] = (case t of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> T_merge t1 t2 + 1)" |
"cost Merge [t1,t2] = T_merge t1 t2"

fun U where
"U Empty [] = 1" |
"U (Insert _) [t] = 3 * log 2 (size1 t + 2) + 2" |
"U Del_min [t] = 3 * log 2 (size1 t + 2) + 2" |
"U Merge [t1,t2] = 3 * log 2 (size1 t1 + size1 t2) + 1"

interpretation Amortized
where arity = arity and exec = exec and inv = "\<lambda>_. True"
and cost = cost and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 t) show ?case using \<Phi>_nneg[of t] by linarith
next
  case (3 ss f)
  show ?case
  proof (cases f)
    case Empty thus ?thesis using 3(2) by (auto)
  next
    case [simp]: (Insert a)
    obtain t where [simp]: "ss = [t]" using 3(2) by (auto)
    thus ?thesis using a_merge[of "Node Leaf a Leaf" "t"]
      by (simp add: numeral_eq_Suc insert_def rh_def T_merge_nneg)
  next
    case [simp]: Del_min
    obtain t where [simp]: "ss = [t]" using 3(2) by (auto)
    thus ?thesis
    proof (cases t)
      case Leaf with Del_min show ?thesis by simp
    next
      case (Node t1 _ t2)
      have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
               log 2 (4 + (real (size t1) + real (size t2)))" by simp
      from Del_min Node show ?thesis using a_merge[of t1 t2]
        by (simp add: size1_size T_merge_nneg)
    qed
  next
    case [simp]: Merge
    obtain t1 t2 where "ss = [t1,t2]" using 3(2) by (auto simp: numeral_eq_Suc)
    thus ?thesis using a_merge[of t1 t2] by (simp add: T_merge_nneg)
  qed
qed

end


theory ex_3_1
  imports Main
begin
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
fun set::"'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node l a r) = {a} \<union> (set l) \<union> (set r)"

(* true \<longrightarrow> isLeft *)
fun isOrdered::"int \<Rightarrow> bool \<Rightarrow> int tree \<Rightarrow> bool" where
"isOrdered _ _ Tip = True" |
"isOrdered parent True (Node _ child _) = (child \<le> parent)" |
"isOrdered parent False (Node _ child _) = (parent \<le> child)"

fun ord::"int tree \<Rightarrow> bool" where
"ord Tip = True" |
"ord (Node l a r) = (isOrdered a True l
                   \<and> isOrdered a False r
                   \<and> ord l \<and> ord r)"

fun ins::"int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins x Tip = Node Tip x Tip" |
"ins x (Node l a r) = (if x = a then (Node l a r)
                 else (if x < a then (Node (ins x l) a r)
                                else (Node l a (ins x r))))"

theorem inserted:"set (ins x t) = {x} \<union> set t"
  apply (induction t)
  by (auto)

lemma isOrdered_ins_l:"\<lbrakk>i < a; isOrdered a True t\<rbrakk> \<Longrightarrow> isOrdered a True (ins i t)"
  apply (induction t)
  by (auto)

lemma isOrdered_ins_r:"\<lbrakk>i > a; isOrdered a False t\<rbrakk> \<Longrightarrow> isOrdered a False (ins i t)"
  apply (induction t)
  by (auto)

theorem still_ordered:"ord t \<Longrightarrow> ord(ins i t)"
  apply (induction t)
  apply (auto)
  apply (rule isOrdered_ins_l)
  apply (auto)
  apply (rule isOrdered_ins_r)
  by (auto)
end


theory Chapter2
  imports Main
begin

(* Exercise 2.1 *)

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

(* Exercise 2.2 *)

datatype mynat = Z | S mynat

fun add :: "mynat \<Rightarrow> mynat \<Rightarrow> mynat" where
"add Z m = m" |
"add (S n) m = S (add n m)"

theorem add_assoc [simp]: "add (add x y) z = add x (add y z)"
  apply(induction x)
  apply(auto)
done

lemma add_Zright [simp]: "add x Z = x"
  apply(induction x)
  apply(auto)
done

lemma add_Sright [simp]: "add x (S y) = S (add x y)"
  apply(induction x)
  apply(auto)
done

theorem add_comm [simp]: "add x y = add y x"
  apply(induction x)
  apply(auto)
done

fun double :: "mynat \<Rightarrow> mynat" where
"double Z = Z" |
"double (S n) = S ( S ( double n))"

theorem double_m_eq_add_m_m: "double m = add m m"
  apply(induction m)
  apply(auto)
done

(* Exercise 2.3 *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count n [] = 0" |
"count n (x#xs) = (if n = x then 1 else 0) + (count n xs)"

theorem count_lte_length: "count x xs \<le> length xs"
  apply(induction xs)
  apply(auto)
done

(* Exercise 2.4 *)

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] e = [e]" |
"snoc (x#xs) e = x#(snoc xs e)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x#xs) = snoc (reverse xs) x"

lemma reverse_snoc [simp]: "reverse (snoc xs x) = x#(reverse xs)"
  apply(induction xs)
  apply(auto)
done

theorem reverse_reverse [simp]: "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto)
done

(* Exercise 2.5 *)

fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto (Suc n) = (Suc n) + (sum_upto n)"

theorem sum_upto_n [simp]: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
  apply(auto)
done

(* Exercise 2.6 *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l a r) = (contents l)@[a]@(contents r)"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r) = (sum_tree l) + a + (sum_tree r)"

theorem sum_tree_eq_sum_list_contents : "sum_tree t = sum_list (contents t)"
  apply(induction t)
  apply(auto)
done

(* Exercise 2.7 *)

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

fun pre_order :: "'a tree \<Rightarrow> 'a list" where
"pre_order Tip = []" |
"pre_order (Node l a r) = a#(pre_order l)@(pre_order r)"

fun post_order :: "'a tree \<Rightarrow> 'a list" where
"post_order Tip = []" |
"post_order (Node l a r) = (post_order l)@(post_order r)@[a]"

theorem pre_order_mirror_eq_rev_post_order : "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
  apply(auto)
done

(* Exercise 2.8 *)

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse _ [] = []" |
"intersperse _ [x] = [x]" |
"intersperse a (x#xs) = a#x#xs"

theorem map_f_intersperse_eq_intersperse_map_f : "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs rule: intersperse.induct)
  apply(auto)
done

(* Exercise 2.9 *)

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 n = n" |
"itadd (Suc m) n = itadd m (Suc n)"

theorem itadd_eq_add : "itadd m n = m + n"
  apply(induction m arbitrary: n)
  apply(auto)
done

(* Exercise 2.10 *)

datatype tree0 = Tip | Node tree0 tree0

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t" |
  "explode (Suc n) t = explode n (Node t t)"

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Tip = 1" |
  "nodes (Node l r) = 1 + (nodes l) + (nodes r)"

theorem nodes_explode : "nodes (explode n t) = 2^n * (1 + nodes t) - 1"
  apply(induction n arbitrary: t)
  apply(auto simp add: algebra_simps)
done

(* Exercise 2.11 *)

datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x" |
"eval (Const n) _ = n" |
"eval (Add e1 e2) x = (eval e1 x) + (eval e2 x)" |
"eval (Mult e1 e2) x = (eval e1 x) + (eval e2 x)"

fun evalp' :: "int list \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
"evalp' [] value order  = 0" |
"evalp' (p#ps) value order = p * (value ^ order) + evalp' ps value (order + 1)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp polynomial value  = evalp' polynomial value 0"

end


theory AExp imports Main begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{AExpaexpdef}{2}{1}{%\<close>
datatype aexp = N int | V vname | Plus aexp aexp
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{AExpavaldef}{1}{2}{%\<close>
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
text_raw\<open>}%endsnip\<close>

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text \<open>The same state more concisely:\<close>
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text \<open>A little syntax magic to write larger states compactly:\<close>

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text \<open>\noindent
  We can now write a series of updates to the function \<open>\<lambda>x. 0\<close> compactly:
\<close>
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text \<open>In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
\<close>
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text\<open>Note that this \<open><\<dots>>\<close> syntax works for any function space
\<open>\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2\<close> where \<open>\<tau>\<^sub>2\<close> has a \<open>0\<close>.\<close>

subsection "Constant Folding"

text\<open>Evaluate constant subsexpressions:\<close>

text_raw\<open>\snip{AExpasimpconstdef}{0}{2}{%\<close>
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw\<open>}%endsnip\<close>

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text\<open>Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors:\<close>

text_raw\<open>\snip{AExpplusdef}{0}{2}{%\<close>
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw\<open>}%endsnip\<close>

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw\<open>\snip{AExpasimpdef}{2}{0}{%\<close>
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw\<open>}%endsnip\<close>

text\<open>Note that in \<^const>\<open>asimp_const\<close> the optimized constructor was
inlined. Making it a separate function \<^const>\<open>plus\<close> improves modularity of
the code and the proofs.\<close>

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end


theory Matrix_Util
  imports "HOL-Analysis.Analysis"
begin

section \<open>Matrices\<close>

proposition scalar_matrix_assoc':
  fixes C :: "('b::real_algebra_1)^'m^'n"
  shows "k *\<^sub>R (C ** D) = C ** (k *\<^sub>R D)"
  by (simp add: matrix_matrix_mult_def sum_distrib_left mult_ac vec_eq_iff scaleR_sum_right)

subsection \<open>Nonnegative Matrices\<close>

lemma nonneg_matrix_nonneg [dest]: "0 \<le> m \<Longrightarrow> 0 \<le> m $ i $ j"
  by (simp add: Finite_Cartesian_Product.less_eq_vec_def)

lemma matrix_mult_mono:
  assumes "0 \<le> E" "0 \<le> C" "(E :: real^'c^'c) \<le> B" "C \<le> D"
  shows "E ** C \<le> B ** D"
  using order.trans[OF assms(1) assms(3)] assms
  unfolding Finite_Cartesian_Product.less_eq_vec_def
  by (auto intro!: sum_mono mult_mono simp: matrix_matrix_mult_def)

lemma nonneg_matrix_mult: "0 \<le> (C :: ('b::{field, ordered_ring})^_^_) \<Longrightarrow> 0 \<le> D \<Longrightarrow> 0 \<le> C ** D"
  unfolding Finite_Cartesian_Product.less_eq_vec_def
  by (auto simp: matrix_matrix_mult_def intro!: sum_nonneg)

lemma zero_le_mat_iff [simp]: "0 \<le> mat (x :: 'c :: {zero, order}) \<longleftrightarrow> 0 \<le> x"
  by (auto simp: Finite_Cartesian_Product.less_eq_vec_def mat_def)

lemma nonneg_mat_ge_zero: "0 \<le> Q \<Longrightarrow> 0 \<le> v \<Longrightarrow> 0 \<le> Q *v (v :: real^'c)"
  unfolding Finite_Cartesian_Product.less_eq_vec_def
  by (auto intro!: sum_nonneg simp: matrix_vector_mult_def)

lemma nonneg_mat_mono: "0 \<le> Q \<Longrightarrow> u \<le> v \<Longrightarrow> Q *v u \<le> Q *v (v :: real^'c)"
  using nonneg_mat_ge_zero[of Q "v - u"]
  by (simp add: vec.diff)

lemma nonneg_mult_imp_nonneg_mat:
  assumes "\<And>v. v \<ge> 0 \<Longrightarrow> X *v v \<ge> 0"
  shows "X \<ge> (0 :: real ^ _ ^_)"
proof -
  { assume "\<not> (0 \<le> X)"
    then obtain i j where neg: "X $ i $ j < 0"
      by (metis less_eq_vec_def not_le zero_index)
    let ?v = "\<chi> k. if j = k then 1::real else 0"
    have "(X *v ?v) $ i < 0"
      using neg
      by (auto simp: matrix_vector_mult_def if_distrib cong: if_cong)
    hence "?v \<ge> 0 \<and> \<not> ((X *v ?v) \<ge> 0)"
      by (auto simp: less_eq_vec_def not_le)
    hence "\<exists>v. v \<ge> 0 \<and> \<not> X *v v \<ge> 0"
      by blast
  }
  thus ?thesis
    using assms by auto
qed

lemma nonneg_mat_iff:
  "(X \<ge> (0 :: real ^ _ ^_)) \<longleftrightarrow> (\<forall>v. v \<ge> 0 \<longrightarrow> X *v v \<ge> 0)"
  using nonneg_mat_ge_zero nonneg_mult_imp_nonneg_mat by auto

lemma mat_le_iff: "(X \<le> Y) \<longleftrightarrow> (\<forall>x\<ge>0. (X::real^_^_) *v x \<le> Y *v x)"
  by (metis diff_ge_0_iff_ge matrix_vector_mult_diff_rdistrib nonneg_mat_iff)

subsection \<open>Matrix Powers\<close>

(* copied from Perron-Frobenius *)
primrec matpow :: "'a::semiring_1^'n^'n \<Rightarrow> nat \<Rightarrow> 'a^'n^'n" where
  matpow_0:   "matpow A 0 = mat 1" |
  matpow_Suc: "matpow A (Suc n) = (matpow A n) ** A"

lemma nonneg_matpow: "0 \<le> X \<Longrightarrow> 0 \<le> matpow (X :: real ^ _ ^ _) i"
  by (induction i) (auto simp: nonneg_matrix_mult)

lemma matpow_mono: "0 \<le> C \<Longrightarrow> C \<le> D \<Longrightarrow> matpow (C :: real^_^_) n \<le> matpow D n"
  by (induction n) (auto intro!: matrix_mult_mono nonneg_matpow)

lemma matpow_scaleR: "matpow (c *\<^sub>R (X :: 'b :: real_algebra_1^_^_)) n = (c^n) *\<^sub>R (matpow X) n"
proof (induction n arbitrary: X c)
  case (Suc n)
  have "matpow (c *\<^sub>R X) (Suc n) = (c^n)*\<^sub>R (matpow X) n ** c *\<^sub>R X"
    using Suc by auto
  also have "\<dots> = c *\<^sub>R ((c^n) *\<^sub>R (matpow X) n ** X)"
    using scalar_matrix_assoc'
    by (auto simp: scalar_matrix_assoc')
  finally show ?case
    by (simp add: scalar_matrix_assoc)
qed auto

lemma matrix_vector_mult_code': "(X *v x) $ i = (\<Sum>j\<in>UNIV. X $ i $ j * x $ j)"
  by (simp add: matrix_vector_mult_def)

lemma matrix_vector_mult_mono: "(0::real^_^_) \<le> X \<Longrightarrow> 0 \<le> v \<Longrightarrow> X \<le> Y \<Longrightarrow> X *v v \<le> Y *v v"
  by (metis diff_ge_0_iff_ge matrix_vector_mult_diff_rdistrib nonneg_mat_iff)

subsection \<open>Triangular Matrices\<close>

definition "lower_triangular_mat X \<longleftrightarrow> (\<forall>i j. (i :: 'b::{finite, linorder}) < j \<longrightarrow> X $ i $ j = 0)"

definition "strict_lower_triangular_mat X \<longleftrightarrow> (\<forall>i j. (i :: 'b::{finite, linorder}) \<le> j \<longrightarrow> X $ i $ j = 0)"

definition "upper_triangular_mat X \<longleftrightarrow> (\<forall>i j. j < i \<longrightarrow> X $ i $ j = 0)"

lemma stlI: "strict_lower_triangular_mat X \<Longrightarrow> lower_triangular_mat X"
  unfolding strict_lower_triangular_mat_def lower_triangular_mat_def
  by auto

lemma lower_triangular_mat_mat: "lower_triangular_mat (mat x)"
  unfolding lower_triangular_mat_def mat_def
  by auto

lemma lower_triangular_mult:
  assumes "lower_triangular_mat X" "lower_triangular_mat Y"
  shows "lower_triangular_mat (X ** Y)"
  using assms
  unfolding matrix_matrix_mult_def lower_triangular_mat_def
  by (auto intro!: sum.neutral) (metis mult_not_zero neqE less_trans)

lemma lower_triangular_pow:
  assumes "lower_triangular_mat X"
  shows "lower_triangular_mat (matpow X i)"
  using assms lower_triangular_mult lower_triangular_mat_mat
  by (induction i) auto

lemma lower_triangular_suminf:
  assumes "\<And>i. lower_triangular_mat (f i)" "summable (f :: nat \<Rightarrow> 'b::real_normed_vector^_^_)"
  shows "lower_triangular_mat (\<Sum>i. f i)"
  using assms
  unfolding lower_triangular_mat_def
  by (subst bounded_linear.suminf) (auto intro: bounded_linear_compose)

lemma lower_triangular_pow_eq:
  assumes "lower_triangular_mat X" "lower_triangular_mat Y" "\<And>s'. s' \<le> s \<Longrightarrow> row s' X = row s' Y" "s' \<le> s"
  shows "row s' (matpow X i) = row s' (matpow Y i)"
  using assms
proof (induction i)
  case (Suc i)
  thus ?case
  proof -
    have ltX: "lower_triangular_mat (matpow X i)"
      by (simp add: Suc(2) lower_triangular_pow)
    have ltY: "lower_triangular_mat (matpow Y i)"
      by (simp add: Suc(3) lower_triangular_pow)
    have " (\<Sum>k\<in>UNIV. matpow X i $ s' $ k * X $ k $ j) = (\<Sum>k\<in>UNIV. matpow Y i $ s' $ k * Y $ k $ j)" for j
    proof -
      have "(\<Sum>k\<in>UNIV. matpow X i $ s' $ k * X $ k $ j) = (\<Sum>k\<in>UNIV. if s' < k then 0 else matpow Y i $ s' $ k * X $ k $ j)"
        using Suc ltY
        by (auto simp: row_def lower_triangular_mat_def intro!: sum.cong)
      also have "\<dots> = (\<Sum>k \<in> UNIV . matpow Y i $ s' $ k * Y $ k $ j)"
        using Suc ltY
        by (auto simp: row_def lower_triangular_mat_def cong: if_cong intro!: sum.cong)
      finally show ?thesis.
    qed
    thus ?thesis
      by (auto simp: row_def matrix_matrix_mult_def)
  qed
qed simp

lemma lower_triangular_mat_mult:
  assumes "lower_triangular_mat M" "\<And>i. i \<le> j \<Longrightarrow> v $ i = v' $ i"
  shows "(M *v v) $ j = (M *v v') $ j"
proof -
  have "(M *v v) $ j = (\<Sum>i\<in>UNIV. (if j < i then 0 else  M $ j $ i * v $ i))"
    using assms unfolding lower_triangular_mat_def
    by (auto simp: matrix_vector_mult_def intro!: sum.cong)
  also have "\<dots> = (\<Sum>i\<in>UNIV. (if j < i then 0 else  M $ j $ i * v' $ i))"
    using assms
    by (auto intro!: sum.cong)
  also have "\<dots> = (M *v v') $ j"
    using assms unfolding lower_triangular_mat_def
    by (auto simp: matrix_vector_mult_def intro!: sum.cong)
  finally show ?thesis.
qed

subsection \<open>Inverses\<close>

(* from AFP/Rank_Nullity_Theorem *)
lemma matrix_inv:
  assumes "invertible M"
  shows matrix_inv_left: "matrix_inv M ** M = mat 1"
    and matrix_inv_right: "M ** matrix_inv M = mat 1"
  using \<open>invertible M\<close> and someI_ex [of "\<lambda> N. M ** N = mat 1 \<and> N ** M = mat 1"]
  unfolding invertible_def and matrix_inv_def
  by simp_all

(* from AFP/Rank_Nullity_Theorem *)
lemma matrix_inv_unique:
  fixes A::"'a::{semiring_1}^'n^'n"
  assumes AB: "A ** B = mat 1" and BA: "B ** A = mat 1"
  shows "matrix_inv A = B"
  by (metis AB BA invertible_def matrix_inv_right matrix_mul_assoc matrix_mul_lid)

end


theory Chap2_3
imports Main
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []"
| "contents (Node l a r) = a # contents l @ contents r"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0"
| "sum_tree (Node l a r) = a + sum_tree l + sum_tree r"

lemma "sum_tree t = sum_list (contents t)"
  apply (induction t)
  by auto

definition pre_order :: "'a tree \<Rightarrow> 'a list" where
"pre_order t = contents t"

fun post_order :: "'a tree \<Rightarrow> 'a list" where
"post_order Tip = []"
| "post_order (Node l a r) = post_order l @ post_order r @ [a]"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip"
| "mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma "pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
  by (auto simp add: pre_order_def)

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a [] = []"
| "intersperse a [x] = [x]"
| "intersperse a (x#y#xs) = x#a#y#(intersperse a xs)"

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
  by simp+

end


theory t2
imports Main
begin

(*Problema 1*)
primrec soma::"nat \<Rightarrow> nat \<Rightarrow> nat" where
soma1: "soma x 0 = x"|
soma2: "soma x (Suc y) = Suc (soma x y)"

value "soma 0 0" (* OK *)

(* soma(x,y) = x + y *)
theorem t1 "soma x y = x + y"
proof (induct y)
  show " soma x 0 = x + 0"
  proof -
    have "soma x 0 = x" by (simp only:soma1)
    also have "... = x + 0" by (simp)
    finally show "soma x 0 = x + 0" by (simp)
  qed
next
  fix y::nat
  assume HI: "soma x y = x + y"
  show "soma x (Suc y) = x + Suc y"
  proof -
    have "soma x (Suc y) = Suc (soma x y)" by (simp only: soma2)
    also have "... = Suc x + y" by (simp only: HI)
    also have "... = x + Suc y" by (simp)
    finally show "soma x (Suc y) = x + Suc y" by (simp)
  qed
qed (*erro*)

(* soma(x,y) = soma(y,x) *)
theorem t2 " soma x y = soma y x"
proof (induct y)
  show "\<forall>x. soma x 0 = soma 0 x"
  proof-
    have "soma x 0 = x by (soma1)
    also have "... = 0 + x by (simp)

(* soma (x,0) = 0 *)

(* soma (0,x) = x *)

(* soma(x,soma(y,z)) = soma(soma (x,y),z) *)

(*Problema 2*)
primrec mult::"nat \<Rightarrow> nat \<Rightarrow> nat" where
"mult x 0 = 0"|
"mult x (Suc y) = soma x (mult x y)"

value " mult 8 3 " (* OK *)

(* mult(x,y) = x * y *)

(* mult(x,y) = mult(y,x) *)

(* mult (x,1) = 1 *)

(* mult (1,x) = x *)

(* mult(x,mult(y,z)) = mult(mult (x,y),z) *)
end


theory Concrete_Semantics_2_2_ex5
imports Main
begin

fun sum_upto :: "nat => nat" where
"sum_upto 0 = 0" |
"sum_upto n = n + sum_upto (n - 1)"

lemma "sum_upto n = n * (n + 1) div 2"
apply(induction n)
apply(auto)
done

end


theory Boolos imports Main
begin

typedecl i
consts
 e :: "i"  (*one*)
 s :: "i \<Rightarrow> i"  (*successor*)
 F :: "i \<Rightarrow> i \<Rightarrow> i" (*binary function; will be axiomatised as Ackermann function*)
 D :: "i \<Rightarrow> bool" (*arbitrary unary predicate*)

axiomatization where
  A1: "\<forall>n. F n e = s e" and
  A2: "\<forall>y. F e (s y) = s (s (F e y))" and
  A3: "\<forall>x y. F (s x) (s y) = F x (F (s x) y)" and
  A4: "D e" and
  A5: "\<forall>x. D x \<longrightarrow> D (s x)"

definition induct where "induct X \<equiv> (X e) \<and> (\<forall>x. X x \<longrightarrow> X (s x))"  (*X inductively def. Pred.*)
definition N where "N x \<equiv> (\<forall>X::i\<Rightarrow>bool. induct X \<longrightarrow> X x)"    (*Higher-order quantifier*)
definition P1 where "P1 x y \<equiv> N (F x y)"
definition P2 where "P2 x \<equiv> (\<forall>z. N z \<longrightarrow> P1 x z)"

theorem Boolos: "D (F (s (s (s (s e)))) (s (s (s (s e)))))"
proof-
  have L1: "\<forall>X::i\<Rightarrow>bool. induct X \<longrightarrow> (\<forall>z. N z \<longrightarrow> X z)" using N_def by fastforce
  have L2: "induct N" by (metis N_def induct_def)
  have L3: "induct D" by (simp add: A4 A5 induct_def)
  have L4: "N (s (s (s (s e))))" by (metis L2 induct_def)
  have L5: "P1 e e" by (metis A1 L2 P1_def induct_def)
  have L6: "\<forall>x. P1 e x \<longrightarrow> P1 e (s x)" by (metis A2 P1_def induct_def L2)
  have L7: "induct (P1 e)" using induct_def L5 L6 by auto
  have L8: "\<forall>x. P1 (s x) e" by (metis A1 P1_def induct_def L2)
  have L9: "P2 e" by (metis L1 L7 P2_def)
  have L10: "\<forall>x. P2 x \<longrightarrow> (\<forall>y. P1 (s x) y \<longrightarrow> P1 (s x) (s y))" by (metis A3 P1_def P2_def)
  have L11: "\<forall>x. P2 x \<longrightarrow> P2 (s x)" by (metis L1 L10 L8 P2_def induct_def)
  have L12: "induct P2" by (simp add: L11 L9 induct_def)
  thus ?thesis using L3 L4 N_def P1_def P2_def by blast
qed

end


theory sample4
  imports Main begin

(* inductive one of evenness *)
inductive ev  :: "nat \<Rightarrow> bool" where
  ev0: "ev 0" |
(*evSS: "ev n \<Longrightarrow> ev (n + 2)*)
  evSS: "ev n \<Longrightarrow> ev (Suc (Suc(n)))"

(*
  How do we prove that some number is even,
  e.g., ev 4? Simply by combining the
  defining rules for ev:
  ev 0 =\<Rightarrow> ev (0 + 2) =\<Rightarrow> ev((0 + 2) + 2) = ev 4
*)

(* recursive one of evenness *)
fun evn :: "nat \<Rightarrow> bool" where
  "evn 0 = True" |
  "evn (Suc 0) = False" |
  "evn (Suc (Suc n)) = evn n"

lemma "ev(Suc(Suc(Suc(Suc 0::nat))))"
  apply(rule evSS)
  apply(rule evSS)
  apply(rule ev0)
  done

lemma agree_ev_evn [simp]: "ev m \<Longrightarrow> evn m"
  apply(induction rule: ev.induct)
(*
  apply(simp)
  apply(simp)
*)
  apply(simp_all)
  done

(*declare ev.intros[simp, intro]*)

lemma "evn n \<Longrightarrow> ev n"
  apply(induction n rule: evn.induct)
    apply(simp_all add: ev0 evSS)
  done