theory Chapter3Guisen
imports "HOL-IMP.BExp"
        "HOL-IMP.ASM"
        "Short_Theory"
begin

text\<open>
\section*{Chapter 3}
 "Short_Theory"
\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
\<close>

fun optimal :: "aexp \<Rightarrow> bool"
  where "optimal (N n) = True"
    | "optimal (V x) = True"
    | "optimal (Plus (N n) (N m)) = False"
    | "optimal (Plus va vb) = ((optimal va) \<and> (optimal vb))"

text\<open>
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
\<close>
value "optimal (asimp_const(Plus (N i) (N j)))"

lemma "optimal (asimp_const a)"
(* your definition/proof here *)

   apply(induction a rule:asimp_const.induct)
    apply (auto split:aexp.split)

  done

text\<open>
This proof needs the same @{text "split:"} directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without @{text case} expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function @{text sumN} that returns the sum of all
constants in an expression and a function @{text zeroN} that replaces all
constants in an expression by zeroes (they will be optimized away later):
\<close>

fun sumN :: "aexp \<Rightarrow> int" where
(* your definition/proof here *)
  "sumN (N n) = n"
    | "sumN (V x) = 0"
    | "sumN (Plus va vb) = sumN(va)+ sumN(vb)"

value "sumN (asimp_const(Plus (N 2) (N 5)))"

fun zeroN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)
"zeroN (N n) =N 0"
    | "zeroN (V x) = V x"
    | "zeroN (Plus va vb) = Plus (zeroN(va)) (zeroN(vb))"

value "zeroN (asimp_const(Plus (V x) (N 5)))"
text \<open>
Next, define a function @{text sepN} that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
@{text sepN} preserves the value of an expression.
\<close>

definition sepN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)
"sepN(a) = Plus(zeroN a)(N(sumN a))"

value "sepN (Plus (N 0)  (Plus (V x) (N 0)))"

lemma aval_sepN: "aval (sepN t) s = aval t s"
(* your definition/proof here *)
  apply (induction t)
    apply (auto split:aexp.split)
  sledgehammer
    apply (simp add: sepN_def)
 sledgehammer
  apply (simp add: sepN_def)
 sledgehammer
  using sepN_def by auto
text \<open>
Finally, define a function @{text full_asimp} that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
\<close>

definition full_asimp :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)
"full_asimp(a)=plus (N 0) (sepN(a))"
lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
(* your definition/proof here *)
apply (induction t)
    apply (auto split:aexp.split)
 sledgehammer
  apply (simp add: full_asimp_def sepN_def)
 sledgehammer
  apply (simp add: full_asimp_def sepN_def)
 sledgehammer
  by (simp add: full_asimp_def sepN_def)
text\<open>
\endexercise

\exercise\label{exe:subst}
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
\<close>

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
(* your definition/proof here *)
  "subst x a (N n) = N n"|
  "subst x a (V v) = (if v=x then (a) else (V v))"|
   "subst x a (Plus b1 b2) = (Plus (subst x a b1) (subst x a b2))"
text\<open>
such that @{term "subst x a e"} is the result of replacing
every occurrence of variable @{text x} by @{text a} in @{text e}.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
\<close>

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
(* your definition/proof here *)
  apply(induction e rule:subst.induct)
    apply (auto split:aexp.split)
  done
text \<open>
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
\<close>
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
(* your definition/proof here *)
  apply(induction a1 a2 rule:subst.induct)
    apply (auto split:aexp.split)
  sledgehammer
    apply (simp add: subst_lemma)
  sledgehammer
   apply (simp add: subst_lemma)
  sledgehammer
  by (simp add: subst_lemma)

text\<open>
\endexercise

\exercise
Take a copy of theory @{short_theory "AExp"} and modify it as follows.
Extend type @{typ aexp} with a binary constructor @{text Times} that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
\<close>

text\<open>
\endexercise

\exercise
Define a datatype @{text aexp2} of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
division by changing the return type of @{text aval2} to
@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
return @{const None}. Division on @{typ int} is the infix @{text div}.
\<close>

text\<open>
\endexercise

\exercise
The following type adds a @{text LET} construct to arithmetic expressions:
\<close>

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

text\<open> The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
Define a function @{const lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{const inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise

\exercise
Show that equality and less-or-equal tests on @{text aexp} are definable
\<close>

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open>
and prove that they do what they are supposed to:
\<close>

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
(* your definition/proof here *)

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional: \<close>

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

text \<open>  First define an evaluation function analogously to @{const bval}: \<close>

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open> Then define two translation functions \<close>

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
(* your definition/proof here *)

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open> and prove their correctness: \<close>

lemma "bval (if2bexp exp) s = ifval exp s"
(* your definition/proof here *)

lemma "ifval (b2ifexp exp) s = bval exp s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
\<close>

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text\<open>
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
\<close>

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"  |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text \<open> Define a function that checks whether a boolean exression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s: \<close>

fun is_nnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
\<close>

fun nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>
Prove that @{const nnf} does what it is supposed to do:
\<close>

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
(* your definition/proof here *)

lemma is_nnf_nnf: "is_nnf (nnf b)"
(* your definition/proof here *)

text\<open>
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
\<close>

fun is_dnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text \<open>
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
\<close>

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text \<open> and prove that it behaves as follows: \<close>

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
(* your definition/proof here *)

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
(* your definition/proof here *)

text \<open> Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
\<close>

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* Prove the correctness of your function: *}

lemma "pbval (dnf_of_nnf b) s = pbval b s"
(* your definition/proof here *)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
(* your definition/proof here *)
  oops
text\<open>
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than 2. In our semantics
a term @{term "exec1 ADD s stk"} where @{prop "length stk < 2"}
is simply some unspecified value, not an error or exception --- HOL does not have those concepts.
Modify theory @{short_theory "ASM"}
such that stack underflow is modelled by @{const None}
and normal execution by @{text Some}, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find @{text"split: option.split"} useful in your proofs.
\<close>

text\<open>
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
\<close>
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

text \<open>
where type @{text reg} is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
@{term "LD x r"} loads the value of @{text x} into register @{text r},
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register @{text r\<^sub>2} to register @{text r\<^sub>1}.

Define the execution of an instruction given a state and a register state;
the result is the new register state: \<close>

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text\<open>
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "< r"} should be left alone.
Define the compiler and prove it correct:
\<close>

theorem "exec (comp a r) s rs r = aval a s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:accumulator}
This exercise is a variation of the previous one
with a different instruction set:
\<close>

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

text\<open>
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
adds the value in register @{text r} to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
\<close>

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text\<open>
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into register 0. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "\<le> r"} should be left alone
(with the exception of 0). Define the compiler and prove it correct:
\<close>

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
(* your definition/proof here *)

text\<open>
\endexercise
\<close>

end


(*  Title:      HOL/Library/Saturated.thy
    Author:     Brian Huffman
    Author:     Peter Gammie
    Author:     Florian Haftmann
*)

section {* Saturated arithmetic *}

theory Saturated
imports Numeral_Type "~~/src/HOL/Word/Type_Length"
begin

subsection {* The type of saturated naturals *}

typedef ('a::len) sat = "{.. len_of TYPE('a)}"
  morphisms nat_of Abs_sat
  by auto

lemma sat_eqI:
  "nat_of m = nat_of n \<Longrightarrow> m = n"
  by (simp add: nat_of_inject)

lemma sat_eq_iff:
  "m = n \<longleftrightarrow> nat_of m = nat_of n"
  by (simp add: nat_of_inject)

lemma Abs_sat_nat_of [code abstype]:
  "Abs_sat (nat_of n) = n"
  by (fact nat_of_inverse)

definition Abs_sat' :: "nat \<Rightarrow> 'a::len sat" where
  "Abs_sat' n = Abs_sat (min (len_of TYPE('a)) n)"

lemma nat_of_Abs_sat' [simp]:
  "nat_of (Abs_sat' n :: ('a::len) sat) = min (len_of TYPE('a)) n"
  unfolding Abs_sat'_def by (rule Abs_sat_inverse) simp

lemma nat_of_le_len_of [simp]:
  "nat_of (n :: ('a::len) sat) \<le> len_of TYPE('a)"
  using nat_of [where x = n] by simp

lemma min_len_of_nat_of [simp]:
  "min (len_of TYPE('a)) (nat_of (n::('a::len) sat)) = nat_of n"
  by (rule min.absorb2 [OF nat_of_le_len_of])

lemma min_nat_of_len_of [simp]:
  "min (nat_of (n::('a::len) sat)) (len_of TYPE('a)) = nat_of n"
  by (subst min.commute) simp

lemma Abs_sat'_nat_of [simp]:
  "Abs_sat' (nat_of n) = n"
  by (simp add: Abs_sat'_def nat_of_inverse)

instantiation sat :: (len) linorder
begin

definition
  less_eq_sat_def: "x \<le> y \<longleftrightarrow> nat_of x \<le> nat_of y"

definition
  less_sat_def: "x < y \<longleftrightarrow> nat_of x < nat_of y"

instance
by default (auto simp add: less_eq_sat_def less_sat_def not_le sat_eq_iff min.coboundedI1 mult.commute)

end

instantiation sat :: (len) "{minus, comm_semiring_1}"
begin

definition
  "0 = Abs_sat' 0"

definition
  "1 = Abs_sat' 1"

lemma nat_of_zero_sat [simp, code abstract]:
  "nat_of 0 = 0"
  by (simp add: zero_sat_def)

lemma nat_of_one_sat [simp, code abstract]:
  "nat_of 1 = min 1 (len_of TYPE('a))"
  by (simp add: one_sat_def)

definition
  "x + y = Abs_sat' (nat_of x + nat_of y)"

lemma nat_of_plus_sat [simp, code abstract]:
  "nat_of (x + y) = min (nat_of x + nat_of y) (len_of TYPE('a))"
  by (simp add: plus_sat_def)

definition
  "x - y = Abs_sat' (nat_of x - nat_of y)"

lemma nat_of_minus_sat [simp, code abstract]:
  "nat_of (x - y) = nat_of x - nat_of y"
proof -
  from nat_of_le_len_of [of x] have "nat_of x - nat_of y \<le> len_of TYPE('a)" by arith
  then show ?thesis by (simp add: minus_sat_def)
qed

definition
  "x * y = Abs_sat' (nat_of x * nat_of y)"

lemma nat_of_times_sat [simp, code abstract]:
  "nat_of (x * y) = min (nat_of x * nat_of y) (len_of TYPE('a))"
  by (simp add: times_sat_def)

instance proof
  fix a b c :: "('a::len) sat"
  show "a * b * c = a * (b * c)"
  proof(cases "a = 0")
    case True thus ?thesis by (simp add: sat_eq_iff)
  next
    case False show ?thesis
    proof(cases "c = 0")
      case True thus ?thesis by (simp add: sat_eq_iff)
    next
      case False with `a \<noteq> 0` show ?thesis
        by (simp add: sat_eq_iff nat_mult_min_left nat_mult_min_right mult.assoc min.assoc min.absorb2)
    qed
  qed
next
  fix a :: "('a::len) sat"
  show "1 * a = a"
    apply (simp add: sat_eq_iff)
    apply (metis One_nat_def len_gt_0 less_Suc0 less_zeroE linorder_not_less min.absorb_iff1 min_nat_of_len_of nat_mult_1_right mult.commute)
    done
next
  fix a b c :: "('a::len) sat"
  show "(a + b) * c = a * c + b * c"
  proof(cases "c = 0")
    case True thus ?thesis by (simp add: sat_eq_iff)
  next
    case False thus ?thesis
      by (simp add: sat_eq_iff nat_mult_min_left add_mult_distrib min_add_distrib_left min_add_distrib_right min.assoc min.absorb2)
  qed
qed (simp_all add: sat_eq_iff mult.commute)

end

instantiation sat :: (len) ordered_comm_semiring
begin

instance
by default (auto simp add: less_eq_sat_def less_sat_def not_le sat_eq_iff min.coboundedI1 mult.commute)

end

lemma Abs_sat'_eq_of_nat: "Abs_sat' n = of_nat n"
  by (rule sat_eqI, induct n, simp_all)

abbreviation Sat :: "nat \<Rightarrow> 'a::len sat" where
  "Sat \<equiv> of_nat"

lemma nat_of_Sat [simp]:
  "nat_of (Sat n :: ('a::len) sat) = min (len_of TYPE('a)) n"
  by (rule nat_of_Abs_sat' [unfolded Abs_sat'_eq_of_nat])

lemma [code_abbrev]:
  "of_nat (numeral k) = (numeral k :: 'a::len sat)"
  by simp

definition sat_of_nat :: "nat \<Rightarrow> ('a::len) sat"
  where [code_abbrev]: "sat_of_nat = of_nat"

lemma [code abstract]:
  "nat_of (sat_of_nat n :: ('a::len) sat) = min (len_of TYPE('a)) n"
  by (simp add: sat_of_nat_def)

instance sat :: (len) finite
proof
  show "finite (UNIV::'a sat set)"
    unfolding type_definition.univ [OF type_definition_sat]
    using finite by simp
qed

instantiation sat :: (len) equal
begin

definition
  "HOL.equal A B \<longleftrightarrow> nat_of A = nat_of B"

instance proof
qed (simp add: equal_sat_def nat_of_inject)

end

instantiation sat :: (len) "{bounded_lattice, distrib_lattice}"
begin

definition
  "(inf :: 'a sat \<Rightarrow> 'a sat \<Rightarrow> 'a sat) = min"

definition
  "(sup :: 'a sat \<Rightarrow> 'a sat \<Rightarrow> 'a sat) = max"

definition
  "bot = (0 :: 'a sat)"

definition
  "top = Sat (len_of TYPE('a))"

instance proof
qed (simp_all add: inf_sat_def sup_sat_def bot_sat_def top_sat_def max_min_distrib2,
  simp_all add: less_eq_sat_def)

end

instantiation sat :: (len) "{Inf, Sup}"
begin

definition
  "Inf = (semilattice_neutr_set.F min top :: 'a sat set \<Rightarrow> 'a sat)"

definition
  "Sup = (semilattice_neutr_set.F max bot :: 'a sat set \<Rightarrow> 'a sat)"

instance ..

end

interpretation Inf_sat!: semilattice_neutr_set min "top :: 'a::len sat"
where
  "semilattice_neutr_set.F min (top :: 'a sat) = Inf"
proof -
  show "semilattice_neutr_set min (top :: 'a sat)" by default (simp add: min_def)
  show "semilattice_neutr_set.F min (top :: 'a sat) = Inf" by (simp add: Inf_sat_def)
qed

interpretation Sup_sat!: semilattice_neutr_set max "bot :: 'a::len sat"
where
  "semilattice_neutr_set.F max (bot :: 'a sat) = Sup"
proof -
  show "semilattice_neutr_set max (bot :: 'a sat)" by default (simp add: max_def bot.extremum_unique)
  show "semilattice_neutr_set.F max (bot :: 'a sat) = Sup" by (simp add: Sup_sat_def)
qed

instance sat :: (len) complete_lattice
proof
  fix x :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume "x \<in> A"
  ultimately show "Inf A \<le> x"
    by (induct A) (auto intro: min.coboundedI2)
next
  fix z :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume z: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  ultimately show "z \<le> Inf A" by (induct A) simp_all
next
  fix x :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume "x \<in> A"
  ultimately show "x \<le> Sup A"
    by (induct A) (auto intro: max.coboundedI2)
next
  fix z :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume z: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  ultimately show "Sup A \<le> z" by (induct A) auto
next
  show "Inf {} = (top::'a sat)"
    by (auto simp: top_sat_def)
next
  show "Sup {} = (bot::'a sat)"
    by (auto simp: bot_sat_def)
qed

hide_const (open) sat_of_nat

end


(*  Title:    HOL/Prolog/Func.thy
    Author:   David von Oheimb (based on a lecture on Lambda Prolog by Nadathur)
*)

section {* Untyped functional language, with call by value semantics *}

theory Func
imports HOHH
begin

typedecl tm

axiomatization
  abs     :: "(tm \<Rightarrow> tm) \<Rightarrow> tm" and
  app     :: "tm \<Rightarrow> tm \<Rightarrow> tm" and

  cond    :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm" and
  "fix"   :: "(tm \<Rightarrow> tm) \<Rightarrow> tm" and

  true    :: tm and
  false   :: tm and
  "and"   :: "tm \<Rightarrow> tm \<Rightarrow> tm"       (infixr "and" 999) and
  eq      :: "tm \<Rightarrow> tm \<Rightarrow> tm"       (infixr "eq" 999) and

  Z       :: tm                     ("Z") and
  S       :: "tm \<Rightarrow> tm" and

  plus    :: "tm \<Rightarrow> tm \<Rightarrow> tm"       (infixl "+" 65) and
  minus   :: "tm \<Rightarrow> tm \<Rightarrow> tm"       (infixl "-" 65) and
  times   :: "tm \<Rightarrow> tm \<Rightarrow> tm"       (infixl "*" 70) and

  eval    :: "tm \<Rightarrow> tm \<Rightarrow> bool" where

eval: "

eval (abs RR) (abs RR)..
eval (app F X) V :- eval F (abs R) & eval X U & eval (R U) V..

eval (cond P L1 R1) D1 :- eval P true  & eval L1 D1..
eval (cond P L2 R2) D2 :- eval P false & eval R2 D2..
eval (fix G) W   :- eval (G (fix G)) W..

eval true  true ..
eval false false..
eval (P and Q) true  :- eval P true  & eval Q true ..
eval (P and Q) false :- eval P false | eval Q false..
eval (A1 eq B1) true  :- eval A1 C1 & eval B1 C1..
eval (A2 eq B2) false :- True..

eval Z Z..
eval (S N) (S M) :- eval N M..
eval ( Z    + M) K     :- eval      M  K..
eval ((S N) + M) (S K) :- eval (N + M) K..
eval (N     - Z) K     :- eval  N      K..
eval ((S N) - (S M)) K :- eval (N- M)  K..
eval ( Z    * M) Z..
eval ((S N) * M) K :- eval (N * M) L & eval (L + M) K"

lemmas prog_Func = eval

schematic_lemma "eval ((S (S Z)) + (S Z)) ?X"
  apply (prolog prog_Func)
  done

schematic_lemma "eval (app (fix (%fact. abs(%n. cond (n eq Z) (S Z)
                        (n * (app fact (n - (S Z))))))) (S (S (S Z)))) ?X"
  apply (prolog prog_Func)
  done

end


(* lemma tfun_fun : "f : x \<leadsto> y \<Longrightarrow> f : Function"
  unfolding total_fun_def by (drule intE1)

(*Can't have \<open>\<forall>b \<in> x. f ` b \<in> y\<close> as introduction,
  because we could have \<open>y = {Function_default}\<close>*)
lemma tfunI :
  assumes f:"f : Function"
      and bc:"\<And>b. b \<in> x \<Longrightarrow> (\<exists>c. c \<in> y \<and> app f b c)"
    shows "f : x \<leadsto> y"
  unfolding total_fun_def
  by (rule intI[OF f], rule tyI, use bc in auto)

lemma tfunE :
  assumes f:"f : x \<leadsto> y"
      and b:"b \<in> x"
    obtains c where "c \<in> y" "app f b c"
  using f b unfolding total_fun_def has_ty_def inter_ty_def
  by auto

lemma tfun_app :
  assumes f:"f : x \<leadsto> y"
      and b:"b \<in> x"
    shows "f ` b \<in> y"
  by (rule tfunE[OF f b],
      use funappI[OF tfun_fun[OF f]] in auto)

lemma tfun_pfun :
  assumes f:"f : x \<leadsto> y"
    shows "f : x \<Zpfun> y"
proof (rule pfunI[OF tfun_fun[OF f]])
  fix a b assume "a \<in> x" and b: "app f a b"
  then obtain c where "c \<in> y" and c:"app f a c" by (blast elim: tfunE[OF f])
  thus "b \<in> y" using app_eqI[OF tfun_fun[OF f] b c] by auto
qed
 *)

(* section \<open>Injective functions\<close>

(*Refactor anything that just makes use of \<open>app\<close> to a special locale for
  definitions and theorems for both relations and functions.*)
definition inj :: "'a \<Rightarrow> bool"
  where "inj f \<equiv> \<forall>x y z. app f x z \<and> app f y z \<longrightarrow> x = y"

lemma injI :
  assumes "\<And>x y z. app f x z \<Longrightarrow> app f y z \<Longrightarrow> x = y"
  shows "inj f"
  unfolding inj_def using assms
  by auto

lemma inj_appI :
  assumes f:"f : Function" and eq:"\<And>x y. f ` x = f ` y \<Longrightarrow> x = y"
  shows "inj f"
proof (rule injI)
  fix x y z
  assume "app f x z" "app f y z"
  hence "f ` x = f ` y" using funappI[OF f] by auto
  thus "x = y" by (rule eq)
qed

lemma inj_eqI:
  assumes f:"inj f"
      and x:"app f x z" and y:"app f y z"
    shows "x = y"
  using assms unfolding inj_def
  by auto

(*Need that x,y \<in> dom f because it is feasible that x\<noteq>y and both f`x and f`y are undefined.*)
lemma inj_app_eqI:
  assumes f:"f : Function" and inj:"inj f"
      and xy:"x \<in> dom f" "y \<in> dom f"
      and eq:"f`x = f`y"
    shows "x = y"
  by (rule inj_eqI[OF inj],
      use funapp_dom[OF f] xy eq in auto)

(*REFACTOR TO 'APP' LOCALE - works on relations as well as functions*)
definition inj_on :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "inj_on f x \<equiv> \<forall>b c d. b \<in> x \<longrightarrow> c \<in> x
                     \<longrightarrow> app f b d \<longrightarrow> app f c d \<longrightarrow> b = c"

lemma inj_onI :
  assumes xy:"\<And>b c d. b \<in> x \<Longrightarrow> c \<in> x \<Longrightarrow> app f b d \<Longrightarrow> app f c d \<Longrightarrow> b = c"
    shows "inj_on f x"
  unfolding inj_on_def using xy by auto

lemma inj_on_appI :
  assumes f:"f: Function"
      and eq:"\<And>b c d. b \<in> x \<Longrightarrow> c \<in> x \<Longrightarrow> f`b = f`c \<Longrightarrow> b = c"
    shows "inj_on f x"
proof (rule inj_onI)
  fix b c d
  assume "b \<in> x" "c \<in> x" "app f b d" "app f c d"
  hence "f ` b = f ` c" using funappI[OF f] by auto
  thus "b = c" by (rule eq[OF \<open>b \<in> x\<close> \<open>c \<in> x\<close>])
qed

lemma inj_injon :
  assumes f:"f : Function" and inj:"inj (f \<restriction> x)"
    shows "inj_on f x"
proof (rule inj_onI)
  fix b c d
  assume "b \<in> x" "c \<in> x" "app f b d" "app f c d"
  hence "app (f \<restriction> x) b d" "app (f \<restriction> x) c d" by (auto intro: restrictI[OF f])
  thus "b = c" by (rule inj_eqI[OF inj])
qed

lemma inj_on_eqI:
  assumes f:"inj_on f x"
    and b:"b \<in> x" and c:"c \<in> x"
    and bc:"app f b d" "app f c d"
  shows "b = c"
  using assms unfolding inj_on_def
  by auto

lemma inj_on_app_eqI:
  assumes f:"f : Function" and inj:"inj_on f x"
    and b:"b \<in> x" "b \<in> dom f"
    and c:"c \<in> x" "c \<in> dom f"
    and bc:"f`b = f`c"
  shows "b = c"
  by (rule inj_on_eqI[OF inj \<open>b \<in> x\<close> \<open>c \<in> x\<close>],
      use funapp_dom[OF f] b c bc in auto)

lemma injon_inj :
  assumes f:"f : Function" and inj:"inj_on f x"
  shows "inj (f \<restriction> x)"
  by (rule injI, unfold restrict_iff[OF f],
      use inj_on_eqI[OF inj] in auto)

subsection \<open>Partial injections\<close>

(* "pinj" stands for "partial injection" *)
definition pinj :: "'a \<Rightarrow> 'a \<Rightarrow>'a \<Rightarrow> bool" (infixl \<open>\<Zpinj>\<close> 70)
  where "x \<Zpinj> y \<equiv> x \<Zpfun> y \<bar> (\<lambda>f. inj (f \<restriction> x))"

lemma pinj_pfun : "f : x \<Zpinj> y \<Longrightarrow> f : x \<Zpfun> y"
  unfolding pinj_def by (rule intE1)
lemmas pinj_fun = pfun_fun[OF pinj_pfun]
lemma pinj_inj : "f : x \<Zpinj> y \<Longrightarrow> inj (f \<restriction> x)"
  unfolding pinj_def by (drule intE2, drule tyE)

lemma pinjI:
  assumes f:"f : x \<Zpfun> y"
    and eq:"\<And>b c d. b \<in> x \<Longrightarrow> c \<in> x \<Longrightarrow> app f b d \<Longrightarrow> app f c d \<Longrightarrow> b = c"
  shows "f : x \<Zpinj> y"
  unfolding pinj_def
  by (rule intI[OF f], rule tyI, rule injI,
      unfold restrict_iff[OF pfun_fun[OF f]],
      use eq in auto)

lemma pinj_appI:
  assumes f:"f : x \<Zpfun> y"
    and eq:"\<And>b c d. b \<in> x \<Longrightarrow> c \<in> x \<Longrightarrow> f`b = f`c \<Longrightarrow> b = c"
  shows "f : x \<Zpinj> y"
  by (rule pinjI[OF f],
      use funappI[OF pfun_fun[OF f]] eq in auto)

lemma pinj_eqI:
  assumes f:"f : x \<Zpinj> y"
    and bc:"b \<in> x" "c \<in> x"
    and app:"app f b d" "app f c d"
  shows "b = c"
  by (rule inj_on_eqI[OF inj_injon[OF pinj_fun[OF f] pinj_inj[OF f]] bc app])

lemma pinj_app_eqI:
  assumes f:"f : x \<Zpinj> y"
    and b:"b \<in> x" "b \<in> dom f"
    and c:"c \<in> x" "c \<in> dom f"
    and eq:"f`b = f`c"
  shows "b = c"
  by (rule inj_on_app_eqI[OF pinj_fun inj_injon[OF pinj_fun pinj_inj] b c eq],
      use f in auto)

subsection \<open>Total injections\<close>

(* "tinj" stands for "total injection" *)
definition tinj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl \<open>\<Zinj>\<close> 70)
  where "x \<Zinj> y \<equiv> x \<leadsto> y \<bar> (\<lambda>f. inj (f \<restriction> x))"

lemma tinj_tfun : "f : x \<Zinj> y \<Longrightarrow> f : x \<leadsto> y"
  unfolding tinj_def by (rule intE1)
lemmas tinj_fun = tfun_fun[OF tinj_tfun]

lemma tinj_inj : "f : x \<Zinj> y \<Longrightarrow> inj (f \<restriction> x)"
  unfolding tinj_def by (drule intE2, drule tyE)
lemma tinj_pinj :
  assumes f:"f : x \<Zinj> y"
    shows "f : x \<Zpinj> y"
  unfolding pinj_def
  by (rule intI[OF tfun_pfun[OF tinj_tfun[OF f]]
           tyI[of \<open>(\<lambda>f. inj (f \<restriction> x))\<close>, OF tinj_inj[OF f]]])

lemma tinj_injon :
  assumes f:"f : x \<Zinj> y"
  shows "inj_on f x"
  by (rule inj_injon[OF tinj_fun[OF f] tinj_inj[OF f]])

lemma tinjI:
  assumes f:"f : x \<leadsto> y"
      and eq:"\<And>b c d. b \<in> x \<Longrightarrow> c \<in> x
                   \<Longrightarrow> app f b d \<Longrightarrow> app f c d \<Longrightarrow> b = c"
  shows "f : x \<Zinj> y"
  unfolding tinj_def
  by (rule intI[OF f], rule tyI,
      rule injon_inj[OF tfun_fun[OF f] inj_onI],
      simp only: eq)

lemma tinj_appI:
  assumes f:"f : x \<leadsto> y"
    and eq:"\<And>b c d. b \<in> x \<Longrightarrow> c \<in> x \<Longrightarrow> f`b = f`c \<Longrightarrow> b = c"
  shows "f : x \<Zinj> y"
  by (rule tinjI[OF f],
      use funappI[OF tfun_fun[OF f]] eq in auto)

lemma tinj_eqI:
  assumes f:"f : x \<Zinj> y"
    and bc:"b \<in> x" "c \<in> x"
    and app:"app f b d" "app f c d"
  shows "b = c"
  by (rule inj_on_eqI[OF tinj_injon[OF f] bc app])

lemma tinj_app_eqI:
  assumes f:"f : x \<Zinj> y"
    and b:"b \<in> x" and c:"c \<in> x"
    and eq:"f`b = f`c"
  shows "b = c"
proof (rule inj_on_eqI[OF tinj_injon[OF f] b c])
  have tfun:"f : x \<leadsto> y" by (rule tinj_tfun[OF f])
  obtain d where "d \<in> y" and 1:"app f b d" by (rule tfunE[OF tfun b])
  obtain e where "e \<in> y" and 2:"app f c e" by (rule tfunE[OF tfun c])
  from 1 2 eq have "f ` b = d" "d = e"using funappI[OF tfun_fun[OF tfun]] by auto
  thus "app f b (f ` b)" "app f c (f ` b)" using 1 2 by auto
qed

section \<open>Surjective functions\<close>

definition surj :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "surj f y \<equiv> \<forall>c. c \<in> y \<longrightarrow> (\<exists>x. app f x y) "

section \<open>Inverses of functions\<close>

definition inverse :: "'a \<Rightarrow> 'a"
  where "inverse f \<equiv> mkfun (ran f) (\<lambda>b a. app f a b)"

lemma inverse_funpred :
  assumes f:"f : Function" and inj:"inj f"
  shows "(\<lambda>b a. app f a b) : FunPred (ran f)"
  unfolding FunPred_def
proof (rule tyI, auto)
  fix a1 a2 b
  assume "b \<in> ran f" "app f a1 b" "app f a2 b"
  thus "a1 = a2" using inj_eqI[OF inj] by auto
next
  fix a b
  assume "b \<in> ran f" "app f a b"
  thus "a : FunMem" "b : FunMem"
    using funmemI1[OF f] ran_funmem[OF f]
    by auto
qed
lemma inj_inverse_fun :
  assumes f:"f : Function" and inj:"inj f"
  shows "inverse f : Function"
  unfolding inverse_def
  by (rule mkfun_fun[OF ran_set[OF f] inverse_funpred[OF f inj]])

lemma inj_inverse_iff :
  assumes f:"f : Function" and inj:"inj f"
  shows "app (inverse f) b a \<longleftrightarrow> app f a b"
  unfolding inverse_def mkfun_iff[OF ran_set[OF f] inverse_funpred[OF f inj]] ran_iff[OF f]
  by auto

lemma pinj_inverse_iff :
  assumes f:"f : x \<Zpinj> y"
      and b:"b \<in> x"
    shows "app (inverse (f \<restriction> x)) c b \<longleftrightarrow> app f b c"
  unfolding inj_inverse_iff[OF restrict_fun[OF pinj_fun[OF f]] pinj_inj[OF f]]
            restrict_iff[OF pinj_fun[OF f]] using b by auto

lemmas tinj_inverse_iff = pinj_inverse_iff[OF tinj_pinj]

lemma inj_inverse_app_eq:
  assumes f:"f : Function"
      and inj:"inj f" and b:"b \<in> dom f"
  shows "inverse f ` (f ` b) = b"
  by (rule funappI[OF inj_inverse_fun[OF f inj]],
      unfold inj_inverse_iff[OF f inj],
      rule funapp_dom[OF f b])

lemma pinj_inverse_app_eq:
  assumes f:"f : x \<Zpinj> y"
      and b:"b \<in> x" and dom:"b \<in> dom f"
    shows "inverse (f \<restriction> x) ` (f ` b) = b"
  using inj_inverse_app_eq[OF restrict_fun[OF pinj_fun[OF f]] pinj_inj[OF f]
                              restrict_domI[OF pinj_fun[OF f] dom b]]
  unfolding restrict_app[OF pinj_fun[OF f] b dom] by auto

lemmas tinj_inverse_app_eq = pinj_inverse_app_eq[OF tinj_pinj]

section \<open>Function composition\<close>
(*Use \circle to avoid clash with HOL function composition*)
definition comp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl \<open>\<circle>\<close> 50)
  where "g \<circle> f \<equiv> mkfun (dom f) (\<lambda>a c. (\<exists>b. app f a b \<and> app g b c))"

lemma comp_funpred :
  assumes f:"f : Function" and g:"g : Function"
  shows "(\<lambda>a c. (\<exists>b. app f a b \<and> app g b c)) : FunPred x"
  unfolding FunPred_def
proof (rule tyI, auto)
  fix a b1 b2 c1 c2
  assume "app f a b1" "app f a b2"
  hence "b1 = b2" using app_eqI[OF f] by auto
  moreover assume "app g b1 c1" "app g b2 c2"
  ultimately show "c1 = c2" using app_eqI[OF g] by auto
next
  fix a b c
  assume "app f a b" "app g b c"
  thus "a : FunMem" "c : FunMem"
    by (auto intro: funmemI1[OF f] funmemI2[OF g])
qed

lemma comp_typ : "(\<circle>) : Function \<rightarrow> Function \<rightarrow> Function"
  unfolding comp_def
  by (rule funI, rule funI, rule mkfun_fun[OF dom_set comp_funpred])

lemmas comp_fun = funE[OF funE[OF comp_typ]]
lemmas pfun_comp_fun = comp_fun[OF pfun_fun pfun_fun]
lemmas tfun_comp_fun = comp_fun[OF tfun_fun tfun_fun]

lemma comp_iff :
  assumes f:"f : Function" and g:"g : Function"
  shows "app (g \<circle> f) a c \<longleftrightarrow> (\<exists>b. app f a b \<and> app g b c)"
  unfolding comp_def mkfun_iff[OF dom_set[OF f] comp_funpred[OF f g]] dom_iff[OF f]
  by auto

lemma compI :
  assumes f:"f : Function" and g:"g : Function"
    and app_f:"app f a b" and app_g:"app g b c"
  shows "app (g \<circle> f) a c"
  using comp_iff[OF f g] app_f app_g
  by auto

lemma compE :
  assumes f:"f : Function" and g:"g : Function"
      and app:"app (g \<circle> f) a c"
  obtains b where "app f a b" "app g b c"
  using comp_iff[OF f g] app by auto

lemma pfun_comp_iff :
  assumes f:"f : x \<Zpfun> y" and g:"g : y \<Zpfun> z"
  shows "g \<circle> f : x \<Zpfun> z"
proof (rule pfunI[OF pfun_comp_fun[OF g f]])
  fix a c assume "a \<in> x" "app (g \<circle> f) a c"
  then obtain b where "app f a b" "app g b c"
    by (blast elim: compE[OF pfun_fun[OF f] pfun_fun[OF g]])
  moreover hence "b \<in> y" using pfunE[OF f \<open>a \<in> x\<close>] by simp
  ultimately show "c \<in> z" using pfunE[OF g] by auto
qed

lemma tfun_comp_iff :
  assumes f:"f : x \<leadsto> y" and g:"g : y \<leadsto> z"
    shows "g \<circle> f : x \<leadsto> z"
proof (rule tfunI[OF tfun_comp_fun[OF g f]])
  fix a c assume "a \<in> x"
  then obtain b where "b \<in> y" "app f a b" by (blast elim: tfunE[OF f])
  moreover then obtain c where "c \<in> z" "app g b c" by (blast elim: tfunE[OF g])
  ultimately show "\<exists>c. c \<in> z \<and> app (g \<circle> f) a c"
    using compI[OF tfun_fun[OF f] tfun_fun[OF g]] by auto
qed

lemma comp_app_eq :
  assumes f:"f : Function" and g:"g : Function"
      and b:"b \<in> dom f" and fb:"f ` b \<in> dom g"
    shows "(g \<circle> f) ` b = g ` (f ` b)"
  by (rule funappI[OF comp_fun[OF g f]], rule compI[OF f g],
      rule funapp_dom[OF f b], rule funapp_dom[OF g fb])

section \<open>Forming functions from ('a=>'a)-operators\<close>

lemma funpredI :
  assumes x:"x : SetOf FunMem" and F:"F : MemOf x \<rightarrow> FunMem"
  shows "(\<lambda>a b. b = F a) : FunPred x"
  using funE[OF F memofI] setof_mem[OF x]
  unfolding FunPred_def has_ty_def
  by auto

definition lam :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "lam x F \<equiv> mkfun x (\<lambda>a b. b = F a)"

lemma lam_fun :
  assumes x:"x : SetOf FunMem" and F:"F : MemOf x \<rightarrow> FunMem"
    shows "lam x F : Function"
  unfolding lam_def
  by (rule mkfun_fun[OF setof_set[OF x] funpredI[OF x F]])

lemma lam_iff :
  assumes x:"x : SetOf FunMem" and F:"F : MemOf x \<rightarrow> FunMem"
  shows "app (lam x F) b c \<longleftrightarrow> b \<in> x \<and> c = F b"
  unfolding lam_def using "fun" setof_set[OF x] funpredI[OF x F] by auto

lemma lam_app :
  assumes x:"x : SetOf FunMem" and F:"F : MemOf x \<rightarrow> FunMem"
      and b : "b \<in> x"
    shows "lam x F ` b = F b"
  by (rule funappI[OF lam_fun[OF x F]],
      use lam_iff[OF x F] b in auto)

lemma lam_tfun :
  assumes x:"x : SetOf FunMem" and y:"y : SetOf FunMem"
      and F:"F : MemOf x \<rightarrow> MemOf y"
    shows "lam x F : x \<leadsto> y"
proof (rule tfunI[OF lam_fun[OF x]])
  show Fmem:"F : MemOf x \<rightarrow> FunMem"
  proof (rule funI)
    fix b assume "b : MemOf x"
    hence "F b : MemOf y" by (rule funE[OF F])
    thus "F b : FunMem" by (rule setof_mem[OF y memofD])
  qed
  fix b assume "b \<in> x"
  hence "F b \<in> y" using funE[OF F] unfolding MemOf_def by (unfold_typs)
  moreover have "app (lam x F) b (F b)" using lam_iff[OF x Fmem] \<open>b \<in> x\<close> by auto
  ultimately show "\<exists>c. c \<in> y \<and> app (lam x F) b c" by auto
qed

(*HOL injection to GST injection*)
(*I think this is the first time we 'flatten' properties of HOL stuff to GST stuff.*)
lemma lam_inj :
  assumes x:"x : SetOf FunMem" and F:"F : MemOf x \<rightarrow> FunMem"
      and Finj:"Fun.inj F"
    shows "inj (lam x F)"
proof (rule injI)
  fix b c d
  assume "app (lam x F) b d" "app (lam x F) c d"
  hence "F b = F c" using lam_iff[OF x F] by auto
  thus "b = c" using Finj unfolding Fun.inj_def by auto
qed
 *)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory RS_prod
imports RS
begin

(*****************************************************************

         1. Productions of RS are also RS.
         2.
         3.
         4.

 *****************************************************************)

(**********************************************************
              def: prod of restriction space
 **********************************************************)

instantiation "fun" :: (type, rs) rs0
begin

definition
  prod_restriction_def :
(*    "xp .|. n == (%i. ((xp i) .|. n))" *)
      "(xp::('a::type => 'b::rs)) .|. n == (%i. ((xp i) .|. n))"  (* note the name of type variable *)

  instance proof qed
end

definition
  prod_Limit :: "(('i => 'a::ms_rs) infinite_seq) => ('i => 'a::ms_rs)"
  where
  prod_Limit_def :"prod_Limit xps == (%i. Limit ((proj_fun i) o xps))"

(************************************************************
                           Basics
 ************************************************************)

lemma rest_to_prod_rest:
    "(ALL i. ((xp::('i => 'a::rs)) i) .|. n = (yp i) .|. n)
     ==> xp .|. n = yp .|. n"
by (simp add: prod_restriction_def)

(************************************************************
                     Product RS ==> RS
 ************************************************************)

(*** prod_zero_eq_rs ***)

lemma prod_zero_eq_rs:
  "(xp::('i => 'a::rs)) .|. 0 = yp .|. 0"
apply (simp add: prod_restriction_def)
by (simp add: fun_eq_iff)
(* by (simp add: expand_fun_eq) *)

(*** prod_min_rs ***)

lemma prod_min_rs:
  "((xp::('i => 'a::rs)) .|. m) .|. n = xp .|. (min m n)"
apply (simp add: prod_restriction_def)
apply (simp add: fun_eq_iff)
(* apply (simp add: expand_fun_eq) *)
by (simp add: min_rs)

(*** prod_diff_rs ***)

lemma prod_diff_rs:
  "((xp::('i => 'a::rs)) ~= yp) ==> (EX n. xp .|. n ~= yp .|. n)"
apply (simp add: prod_restriction_def)
apply (simp add: fun_eq_iff)
(* apply (simp add: expand_fun_eq) *)
apply (erule exE)

apply (insert diff_rs)
apply (drule_tac x="xp x" in spec)
apply (drule_tac x="yp x" in spec)
by (auto)

(*****************************
       Prod RS => RS
 *****************************)

instance "fun" :: (type,rs) rs
apply (intro_classes)
apply (simp add: prod_zero_eq_rs)
apply (simp add: prod_min_rs)
apply (simp add: prod_diff_rs)
done

(************************************************************
                   Product RS ==> MS
 ************************************************************)

instantiation "fun" :: (type, rs) ms0
begin

definition
  prod_distance_def: "distance (f::(('a=>'b::rs)*('a=>'b::rs))) = distance_rs f"

  instance proof qed
end

instance "fun" :: (type,rs) ms
apply (intro_classes)
apply (simp_all add: prod_distance_def)
apply (simp add: diagonal_rs)
apply (simp add: symmetry_rs)
apply (simp add: triangle_inequality_rs)
done

(************************************************************
             i.e.  Product RS ==> MS & RS
 ************************************************************)

instance "fun" :: (type,rs) ms_rs
apply (intro_classes)
apply (simp add: prod_distance_def)
done

(************************************************************
                    distance
 ************************************************************)

lemma prod_distance_nat_le:
      "xp i ~= yp i
       ==> distance_nat ((xp::('i => 'a::rs)), yp)
        <= distance_nat (xp i, yp i)"
apply (case_tac "xp = yp", simp)
apply (simp add: distance_nat_le_1[THEN sym])

apply (insert distance_nat_is[of xp yp], simp)
apply (simp add: isMAX_def)
apply (simp add: distance_nat_set_def)
apply (simp add: prod_restriction_def)
by (simp add: fun_eq_iff)
(* by (simp add: expand_fun_eq) *)

lemma prod_distance_def_le:
      "distance (xp i, yp i) <= distance ((xp::('i => 'a::ms0_rs)), yp)"
apply (case_tac "xp i = yp i", simp)
apply (case_tac "xp = yp", simp)
apply (simp_all add: to_distance_rs)
apply (case_tac "xp = yp", simp)
apply (simp add: distance_iff)
(* apply (rule power_decreasing, simp_all)    not necessary for Isabelle2020 *)
by (simp add: prod_distance_nat_le)

(*** prod_distance (Upper Bound) ***)

lemma prod_distance_UB:
  "distance((xp::('i => 'a::ms0_rs)), yp) isUB {u. EX i. u = distance (xp i, yp i)}"
apply (simp add: isUB_def)
apply (intro allI impI)
apply (erule exE)
by (simp add: prod_distance_def_le)

(*** prod_distance (Least) ***)

lemma prod_distance_least:
   "ALL i. distance (xp i, yp i) <= u
    ==> distance((xp::('i => 'a::ms0_rs)), yp) <= u"
apply (case_tac "xp = yp")
apply (simp add: to_distance_rs)

(* to use a contradiction *)
apply (case_tac "distance (xp, yp) <= u", simp)
apply (simp add: linorder_not_le)

 apply (insert rest_to_prod_rest[of xp "Suc (distance_nat (xp, yp))" yp])
 apply (subgoal_tac "ALL i. xp i .|. Suc (distance_nat (xp, yp)) =
                            yp i .|. Suc (distance_nat (xp, yp))") (* ...1 *)
 apply (simp add: distance_nat_less_1)

  apply (rule allI)
  apply (case_tac "xp i = yp i", simp)
  apply (drule_tac x="i" in spec)
  apply (simp add: to_distance_rs)
  apply (simp add: distance_iff)
  apply (simp add: distance_nat_less_1)
  apply (rule rev_power_decreasing_strict[of "1/2"])
  apply (simp)
  apply (simp)
  apply (rule le_less_trans)   (* modified for Isabelle2020 *)
  apply (simp)
  apply (simp)
done

(*** prod_distance (Least Upper Bound) ***)

lemma prod_distance:
   "distance((xp::('i => 'a::ms0_rs)), yp) isLUB {u. EX i. u = distance (xp i, yp i)}"
apply (simp add: isLUB_def)
apply (simp add: prod_distance_UB)

apply (intro allI impI)
apply (rule prod_distance_least)
apply (simp add: isUB_def)
apply (rule allI)
apply (drule_tac x="distance (xp i, yp i)" in spec)
apply (auto)
done

lemma ALL_prod_distance:
   "ALL xp yp.
    distance((xp::('i => 'a::ms0_rs)), yp) isLUB {u. EX i. u = distance (xp i, yp i)}"
by (simp add: prod_distance)

(*************************************************************
                        product maps
 *************************************************************)

(*** proj_fun ***)

lemma proj_non_expand: "non_expanding ((proj_fun::('i => ('i => 'a::ms_rs) => 'a)) i)"
apply (simp add: non_expanding_def)
apply (simp add: map_alpha_def)
apply (simp add: proj_fun_def)
apply (simp add: prod_distance_def_le)
done

(*---------------------*
 |    non_expanding    |
 *---------------------*)

(* only_if *)

lemma prod_non_expand_only_if:
  "non_expanding (fp::('a::ms_rs => ('i => 'b::ms_rs)))
   ==> ALL i. non_expanding ((proj_fun i) o fp)"
by (simp add: compo_non_expand proj_non_expand)

(* if *)

lemma prod_non_expand_if:
  "ALL i. non_expanding ((proj_fun i) o fp)
   ==> non_expanding (fp::('a::ms_rs => ('i => 'b::ms_rs)))"
apply (simp add: non_expanding_def map_alpha_def)
apply (intro allI)
apply (insert ALL_prod_distance)
apply (drule_tac x="fp x" in spec)
apply (drule_tac x="fp y" in spec)
apply (simp add: isLUB_def)
apply (erule conjE)
apply (drule_tac x="distance (x, y)" in spec)
apply (drule mp)

 apply (simp add: isUB_def)
 apply (intro allI impI)
 apply (erule exE)
 apply (drule_tac x="i" in spec)
 apply (drule_tac x="x" in spec)
 apply (drule_tac x="y" in spec)
 apply (simp add: proj_fun_def)

by (simp)

(* iff *)

lemma prod_non_expand:
  "non_expanding (fp::('a::ms_rs => ('i => 'b::ms_rs)))
   = (ALL i. non_expanding ((proj_fun i) o fp))"
apply (rule iffI)
apply (simp add: prod_non_expand_only_if)
apply (simp add: prod_non_expand_if)
done

(*---------------------*
 |  alpha_contraction  |
 *---------------------*)

(* only_if *)

lemma prod_contra_alpha_only_if:
  "contraction_alpha (fp::('a::ms_rs => ('i => 'b::ms_rs))) alpha
   ==> ALL i. contraction_alpha ((proj_fun i) o fp) alpha"
by (simp add: compo_non_expand_contra_alpha proj_non_expand)

(* if *)

lemma prod_contra_alpha_if:
  "ALL i. contraction_alpha ((proj_fun i) o fp) alpha
   ==> contraction_alpha (fp::('a::ms_rs => ('i => 'b::ms_rs))) alpha"
apply (simp add: contraction_alpha_def map_alpha_def)
apply (intro allI)
apply (insert ALL_prod_distance)
apply (drule_tac x="fp x" in spec)
apply (drule_tac x="fp y" in spec)
apply (simp add: isLUB_def)
apply (elim conjE)
apply (drule_tac x="alpha * distance (x, y)" in spec)
apply (drule mp)

 apply (simp add: isUB_def)
 apply (intro allI impI)
 apply (erule exE)
 apply (drule_tac x="i" in spec)
 apply (drule_tac x="x" in spec)
 apply (drule_tac x="y" in spec)
 apply (simp add: proj_fun_def)

by (simp)

(* iff *)

lemma prod_contra_alpha:
  "contraction_alpha (fp::('a::ms_rs => ('i => 'b::ms_rs))) alpha
   = (ALL i. contraction_alpha ((proj_fun i) o fp) alpha)"
apply (rule iffI)
apply (simp add: prod_contra_alpha_only_if)
apply (simp add: prod_contra_alpha_if)
done

(************************************************************
                       Lemmas (limit)
 ************************************************************)

(*** cauchy ***)

lemma prod_cauchy_seq:
  "cauchy (xps::(('i => 'b::ms_rs) infinite_seq))
   ==> cauchy ((proj_fun i) o xps)"
apply (simp add: cauchy_def)
apply (intro allI impI)

apply (drule_tac x="delta" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac delta N n m)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: proj_fun_def)

apply (insert ALL_prod_distance)
apply (drule_tac x="xps n" in spec)
apply (drule_tac x="xps m" in spec)

apply (simp add: isLUB_def)
apply (simp add: isUB_def)
apply (erule conjE)+
apply (drule_tac x="distance ((xps n) i, (xps m) i)" in spec)
apply (drule mp)

apply (rule_tac x="i" in exI)
by (simp_all)

(*** normal ***)

lemma prod_normal_seq:
  "normal (xps::(('i => 'b::ms_rs) infinite_seq))
    ==> normal ((proj_fun i) o xps)"
apply (simp add: normal_def)
apply (intro allI)

apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: proj_fun_def)

apply (insert ALL_prod_distance)
apply (drule_tac x="xps n" in spec)
apply (drule_tac x="xps m" in spec)

apply (simp add: isLUB_def)
apply (simp add: isUB_def)
apply (erule conjE)+
apply (drule_tac x="distance ((xps n) i, (xps m) i)" in spec)
apply (drule mp)

apply (rule_tac x="i" in exI)
by (simp_all)

lemma prod_normal_seq_only_if:
  "ALL i. normal ((proj_fun i) o xps)
    ==> normal (xps::(('i => 'b::ms_rs) infinite_seq))"
apply (simp add: normal_def)
apply (intro allI)
apply (rule prod_distance_least)
apply (intro allI)
apply (drule_tac x="i" in spec)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: proj_fun_def)
done

(* iff *)

lemma prod_normal_seq_iff:
  "normal (xps::(('i => 'b::ms_rs) infinite_seq))
   = (ALL i. normal ((proj_fun i) o xps))"
apply (rule)
apply (simp add: prod_normal_seq)
apply (simp add: prod_normal_seq_only_if)
done

(*-----------------------*
 |   product of limits   |
 *-----------------------*)

(*** limit (single <-- prod) ***)

lemma prod_convergeTo_only_if:
  "(xps::(('i => 'b::ms_rs) infinite_seq)) convergeTo yp
   ==> ALL i. ((proj_fun i) o xps) convergeTo (yp i)"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac i eps N n)
apply (drule_tac x="n" in spec)
apply (simp add: proj_fun_def)

apply (insert ALL_prod_distance)
apply (drule_tac x="yp" in spec)
apply (drule_tac x="xps n" in spec)
apply (simp add: isLUB_def isUB_def)

apply (erule conjE)+
apply (drule_tac x="distance (yp i, (xps n) i)" in spec)
apply (drule mp)

apply (rule_tac x="i" in exI)
by (simp_all)

(*** limit (single --> prod) (note: ms_rs) ***)

lemma prod_convergeTo_if:
  "[| normal xps ; ALL i. ((proj_fun i) o xps) convergeTo (yp i) |]
   ==> (xps::(('i => 'b::ms_rs) infinite_seq)) convergeTo yp"
apply (simp (no_asm) add: convergeTo_def)
apply (intro allI impI)

apply (subgoal_tac "EX n. ((1::real)/2) ^ n < eps")  (* ...1 *)
 apply (erule exE)
 apply (rename_tac eps M)

 apply (rule_tac x="Suc M" in exI)
 apply (intro allI impI)

 apply (insert ALL_prod_distance)
 apply (drule_tac x="yp" in spec)
 apply (drule_tac x="xps m" in spec)

 apply (simp add: isLUB_def)
 apply (erule conjE)+
 apply (drule_tac x="(1 / 2) ^ M" in spec)
 apply (drule mp)  (* mp *)

  apply (simp add: isUB_def)
  apply (intro allI impI)
  apply (erule exE)
  apply (simp)
  apply (drule_tac x="i" in spec)

  apply (subgoal_tac "EX n. M <= n & m = Suc n")  (* ...2 *)
   apply (erule exE)
   apply (simp)

   apply (subgoal_tac "distance((proj_fun i o xps) (Suc n), yp i) < (1/2)^n") (* ...3 *)
   apply (simp add: proj_fun_def)

   apply (subgoal_tac "distance (xps (Suc n) i, yp i) = distance (yp i, xps (Suc n) i)")
     (* added for Isabelle2020 *)(* 4 *)
    apply (simp)
    apply (rule less_imp_le)
    apply (rule less_le_trans[of _ "(1/2) ^ _"])
    apply (simp)
    apply (simp)
    (* 4 *)
    apply (simp add: symmetry_ms)

   (* 3 *)
   apply (rule normal_Limit)
   apply (simp add: prod_normal_seq del: o_apply)
   apply (simp del: o_apply)

  (* 2 *)
  apply (insert nat_zero_or_Suc)
  apply (drule_tac x="m" in spec)
  apply (erule disjE, simp)
  apply (erule exE)
  apply (rule_tac x="ma" in exI)
  apply (simp)

 (* mp *)
 apply (simp)

(* 1 *)
by (simp add: pow_convergence)

(*** iff ***)

lemma prod_convergeTo:
  "normal xps
   ==> (xps::(('i => 'b::ms_rs) infinite_seq)) convergeTo yp
     = (ALL i. ((proj_fun i) o xps) convergeTo (yp i))"
apply (rule iffI)
apply (simp add: prod_convergeTo_only_if)
apply (simp add: prod_convergeTo_if)
done

(*****************************************
      limit (cms and normal --> limit)
 *****************************************)

lemma prod_cms_normal_Limit:
  "normal (xps::(('i => 'b::cms_rs) infinite_seq))
   ==> xps convergeTo prod_Limit xps"
apply (simp add: prod_convergeTo prod_Limit_def)
by (simp add: prod_normal_seq normal_cauchy Limit_is)

(*****************************************
      limit (cms and cauchy --> limit)
 *****************************************)

lemma prod_cms_cauchy_Limit:
  "cauchy (xps::(('i => 'b::cms_rs) infinite_seq))
   ==> xps convergeTo prod_Limit (NF xps)"
by (simp add: prod_cms_normal_Limit normal_form_seq_normal
              normal_form_seq_same_Limit)

(*****************************************
     Product Complete Metric Space (RS)
 *****************************************)

lemma prod_cms_rs:
  "cauchy (xps::(('i => 'b::cms_rs) infinite_seq))
   ==> (EX yp. xps convergeTo yp)"
apply (rule_tac x="prod_Limit (NF xps)" in exI)
by (simp add: prod_cms_cauchy_Limit)

(************************************************************
                   Product RS ==> CMS and RS
 ************************************************************)

instance "fun" :: (type,cms_rs) cms
apply (intro_classes)
by (simp add: prod_cms_rs)

instance "fun" :: (type,cms_rs) cms_rs
by (intro_classes)

(************************************************************
                       prod_variable
 ************************************************************)

lemma non_expanding_prod_variable:
  "non_expanding (%(f::('i => 'a::ms_rs)). f pn)"
apply (simp add: non_expanding_def map_alpha_def)
apply (simp add: prod_distance_def_le)
done

(************************************************************
               Banach theorem for production
 ************************************************************)

theorem Banach_thm_prod:
  "[| normal (%n. (f^^n) x0) ;
      contraction (f::(('i => 'a::cms_rs) => ('i => 'a))) |]
     ==> f hasUFP & (ALL i. (%n. (f^^n) x0 i) convergeTo (UFP f) i)"
apply (insert Banach_thm[of f x0])
apply (simp)
apply (erule conjE)
apply (rule allI)
apply (simp add: prod_convergeTo)
apply (drule_tac x="i" in spec)
apply (simp add: proj_fun_def)
apply (simp add: comp_def)
done

(*----------------------------------------------------------*
 |                                                          |
 |                Continuity on Metric space                |
 |                                                          |
 *----------------------------------------------------------*)

lemma prod_continuous_rs:
  "(ALL i. continuous_rs (R i))
       ==> continuous_rs (%xp. (ALL i. (R i) (xp i)))"
apply (simp add: continuous_rs_def)
apply (intro allI impI)
apply (erule exE)
apply (drule_tac x="i" in spec)
apply (drule_tac x="x i" in spec)
apply (simp)

apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (drule_tac x="y i" in spec)
apply (rule_tac x="i" in exI)
apply (simp add: prod_restriction_def)
apply (simp add: fun_eq_iff)
(* apply (simp add: expand_fun_eq) *)
done

(*----------------------------------------------------------*
 |                                                          |
 |      !!!     order and restriction space     !!!         |
 |                                                          |
 *----------------------------------------------------------*)

instance "fun" :: (type,ms_rs_order) ms_rs_order0
by (intro_classes)

instance "fun" :: (type,ms_rs_order) ms_rs_order
apply (intro_classes)
apply (simp add: le_fun_def prod_restriction_def)
apply (intro allI)
apply (rule iffI)
apply (intro allI)
apply (erule exchange_forall_orderE)
apply (drule_tac x="xa" in spec)
apply (simp add: rs_order_iff)

apply (intro allI)
apply (drule_tac x="xa" in spec)
apply (insert rs_order_iff)
apply (drule_tac x="x xa" in spec)
apply (drule_tac x="y xa" in spec)
apply (fast)
done

(*** cms rs order ***)

instance "fun" :: (type,cms_rs_order) cms_rs_order
by (intro_classes)

end


(*
Author:
  Mnacho Echenim, Université Grenoble Alpes
*)

theory Commuting_Hermitian_Misc imports "Jordan_Normal_Form.Matrix"

begin
section \<open>Misc\<close>

fun n_sum where
  "n_sum 0 l = 0"
| "n_sum (Suc n) l = (hd l) + (n_sum n (tl l))"

lemma n_sum_last:
  fixes l::"'a::{comm_monoid_add} list"
  assumes "i < length l"
  shows "n_sum (Suc i) l = n_sum i l + l!i" using assms
proof (induct i arbitrary:l)
  case 0
  hence "l = hd l # tl l" by simp
  then show ?case
    using "0.prems" hd_conv_nth by auto
next
  case (Suc i)
  hence "n_sum (Suc (Suc i)) l = hd l + n_sum (Suc i) (tl l)" by simp
  also have "... = hd l + n_sum i (tl l) + tl l!i" using Suc
    by (metis Groups.add_ac(1) drop_Suc drop_eq_Nil2 leD leI)
  also have "... = n_sum (Suc i) l + tl l!i" by simp
  also have "... = n_sum (Suc i) l + l!(Suc i)"
    by (metis Suc(2) Suc_lessD hd_Cons_tl list.sel(2) nth_Cons_Suc nth_tl)
  finally show ?case .
qed

lemma n_sum_last_lt:
  fixes l::"'a::{comm_monoid_add, ordered_cancel_ab_semigroup_add} list"
  assumes "j < l!i"
  and "i < length l"
  shows "n_sum i l + j < n_sum (Suc i) l"
proof -
  have "n_sum i l + j < n_sum i l + l!i"
    using assms add_strict_left_mono[of j "l!i"] by simp
  also have "... = n_sum (Suc i) l" using n_sum_last[of i l] assms
    by simp
  finally show ?thesis .
qed

lemma sum_list_tl_leq:
  assumes "sum_list l \<le> (n::nat)"
  and "l\<noteq> []"
  and "hd l \<le> n"
  shows "sum_list (tl l) \<le> n - hd l"
proof -
  have "hd l + sum_list (tl l) = sum_list l" using assms
    by (metis list.exhaust_sel sum_list_simps(2))
  also have "... \<le> n" using assms by simp
  finally have "hd l + sum_list (tl l) \<le> n" .
  thus ?thesis by simp
qed

lemma diag_mat_length:
  shows "length (diag_mat A) = dim_row A" unfolding diag_mat_def by simp

lemma sum_list_geq_tl:
  fixes l::"'a::{comm_monoid_add, ordered_ab_semigroup_add_imp_le} list"
  assumes  "l\<noteq>[]"
  and "\<forall>j < length l. 0 \<le> l!j"
shows "sum_list (tl l) \<le> sum_list l" using assms
proof (induct l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  hence "0 \<le> a"
    by (metis length_greater_0_conv nth_Cons_0)
  have "sum_list (tl (a#l)) = sum_list l" by simp
  also have "... \<le> a + sum_list l" using \<open>0 \<le> a\<close>
    by (metis add_0 add_le_cancel_right)
  also have "... = sum_list (a#l)" by simp
  finally show ?case .
qed

lemma sum_list_geq_0:
  fixes l::"'a::{comm_monoid_add, ordered_ab_semigroup_add_imp_le} list"
  assumes  "l\<noteq>[]"
  and "\<forall>j < length l. 0 \<le> l!j"
shows "0 \<le> sum_list l" using assms
proof (induct l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  hence "0 \<le> a"
    by (metis length_greater_0_conv nth_Cons_0)
  show ?case
  proof (cases "l = []")
    case True
    hence "sum_list (a#l) = a" by simp
    then show ?thesis using \<open>0 \<le> a\<close> by simp
  next
    case False
    hence "0 \<le> sum_list l" using Cons by force
    also have "... = sum_list (tl (a#l))" by simp
    also have "... \<le> sum_list (a#l)" using sum_list_geq_tl Cons by metis
    finally show ?thesis .
  qed
qed

lemma sum_list_cong:
  assumes "length l = length m"
  and "\<forall>i < length l. l!i = m!i"
shows "sum_list l = sum_list m" using assms
proof (induct l arbitrary: m)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  hence "0 < length m" by auto
  hence "m = hd m # (tl m)" by simp
  have "sum_list (a#l) = a + sum_list l" by simp
  also have "... = hd m + sum_list l" using Cons
    by (metis \<open>0 < length m\<close> \<open>m = hd m # tl m\<close> nth_Cons_0)
  also have "... = hd m + sum_list (tl m)"
    by (metis Cons.prems(1) Cons.prems(2) \<open>m = hd m # tl m\<close>
        calculation nth_equalityI sum_list.Cons)
  also have "... = sum_list m"
    by (metis \<open>m = hd m # tl m\<close> sum_list.Cons)
  finally show ?case .
qed

lemma n_sum_sum_list:
  fixes l::"'a::{comm_monoid_add, ordered_ab_semigroup_add_imp_le} list"
  assumes "i \<le> length l"
  and "\<forall>j < length l. 0 \<le> l!j"
  shows "n_sum i l \<le> sum_list l" using assms
proof (induct i arbitrary: l)
  case 0
  then show ?case
    by (metis n_sum.simps(1) order.eq_iff sum_list_geq_0 sum_list_simps(1))
next
  case (Suc i)
  hence "1 \<le> length l" by presburger
  hence "l = hd l#(tl l)"
    by (metis hd_Cons_tl list.size(3) rel_simps(45))
  have "n_sum (Suc i) l \<le> hd l + sum_list (tl l)"
  proof -
    have "n_sum i (tl l) \<le> sum_list (tl l)"
    proof (rule Suc(1))
      show "i \<le> length (tl l)" using Suc by simp
      show "\<forall>j<length (tl l). 0 \<le> tl l ! j" using Suc
        by (metis Nitpick.size_list_simp(2) le_simps(3) nth_tl
            verit_comp_simplify1(3) zero_less_Suc)
    qed
    thus ?thesis by simp
  qed
  also have "... = sum_list l"
    by (metis \<open>l = hd l # tl l\<close> sum_list.Cons)
  finally show ?case .
qed

lemma map2_commute:
  assumes "length l = length m"
  and "\<forall>i < length l. f (l!i) (m!i) = f (m!i) (l!i)"
shows "map2 f l m = map2 f m l" using assms
proof (induct l arbitrary: m)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  hence "0 < length m" by auto
  hence "m = hd m#(tl m)" by simp
  hence "map2 f (a#l) m = f a (hd m) # (map2 f l (tl m))"
    by (metis (no_types, lifting) list.map(2) prod.simps(2) zip_Cons_Cons)
  also have "... = f (hd m) a # (map2 f l (tl m))" using Cons
    by (metis \<open>0 < length m\<close> \<open>m = hd m # tl m\<close> nth_Cons_0)
  also have "... = f (hd m) a # (map2 f (tl m) l)" using Cons
    by (metis Suc_less_eq \<open>m = hd m # tl m\<close> length_Cons nat.simps(1)
        nth_Cons_Suc)
  also have "... = map2 f m (a#l)"
    by (metis (no_types, lifting) Cons_eq_map_conv \<open>m = hd m # tl m\<close>
        prod.simps(2) zip_Cons_Cons)
  finally show ?case .
qed

lemma map2_length:
  assumes "length Al = length Bl"
  shows "length (map2 f Al Bl) = length Al" using assms by simp

end


(*<*)
theory LoweOntologicalArgument_7
imports QML
begin

nitpick_params[box=false, user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]

consts Concrete::"e\<Rightarrow>wo"
consts Abstract::"e\<Rightarrow>wo"
consts Necessary::"e\<Rightarrow>wo"
consts Contingent::"e\<Rightarrow>wo"
consts dependence::"e\<Rightarrow>e\<Rightarrow>wo" (infix "dependsOn"(*<*)100(*>*))
consts explanation::"e\<Rightarrow>e\<Rightarrow>wo" (infix "explains"(*<*)100(*>*))
consts Dependent::"e\<Rightarrow>wo"
abbreviation Independent::"e\<Rightarrow>wo" where "Independent x  \<equiv> \<^bold>\<not>(Dependent x)"

abbreviation Godlike::"e\<Rightarrow>wo" where "Godlike x \<equiv> \<^bold>\<box>Concrete x"

axiomatization where
P2: "\<lfloor>\<^bold>\<exists>x. \<^bold>\<box>Abstract x\<rfloor>" and
P3: "\<lfloor>\<^bold>\<forall>x. Abstract x \<^bold>\<rightarrow> Dependent x\<rfloor>" and
P4: "\<lfloor>\<^bold>\<forall>x. Dependent x \<^bold>\<rightarrow> (\<^bold>\<exists>y. Independent y \<^bold>\<and> x dependsOn y)\<rfloor>" and
P5: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>x. \<^bold>\<exists>y. Contingent y \<^bold>\<and> Necessary x \<^bold>\<and> y explains x)\<rfloor>"
(*>*)

subsection \<open>Modified Modal Argument II\<close>

text\<open>\noindent{We start again our interpretive process with no pre-understanding of the
concepts involved (by taking them as primitive).
We then see how their inferential role gradually becomes apparent in the process
of axiomatizing further constraints. We follow on with the adverbial reading of the expression "necessary"
as in the previous version.}\<close>

text\<open>\noindent{Another explication of the concepts of necessariness and contingency is provided below.
We think that this explication, in comparison to the previous one, better fits our intuitive
understanding of necessariness.
We now regard necessariness as being \emph{necessarily} abstract or concrete, and
explanation as the inverse relation of dependence, as before.}\<close>
axiomatization where
Necessary_expl: "\<lfloor>\<^bold>\<forall>x. Necessary x \<^bold>\<leftrightarrow> \<^bold>\<box>(Abstract x \<^bold>\<or> Concrete x)\<rfloor>" and
Contingent_expl: "\<lfloor>\<^bold>\<forall>x. Contingent x \<^bold>\<leftrightarrow> \<^bold>\<not>Necessary x\<rfloor>" and
Explanation_expl: "\<lfloor>\<^bold>\<forall>x y. y explains x \<^bold>\<leftrightarrow> x dependsOn y\<rfloor>"

text\<open>\noindent{These constraints are, however, not enough to ensure the argument's validity as confirmed by Nitpick.}\<close>
theorem C10: "\<lfloor>\<^bold>\<exists>x. Godlike x\<rfloor>"
  nitpick oops \<comment> \<open>Countermodel found\<close>

text\<open>\noindent{After some iterations, we see that, by giving a more satisfactory explication of the concept
of necesariness, we are also required to assume the essentiality of abstractness
(as we did in a former iteration) and to restrict the accessibility relation by enforcing its symmetry
(i.e. assuming the modal axiom \emph{B}).}\<close>
axiomatization where
  abstractness_essential: "\<lfloor>\<^bold>\<forall>x. Abstract x \<^bold>\<rightarrow> \<^bold>\<box>Abstract x\<rfloor>" and
  B_Axiom:  "symmetric R"

theorem C10: "\<lfloor>\<^bold>\<exists>x. Godlike x\<rfloor>" using Contingent_expl Explanation_expl
    Necessary_expl P2 P3 P4 P5 abstractness_essential B_Axiom by metis

text\<open>\noindent{We have chosen to terminate, after this series of iterations, our interpretive endeavor.
In each of the previous versions we have illustrated how our understanding of the concepts of
necessity/contingency, explanation/dependence and abstractness/concreteness has gradually evolved
thanks to the kind of iterative hypothetico-deductive method which has been made possible
by the real-time feedback provided by Isabelle's automated proving tools.}\<close>

(*<*)
(* We carry out our `sanity checks' as usual.*)
lemma True nitpick[satisfy, user_axioms] oops (* model found: axioms are consistent *)
lemma "\<lfloor>\<^bold>\<forall>x. Necessary x\<rfloor>" nitpick[user_axioms] oops \<comment> \<open>counter-model found: argument is not trivial\<close>
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>" nitpick[user_axioms] oops (* counter-model found: modal collapse is not valid *)

end
(*>*)