theory Trees2_1
imports Main
begin

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

value "Leaf 1"
value "Node 2 (Leaf 1) (Leaf 2)"

primrec preOrder :: "'a tree \<Rightarrow> 'a list"
where
  "preOrder (Leaf a) = [a]"
| "preOrder (Node a b c) = (a # preOrder b) @ preOrder c"

value "preOrder (Leaf 1)"
value "preOrder (Node 2 (Leaf 1) (Leaf 3))"

primrec postOrder :: "'a tree \<Rightarrow> 'a list"
where
  "postOrder (Leaf a) = [a]"
| "postOrder (Node a b c) = (postOrder b) @ (postOrder c) @ [a]"

value "postOrder (Leaf 1)"
value "postOrder (Node 2 (Leaf 1) (Leaf 3))"

primrec inOrder :: "'a tree \<Rightarrow> 'a list"
where
  "inOrder (Leaf a) = [a]"
| "inOrder (Node a b c) = (inOrder b) @ [a] @ (inOrder c)"

value "inOrder (Leaf 1)"
value "inOrder (Node 2 (Leaf 1) (Leaf 3))"

primrec mirror :: "'a tree \<Rightarrow> 'a tree"
where
  "mirror (Leaf a) = (Leaf a)"
| "mirror (Node a b c) = Node a (mirror c) (mirror b)"

value "mirror (Leaf 1)"
value "mirror (Node 2 (Leaf 1) (Leaf 3))"

theorem "preOrder (mirror t) = rev (postOrder t)"
  apply (induct t)
  apply auto
done

theorem "postOrder (mirror t) = rev (preOrder t)"
  apply (induct t)
  apply auto
done

theorem "inOrder (mirror t) = rev (inOrder t)"
  apply (induct t)
  apply auto
done

primrec root :: "'a tree \<Rightarrow> 'a"
where
  "root (Leaf a) = a"
| "root (Node a b c) = a"

value "root (Leaf 1)"
value "root (Node 2 (Leaf 1) (Leaf 3))"

primrec leftmost :: "'a tree \<Rightarrow> 'a"
where
  "leftmost (Leaf a) = a"
| "leftmost (Node a b c) = leftmost b"

value "leftmost (Leaf 1)"
value "leftmost (Node 2 (Leaf 1) (Leaf 3))"

primrec rightmost :: "'a tree \<Rightarrow> 'a"
where
  "rightmost (Leaf a) = a"
| "rightmost (Node a b c) = rightmost c"

value "rightmost (Leaf 1)"
value "rightmost (Node 2 (Leaf 1) (Leaf 3))"

theorem "last (inOrder t) = rightmost t"
  apply (induct t)
  apply simp
  (* inOrder t2 = [] \<longrightarrow> a = rightmost t2
        can be proven by showing inOrder t2 \<noteq> [] *)
  apply simp
done

theorem "hd (inOrder xt) = leftmost xt"
  apply (induct xt)
  apply simp
  apply simp
done

theorem "hd (preOrder xt) = last (postOrder xt)"
  apply (induct xt)
  apply simp
  apply simp
done

theorem "hd (preOrder xt) = root xt"
  apply (induct xt)
  apply simp
  apply simp
done

theorem "hd (inOrder xt) = root xt"
  quickcheck
oops

theorem "last (postOrder xt) = root xt"
  apply (induct xt)
  apply simp
  apply simp
done

end


header {* Regular Expressions as Homogeneous Binary Relations *}

theory Relation_Interpretation
imports Regular_Exp
begin

primrec rel :: "('a \<Rightarrow> ('b * 'b) set) \<Rightarrow> 'a rexp \<Rightarrow> ('b * 'b) set"
where
  "rel v Zero = {}" |
  "rel v One = Id" |
  "rel v (Atom a) = v a" |
  "rel v (Plus r s) = rel v r \<union> rel v s" |
  "rel v (Times r s) = rel v r O rel v s" |
  "rel v (Star r) = (rel v r)^*"

primrec word_rel :: "('a \<Rightarrow> ('b * 'b) set) \<Rightarrow> 'a list \<Rightarrow> ('b * 'b) set"
where
  "word_rel v [] = Id"
| "word_rel v (a#as) = v a O word_rel v as"

lemma word_rel_append:
  "word_rel v w O word_rel v w' = word_rel v (w @ w')"
by (rule sym) (induct w, auto)

lemma rel_word_rel: "rel v r = (\<Union>w\<in>lang r. word_rel v w)"
proof (induct r)
  case Times thus ?case
    by (auto simp: rel_def word_rel_append conc_def relcomp_UNION_distrib relcomp_UNION_distrib2)
next
  case (Star r)
  { fix n
    have "(rel v r) ^^ n = (\<Union>w \<in> lang r ^^ n. word_rel v w)"
    proof (induct n)
      case 0 show ?case by simp
    next
      case (Suc n) thus ?case
        unfolding relpow.simps relpow_commute[symmetric]
        by (auto simp add: Star conc_def word_rel_append
          relcomp_UNION_distrib relcomp_UNION_distrib2)
    qed }

  thus ?case unfolding rel.simps
    by (force simp: rtrancl_power star_def)
qed auto

text {* Soundness: *}

end


theory sort_NMSortTDSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun half :: "Nat => Nat" where
"half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S n)) = S (half n)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun nmsorttd :: "int list => int list" where
"nmsorttd (Nil2) = Nil2"
| "nmsorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nmsorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (nmsorttd
          (take
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))
       (nmsorttd
          (drop
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster take lmerge length half drop nmsorttd and2 ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (nmsorttd x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
    File:      Dirichlet_Misc.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>Miscellaneous auxiliary facts\<close>
theory Dirichlet_Misc
  imports
    "HOL-Number_Theory.Number_Theory"
begin

lemma
  fixes a k :: nat
  assumes "a > 1" "k > 0"
  shows geometric_sum_nat_aux: "(a - 1) * (\<Sum>i<k. a ^ i) = a ^ k - 1"
    and geometric_sum_nat_dvd: "a - 1 dvd a ^ k - 1"
    and geometric_sum_nat:     "(\<Sum>i<k. a ^ i) = (a ^ k - 1) div (a - 1)"
proof -
  have "(real a - 1) * (\<Sum>i<k. real a ^ i) = real a ^ k - 1"
    using assms by (subst geometric_sum) auto
  also have "(real a - 1) * (\<Sum>i<k. real a ^ i) = real ((a - 1) * (\<Sum>i<k. a ^ i))"
    using assms by (simp add: of_nat_diff)
  also have "real a ^ k - 1 = real (a ^ k - 1)" using assms by (subst of_nat_diff) auto
  finally show *: "(a - 1) * (\<Sum>i<k. a ^ i) = a ^ k - 1" by (subst (asm) of_nat_eq_iff)
  show "a - 1 dvd a ^ k - 1" by (subst * [symmetric]) simp
  from assms show "(\<Sum>i<k. a ^ i) = (a ^ k - 1) div (a - 1)"
    by (subst * [symmetric]) simp
qed

lemma dvd_div_gt0: "d dvd n \<Longrightarrow> n > 0 \<Longrightarrow> n div d > (0::nat)"
  by auto

lemma Set_filter_insert:
  "Set.filter P (insert x A) = (if P x then insert x (Set.filter P A) else Set.filter P A)"
  by auto

lemma Set_filter_union: "Set.filter P (A \<union> B) = Set.filter P A \<union> Set.filter P B"
  by auto

lemma Set_filter_empty [simp]: "Set.filter P {} = {}"
  by auto

lemma Set_filter_image: "Set.filter P (f ` A) = f ` Set.filter (P \<circ> f) A"
  by auto

lemma Set_filter_cong [cong]:
    "(\<And>x. x \<in> A \<Longrightarrow> P x \<longleftrightarrow> Q x) \<Longrightarrow> A = B \<Longrightarrow>  Set.filter P A = Set.filter Q B"
  by auto

lemma
  assumes "finite A" "A \<noteq> {}"
  shows   card_even_subset_aux: "card {B. B \<subseteq> A \<and> even (card B)} = 2 ^ (card A - 1)"
    and   card_odd_subset_aux:  "card {B. B \<subseteq> A \<and> odd (card B)} = 2 ^ (card A - 1)"
    and   card_even_odd_subset: "card {B. B \<subseteq> A \<and> even (card B)} = card {B. B \<subseteq> A \<and> odd (card B)}"
proof -
  from assms have *: "2 * card (Set.filter (even \<circ> card) (Pow A)) = 2 ^ card A"
  proof (induction A rule: finite_ne_induct)
    case (singleton x)
    hence "Pow {x} = {{}, {x}}" by auto
    thus ?case by (simp add: Set_filter_insert)
  next
    case (insert x A)
    note fin = finite_subset[OF _ \<open>finite A\<close>]
    have "Pow (insert x A) = Pow A \<union> insert x ` Pow A" by (rule Pow_insert)
    have "Set.filter (even \<circ> card) (Pow (insert x A)) =
            Set.filter (even \<circ> card) (Pow A) \<union>
            insert x ` Set.filter (even \<circ> card \<circ> insert x) (Pow A)"
      unfolding Pow_insert Set_filter_union Set_filter_image by blast
    also have "Set.filter (even \<circ> card \<circ> insert x) (Pow A) = Set.filter (odd \<circ> card) (Pow A)"
      unfolding o_def
      by (intro Set_filter_cong refl, subst card_insert_disjoint)
         (insert insert.hyps, auto dest: finite_subset)
    also have "card (Set.filter (even \<circ> card) (Pow A) \<union> insert x ` \<dots>) =
                 card (Set.filter (even \<circ> card) (Pow A)) + card (insert x ` \<dots>)"
      (is "card (?A \<union> ?B) = _")
      by (intro card_Un_disjoint finite_filter finite_imageI) (auto simp:  insert.hyps)
    also have "card ?B = card (Set.filter (odd \<circ> card) (Pow A))"
      using insert.hyps by (intro card_image inj_on_insert') auto
    also have "Set.filter (odd \<circ> card) (Pow A) = Pow A - Set.filter (even \<circ> card) (Pow A)"
      by auto
    also have "card \<dots> = card (Pow A) - card (Set.filter (even \<circ> card) (Pow A))"
      using insert.hyps by (subst card_Diff_subset) (auto simp: finite_filter)
    also have "card (Set.filter (even \<circ> card) (Pow A)) + \<dots> = card (Pow A)"
      by (intro add_diff_inverse_nat, subst not_less, rule card_mono) (insert insert.hyps, auto)
    also have "2 * \<dots> = 2 ^ card (insert x A)"
      using insert.hyps by (simp add: card_Pow)
    finally show ?case .
  qed
  from * show A: "card {B. B \<subseteq> A \<and> even (card B)} = 2 ^ (card A - 1)"
    by (cases "card A") (simp_all add: Set.filter_def)

  have "Set.filter (odd \<circ> card) (Pow A) = Pow A - Set.filter (even \<circ> card) (Pow A)" by auto
  also have "2 * card \<dots> = 2 * 2 ^ card A - 2 * card (Set.filter (even \<circ> card) (Pow A))"
    using assms by (subst card_Diff_subset) (auto intro!: finite_filter simp: card_Pow)
  also note *
  also have "2 * 2 ^ card A - 2 ^ card A = (2 ^ card A :: nat)" by simp
  finally show B: "card {B. B \<subseteq> A \<and> odd (card B)} = 2 ^ (card A - 1)"
    by (cases "card A") (simp_all add: Set.filter_def)

  from A and B show "card {B. B \<subseteq> A \<and> even (card B)} = card {B. B \<subseteq> A \<and> odd (card B)}" by simp
qed

lemma bij_betw_prod_divisors_coprime:
  assumes "coprime a (b :: nat)"
  shows   "bij_betw (\<lambda>x. fst x * snd x) ({d. d dvd a} \<times> {d. d dvd b}) {k. k dvd a * b}"
  unfolding bij_betw_def
proof
  from assms show "inj_on (\<lambda>x. fst x * snd x) ({d. d dvd a} \<times> {d. d dvd b})"
    by (auto simp: inj_on_def coprime_crossproduct_nat coprime_divisors)
  show "(\<lambda>x. fst x * snd x) ` ({d. d dvd a} \<times> {d. d dvd b}) = {k. k dvd a * b}"
  proof safe
    fix x assume "x dvd a * b"
    then obtain b' c' where "x = b' * c'" "b' dvd a" "c' dvd b"
      using division_decomp by blast
    thus "x \<in> (\<lambda>x. fst x * snd x) ` ({d. d dvd a} \<times> {d. d dvd b})" by force
  qed (insert assms, auto intro: mult_dvd_mono)
qed

lemma bij_betw_prime_power_divisors:
  assumes "prime (p :: nat)"
  shows   "bij_betw ((^) p) {..k} {d. d dvd p ^ k}"
  unfolding bij_betw_def
proof
  from assms have *: "p > 1" by (simp add: prime_gt_Suc_0_nat)
  show "inj_on ((^) p) {..k}" using assms
    by (auto simp: inj_on_def prime_gt_Suc_0_nat power_inject_exp[OF *])
  show "(^) p ` {..k} = {d. d dvd p ^ k}"
    using assms by (auto simp: le_imp_power_dvd divides_primepow_nat)
qed

lemma sum_divisors_coprime_mult:
  assumes "coprime a (b :: nat)"
  shows   "(\<Sum>d | d dvd a * b. f d) = (\<Sum>r | r dvd a. \<Sum>s | s dvd b. f (r * s))"
proof -
  have "(\<Sum>r | r dvd a. \<Sum>s | s dvd b. f (r * s)) =
          (\<Sum>z\<in>{r. r dvd a} \<times> {s. s dvd b}. f (fst z * snd z))"
    by (subst sum.cartesian_product) (simp add: case_prod_unfold)
  also have "\<dots> = (\<Sum>d | d dvd a * b. f d)"
    by (intro sum.reindex_bij_betw bij_betw_prod_divisors_coprime assms)
  finally show ?thesis ..
qed

end


theory Chapter3
imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

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

text {* A little syntax magic to write larger states compactly: *}

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"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x.0)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N i) = N i" |
  "asimp_const (V x) = V x" |
  "asimp_const (Plus a1 a2) =
     (case (asimp_const a1, asimp_const a2) of
       (N n1, N n2) \<Rightarrow> N (n1 + n2) |
       (b1, b2)     \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  by (induction a, auto split: aexp.split)

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N i1) (N i2) = N (i1 + i2)" |
  "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 a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 a2 rule: plus.induct)
              apply auto
    done

fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
  apply (induction a)
    apply (auto simp: aval_plus)
    done

(* Exercise 3.1

To show that asimp_const really folds all subexpressions of the form Plus (N
i) (N j), define a function optimal :: aexp \<Rightarrow> bool that checks that its
argument does not contain a subexpression of the form Plus (N i) (N j). Then
prove optimal (asimp_const a)

*)

fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (Plus (N _) (N _)) = False" |
  "optimal _ = True"

lemma "optimal (asimp_const a)"
  by (induction a, auto split: aexp.split)

(* Exercise 3.2 *)

fun asimp_constant_total :: "aexp \<Rightarrow> int" where
      "asimp_constant_total (N i) = i" |
      "asimp_constant_total (V x) = 0 "|
      "asimp_constant_total (Plus a1 a2) = asimp_constant_total a1 + asimp_constant_total a2"

fun asimp_remove_constants :: "aexp \<Rightarrow> aexp option" where
      "asimp_remove_constants (N i) = None" |
      "asimp_remove_constants (V x) = Some (V x)" |
      "asimp_remove_constants (Plus a1 a2) =
        (case (asimp_remove_constants a1, asimp_remove_constants a2) of
          (Some a1P, Some a2P) \<Rightarrow> Some (Plus a1P a2P) |
          (None, Some a2P) \<Rightarrow> Some a2P |
          (Some a1P, None) \<Rightarrow> Some a1P |
          (None, None) \<Rightarrow> None)"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
      "full_asimp a =
         (case (asimp_constant_total a, asimp_remove_constants a) of
            (i, None) \<Rightarrow> N i |
            (i, Some a) \<Rightarrow> (if i = 0 then a else Plus a (N i)))"

lemma "aval (full_asimp a) s = aval a s"
      apply (induction a)
        apply (auto split:  aexp.splits option.splits if_splits)
        done

(* Exercise 3.3 *)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst _ _ (N i) = N i" |
  "subst x a (V y) = (if x = y then a else V y)" |
  "subst x a (Plus a1 a2) = Plus (subst x a a1) (subst x a a2)"

(* Should evaluate to Plus (N 3) V ''y'' *)
value  "subst ''x'' (N 3) (Plus (V ''x'') (V ''y''))"

lemma aval_subst_eq: "aval (subst x a e) s = aval e (s(x:= aval a s))"
  by (induction e, auto)

lemma aval_subst_ext: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  by (auto simp: aval_subst_eq)

(* Exercise 3.4: see Exercise3p4.thy *)

(* Execise 3.5

Define a datatype aexp2 of extended arithmetic expressions that has, in
addition to the constructors of aexp, a constructor for modelling a C-like
post-increment operation x++, where x must be a variable. Define an evaluation
function 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 aexp2 and aval2 with a division operation.
Model partiality of division by changing the return type of aval2 to (val \<times>
state) option. In case of division by 0 let aval2 return None. Division on int
is the infix div

*)

datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | PostInc2 vname | Div2 aexp2 aexp2

(* sseefried: It's not mentioned in the exercise but we have to choose an order in
   which to evaluate sub expressions for Plus and Div. We choose left-to-right
   So that, for instance in the expression Plus a1 a2, a1 is first evaluated and the
   state that arises from that is passed in when evaluating a2
 *)

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
  "aval2 (N2 n) s = Some (n, s)" |
  "aval2 (V2 x) s = Some (s x, s)" |
  "aval2 (Plus2 a1 a2) s =
    (case aval2 a1 s of
       None \<Rightarrow> None |
       Some (n1, s1) \<Rightarrow>
         (case aval2 a2 s1 of
           None \<Rightarrow> None |
           Some (n2, s2) \<Rightarrow> Some (n1 + n2, s2)
         )
    )" |
  "aval2 (PostInc2 x) s = Some (s x, s (x:= s x + 1))" |
  "aval2 (Div2 a1 a2) s =
    (case aval2 a1 s of
      None \<Rightarrow> None |
      Some (n1, s1) \<Rightarrow>
        (case aval2 a2 s1 of
          None \<Rightarrow> None |
          Some (n2, s2) \<Rightarrow> (if n2 = 0 then None else Some (n1 div n2, s2))
        )
    )"

(* Exercise 3.6
The following type adds a LET construct to arithmetic ex- pressions:

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

The LET constructor introduces a local variable: the value of LET x e1 e2 is
the value of e2 in the state where x is bound to the value of e1 in the
original state. Define a function lval :: lexp \<Rightarrow> state \<Rightarrow> int that evaluates
lexp expressions. Remember s(x := i).

Define a conversion inline :: lexp \<Rightarrow>
aexp. The expression LET x e1 e2 is inlined by substituting the converted form
of e1 for x in the converted form of e2. See Exercise 3.3 for more on
substitution. Prove that inline is correct w.r.t. evaluation.

*)

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

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int"  where
  "lval (Nl i) s = i" |
  "lval (Vl x) s = s x" |
  "lval (Plusl l1 l2) s = lval l1 s + lval l2 s" |
  "lval (LET x rhs body) s = lval body (s (x := lval rhs s))"

fun inline :: "lexp \<Rightarrow> aexp" where
  "inline (Nl i) = N i" |
  "inline (Vl x) = V x" |
  "inline (Plusl l1 l2) = Plus (inline l1) (inline l2)" |
  "inline (LET x rhs body) = subst x (inline rhs) (inline body)"

value "lval (LET ''x'' (Plusl (Nl 1) (Nl 2)) (Plusl (Vl ''x'') (Nl 3))) (\<lambda>x.0)"
value "inline (LET ''x'' (Plusl (Nl 1) (Nl 2)) (Plusl (Vl ''x'') (Nl 3)))"

(* Wow, this one was hard. I needed to make sure that I was quantifying over an _arbitrary_
   state.

   Without "arbitrary: s" I got the following goal:

   \<And>x rhs body. aval (inline rhs) s = lval rhs s \<Longrightarrow>
                 aval (inline body) s = lval body s \<Longrightarrow>
                 aval (inline body) (s(x := lval rhs s)) = lval body (s(x := lval rhs s))

   With "arbitrary: s" the goal becomes:

   \<And>x rhs body s. (\<And>s. aval (inline rhs) s = lval rhs s) \<Longrightarrow>
                   (\<And>s. aval (inline body) s = lval body s) \<Longrightarrow>
                   aval (subst x (inline rhs) (inline body)) s = lval body (s(x := lval rhs s))

  The term "aval (subst x (inline rhs) (inline body)) s = lval body (s(x := lval rhs s))" is
  first simplified to:

  aval (inline body) (s(x := aval (inline rhs) s)) = lval body (s(x := lval rhs s))

  and then to:

  aval (inline body) (s(x := lval rhs s)) = lval body (s(x := lval rhs s))
  (by the first assumption above)

  The universal quantification on "s" in the assumptions now helps us. The second assumption
  is applied where the quantified "s" is replaced with "s(x := lval rhs s)" and hence we
  can discharge this goal.

  The book is well written. This issue was already covered in p20-21.

*)

lemma "aval (inline l) s = lval l s"
  apply (induction l arbitrary: s rule: inline.induct)
     apply (auto simp: aval_subst_eq)
    done

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
  "bval (Bc v) s       = v" |
  "bval (Not b) s      = (\<not> bval b s)" |
  "bval (And b1 b2) s  = (bval b1 s \<and> bval b2 s)" |
  "bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
  "not (Bc True) = Bc False" |
  "not (Bc False) = Bc True" |
  "not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "and (Bc True) b = b" |
  "and b (Bc True) = b" |
  "and (Bc False) b = Bc False" |
  "and b (Bc False) = Bc False" |
  "and b1 b2 = And b1 b2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "less (N n1) (N n2) = Bc (n1 < n2)" |
  "less a1 a2 = Less a1 a2"

fun bsimp :: "bexp \<Rightarrow> bexp" where
  "bsimp (Bc v) = Bc v" |
  "bsimp (Not b) = not (bsimp b)" |
  "bsimp (And b1 b2) = and (bsimp b1) (bsimp b2)" |
  "bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"

(* Exercise 3.7

Define functions Eq, Le :: aexp \<Rightarrow> aexp \<Rightarrow> bexp and
prove bval(Eqa1 a2) s = (aval a1 s = aval a2 s) and
bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)

*)

(* I've decided to make these constant-folding, but for this I will
   require some helper theorems
*)

lemma [simp]: "bval (and b1 b2) s = bval (And b1 b2) s"
  by (induction b1 b2 rule: and.induct, auto)

lemma [simp]: "bval (less a1 a2) s = bval (Less a1 a2) s"
  by (induction a1 a2 rule: less.induct, auto)

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = and (not (less a1 a2)) (not (less a2 a1))"

lemma "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  by auto

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Le a1 a2 = not (less a2 a1)"

lemma "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  by auto

(* Exercise 3.8

Consider an alternative type of boolean expressions featuring a conditional:
datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp
First define an evaluation function ifval :: ifexp \<Rightarrow> state \<Rightarrow> bool analogously to bval.
Then define two functions b2ifexp :: bexp \<Rightarrow> ifexp and if2bexp :: ifexp \<Rightarrow> bexp and
prove their correctness, i.e., that they preserve the value of an expression.

*)

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

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval (Bc2 b) s = b" |
  "ifval (If cond thn els) s = (if (ifval cond s) then (ifval thn s) else (ifval els s))" |
  "ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

fun or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "or b1 b2 = Not (And (Not b1) (Not b2))"  (* de Morgan's Law *)

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc b) = Bc2 b" |
  "b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)" |
  "b2ifexp (And b1 b2) = If (b2ifexp b1) (b2ifexp b2) (Bc2 False)" |
  "b2ifexp (Less a1 a2) = Less2 a1 a2"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp (Bc2 b) = Bc b" |
  "if2bexp (If cond thn els) =
     or (And (if2bexp cond) (if2bexp thn)) (And (Not (if2bexp cond)) (if2bexp els))" |
  "if2bexp (Less2 a1 a2) = Less a1 a2"

value "bval (if2bexp (If (Less2 (N 2) (N 2)) (Bc2 True) (Bc2 False))) (\<lambda>x.0)"

lemma "ifval (b2ifexp b) s = bval b s"
  by (induction b arbitrary: s, auto)

lemma "bval (if2bexp b) s = ifval b s"
  by (induction b arbitrary: s, auto)

(* Exercise 3.9

Define a new type of purely boolean expressions

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

where variables range over values of type bool:

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)"

Define a function is_nnf :: pbexp \<Rightarrow> bool that checks whether a boolean expression is in
NNF (negation normal form), i.e., if NOT is only applied directly to VARs. Also define a
function nnf :: pbexp \<Rightarrow> pbexp that converts a pbexp into NNF by pushing NOT inwards as much as
possible. Prove that nnf preserves the value (pbval (nnf b) s = pbval b s) and returns
an NNF (is_nnf (nnf b)).

An expression is in DNF (disjunctive normal form) if it is in NNF and if no
OR occurs below an AND. Define a corresponding test is_dnf :: pbexp \<Rightarrow> bool. An NNF can be
converted into a DNF in a bottom-up manner. The critical case is the conversion of AND b1 b2.
Having converted b1 and b2, apply distributivity of AND over OR.

Define a conversion function dnf_of_nnf :: pbexp \<Rightarrow> pbexp from NNF to DNF.

Prove that your function preserves the value (pbval (dnf_of_nnf b) s = pbval b s) and
converts an NNF into a DNF (is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b))

*)

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

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)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
  "is_nnf (VAR _) = True" |
  "is_nnf (NOT (VAR _)) = True" |
  "is_nnf (NOT b)       = False" |
  "is_nnf (AND b1 b2) = (is_nnf b1 \<and> is_nnf b2)" |
  "is_nnf (OR b1 b2) = (is_nnf b1 \<and> is_nnf b2)"

value "is_nnf (NOT (AND (VAR ''x'') (VAR ''y'')))"
value "is_nnf (AND (AND (NOT (VAR ''x'')) (VAR ''y'')) (OR (VAR ''z'') (NOT (VAR ''a'' ))))"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
  "nnf (VAR x) = VAR x" |
  "nnf (AND b1 b2) = AND (nnf b1) (nnf b2)" |
  "nnf (OR b1 b2) = OR (nnf b1) (nnf b2)" |
  "nnf (NOT (VAR x)) = NOT (VAR x)" |
  "nnf (NOT (NOT b)) = nnf b" |
  "nnf (NOT (AND b1 b2)) = OR (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (NOT (OR b1 b2)) = AND (nnf (NOT b1)) (nnf (NOT b2))"

value "nnf (NOT (OR (NOT (AND (VAR ''x'') (VAR ''y''))) (VAR ''z'')))"

lemma "is_nnf (nnf b)"
  by (induction b rule: nnf.induct, auto)

lemma "pbval (nnf b) s = pbval b s"
  by (induction b rule: nnf.induct, auto)

fun is_dnf :: "pbexp \<Rightarrow> bool"
and no_ors :: "pbexp \<Rightarrow> bool" where
  "is_dnf (VAR _)     = True" |
  "is_dnf (NOT b)     = is_nnf (NOT b)" |
  "is_dnf (AND b1 b2) = (no_ors b1 \<and> no_ors b2 \<and> is_dnf b1 \<and> is_dnf b2)" |
  "is_dnf (OR  b1 b2) = (is_dnf b1 \<and> is_dnf b2)" |

  "no_ors (VAR _)     = True" |
  "no_ors (NOT b)     = no_ors b" |
  "no_ors (AND b1 b2) = (no_ors b1 \<and> no_ors b2)" |
  "no_ors (OR _ _)    = False"

(* left distribute AND A (OR B C)" *)
fun dist :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
  "dist a (OR b c)        = OR (dist a b) (dist a c)" |
  "dist (OR a b) c        = OR (dist a c) (dist b c)" |
  "dist a b               = AND a b"

 value "dist (VAR ''a'') (OR (OR (VAR ''x'') (VAR ''y'')) (VAR ''z''))"

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf (VAR x) = VAR x" |
  "dnf_of_nnf (NOT b) = NOT b" |
  "dnf_of_nnf (OR b1 b2)  = OR (dnf_of_nnf b1) (dnf_of_nnf b2)" |
  "dnf_of_nnf (AND b1 b2) = dist (dnf_of_nnf b1) (dnf_of_nnf b2)"

value "is_dnf (AND (AND (OR (VAR ''x'') (VAR ''y'')) (VAR ''z'')) (VAR ''a''))"
value "dnf_of_nnf (nnf (NOT (OR (VAR ''x'') (AND (VAR ''y'') (VAR ''z'')))))"

value "dnf_of_nnf (AND (OR (VAR ''x1'') (VAR ''y1'')) (OR (VAR ''x2'') (VAR ''y2'')))"

value "dnf_of_nnf (AND (AND (OR (VAR ''x1'') (VAR ''y1'')) (OR (VAR ''x2'') (VAR ''y2''))) (OR (VAR ''x3'') (VAR ''y3'')))"

value "dnf_of_nnf (AND (OR (OR (VAR ''x'') (VAR ''y'')) (VAR ''z'')) (VAR ''a''))"

(* The order of the equality matters! *)
lemma dist_AND_eq: "pbval (dist a b) s = pbval (AND a b) s"
  by (induction a b rule: dist.induct, auto)

lemma  "pbval (dnf_of_nnf b) s = pbval b s"
  by (induction b rule: dnf_of_nnf.induct, auto simp: dist_AND_eq)

(* This is true because v must be a VAR *)
lemma no_ors_in_NOT_if_nnf: "is_nnf (NOT v) \<Longrightarrow> no_ors v"
  by (induction v, auto)

lemma dnf_dist: "is_dnf a \<Longrightarrow> is_dnf b \<Longrightarrow> is_dnf (dist a b)"
  by (induction a b rule: dist.induct, auto simp: no_ors_in_NOT_if_nnf)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  by  (induction b rule: dnf_of_nnf.induct, auto simp: dnf_dist)

(* End of Exercise 3.9 *)

end


theory Chapter17
imports DeBruijnEnvironment
begin

datatype expr =
  Var var
| Lam expr
| Appl expr expr

primrec insert :: "var => expr => expr"
where "insert n (Var v) = Var (incr n v)"
    | "insert n (Lam e) = Lam (insert (next n) e)"
    | "insert n (Appl e1 e2) = Appl (insert n e1) (insert n e2)"

primrec subst :: "expr => var => expr => expr"
where "subst e' n (Var v) = (if v = n then e' else Var (subr n v))"
    | "subst e' n (Lam e) = Lam (subst (insert first e') (next n) e)"
    | "subst e' n (Appl e1 e2) = Appl (subst e' n e1) (subst e' n e2)"

lemma [simp]: "subst e' n (insert n e) = e"
by (induction e arbitrary: e' n, simp_all)

primrec is_ok :: "unit env => expr => bool"
where "is_ok del (Var x) = (lookup del x = Some ())"
    | "is_ok del (Lam e) = is_ok (extend del ()) e"
    | "is_ok del (Appl e1 e2) = (is_ok del e1 & is_ok del e2)"

lemma [simp]: "is_ok gam e ==> n in gam ==> is_ok (extend_at n gam ()) (insert n e)"
by (induction e arbitrary: n gam, fastforce+)

lemma [simp]: "is_ok (extend_at n gam ()) e ==> n in gam ==> is_ok gam e' ==>
                  is_ok gam (subst e' n e)"
by (induction e arbitrary: n gam e', fastforce+)

primrec is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val (Lam e) = True"
    | "is_val (Appl e1 e2) = False"

inductive eval :: "expr => expr => bool"
where eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Appl e1 e2) (Appl e1 e2')"
    | eval_appl_3 [simp]: "is_val e2 ==> eval (Appl (Lam e1) e2) (subst e2 first e1)"

theorem preservation: "eval e e' ==> is_ok del e ==> is_ok del e'"
by (induction e e' rule: eval.induct, fastforce+)

theorem progress: "is_ok del e ==> del = empty_env ==> is_val e | (EX e'. eval e e')"
proof (induction e)
case Var
  thus ?case by simp
next case Lam
  thus ?case by simp
next case Appl
  thus ?case by (metis eval.intros expr.exhaust is_ok.simps(3) is_val.simps(1) is_val.simps(3))
qed

end


(*  Title:      CTT/Arith.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>Elementary arithmetic\<close>

theory Arith
  imports Bool
begin

subsection \<open>Arithmetic operators and their definitions\<close>

definition add :: "[i,i]\<Rightarrow>i"   (infixr "#+" 65)
  where "a#+b \<equiv> rec(a, b, \<lambda>u v. succ(v))"

definition diff :: "[i,i]\<Rightarrow>i"   (infixr "-" 65)
  where "a-b \<equiv> rec(b, a, \<lambda>u v. rec(v, 0, \<lambda>x y. x))"

definition absdiff :: "[i,i]\<Rightarrow>i"   (infixr "|-|" 65)
  where "a|-|b \<equiv> (a-b) #+ (b-a)"

definition mult :: "[i,i]\<Rightarrow>i"   (infixr "#*" 70)
  where "a#*b \<equiv> rec(a, 0, \<lambda>u v. b #+ v)"

definition mod :: "[i,i]\<Rightarrow>i"   (infixr "mod" 70)
  where "a mod b \<equiv> rec(a, 0, \<lambda>u v. rec(succ(v) |-| b, 0, \<lambda>x y. succ(v)))"

definition div :: "[i,i]\<Rightarrow>i"   (infixr "div" 70)
  where "a div b \<equiv> rec(a, 0, \<lambda>u v. rec(succ(u) mod b, succ(v), \<lambda>x y. v))"

lemmas arith_defs = add_def diff_def absdiff_def mult_def mod_def div_def

subsection \<open>Proofs about elementary arithmetic: addition, multiplication, etc.\<close>

subsubsection \<open>Addition\<close>

text \<open>Typing of \<open>add\<close>: short and long versions.\<close>

lemma add_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #+ b : N"
  unfolding arith_defs by typechk

lemma add_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a #+ b = c #+ d : N"
  unfolding arith_defs by equal

text \<open>Computation for \<open>add\<close>: 0 and successor cases.\<close>

lemma addC0: "b:N \<Longrightarrow> 0 #+ b = b : N"
  unfolding arith_defs by rew

lemma addC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) #+ b = succ(a #+ b) : N"
  unfolding arith_defs by rew

subsubsection \<open>Multiplication\<close>

text \<open>Typing of \<open>mult\<close>: short and long versions.\<close>

lemma mult_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #* b : N"
  unfolding arith_defs by (typechk add_typing)

lemma mult_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a #* b = c #* d : N"
  unfolding arith_defs by (equal add_typingL)

text \<open>Computation for \<open>mult\<close>: 0 and successor cases.\<close>

lemma multC0: "b:N \<Longrightarrow> 0 #* b = 0 : N"
  unfolding arith_defs by rew

lemma multC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) #* b = b #+ (a #* b) : N"
  unfolding arith_defs by rew

subsubsection \<open>Difference\<close>

text \<open>Typing of difference.\<close>

lemma diff_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a - b : N"
  unfolding arith_defs by typechk

lemma diff_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a - b = c - d : N"
  unfolding arith_defs by equal

text \<open>Computation for difference: 0 and successor cases.\<close>

lemma diffC0: "a:N \<Longrightarrow> a - 0 = a : N"
  unfolding arith_defs by rew

text \<open>Note: \<open>rec(a, 0, \<lambda>z w.z)\<close> is \<open>pred(a).\<close>\<close>

lemma diff_0_eq_0: "b:N \<Longrightarrow> 0 - b = 0 : N"
  unfolding arith_defs
  apply (NE b)
    apply hyp_rew
  done

text \<open>
  Essential to simplify FIRST!!  (Else we get a critical pair)
  \<open>succ(a) - succ(b)\<close> rewrites to \<open>pred(succ(a) - b)\<close>.
\<close>
lemma diff_succ_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) - succ(b) = a - b : N"
  unfolding arith_defs
  apply hyp_rew
  apply (NE b)
    apply hyp_rew
  done

subsection \<open>Simplification\<close>

lemmas arith_typing_rls = add_typing mult_typing diff_typing
  and arith_congr_rls = add_typingL mult_typingL diff_typingL

lemmas congr_rls = arith_congr_rls intrL2_rls elimL_rls

lemmas arithC_rls =
  addC0 addC_succ
  multC0 multC_succ
  diffC0 diff_0_eq_0 diff_succ_succ

ML \<open>
  structure Arith_simp = TSimpFun(
    val refl = @{thm refl_elem}
    val sym = @{thm sym_elem}
    val trans = @{thm trans_elem}
    val refl_red = @{thm refl_red}
    val trans_red = @{thm trans_red}
    val red_if_equal = @{thm red_if_equal}
    val default_rls = @{thms arithC_rls comp_rls}
    val routine_tac = routine_tac @{thms arith_typing_rls routine_rls}
  )

  fun arith_rew_tac ctxt prems =
    make_rew_tac ctxt (Arith_simp.norm_tac ctxt (@{thms congr_rls}, prems))

  fun hyp_arith_rew_tac ctxt prems =
    make_rew_tac ctxt
      (Arith_simp.cond_norm_tac ctxt (prove_cond_tac ctxt, @{thms congr_rls}, prems))
\<close>

method_setup arith_rew = \<open>
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (arith_rew_tac ctxt ths))
\<close>

method_setup hyp_arith_rew = \<open>
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD (hyp_arith_rew_tac ctxt ths))
\<close>

subsection \<open>Addition\<close>

text \<open>Associative law for addition.\<close>

text \<open>Commutative law for addition.  Can be proved using three inductions.
  Must simplify after first induction!  Orientation of rewrites is delicate.\<close>
lemma add_commute: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #+ b = b #+ a : N"
  apply (NE a)
    apply hyp_arith_rew
   apply (rule sym_elem)
   prefer 2
   apply (NE b)
     prefer 4
     apply (NE b)
       apply hyp_arith_rew
  done

subsection \<open>Multiplication\<close>

text \<open>Right annihilation in product.\<close>
lemma mult_0_right: "a:N \<Longrightarrow> a #* 0 = 0 : N"
  apply (NE a)
    apply hyp_arith_rew
  done

text \<open>Right successor law for multiplication.\<close>
lemma mult_succ_right: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #* succ(b) = a #+ (a #* b) : N"
  apply (NE a)
    apply (hyp_arith_rew add_assoc [THEN sym_elem])
  apply (assumption | rule add_commute mult_typingL add_typingL intrL_rls refl_elem)+
  done

text \<open>Commutative law for multiplication.\<close>
lemma mult_commute: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a #* b = b #* a : N"
  apply (NE a)
    apply (hyp_arith_rew mult_0_right mult_succ_right)
  done

text \<open>Addition distributes over multiplication.\<close>
lemma add_mult_distrib: "\<lbrakk>a:N; b:N; c:N\<rbrakk> \<Longrightarrow> (a #+ b) #* c = (a #* c) #+ (b #* c) : N"
  apply (NE a)
    apply (hyp_arith_rew add_assoc [THEN sym_elem])
  done

text \<open>Associative law for multiplication.\<close>
lemma mult_assoc: "\<lbrakk>a:N; b:N; c:N\<rbrakk> \<Longrightarrow> (a #* b) #* c = a #* (b #* c) : N"
  apply (NE a)
    apply (hyp_arith_rew add_mult_distrib)
  done

subsection \<open>Difference\<close>

text \<open>
  Difference on natural numbers, without negative numbers
  \<^item> \<open>a - b = 0\<close>  iff  \<open>a \<le> b\<close>
  \<^item> \<open>a - b = succ(c)\<close> iff \<open>a > b\<close>
\<close>

lemma diff_self_eq_0: "a:N \<Longrightarrow> a - a = 0 : N"
  apply (NE a)
    apply hyp_arith_rew
  done

lemma add_0_right: "\<lbrakk>c : N; 0 : N; c : N\<rbrakk> \<Longrightarrow> c #+ 0 = c : N"
  by (rule addC0 [THEN [3] add_commute [THEN trans_elem]])

text \<open>
  Addition is the inverse of subtraction: if \<open>b \<le> x\<close> then \<open>b #+ (x - b) = x\<close>.
  An example of induction over a quantified formula (a product).
  Uses rewriting with a quantified, implicative inductive hypothesis.
\<close>
schematic_goal add_diff_inverse_lemma:
  "b:N \<Longrightarrow> ?a : \<Prod>x:N. Eq(N, b-x, 0) \<longrightarrow> Eq(N, b #+ (x-b), x)"
  apply (NE b)
    \<comment> \<open>strip one "universal quantifier" but not the "implication"\<close>
    apply (rule_tac [3] intr_rls)
    \<comment> \<open>case analysis on \<open>x\<close> in \<open>succ(u) \<le> x \<longrightarrow> succ(u) #+ (x - succ(u)) = x\<close>\<close>
     prefer 4
     apply (NE x)
       apply assumption
    \<comment> \<open>Prepare for simplification of types -- the antecedent \<open>succ(u) \<le> x\<close>\<close>
      apply (rule_tac [2] replace_type)
       apply (rule_tac [1] replace_type)
        apply arith_rew
    \<comment> \<open>Solves first 0 goal, simplifies others.  Two sugbgoals remain.
    Both follow by rewriting, (2) using quantified induction hyp.\<close>
   apply intr \<comment> \<open>strips remaining \<open>\<Prod>\<close>s\<close>
    apply (hyp_arith_rew add_0_right)
  apply assumption
  done

text \<open>
  Version of above with premise \<open>b - a = 0\<close> i.e. \<open>a \<ge> b\<close>.
  Using @{thm ProdE} does not work -- for \<open>?B(?a)\<close> is ambiguous.
  Instead, @{thm add_diff_inverse_lemma} states the desired induction scheme;
  the use of \<open>THEN\<close> below instantiates Vars in @{thm ProdE} automatically.
\<close>
lemma add_diff_inverse: "\<lbrakk>a:N; b:N; b - a = 0 : N\<rbrakk> \<Longrightarrow> b #+ (a-b) = a : N"
  apply (rule EqE)
  apply (rule add_diff_inverse_lemma [THEN ProdE, THEN ProdE])
    apply (assumption | rule EqI)+
  done

subsection \<open>Absolute difference\<close>

text \<open>Typing of absolute difference: short and long versions.\<close>

lemma absdiff_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a |-| b : N"
  unfolding arith_defs by typechk

lemma absdiff_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a |-| b = c |-| d : N"
  unfolding arith_defs by equal

lemma absdiff_self_eq_0: "a:N \<Longrightarrow> a |-| a = 0 : N"
  unfolding absdiff_def by (arith_rew diff_self_eq_0)

lemma absdiffC0: "a:N \<Longrightarrow> 0 |-| a = a : N"
  unfolding absdiff_def by hyp_arith_rew

lemma absdiff_succ_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> succ(a) |-| succ(b)  =  a |-| b : N"
  unfolding absdiff_def by hyp_arith_rew

text \<open>Note how easy using commutative laws can be?  ...not always...\<close>
lemma absdiff_commute: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a |-| b = b |-| a : N"
  unfolding absdiff_def
  apply (rule add_commute)
   apply (typechk diff_typing)
  done

text \<open>If \<open>a + b = 0\<close> then \<open>a = 0\<close>. Surprisingly tedious.\<close>
schematic_goal add_eq0_lemma: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> ?c : \<Prod>u: Eq(N,a#+b,0) .  Eq(N,a,0)"
  apply (NE a)
    apply (rule_tac [3] replace_type)
     apply arith_rew
  apply intr  \<comment> \<open>strips remaining \<open>\<Prod>\<close>s\<close>
   apply (rule_tac [2] zero_ne_succ [THEN FE])
     apply (erule_tac [3] EqE [THEN sym_elem])
    apply (typechk add_typing)
  done

text \<open>
  Version of above with the premise \<open>a + b = 0\<close>.
  Again, resolution instantiates variables in @{thm ProdE}.
\<close>
lemma add_eq0: "\<lbrakk>a:N; b:N; a #+ b = 0 : N\<rbrakk> \<Longrightarrow> a = 0 : N"
  apply (rule EqE)
  apply (rule add_eq0_lemma [THEN ProdE])
    apply (rule_tac [3] EqI)
    apply typechk
  done

text \<open>Here is a lemma to infer \<open>a - b = 0\<close> and \<open>b - a = 0\<close> from \<open>a |-| b = 0\<close>, below.\<close>
schematic_goal absdiff_eq0_lem:
  "\<lbrakk>a:N; b:N; a |-| b = 0 : N\<rbrakk> \<Longrightarrow> ?a : \<Sum>v: Eq(N, a-b, 0) . Eq(N, b-a, 0)"
  apply (unfold absdiff_def)
  apply intr
   apply eqintr
   apply (rule_tac [2] add_eq0)
     apply (rule add_eq0)
       apply (rule_tac [6] add_commute [THEN trans_elem])
         apply (typechk diff_typing)
  done

text \<open>If \<open>a |-| b = 0\<close> then \<open>a = b\<close>
  proof: \<open>a - b = 0\<close> and \<open>b - a = 0\<close>, so \<open>b = a + (b - a) = a + 0 = a\<close>.
\<close>
lemma absdiff_eq0: "\<lbrakk>a |-| b = 0 : N; a:N; b:N\<rbrakk> \<Longrightarrow> a = b : N"
  apply (rule EqE)
  apply (rule absdiff_eq0_lem [THEN SumE])
     apply eqintr
  apply (rule add_diff_inverse [THEN sym_elem, THEN trans_elem])
     apply (erule_tac [3] EqE)
    apply (hyp_arith_rew add_0_right)
  done

subsection \<open>Remainder and Quotient\<close>

text \<open>Typing of remainder: short and long versions.\<close>

lemma mod_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a mod b : N"
  unfolding mod_def by (typechk absdiff_typing)

lemma mod_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a mod b = c mod d : N"
  unfolding mod_def by (equal absdiff_typingL)

text \<open>Computation for \<open>mod\<close>: 0 and successor cases.\<close>

lemma modC0: "b:N \<Longrightarrow> 0 mod b = 0 : N"
  unfolding mod_def by (rew absdiff_typing)

lemma modC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow>
  succ(a) mod b = rec(succ(a mod b) |-| b, 0, \<lambda>x y. succ(a mod b)) : N"
  unfolding mod_def by (rew absdiff_typing)

text \<open>Typing of quotient: short and long versions.\<close>

lemma div_typing: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a div b : N"
  unfolding div_def by (typechk absdiff_typing mod_typing)

lemma div_typingL: "\<lbrakk>a = c:N; b = d:N\<rbrakk> \<Longrightarrow> a div b = c div d : N"
  unfolding div_def by (equal absdiff_typingL mod_typingL)

lemmas div_typing_rls = mod_typing div_typing absdiff_typing

text \<open>Computation for quotient: 0 and successor cases.\<close>

lemma divC0: "b:N \<Longrightarrow> 0 div b = 0 : N"
  unfolding div_def by (rew mod_typing absdiff_typing)

lemma divC_succ: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow>
  succ(a) div b = rec(succ(a) mod b, succ(a div b), \<lambda>x y. a div b) : N"
  unfolding div_def by (rew mod_typing)

text \<open>Version of above with same condition as the \<open>mod\<close> one.\<close>
lemma divC_succ2: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow>
  succ(a) div b =rec(succ(a mod b) |-| b, succ(a div b), \<lambda>x y. a div b) : N"
  apply (rule divC_succ [THEN trans_elem])
    apply (rew div_typing_rls modC_succ)
  apply (NE "succ (a mod b) |-|b")
    apply (rew mod_typing div_typing absdiff_typing)
  done

text \<open>For case analysis on whether a number is 0 or a successor.\<close>
lemma iszero_decidable: "a:N \<Longrightarrow> rec(a, inl(eq), \<lambda>ka kb. inr(<ka, eq>)) :
  Eq(N,a,0) + (\<Sum>x:N. Eq(N,a, succ(x)))"
  apply (NE a)
    apply (rule_tac [3] PlusI_inr)
     apply (rule_tac [2] PlusI_inl)
      apply eqintr
     apply equal
  done

text \<open>Main Result. Holds when \<open>b\<close> is 0 since \<open>a mod 0 = a\<close> and \<open>a div 0 = 0\<close>.\<close>
lemma mod_div_equality: "\<lbrakk>a:N; b:N\<rbrakk> \<Longrightarrow> a mod b #+ (a div b) #* b = a : N"
  apply (NE a)
    apply (arith_rew div_typing_rls modC0 modC_succ divC0 divC_succ2)
  apply (rule EqE)
    \<comment> \<open>case analysis on \<open>succ(u mod b) |-| b\<close>\<close>
  apply (rule_tac a1 = "succ (u mod b) |-| b" in iszero_decidable [THEN PlusE])
    apply (erule_tac [3] SumE)
    apply (hyp_arith_rew div_typing_rls modC0 modC_succ divC0 divC_succ2)
    \<comment> \<open>Replace one occurrence of \<open>b\<close> by \<open>succ(u mod b)\<close>. Clumsy!\<close>
  apply (rule add_typingL [THEN trans_elem])
    apply (erule EqE [THEN absdiff_eq0, THEN sym_elem])
     apply (rule_tac [3] refl_elem)
     apply (hyp_arith_rew div_typing_rls)
  done

end


section \<open>Kleene Algebra\<close>

theory KA_iso
  imports Main

begin

notation times (infixl "\<cdot>" 70)

subsection \<open>Semilattices\<close>

class sup_semilattice = comm_monoid_add + ord +
  assumes add_idem [simp]: "x + x = x"
  and order_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and strict_order_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

begin

subclass order
  apply unfold_locales
  unfolding order_def strict_order_def
  using add_commute apply fastforce
  apply simp
  apply (metis add_assoc)
  by (simp add: add_commute)

lemma zero_least: "0 \<le> x"
  by (simp add: local.order_def)

lemma add_isor: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
  by (smt (z3) add_assoc add_commute local.add_idem local.order_def)

lemma add_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x + x' \<le> y + y'"
  by (metis add_commute add_isor local.dual_order.trans)

lemma add_ubl: "x \<le> x + y"
  by (metis add_assoc local.add_idem local.order_def)

lemma add_ubr: "y \<le> x + y"
  using add_commute add_ubl by fastforce

lemma add_least: "x \<le> z \<Longrightarrow> y \<le> z \<Longrightarrow> x + y \<le> z"
  by (simp add: add_assoc local.order_def)

lemma add_lub: "(x + y \<le> z) = (x \<le> z \<and> y \<le> z)"
  using add_least add_ubl add_ubr dual_order.trans by blast

end

subsection \<open>Semirings and Dioids\<close>

class semiring = comm_monoid_add + monoid_mult +
  assumes distl: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
  and distr: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

class dioid = semiring + sup_semilattice

begin

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis local.distl local.order_def)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distr order_def)

lemma mult_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x \<cdot> x' \<le> y \<cdot> y'"
  using order_trans mult_isol mult_isor by blast

lemma power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  apply (induct i)
  apply (simp add: local.add_lub)
  by (smt (z3) local.add_lub local.dual_order.trans local.power.power_Suc mult_assoc mult_isol)

lemma power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  apply (induct i)
  apply (simp add: local.add_lub)
  by (smt (verit, ccfv_SIG) local.add_lub local.dual_order.trans local.power_Suc2 mult_assoc mult_isor)

end

subsection \<open>Kleene Algebras\<close>

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

subsection \<open>Relational Model of Kleene algebra\<close>

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)"
  by unfold_locales auto

lemma power_is_relpow: "rel_d.power R i = R ^^ i"
  by (induct i) (simp_all add: relpow_commute)

lemma rel_star_def: "R\<^sup>* = (\<Union>i. rel_d.power R i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "R ; S\<^sup>* = (\<Union>i. R ; rel_d.power S i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "R\<^sup>* ; S = (\<Union>i. (rel_d.power R i) ; S)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

lemma rel_star_unfoldl: "Id \<union> R ; R\<^sup>* = R\<^sup>*"
  by (metis r_comp_rtrancl_eq rtrancl_unfold)

lemma rel_star_unfoldr: "Id \<union> R\<^sup>* ; R = R\<^sup>*"
  using rtrancl_unfold by blast

lemma rel_star_inductl:
  fixes R S T :: "'a rel"
  assumes "T \<union> R ; S \<subseteq> S"
  shows "R\<^sup>* ; T \<subseteq> S"
  unfolding rel_star_def
  by (metis UN_least assms rel_d.power_inductl relcomp_UNION_distrib2)

lemma rel_star_inductr: "(T::'a rel) \<union> S ; R \<subseteq> S \<Longrightarrow> T ; R\<^sup>* \<subseteq> S"
  unfolding rel_star_def by (simp add: SUP_le_iff rel_d.power_inductr relcomp_UNION_distrib)

interpretation rel_ka: kleene_algebra "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl
  by (unfold_locales, simp_all add: rel_star_unfoldl rel_star_unfoldr rel_star_inductl rel_star_inductr)

subsection \<open>State Transformer Model of Kleene Algebra\<close>

type_synonym 'a sta = "'a \<Rightarrow> 'a set"

definition eta :: "'a sta" ("\<eta>") where
  "\<eta> x = {x}"

definition nsta :: "'a sta" ("\<nu>") where
  "\<nu> x = {}"

definition kcomp :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "\<circ>\<^sub>K" 75) where
  "(f \<circ>\<^sub>K g) x = \<Union>{g y |y. y \<in> f x}"

definition kadd :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "+\<^sub>K" 65) where
  "(f +\<^sub>K g) x = f x \<union> g x"

definition kleq :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "f \<sqsubseteq> g = (\<forall>x. f x \<subseteq> g x)"

definition kle :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
  "f \<sqsubset> g = (f \<sqsubseteq> g \<and> f \<noteq> g)"

subsection \<open>Bijections between the relations and state transformers\<close>

definition r2s :: "'a rel \<Rightarrow> 'a sta" ("\<S>") where
  "\<S> R = Image R \<circ> \<eta>"

definition s2r :: "'a sta \<Rightarrow> 'a rel" ("\<R>") where
  "\<R> f = {(x,y). y \<in> f x}"

lemma r2s2r_galois: "(\<R> f = R) = (\<S> R = f)"
  by (force simp: s2r_def eta_def r2s_def)

lemma r2s_bij: "bij \<S>"
  by (metis bij_def inj_def r2s2r_galois surj_def)

lemma s2r_bij: "bij \<R>"
  by (metis bij_def inj_def r2s2r_galois surj_def)

subsection \<open>Type definition and lifting for bijections\<close>

lemma type_definition_s2r_r2s: "type_definition \<R> \<S> UNIV"
  unfolding type_definition_def by (meson iso_tuple_UNIV_I r2s2r_galois)

definition "rel_s2r R f = (R = \<R> f)"

lemma bi_unique_rel_s2r [transfer_rule]: "bi_unique rel_s2r"
  by (metis rel_s2r_def type_definition_s2r_r2s typedef_bi_unique)

lemma bi_total_rel_s2r [transfer_rule]: "bi_total rel_s2r"
  by (metis bi_total_def r2s2r_galois rel_s2r_def)

subsection \<open>Transfer functions\<close>

lemma r2s_id: "\<R> \<eta> = Id"
  unfolding s2r_def Id_def eta_def by force

lemma Id_eta_transfer [transfer_rule]: "rel_s2r Id \<eta>"
  unfolding rel_s2r_def
  by (simp add: r2s_id rel_s2r_def)

lemma r2s_zero: "\<R> \<nu> = {}"
  by (simp add: s2r_def nsta_def)

lemma emp_nsta_transfer [transfer_rule]: "rel_s2r {} \<nu>"
  by (simp add: r2s_zero rel_s2r_def)

lemma r2s_comp: "\<R> (f \<circ>\<^sub>K g) = \<R> f ; \<R> g"
  unfolding s2r_def kcomp_def by force

lemma relcomp_kcomp_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (;) (\<circ>\<^sub>K)"
  by (metis r2s_comp rel_funI rel_s2r_def)

lemma s2r_add: "\<R> (f +\<^sub>K g) = \<R> f \<union> \<R> g"
  unfolding s2r_def kadd_def by force

lemma un_kadd_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (\<union>) (+\<^sub>K)"
  by (metis rel_funI rel_s2r_def s2r_add)

lemma leq_kleq_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r (=)) (\<subseteq>) (\<sqsubseteq>)"
  unfolding kleq_def s2r_def rel_s2r_def by force

lemma le_kle_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r (=)) (\<subset>) (\<sqsubset>)"
  unfolding kle_def kleq_def s2r_def rel_s2r_def by blast

text \<open>State transformer model of Kleene algebra\<close>

interpretation sta_monm: monoid_mult "\<eta>" "(\<circ>\<^sub>K)"
  by unfold_locales (transfer, force)+

interpretation sta_di: dioid "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)"
  by unfold_locales (transfer, force)+

abbreviation "kpow \<equiv> sta_monm.power"

definition kstar :: "'a sta \<Rightarrow> 'a sta" where
  "kstar f x = (\<Union>i. kpow f i x)"

lemma r2s_pow: "rel_d.power (\<R> f) i = \<R> (kpow f i)"
  by (induct i, simp_all add: r2s_id r2s_comp)

lemma r2s_star: "\<R> (kstar f) = (\<R> f)\<^sup>*"
proof-
  {fix x y
    have "(x,y) \<in> \<R> (kstar f) = (\<exists>i. y \<in> kpow f i x)"
      by (simp add: kstar_def s2r_def)
    also have "\<dots> = ((x,y) \<in> (\<Union>i. \<R> (kpow f i)))"
      unfolding s2r_def by simp
    also have "\<dots> = ((x,y) \<in> (\<Union>i. rel_d.power (\<R> f) i))"
      using r2s_pow by fastforce
    finally have "(x,y) \<in> \<R> (kstar f) = ((x,y) \<in> (\<R> f)\<^sup>*)"
      using rel_star_def by blast}
  thus ?thesis
    by auto
qed

lemma rtrancl_kstar_transfer [transfer_rule]: "rel_fun rel_s2r rel_s2r rtrancl kstar"
  unfolding rel_fun_def rel_s2r_def
  by (simp add: r2s_star)

interpretation sta_ka: kleene_algebra "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar
  by unfold_locales (transfer, auto simp: rel_star_inductl rel_star_inductr)+

end


theory Chapter7
imports "HOL-IMP.Small_Step" (*"Short_Theory"*)
begin

text \<open>
\section*{Chapter 7}

\exercise
Define a function that computes the set of variables that are assigned to
in a command:
\<close>

fun assigned :: "com \<Rightarrow> vname set" where
(* your definition/proof here *)

text \<open>
Prove that if some variable is not assigned to in a command,
then that variable is never modified by the command:
\<close>

lemma "\<lbrakk> (c, s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
(* your definition/proof here *)

text {*
\endexercise

\exercise
Define a recursive function that determines if a command behaves like @{const SKIP}
and prove its correctness:
*}

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

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Define a recursive function
*}

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

text{*
that eliminates as many @{const SKIP}s as possible from a command. For example:
@{prop[display]"deskip (SKIP;; WHILE b DO (x::=a;; SKIP)) = WHILE b DO x::=a"}
Prove its correctness by induction on @{text c}: *}

lemma "deskip c \<sim> c"
(* your definition/proof here *)

text{*
Remember lemma @{thm[source]sim_while_cong} for the @{text WHILE} case.
\endexercise

\exercise
A small-step semantics for the evaluation of arithmetic expressions
can be defined like this:
*}

inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"(V x, s) \<leadsto> N (s x)" |
"(Plus (N i) (N j), s) \<leadsto> N (i + j)" |
(* your definition/proof here *)

text{*
Complete the definition with two rules for @{const Plus}
that model a left-to-right evaluation strategy:
reduce the first argument with @{text"\<leadsto>"} if possible,
reduce the second argument with @{text"\<leadsto>"} if the first argument is a number.
Prove that each @{text"\<leadsto>"} step preserves the value of the expression:
*}

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep.induct [split_format (complete)])
(* your definition/proof here *)

text{*
Do not use the \isacom{case} idiom but write down explicitly what you assume
and show in each case: \isacom{fix} \dots \isacom{assume} \dots \isacom{show} \dots.
\endexercise

\exercise
Prove or disprove (by giving a counterexample):
*}

lemma "IF And b\<^sub>1 b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 \<sim>
          IF b\<^sub>1 THEN IF b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 ELSE c\<^sub>2"
(* your definition/proof here *)

lemma "WHILE And b\<^sub>1 b\<^sub>2 DO c \<sim> WHILE b\<^sub>1 DO WHILE b\<^sub>2 DO c"
(* your definition/proof here *)

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or b\<^sub>1 b\<^sub>2 = Not (And (Not b\<^sub>1) (Not b\<^sub>2))"

lemma "WHILE Or b\<^sub>1 b\<^sub>2 DO c \<sim>
          WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Define a new loop construct @{text "DO c WHILE b"} (where @{text c} is
executed once before @{text b} is tested) in terms of the
existing constructs in @{typ com}:
*}

definition Do :: "com \<Rightarrow> bexp \<Rightarrow> com" ("DO _ WHILE _"  [0, 61] 61) where
(* your definition/proof here *)

text{*
Define a translation on commands that replaces all @{term "WHILE b DO c"}
by suitable commands that use @{term "DO c WHILE b"} instead:
*}

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

text{* Prove that your translation preserves the semantics: *}

lemma "dewhile c \<sim> c"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Let @{text "C :: nat \<Rightarrow> com"} be an infinite sequence of commands and
@{text "S :: nat \<Rightarrow> state"} an infinite sequence of states such that
@{prop"C(0::nat) = c;;d"} and \mbox{@{prop"\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"}}.
Then either all @{text"C n"} are of the form \mbox{@{term"c\<^sub>n;;d"}}
and it is always @{text c\<^sub>n} that is reduced or @{text c\<^sub>n} eventually becomes @{const SKIP}.
Prove
*}

lemma assumes "C 0 = c;;d" and "\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"
shows "(\<forall>n. \<exists>c\<^sub>1 c\<^sub>2. C n = c\<^sub>1;;d \<and> C(Suc n) = c\<^sub>2;;d \<and>
                         (c\<^sub>1, S n) \<rightarrow> (c\<^sub>2, S(Suc n)))
     \<or> (\<exists>k. C k = SKIP;;d)" (is "(\<forall>i. ?P i) \<or> ?Q")
(* your definition/proof here *)

text{*
\endexercise
\bigskip

For the following exercises copy theories
@{short_theory "Com"}, @{short_theory "Big_Step"} and @{short_theory "Small_Step"}
and modify them as required. Those parts of the theories
that do not contribute to the results required in the exercise can be discarded.
If there are multiple proofs of the same result, you may update any one of them.

\begin{exercise}\label{exe:IMP:REPEAT}
Extend IMP with a @{text "REPEAT c UNTIL b"} command by adding the constructor
\begin{alltt}
  Repeat com bexp   ("(REPEAT _/ UNTIL _)"  [0, 61] 61)
\end{alltt}
to datatype @{typ com}.
Adjust the definitions of big-step and small-step semantics,
the proof that the big-step semantics is deterministic and
the equivalence proof between the two semantics.
\end{exercise}

\begin{exercise}\label{exe:IMP:OR}
Extend IMP with a new command @{text "c\<^sub>1 OR c\<^sub>2"} that is a
nondeterministic choice: it may execute either @{text
"c\<^sub>1"} or @{text "c\<^sub>2"}. Add the constructor
\begin{alltt}
  Or com com   ("_ OR/ _" [60, 61] 60)
\end{alltt}
to datatype @{typ com}. Adjust the definitions of big-step
and small-step semantics, prove @{text"(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)"}
and update the equivalence proof between the two semantics.
\end{exercise}

\begin{exercise}
Extend IMP with exceptions. Add two constructors @{text THROW} and
@{text "TRY c\<^sub>1 CATCH c\<^sub>2"} to datatype @{typ com}:
\begin{alltt}
  THROW  |  Try com com   ("(TRY _/ CATCH _)"  [0, 61] 61)
\end{alltt}
Command @{text THROW} throws an exception. The only command that can
catch an execption is @{text "TRY c\<^sub>1 CATCH c\<^sub>2"}: if an execption
is thrown by @{text c\<^sub>1}, execution continues with @{text c\<^sub>2},
otherwise @{text c\<^sub>2} is ignored.
Adjust the definitions of big-step and small-step semantics as follows.

The big-step semantics is now of type @{typ "com \<times> state \<Rightarrow> com \<times> state"}.
In a big step @{text "(c,s) \<Rightarrow> (x,t)"}, @{text x} can only be @{term SKIP}
(signalling normal termination) or @{text THROW} (signalling that an exception
was thrown but not caught).

The small-step semantics is of the same type as before. There are two final
configurations now, @{term "(SKIP, t)"} and @{term "(THROW, t)"}.
Exceptions propagate upwards until an enclosing handler is found.
That is, until a configuration @{text "(TRY THROW CATCH c, s)"}
is reached and @{text THROW} can be caught.

Adjust the equivalence proof between the two semantics such that you obtain
@{text "cs \<Rightarrow> (SKIP,t)  \<longleftrightarrow>  cs \<rightarrow>* (SKIP,t)"}
and @{text "cs \<Rightarrow> (THROW,t)  \<longleftrightarrow>  cs \<rightarrow>* (THROW,t)"}.
Also revise the proof of
\noquotes{@{prop [source] "(\<exists>cs'. cs \<Rightarrow> cs')  \<longleftrightarrow>  (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"}}.
\end{exercise}
*}

end


section \<open>CCW for Nonaligned Points in the Plane\<close>
theory Counterclockwise_2D_Strict
imports Counterclockwise_Vector
begin
text \<open>\label{sec:counterclockwise2d}\<close>

subsection \<open>Determinant\<close>

type_synonym point = "real*real"

fun det3::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> real" where "det3 (xp, yp) (xq, yq) (xr, yr) =
  xp * yq + yp * xr + xq * yr - yq * xr - yp * xq - xp * yr"

lemma det3_def':
  "det3 p q r = fst p * snd q + snd p * fst r + fst q * snd r -
    snd q * fst r - snd p * fst q - fst p * snd r"
  by (cases p q r rule: prod.exhaust[case_product prod.exhaust[case_product prod.exhaust]]) auto

lemma det3_eq_det: "det3 (xa, ya) (xb, yb) (xc, yc) =
  det (vector [vector [xa, ya, 1], vector [xb, yb, 1], vector [xc, yc, 1]]::real^3^3)"
  unfolding Determinants.det_def UNIV_3
  by (auto simp: sum_over_permutations_insert
    vector_3 sign_swap_id permutation_swap_id sign_compose)

declare det3.simps[simp del]

lemma det3_self23[simp]: "det3 a b b = 0"
  and det3_self12[simp]: "det3 b b a = 0"
  by (auto simp: det3_def')

lemma
  coll_ex_scaling:
  assumes "b \<noteq> c"
  assumes d: "det3 a b c = 0"
  shows "\<exists>r. a = b + r *\<^sub>R (c - b)"
proof -
  from assms have "fst b \<noteq> fst c \<or> snd b \<noteq> snd c" by (auto simp: prod_eq_iff)
  thus ?thesis
  proof
    assume neq: "fst b \<noteq> fst c"
    with d have "snd a = ((fst a - fst b) * snd c + (fst c - fst a) * snd b) / (fst c - fst b)"
      by (auto simp: det3_def' field_simps)
    hence "snd a = ((fst a - fst b)/ (fst c - fst b)) * snd c +
      ((fst c - fst a)/ (fst c - fst b)) * snd b"
      by (simp add: add_divide_distrib)
    hence "snd a = snd b + (fst a - fst b) * snd c / (fst c - fst b) +
      ((fst c - fst a) - (fst c - fst b)) * snd b / (fst c - fst b)"
      using neq
      by (simp add: field_simps)
    hence "snd a = snd b + ((fst a - fst b) * snd c + (- fst a + fst b) * snd b) / (fst c - fst b)"
      unfolding add_divide_distrib
      by (simp add: algebra_simps)
    also
    have "(fst a - fst b) * snd c + (- fst a + fst b) * snd b = (fst a - fst b) * (snd c - snd b)"
      by (simp add: algebra_simps)
    finally have "snd a = snd b + (fst a - fst b) / (fst c - fst b) * (snd c - snd b)"
      by simp
    moreover
    hence "fst a = fst b + (fst a - fst b) / (fst c - fst b) * (fst c - fst b)"
      using neq by simp
    ultimately have "a = b + ((fst a - fst b) / (fst c - fst b)) *\<^sub>R (c - b)"
      by (auto simp: prod_eq_iff)
    thus ?thesis by blast
  next
    assume neq: "snd b \<noteq> snd c"
    with d have "fst a = ((snd a - snd b) * fst c + (snd c - snd a) * fst b) / (snd c - snd b)"
      by (auto simp: det3_def' field_simps)
    hence "fst a = ((snd a - snd b)/ (snd c - snd b)) * fst c +
      ((snd c - snd a)/ (snd c - snd b)) * fst b"
      by (simp add: add_divide_distrib)
    hence "fst a = fst b + (snd a - snd b) * fst c / (snd c - snd b) +
      ((snd c - snd a) - (snd c - snd b)) * fst b / (snd c - snd b)"
      using neq
      by (simp add: field_simps)
    hence "fst a = fst b + ((snd a - snd b) * fst c + (- snd a + snd b) * fst b) / (snd c - snd b)"
      unfolding add_divide_distrib
      by (simp add: algebra_simps)
    also
    have "(snd a - snd b) * fst c + (- snd a + snd b) * fst b = (snd a - snd b) * (fst c - fst b)"
      by (simp add: algebra_simps)
    finally have "fst a = fst b + (snd a - snd b) / (snd c - snd b) * (fst c - fst b)"
      by simp
    moreover
    hence "snd a = snd b + (snd a - snd b) / (snd c - snd b) * (snd c - snd b)"
      using neq by simp
    ultimately have "a = b + ((snd a - snd b) / (snd c - snd b)) *\<^sub>R (c - b)"
      by (auto simp: prod_eq_iff)
    thus ?thesis by blast
  qed
qed

lemma cramer: "\<not>det3 s t q = 0 \<Longrightarrow>
  (det3 t p r) = ((det3 t q r) * (det3 s t p) + (det3 t p q) * (det3 s t r))/(det3 s t q)"
  by (auto simp: det3_def' field_simps)

lemma convex_comb_dets:
  assumes "det3 p q r > 0"
  shows "s = (det3 s q r / det3 p q r) *\<^sub>R p + (det3 p s r /  det3 p q r) *\<^sub>R q +
      (det3 p q s / det3 p q r) *\<^sub>R r"
    (is "?lhs = ?rhs")
proof -
  from assms have "det3 p q r *\<^sub>R ?lhs = det3 p q r *\<^sub>R ?rhs"
    by (simp add: field_simps prod_eq_iff scaleR_add_right) (simp add: algebra_simps det3_def')
  thus ?thesis using assms by simp
qed

lemma four_points_aligned:
  assumes c: "det3 t p q = 0" "det3 t q r = 0"
  assumes distinct: "distinct5 t s p q r"
  shows "det3 t r p = 0" "det3 p q r = 0"
proof -
  from distinct have d: "p \<noteq> q" "q \<noteq> r" by (auto)
  from coll_ex_scaling[OF d(1) c(1)] obtain s1 where s1: "t = p + s1 *\<^sub>R (q - p)" by auto
  from coll_ex_scaling[OF d(2) c(2)] obtain s2 where s2: "t = q + s2 *\<^sub>R (r - q)" by auto
  from distinct s1 have ne: "1 - s1 \<noteq> 0" by auto
  from s1 s2 have "(1 - s1) *\<^sub>R p = (1 - s1 - s2) *\<^sub>R q + s2 *\<^sub>R r"
    by (simp add: algebra_simps)
  hence "(1 - s1) *\<^sub>R p /\<^sub>R (1 - s1)= ((1 - s1 - s2) *\<^sub>R q + s2 *\<^sub>R r) /\<^sub>R (1 - s1)"
    by simp
  with ne have p: "p = ((1 - s1 - s2) / (1 - s1)) *\<^sub>R q + (s2 / (1 - s1)) *\<^sub>R r"
    using ne
    by (simp add: prod_eq_iff inverse_eq_divide add_divide_distrib)
  define k1 where "k1 = (1 - s1 - s2) / (1 - s1)"
  define k2 where "k2 = s2 / (1 - s1)"
  have "det3 t r p = det3 0 (k1 *\<^sub>R q + (k2 - 1) *\<^sub>R r)
    (k1 *\<^sub>R q + (k2 - 1) *\<^sub>R r + (- s1 * (k1 - 1)) *\<^sub>R q - (s1 * k2) *\<^sub>R r)"
    unfolding s1 p k1_def[symmetric] k2_def[symmetric]
    by (simp add: algebra_simps det3_def')
  also have "- s1 * (k1 - 1) = s1 * k2"
    using ne by (auto simp: k1_def field_simps k2_def)
  also
  have "1 - k1 = k2"
    using ne
    by (auto simp: k2_def k1_def field_simps)
  have k21: "k2 - 1 = -k1"
    using ne
    by (auto simp: k2_def k1_def field_simps)
  finally have "det3 t r p = det3 0 (k1 *\<^sub>R (q - r)) ((k1 + (s1 * k2)) *\<^sub>R (q - r))"
    by (auto simp: algebra_simps)
  also have "\<dots> = 0"
    by (simp add: algebra_simps det3_def')
  finally show "det3 t r p = 0" .
  have "det3 p q r = det3 (k1 *\<^sub>R q + k2 *\<^sub>R r) q r"
    unfolding p k1_def[symmetric] k2_def[symmetric] ..
  also have "\<dots> = det3 0 (r - q) (k1 *\<^sub>R q + (-k1) *\<^sub>R r)"
    unfolding k21[symmetric]
    by (auto simp: algebra_simps det3_def')
  also have "\<dots> = det3 0 (r - q) (-k1 *\<^sub>R (r - q))"
    by (auto simp: det3_def' algebra_simps)
  also have "\<dots> = 0"
    by (auto simp: det3_def')
  finally show "det3 p q r = 0" .
qed

lemma det_identity:
  "det3 t p q * det3 t s r + det3 t q r * det3 t s p + det3 t r p * det3 t s q = 0"
  by (auto simp: det3_def' algebra_simps)

lemma det3_eq_zeroI:
  assumes "p = q + x *\<^sub>R (t - q)"
  shows "det3 q t p = 0"
  unfolding assms
  by (auto simp: det3_def' algebra_simps)

lemma det3_rotate: "det3 a b c = det3 c a b"
  by (auto simp: det3_def')

lemma det3_switch: "det3 a b c = - det3 a c b"
  by (auto simp: det3_def')

lemma det3_switch': "det3 a b c = - det3 b a c"
  by (auto simp: det3_def')

lemma det3_pos_transitive_coll:
  "det3 t s p > 0 \<Longrightarrow> det3 t s r \<ge> 0 \<Longrightarrow> det3 t p q \<ge> 0 \<Longrightarrow>
  det3 t q r > 0 \<Longrightarrow> det3 t s q = 0 \<Longrightarrow> det3 t p r > 0"
  using det_identity[of t p q s r]
  by (metis add.commute add_less_same_cancel1 det3_switch det3_switch' less_eq_real_def
    less_not_sym monoid_add_class.add.left_neutral mult_pos_pos mult_zero_left mult_zero_right)

lemma det3_pos_transitive:
  "det3 t s p > 0 \<Longrightarrow> det3 t s q \<ge> 0 \<Longrightarrow> det3 t s r \<ge> 0 \<Longrightarrow> det3 t p q \<ge> 0 \<Longrightarrow>
  det3 t q r > 0 \<Longrightarrow> det3 t p r > 0"
  apply (cases "det3 t s q \<noteq> 0")
   using cramer[of q t s p r]
   apply (force simp: det3_rotate[of q t p] det3_rotate[of p q t] det3_switch[of t p s]
     det3_switch'[of q t r] det3_rotate[of q t s] det3_rotate[of s q t]
     intro!: divide_pos_pos add_nonneg_pos)
  apply (metis det3_pos_transitive_coll)
  done

lemma det3_zero_translate_plus[simp]: "det3 (a + x) (b + x) (c + x) = 0 \<longleftrightarrow> det3 a b c = 0"
  by (auto simp: algebra_simps det3_def')

lemma det3_zero_translate_plus'[simp]: "det3 (a) (a + b) (a + c) = 0 \<longleftrightarrow> det3 0 b c = 0"
  by (auto simp: algebra_simps det3_def')

lemma
  det30_zero_scaleR1:
  "0 < e \<Longrightarrow> det3 0 xr P = 0 \<Longrightarrow> det3 0 (e *\<^sub>R xr) P = 0"
  by (auto simp: zero_prod_def algebra_simps det3_def')

lemma det3_same[simp]: "det3 a x x = 0"
  by (auto simp: det3_def')

lemma
  det30_zero_scaleR2:
  "0 < e \<Longrightarrow> det3 0 P xr = 0 \<Longrightarrow> det3 0 P (e *\<^sub>R xr) = 0"
  by (auto simp: zero_prod_def algebra_simps det3_def')

lemma det30_plus_scaled3[simp]: "det3 0 a (b + x *\<^sub>R a) = 0 \<longleftrightarrow> det3 0 a b = 0"
  by (auto simp: det3_def' algebra_simps)

lemma det30_plus_scaled2[simp]:
  shows "det3 0 (a + x *\<^sub>R a) b = 0 \<longleftrightarrow> (if x = -1 then True else det3 0 a b = 0)"
    (is "?lhs = ?rhs")
proof
  assume "det3 0 (a + x *\<^sub>R a) b = 0"
  hence "fst a * snd b * (1 + x) = fst b * snd a * (1 + x)"
    by (simp add: algebra_simps det3_def')
  thus ?rhs
    by (auto simp add: det3_def')
qed (auto simp: det3_def' algebra_simps split: if_split_asm)

lemma det30_uminus2[simp]: "det3 0 (-a) (b) = 0 \<longleftrightarrow> det3 0 a b = 0"
  and det30_uminus3[simp]: "det3 0 a (-b) = 0 \<longleftrightarrow> det3 0 a b = 0"
  by (auto simp: det3_def' algebra_simps)

lemma det30_minus_scaled3[simp]: "det3 0 a (b - x *\<^sub>R a) = 0 \<longleftrightarrow> det3 0 a b = 0"
  using det30_plus_scaled3[of a b "-x"] by simp

lemma det30_scaled_minus3[simp]: "det3 0 a (e *\<^sub>R a - b) = 0 \<longleftrightarrow> det3 0 a b = 0"
  using det30_plus_scaled3[of a "-b" e]
  by (simp add: algebra_simps)

lemma det30_minus_scaled2[simp]:
  "det3 0 (a - x *\<^sub>R a) b = 0 \<longleftrightarrow> (if x = 1 then True else det3 0 a b = 0)"
  using det30_plus_scaled2[of a  "-x" b] by simp

lemma det3_nonneg_scaleR1:
  "0 < e \<Longrightarrow> det3 0 xr P \<ge> 0 \<Longrightarrow> det3 0 (e*\<^sub>Rxr) P \<ge> 0"
  by (auto simp add: det3_def' algebra_simps)

lemma det3_nonneg_scaleR1_eq:
  "0 < e \<Longrightarrow> det3 0 (e*\<^sub>Rxr) P \<ge> 0 \<longleftrightarrow> det3 0 xr P \<ge> 0"
  by (auto simp add: det3_def' algebra_simps)

lemma det3_translate_origin: "NO_MATCH 0 p \<Longrightarrow> det3 p q r = det3 0 (q - p) (r - p)"
  by (auto simp: det3_def' algebra_simps)

lemma det3_nonneg_scaleR_segment2:
  assumes "det3 x y z \<ge> 0"
  assumes "a > 0"
  shows "det3 x ((1 - a) *\<^sub>R x + a *\<^sub>R y) z \<ge> 0"
proof -
  from assms have "0 \<le> det3 0 (a *\<^sub>R (y - x)) (z - x)"
    by (intro det3_nonneg_scaleR1) (simp_all add: det3_translate_origin)
  thus ?thesis
    by (simp add: algebra_simps det3_translate_origin)
qed

lemma det3_nonneg_scaleR_segment1:
  assumes "det3 x y z \<ge> 0"
  assumes "0 \<le> a" "a < 1"
  shows "det3 ((1 - a) *\<^sub>R x + a *\<^sub>R y) y z \<ge> 0"
proof -
  from assms have "det3 0 ((1 - a) *\<^sub>R (y - x)) (z - x + (- a) *\<^sub>R (y - x)) \<ge> 0"
    by (subst det3_nonneg_scaleR1_eq) (auto simp add: det3_def' algebra_simps)
  thus ?thesis
    by (auto simp: algebra_simps det3_translate_origin)
qed

subsection \<open>Strict CCW Predicate\<close>

definition "ccw' p q r \<longleftrightarrow> 0 < det3 p q r"

interpretation ccw': ccw_vector_space ccw'
  by unfold_locales (auto simp: ccw'_def det3_def' algebra_simps)

interpretation ccw': linorder_list0 "ccw' x" for x .

lemma ccw'_contra: "ccw' t r q \<Longrightarrow> ccw' t q r = False"
  by (auto simp: ccw'_def det3_def' algebra_simps)

lemma not_ccw'_eq: "\<not> ccw' t p s \<longleftrightarrow> ccw' t s p \<or> det3 t s p = 0"
  by (auto simp: ccw'_def det3_def' algebra_simps)

lemma neq_left_right_of: "ccw' a b c \<Longrightarrow> ccw' a c d \<Longrightarrow> b \<noteq> d"
  by (auto simp: ccw'_def det3_def' algebra_simps)

lemma ccw'_subst_collinear:
  assumes "det3 t r s = 0"
  assumes "s \<noteq> t"
  assumes "ccw' t r p"
  shows "ccw' t s p \<or> ccw' t p s"
proof cases
  assume "r \<noteq> s"
  from assms have "det3 r s t = 0"
    by (auto simp: algebra_simps det3_def')
  from coll_ex_scaling[OF assms(2) this]
  obtain x where s: "r = s + x *\<^sub>R (t - s)" by auto
  from assms(3)[simplified ccw'_def s]
  have "0 < det3 0 (s + x *\<^sub>R (t - s) - t) (p - t)"
    by (auto simp: algebra_simps det3_def')
  also have "s + x *\<^sub>R (t - s) - t = (1 - x) *\<^sub>R (s - t)"
    by (simp add: algebra_simps)
  finally have ccw': "ccw' 0 ((1 - x) *\<^sub>R (s - t)) (p - t)"
    by (simp add: ccw'_def)
  hence "x \<noteq> 1" by (auto simp add: det3_def' ccw'_def)
  {
    assume "x < 1"
    hence ?thesis using ccw'
      by (auto simp: not_ccw'_eq ccw'.translate_origin)
  } moreover {
    assume "x > 1"
    hence ?thesis using ccw'
      by (auto simp: not_ccw'_eq ccw'.translate_origin)
  } ultimately show ?thesis using \<open>x \<noteq> 1\<close> by arith
qed (insert assms, simp)

lemma ccw'_sorted_scaleR: "ccw'.sortedP 0 xs \<Longrightarrow> r > 0 \<Longrightarrow> ccw'.sortedP 0 (map (op *\<^sub>R r) xs)"
  by (induct xs) (auto intro!: ccw'.sortedP.Cons  elim!: ccw'.sortedP_Cons simp del: scaleR_Pair)

subsection \<open>Collinearity\<close>

abbreviation "coll a b c \<equiv> det3 a b c = 0"

lemma coll_zero[intro, simp]: "coll 0 z 0"
  by (auto simp: det3_def')

lemma coll_zero1[intro, simp]: "coll 0 0 z"
  by (auto simp: det3_def')

lemma coll_self[intro, simp]: "coll 0 z z"
  by (auto simp: )

lemma ccw'_not_coll:
  "ccw' a b c \<Longrightarrow> \<not>coll a b c"
  "ccw' a b c \<Longrightarrow> \<not>coll a c b"
  "ccw' a b c \<Longrightarrow> \<not>coll b a c"
  "ccw' a b c \<Longrightarrow> \<not>coll b c a"
  "ccw' a b c \<Longrightarrow> \<not>coll c a b"
  "ccw' a b c \<Longrightarrow> \<not>coll c b a"
  by (auto simp: det3_def' ccw'_def algebra_simps)

lemma coll_add: "coll 0 x y \<Longrightarrow> coll 0 x z \<Longrightarrow> coll 0 x (y + z)"
  by (auto simp: det3_def' algebra_simps)

lemma coll_scaleR_left_eq[simp]: "coll 0 (r *\<^sub>R x) y \<longleftrightarrow> r = 0 \<or> coll 0 x y"
  by (auto simp: det3_def' algebra_simps)

lemma coll_scaleR_right_eq[simp]: "coll 0 y (r *\<^sub>R x) \<longleftrightarrow> r = 0 \<or> coll 0 y x"
  by (auto simp: det3_def' algebra_simps)

lemma coll_scaleR: "coll 0 x y \<Longrightarrow> coll 0 (r *\<^sub>R x) y"
  by (auto simp: det3_def' algebra_simps)

lemma coll_sum_list: "(\<And>y. y \<in> set ys \<Longrightarrow> coll 0 x y) \<Longrightarrow> coll 0 x (sum_list ys)"
  by (induct ys) (auto intro!: coll_add)

lemma scaleR_left_normalize:
  fixes a ::real and b c::"'a::real_vector"
  shows "a *\<^sub>R b = c \<longleftrightarrow> (if a = 0 then c = 0 else b = c /\<^sub>R a)"
  by (auto simp: field_simps)

lemma coll_scale: "coll 0 r q \<Longrightarrow> r \<noteq> 0 \<Longrightarrow> (\<exists>x. q = x *\<^sub>R r)"
  using coll_scale_pair[of "fst r" "snd r" "fst q" "snd q"]
  by simp

lemma coll_add_trans:
  assumes "coll 0 x (y + z)"
  assumes "coll 0 y z"
  assumes "x \<noteq> 0"
  assumes "y \<noteq> 0"
  assumes "z \<noteq> 0"
  assumes "y + z \<noteq> 0"
  shows "coll 0 x z"
proof (cases "snd z = 0")
  case True
  hence "snd y = 0"
    using assms
    by (cases z) (auto simp add: zero_prod_def det3_def')
  with True assms have "snd x = 0"
    by (cases y, cases z) (auto simp add: zero_prod_def det3_def')
  from \<open>snd x = 0\<close> \<open>snd y = 0\<close> \<open>snd z = 0\<close>
  show ?thesis
    by (auto simp add: zero_prod_def det3_def')
next
  case False
  note z = False
  hence "snd y \<noteq> 0"
    using assms
    by (cases y) (auto simp add: zero_prod_def det3_def')
  with False assms have "snd x \<noteq> 0"
    apply (cases x)
    apply (cases y)
    apply (cases z)
    apply (auto simp add: zero_prod_def det3_def')
    apply (metis mult.commute mult_eq_0_iff ring_class.ring_distribs(1))
    done
  with False assms \<open>snd y \<noteq> 0\<close> have yz: "snd (y + z) \<noteq> 0"
    by (cases x; cases y; cases z) (auto simp add: det3_def' zero_prod_def)
  from coll_scale[OF assms(1) assms(3)] coll_scale[OF assms(2) assms(4)]
  obtain r s where rs: "y + z = r *\<^sub>R x" "z = s *\<^sub>R y"
    by auto
  with z have "s \<noteq> 0"
    by (cases x; cases y; cases z) (auto simp: zero_prod_def)
  with rs z yz have "r \<noteq> 0"
    by (cases x; cases y; cases z) (auto simp: zero_prod_def)
  from \<open>s \<noteq> 0\<close> rs have "y = r *\<^sub>R x - z" "y = z /\<^sub>R s"
    by (auto simp: inverse_eq_divide algebra_simps)
  hence "r *\<^sub>R x - z = z /\<^sub>R s" by simp
  hence "r *\<^sub>R x = (1 + inverse s) *\<^sub>R z"
    by (auto simp: inverse_eq_divide algebra_simps)
  hence "x = (inverse r * (1 + inverse s)) *\<^sub>R z"
    using \<open>r \<noteq> 0\<close> \<open>s \<noteq> 0\<close>
    by (auto simp: field_simps scaleR_left_normalize)
  from this
  show ?thesis
    by (auto intro: coll_scaleR)
qed

lemma coll_commute: "coll 0 a b \<longleftrightarrow> coll 0 b a"
  by (metis det3_rotate det3_switch' diff_0 diff_self)

lemma coll_add_cancel: "coll 0 a (a + b) \<Longrightarrow> coll 0 a b"
  by (cases a, cases b) (auto simp: det3_def' algebra_simps)

lemma coll_trans:
  "coll 0 a b \<Longrightarrow> coll 0 a c \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coll 0 b c"
  by (metis coll_scale coll_scaleR)

lemma sum_list_posI:
  fixes xs::"'a::ordered_comm_monoid_add list"
  shows "(\<And>x. x \<in> set xs \<Longrightarrow> x > 0) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> sum_list xs > 0"
proof (induct xs)
  case (Cons x xs)
  thus ?case
    by (cases "xs = []") (auto intro!: add_pos_pos)
qed simp

lemma fst_sum_list: "fst (sum_list xs) = sum_list (map fst xs)"
  by (induct xs) auto

lemma snd_sum_list: "snd (sum_list xs) = sum_list (map snd xs)"
  by (induct xs) auto

lemma nonzero_fstI[intro, simp]: "fst x \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
  and nonzero_sndI[intro, simp]: "snd x \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
  by auto

lemma coll_sum_list_trans:
  "xs \<noteq> [] \<Longrightarrow> coll 0 a (sum_list xs) \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x y) \<Longrightarrow>
    (\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x (sum_list xs)) \<Longrightarrow>
    (\<And>x. x \<in> set xs \<Longrightarrow> snd x > 0) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coll 0 a y"
proof (induct xs rule: list_nonempty_induct)
  case (single x)
  from single(1) single(2)[of x] single(4)[of x] have "coll 0 x a" "coll 0 x y" "x \<noteq> 0"
    by (auto simp: coll_commute)
  thus ?case by (rule coll_trans)
next
  case (cons x xs)
  from cons(5)[of x] \<open>a \<noteq> 0\<close> cons(6)[of x]
  have *: "coll 0 x (sum_list xs)" "a \<noteq> 0" "x \<noteq> 0" by (force simp add: coll_add_cancel)+
  have "0 < snd (sum_list (x#xs))"
    unfolding snd_sum_list
    by (rule sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list)
  hence "x + sum_list xs \<noteq> 0" by simp
  from coll_add_trans[OF cons(3)[simplified] * _ this]
  have cH: "coll 0 a (sum_list xs)"
    by (cases "sum_list xs = 0") auto
  from cons(4) have cy: "(\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x y)" by simp
  {
    fix y assume "y \<in> set xs"
    hence "snd (sum_list xs) > 0"
      unfolding snd_sum_list
      by (intro sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list)
    hence "sum_list xs \<noteq> 0" by simp
    from cons(5)[of x] have "coll 0 x (sum_list xs)"
      by (simp add: coll_add_cancel)
    from cons(5)[of y]
    have "coll 0 y (sum_list xs)"
      using \<open>y \<in> set xs\<close> cons(6)[of y] \<open>x + sum_list xs \<noteq> 0\<close>
      apply (cases "y = x")
      subgoal by (force simp add: coll_add_cancel)
      subgoal by (force simp: dest!: coll_add_trans[OF _ *(1) _ *(3)])
      done
  } note cl = this
  show ?case
    by (rule cons(2)[OF cH cy cl cons(6) \<open>a \<noteq> 0\<close>]) auto
qed

lemma sum_list_coll_ex_scale:
  assumes coll: "\<And>x. x \<in> set xs \<Longrightarrow> coll 0 z x"
  assumes nz: "z \<noteq> 0"
  shows "\<exists>r. sum_list xs = r *\<^sub>R z"
proof -
  {
    fix i assume i: "i < length xs"
    hence nth: "xs ! i \<in> set xs" by simp
    note coll_scale[OF coll[OF nth] \<open>z \<noteq> 0\<close>]
  } then obtain r where r: "\<And>i. i < length xs \<Longrightarrow> xs ! i = r i *\<^sub>R z"
    by metis
  have "xs = map (op ! xs) [0..<length xs]" by (simp add: map_nth)
  also have "\<dots> = map (\<lambda>i. r i *\<^sub>R z) [0..<length xs]" by (simp add: r)
  also have "sum_list \<dots> = (\<Sum>i\<leftarrow>[0..<length xs]. r i) *\<^sub>R z"
    by (simp add: sum_list_sum_nth scaleR_sum_left)
  finally show ?thesis ..
qed

lemma sum_list_filter_coll_ex_scale: "z \<noteq> 0 \<Longrightarrow> \<exists>r. sum_list (filter (coll 0 z) zs) = r *\<^sub>R z"
  by (rule sum_list_coll_ex_scale) simp

end


(*
    Title:      Rank.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
    Maintainer: Jose Divasón <jose.divasonm at unirioja.es>
*)

section\<open>Rank of a matrix\<close>

theory Rank
imports
      Rank_Nullity_Theorem.Dim_Formula
begin

subsection\<open>Row rank, column rank and rank\<close>

text\<open>Definitions of row rank, column rank and rank\<close>

definition row_rank :: "'a::{field}^'n^'m=>nat"
  where "row_rank A = vec.dim (row_space A)"

definition col_rank :: "'a::{field}^'n^'m=>nat"
  where "col_rank A = vec.dim (col_space A)"

lemma rank_def: "rank A = row_rank A"
  by (auto simp: row_rank_def row_rank_def_gen row_space_def)

subsection\<open>Properties\<close>

lemma rrk_is_preserved:
fixes A::"'a::{field}^'cols^'rows::{finite, wellorder}"
  and P::"'a::{field}^'rows::{finite, wellorder}^'rows::{finite, wellorder}"
assumes inv_P: "invertible P"
shows "row_rank A = row_rank (P**A)"
by (metis row_space_is_preserved row_rank_def inv_P)

lemma crk_is_preserved:
fixes A::"'a::{field}^'cols::{finite, wellorder}^'rows"
  and P::"'a::{field}^'rows^'rows"
assumes inv_P: "invertible P"
shows "col_rank A = col_rank (P**A)"
  using rank_nullity_theorem_matrices unfolding ncols_def
  by (metis col_rank_def inv_P add_left_cancel null_space_is_preserved)

end