theory estudosP1
imports Main
begin
(* Conjunto Indutivo \<nat>

                                    x0:Nat
                                    P(x0)     hI
    \<dots>                              \<dots>
    \<dots>                              \<dots>
    \<dots>                              \<dots>
    P(zero)                         P(suc x0)
    ------------------------------------------------- Ind Nat
                         \<forall>n:Nat. P(n)
*)

datatype Nat = Z | suc Nat

(* Primitiva Recursiva add: \<nat> \<Rightarrow> \<nat> \<Rightarrow> \<nat>

  add: \<nat> \<Rightarrow> \<nat> \<Rightarrow> \<nat>, onde
    add x 0 = x                    (add01)
    add x (suc y) = suc (add x y)  (add02)
*)

primrec add::"Nat \<Rightarrow> Nat \<Rightarrow> Nat" where
  add01: "add x Z = x" |
  add02: "add x (suc y) = suc (add x y)"

value "add Z (suc (suc Z))"
value "add (suc Z) (suc (suc (suc Z)))"

(* Provas por Indução Estrutural

  add 0 (suc (suc 0)) = suc (add 0 (suc 0))   (by add02, [x:=0, y:=suc 0])
                      = suc (suc (add 0 0))   (by add02, [x:=0, y:=0])
                      = suc (suc 0)           (by add01, [x:=0])
                      = 2                     (por definição de suc)

  add (suc 0) (suc (suc (suc 0))) = suc (add (suc 0) (suc (suc 0)))  (by add02, [x:=suc 0, y:=suc (suc 0)])
                                  = suc (suc (add (suc 0) (suc 0)))  (by add02, [x:=suc 0, y:=suc 0])
                                  = suc (suc (suc (add (suc 0) 0)))  (by add02, [x:=suc 0, y:=0])
                                  = suc (suc (suc (suc 0)))          (by add01, [x:=suc 0])
                                  = 4                                (por definição de suc)
*)

(*
  Provar os teoremas:

    Th-add-01: \<forall>x:\<nat>. \<forall>y:\<nat>. \<forall>z:\<nat>. add x (add y z) = add (add x y) z
    Th-add-02: \<forall>x:\<nat>. \<forall>y:\<nat>. add x y = add y x
    Th-add-03: \<forall>x:\<nat>. add 0 x = x
    Th-add-04: \<forall>x:\<nat>. \<forall>y:\<nat>. add x (suc y) = add (suc x) y
    Th-add-05: \<forall>x:\<nat>. \<forall>y:\<nat>. add (suc x) y = suc (add x y)
*)

(*
1) Provando Th-add-01 (associatividade da função add)
  1.1) Formalização da propriedade

    P \<triangleq> \<forall>x:\<nat>. \<forall>y:\<nat>. \<forall>z:\<nat>. add x (add y z) = add (add x y) z

  1.2) Escolha da variável indutiva

    P(n) \<triangleq> \<forall>x:\<nat>. \<forall>y:\<nat>. add x (add y n) = add (add x y) n

    Logo, temos que provar que \<forall>n:\<nat>. P(n).

  1.2.1) Prova do caso base P(0)

    Temos que mostrar que:
      \<forall>x:\<nat>. \<forall>y:\<nat>. add x (add y 0) = add (add x y) 0

    Sejam x0 e y0 valores arbitrários em \<nat>, então é suficiente mostrar que:
      add x0 (add y0 0) = add (add x0 y0) 0

    Agora, veja que:

      add x0 (add y0 0)
        = add x0 y0           (by add01, [x:=y0])
        = add (add x0 y0) 0   (by add01, [x:=add x0 y0])

        q.e.d.

  1.2.2) Prova do caso indutivo P(x0) \<longrightarrow> P(suc x0)

    Seja x0 um valor arbitrário em \<nat>, assumimos como hipótese de indução:
      \<forall>x:\<nat>. \<forall>y:\<nat>. add x (add y x0) = add (add x y) x0

    Temos que mostrar que:
      \<forall>x:\<nat>. \<forall>y:\<nat>. add x (add y (suc x0)) = add (add x y) (suc x0)

    Sejam x1 e y1 valores arbitrários em \<nat>. Logo, é suficiente mostrar que:
      add x1 (add y1 (suc x0)) = add (add x1 y1) (suc x0)

    Agora, veja que:

      add x1 (add y1 (suc x0))
        = add x1 (suc (add y1 x0))        (by add02, [x:=y1, y:=suc x0])
        = suc (add x1 (add y1 x0))        (by add02, [x:=x1, y:=add y1 x0])
        = suc (add (add x1 y1) x0)        (by HI, [x:=x1, y:=y1])
        = add (add x1 y1) (suc x0)        (by add02, [x:=(add x1 y1), y:=x0])

        q.e.d
*)

theorem thadd01: "\<forall>x. \<forall>y. add x (add y n) = add (add x y) n"
  proof (induction n)
    show "\<forall>x. \<forall>y. add x (add y Z) = add (add x y) Z"
      proof (rule allI, rule allI)
        fix x0::Nat and y0::Nat
          have "add x0 (add y0 Z) = add x0 y0" by (simp only:add01)
          also have "add x0 y0 = add (add x0 y0) Z" by (simp only:add01)
          finally show "add x0 (add y0 Z) = add (add x0 y0) Z" by this
      qed
      next
        fix x0::Nat
        assume IH:"\<forall>x. \<forall>y. add x (add y x0) = add (add x y) x0"
        show "\<forall>x. \<forall>y. add x (add y (suc x0)) = add (add x y) (suc x0)"
        proof (rule allI, rule allI)
          fix x1::Nat and y1::Nat
          have "add x1 (add y1 (suc x0)) = add x1 (suc (add y1 x0))" by (simp only:add02)
          also have "add x1 (suc (add y1 x0)) = suc (add x1 (add y1 x0))" by (simp only:add02)
          also have "suc (add x1 (add y1 x0)) = suc (add (add x1 y1) x0)" by (simp only:IH)
          also have "suc (add (add x1 y1) x0) = add (add x1 y1) (suc x0)" by (simp only:add02)
          finally show "add x1 (add y1 (suc x0)) = add (add x1 y1) (suc x0)" by this
        qed
  qed

(*
2) Provando Th-add-03 (0 é neutro à esquerda)
  2.1) Formalização da propriedade

    P \<triangleq> \<forall>x:\<nat>. add 0 x = x

  2.2) Escolha da variável indutiva

    P(n) \<triangleq> add 0 n = n

    Logo, temos que provar que \<forall>n:\<nat>. P(n).

  2.2.1) Prova do caso base P(0)

    Temos que mostrar que:
      add 0 0 = 0

    Agora veja que:

      add 0 0
        = 0     (by add01, [x:=0])

        q.e.d.

  2.2.2) Prova do caso indutivo P(x0) \<longrightarrow> P(suc x0)

    Seja x0 um valor arbitrário em \<nat>, assumimos como hipótese de indução:
      add 0 x0 = x0

    Temos que mostrar que:
      add 0 (suc x0) = suc x0

    Agora, veja que:

      add 0 (suc x0)
        = suc (add 0 x0)            (by add02, [x:=0, y:=x0])
        = suc x0                    (by HI, [x0:=x0])

        q.e.d.
*)

theorem thadd03: "add Z n = n"
  proof (induction n)
    show "add Z Z = Z" by (simp only:add01)
    next
     fix x0::Nat
      assume IH:"add Z x0 = x0"
      show "add Z (suc x0) = suc x0"
      proof -
        have "add Z (suc x0) = suc (add Z x0)" by (simp only:add02) also
        have "suc (add Z x0) = suc x0" by (simp only:IH)
        finally show "add Z (suc x0) = suc x0" by this
      qed
  qed

(*
3) Provando Th-add-02 (comutatividade da função add)
  3.1) Formalização da propriedade

    P \<triangleq> \<forall>x:\<nat>. \<forall>y:\<nat>. add x y = add y x

  3.2) Escolha da variável indutiva

    P(n) \<triangleq> \<forall>x:\<nat>. add x n = add n x

    Logo, temos que provar que \<forall>n:\<nat>. P(n).

  3.2.1) Prova do caso base P(0)

    Temos que mostrar que:
      \<forall>x:\<nat>. add x 0 = add 0 x

    Seja x0 um valor arbitrário em \<nat>, então é suficiente mostrar que:
      add x0 0 = add 0 x0

    Agora, veja que:

      add x0 0
        = x0          (by add01, [x:=x0])
        = add 0 x0    (by Th-add-03, [x:=x0])

        q.e.d.

  3.2.2.) Prova do caso indutivo P(x0) \<longrightarrow> P(suc x0)

    Seja x0 um valor arbitrário em \<nat>, assumimos como hipótese de indução:
      \<forall>x:\<nat>. add x x0 = add x0 x

    Temos que mostrar que:
      \<forall>x:\<nat>. add x (suc x0) = add (suc x0) x

    Seja x1 um valor arbitrário em \<nat>, é suficiente provar que:
      add x1 (suc x0) = add (suc x0) x1

    Agora, veja que:

      add x1 (suc x0)
        = add (suc x0) x1           (by HI, x:=x1, x0=x0])

      add x1 (suc x0)
      = suc (add x1 x0).   (by add02, x:=x1, y:=x0)
      = suc (add x0 x1).   (by IH, allE)
      = add (x0 (suc x1))  (by add02, x:=x0, y:=x1)
      = add (suc x0) x1.   (by Th-add04, allE, x:=x0, y:=x1

        q.e.d.
*)

theorem thadd02: "\<forall>x. add x n = add n x"
  proof (induction n)
    show "\<forall>x. add x Z = add Z x"
      proof (rule allI)
        fix x0::Nat
        have "add x0 Z = x0" by (simp only:add01) also
        have "x0 = add Z x0" by (simp only:thadd03)
        finally show "add x0 Z = add Z x0" by this
      qed
      next
        fix x0::Nat
        assume IH:"\<forall>x. add x x0 = add x0 x"
        show "\<forall>x. add x (suc x0) = add (suc x0) x"
        proof (rule allI)
          fix x1::Nat
          have "add x1 (suc x0) = suc (add x1 x0)" by (simp only:add02) also
          have "suc (add x1 x0) = suc (add x0 x1)" by (simp only:IH) also
          have "suc (add x0 x1) = add (suc x0) x1" by (simp only:thadd05)
          finally show "add x1 (suc x0) = add (suc x0) x1" by this
        qed
  qed

(*
4) Provando Th-add-04
  4.1) Formalização da propriedade

    P \<triangleq> \<forall>x:\<nat>. \<forall>y:\<nat>. add x (suc y) = add (suc x) y

  4.2) Escolha da variável indutiva

    P(n) \<triangleq> \<forall>x:\<nat>. add x (suc n) = add (suc x) n

    Logo, temos que provar que \<forall>n:\<nat>. P(n).

  4.2.1) Prova do caso base P(0)

    Temos que mostrar que:
      P(0) \<triangleq> \<forall>x:\<nat>. add x (suc 0) = add (suc x) 0

    Seja x0 um valor arbitrário em \<nat>, então é suficiente mostrar que:
      add x0 (suc 0) = add (suc x0) 0

    Agora, veja que:

      add x0 (suc 0)
        = suc (add x0 0)          (by add02, [x:=x0, y:=0])
        = suc (add 0 x0)          (by th-add-02, [x:=x0, y:=0])
        = add 0 (suc x0)          (by add02, [x:=0, y:=x0])
        = add (suc x0) 0          (by th-add-02, [x:=suc x0, y:=0])

        q.e.d.

  4.2.2.) Prova do caso indutivo P(x0) \<longrightarrow> P(suc x0)

    Seja x0 um valor arbitrário em \<nat>, assumimos como hipótese de indução:
      P(x0) \<triangleq> \<forall>x:\<nat>. add x (suc x0) = add (suc x) x0

    Temos que mostrar que:
      P(suc x0) \<triangleq> \<forall>x:\<nat>. add x (suc (suc x0)) = add (suc x) (suc x0)

    Seja x1 um valor arbitrário em \<nat>, é suficiente provar que:
      add x1 (suc (suc x0)) = add (suc x1) (suc x0)

    Agora, veja que:

      add x1 (suc (suc x0))
        = suc (add x1 (suc x0))          (by add02, [x:=x1, y:=suc x0])
        = suc (add (suc x1) x0)          (by HI, [x:=x1, x0:=x0])
        = add (suc x1) (suc x0)          (by add02, [x:=suc x1, y:=x0])

        q.e.d.
*)

theorem thadd04: "\<forall>x. add x (suc n) = add (suc x) n"
  proof (induction n)
    show "\<forall>x. add x (suc Z) = add (suc x) Z"
      proof (rule allI)
        fix x0::Nat
        have "add x0 (suc Z) = suc (add x0 Z)" by (simp only:add02)
        also have "suc (add x0 Z) = suc (add Z x0)" by (simp only:thadd02)
        also have "suc (add Z x0) = add Z (suc x0)" by (simp only:add02)
        also have "add Z (suc x0) = add (suc x0) Z" by (simp only:thadd02)
        finally show "add x0 (suc Z) = add (suc x0) Z" by this
      qed
      next
        fix x0::Nat
        assume IH:"\<forall>x. add x (suc x0) = add (suc x) x0"
        show "\<forall>x. add x (suc (suc x0)) = add (suc x) (suc x0)"
        proof (rule allI)
          fix x1::Nat
          have "add x1 (suc (suc x0)) = suc (add x1 (suc x0))" by (simp only:add02) also
          have "suc (add x1 (suc x0)) = suc (add (suc x1) x0)" by (simp only:IH) also
          have "suc (add (suc x1) x0) = add (suc x1) (suc x0)" by (simp only:add02)
          finally show "add x1 (suc (suc x0)) = add (suc x1) (suc x0)" by this
        qed
  qed

(*
5) Provando Th-add-05
  5.1) Formalização da propriedade

    P \<triangleq> \<forall>x:\<nat>. \<forall>y:\<nat>. add (suc x) y = suc (add x y)

  5.2) Escolha da variável indutiva

    P(n) \<triangleq> \<forall>x:\<nat>. add (suc x) n = suc (add x n)

    Logo, temos que provar que \<forall>n:\<nat>. P(n).

  5.2.1) Prova do caso base P(0)

    Temos que mostrar que:
      P(0) \<triangleq> \<forall>x:\<nat>. add (suc x) 0 = suc (add x 0)

    Seja x0 um valor arbitrário em \<nat>, então é suficiente mostrar que:
      add (suc x0) 0 = suc (add x0 0)

    Agora, veja que:

      add (suc x0) 0
        = add 0 (suc x0)          (by th-add-02, [x:=suc x0, y:=0])
        = suc (add 0 x0)          (by add02, [x:=0, y:=x0])
        = suc (add x0 0)          (by th-add-02, [x:=x0, y:=0]

        q.e.d.

  5.2.2.) Prova do caso indutivo P(x0) \<longrightarrow> P(suc x0)

    Seja x0 um valor arbitrário em \<nat>, assumimos como hipótese de indução:
      P(x0) \<triangleq> \<forall>x:\<nat>. add (suc x) x0 = suc (add x x0)

    Temos que mostrar que:
      P(suc x0) \<triangleq> \<forall>x:\<nat>. add (suc x) (suc x0) = suc (add x (suc x0))

    Seja x1 um valor arbitrário em \<nat>, é suficiente provar que:
      add (suc x1) (suc x0) = suc (add x1 (suc x0))

    Agora, veja que:

      add (suc x1) (suc x0)
        = suc (add (suc x1) x0)          (by add02, [x:=suc x1, y:=x0])
        = suc (add x1 (suc x0))          (by th-add-04, [x:=x1, y:=x0])

        q.e.d.
*)

theorem thadd05: "\<forall>x. add (suc x) n = suc (add x n)"
  proof (induction n)
    show "\<forall>x. add (suc x) Z = suc (add x Z)"
    proof (rule allI)
      fix x0::Nat
      have "add (suc x0) Z = add Z (suc x0)" by (simp only:thadd02) also
      have "add Z (suc x0) = suc (add Z x0)" by (simp only:add02) also
      have "suc (add Z x0) = suc (add x0 Z)" by (simp only:thadd02)
      finally show "add (suc x0) Z = suc (add x0 Z)" by this
    qed
    next
      fix x0::Nat
      assume IH: "\<forall>x. add (suc x) x0 = suc (add x x0)"
      show "\<forall>x. add (suc x) (suc x0) = suc (add x (suc x0))"
      proof (rule allI)
        fix x1::Nat
        have "add (suc x1) (suc x0) = suc (add (suc x1) x0)" by (simp only:add02) also
        have "suc (add (suc x1) x0) = suc (add x1 (suc x0))" by (simp only:thadd04)
        finally show "add (suc x1) (suc x0) = suc (add x1 (suc x0))" by this
      qed
  qed

primrec mult::"Nat \<Rightarrow> Nat \<Rightarrow> Nat" where
  mult01: "mult x Z = Z" |
  mult02: "mult x (suc y) = add x (mult x y)"

value "mult Z (suc (suc Z))"
value "mult (suc Z) (suc Z)"
value "mult (suc (suc Z)) (suc (suc (suc Z)))"

(*
  Th-mult-01:   \<forall>x:\<nat>. \<forall>y:\<nat>. \<forall>z:\<nat>. mult x (mult y z) = mult (mult x y) z
  Th-mult-02:   \<forall>x:\<nat>. \<forall>y:\<nat>. mult x y = mult y z
  Th-mult-03:   \<forall>x:\<nat>. \<forall>y:\<nat>. \<forall>z:\<nat>. mult x (add y z) = add (mult x y) (mult x z)
*)

theorem thmult01: "\<forall>x. \<forall>y. mult x (mult y n) = mult (mult x y) n"
  proof (induction n)
    show "\<forall>x. \<forall>y. mult x (mult y Z) = mult (mult x y) Z"
    proof (rule allI, rule allI)
      fix x0::Nat and y0::Nat
      have "mult x0 (mult y0 Z) = mult x0 Z" by (simp only:mult01) also
      have "mult x0 Z = mult (mult x0 y0) Z" by (simp only:mult01)
      finally show "mult x0 (mult y0 Z) = mult (mult x0 y0) Z" by this
    qed
    next
      fix x0::Nat
      assume IH: "\<forall>x. \<forall>y. mult x (mult y x0) = mult (mult x y) x0"
      show "\<forall>x. \<forall>y. mult x (mult y (suc x0)) = mult (mult x y) (suc x0)"
      proof (rule allI, rule allI)
        fix x1::Nat and y1::Nat
        have "mult x1 (mult y1 (suc x0)) = mult x1 (add y1 (mult y1 x0))" by (simp only:mult02) also
        have "mult x1 (add y1 (mult y1 x0)) = mult x1 (add (mult y1 x0) y1)" by (simp only:thadd02) also
        finally show "mult x1 (mult y1 (suc x0)) = mult (mult x1 y1) (suc x0)" by this
      qed
  qed


theory Monotony
  imports Main
begin

type_synonym variable = string

datatype bexpr =
    Const bool
  | Var variable
  | And bexpr bexpr
  | Or bexpr bexpr
  | Imp bexpr bexpr
  | Neg bexpr

datatype occ =
    Even
  | Odd
  | Both

fun negate :: "occ \<Rightarrow> occ" where
"negate Even = Odd" |
"negate Odd = Even" |
"negate Both = Both"

fun merge :: "occ \<Rightarrow> occ \<Rightarrow> occ" where
"merge x y = (if x = y then x else Both)"

primrec occurrences :: "bexpr \<Rightarrow> variable \<Rightarrow> occ" where
"occurrences (Const _) _ = Even" |
"occurrences (Var y) x = Even" |
"occurrences (And phi psi) x = (merge (occurrences phi x) (occurrences psi x))" |
"occurrences (Or phi psi) x = (merge (occurrences phi x) (occurrences psi x))" |
"occurrences (Imp phi psi) x = (merge (negate (occurrences phi x)) (occurrences psi x))" |
"occurrences (Neg phi) x = (negate (occurrences phi x))"

type_synonym environment = "string \<Rightarrow> bool"

fun update :: "environment \<Rightarrow> variable \<Rightarrow> bool \<Rightarrow> environment" where
"update env x b y = (if y = x then b else env y)"

fun update2 :: "environment \<Rightarrow> variable \<Rightarrow> bool \<Rightarrow> environment" where
"update2 env x b = (\<lambda>y. (if y = x then b else env y))"

fun update3 :: "environment \<Rightarrow> variable \<Rightarrow> bool \<Rightarrow> environment" where
"update3 env x = (\<lambda>b. (\<lambda>y. (if y = x then b else env y)))"

definition env0 :: environment where
"env0 _ \<equiv> False"

value "(update env0 ''x'' True) ''y''"

primrec eval :: "bexpr \<Rightarrow> environment \<Rightarrow> bool" where
"eval (Const b) _ = b" |
"eval (Var x) env = (env x)" |
"eval (And phi psi) env = ((eval phi env) \<and> (eval psi env))" |
"eval (Or phi psi) env = ((eval phi env) \<or> (eval psi env))" |
"eval (Imp phi psi) env = ((eval phi env) \<longrightarrow> (eval psi env))" |
"eval (Neg phi) env = (\<not> (eval phi env))"

definition monotonic_in :: "bexpr \<Rightarrow> variable \<Rightarrow> bool" where
"monotonic_in phi x \<equiv> \<forall>env. (eval phi (update env x False)) \<longrightarrow> (eval phi (update env x True))"

definition antitonic_in :: "bexpr \<Rightarrow> variable \<Rightarrow> bool" where
"antitonic_in phi x \<equiv>  \<forall>env. (eval phi (update env x True)) \<longrightarrow> (eval phi (update env x False))"

lemma mergeBothEven: "merge x y = Even \<longrightarrow> x = Even \<and> y = Even"
  by simp

lemma mergeBothOdd: "merge x y = Odd \<longrightarrow> x = Odd \<and> y = Odd"
  by simp

lemma negateOccEvenIsOdd: "negate (occurrences phi x) = Even \<longrightarrow> occurrences phi x = Odd"
  using negate.elims by auto

lemma negateOccOddIsEven: "negate (occurrences phi x) = Odd \<longrightarrow> occurrences phi x = Even"
  using negate.elims by auto

lemma occNegEvenIsOdd: "occurrences (Neg phi) x = Even \<longrightarrow> occurrences phi x = Odd"
  using negateOccEvenIsOdd by auto

lemma occNegOddIsEven: "occurrences (Neg phi) x = Odd \<longrightarrow> occurrences phi x = Even"
  using negateOccOddIsEven by auto

lemma aux: "((occurrences phi x = Even) \<longrightarrow> (monotonic_in phi x)) \<and>
            ((occurrences phi x = Odd) \<longrightarrow> (antitonic_in phi x))"
proof (induction phi arbitrary: x)
  case (Const x)
  show ?case by (simp add: monotonic_in_def antitonic_in_def)
next
  case (Var x)
  show ?case by (simp add: monotonic_in_def antitonic_in_def)
next
  case (And phi1 phi2)
  show ?case
  proof
    show "occurrences (And phi1 phi2) x = Even \<longrightarrow> monotonic_in (And phi1 phi2) x"
    proof (rule impI)
      assume "occurrences (And phi1 phi2) x = Even"
      then have "merge (occurrences phi1 x) (occurrences phi2 x) = Even"
        by simp
      then have bothEven: "occurrences phi1 x = Even \<and> occurrences phi2 x = Even"
        using mergeBothEven by blast
      from bothEven have "occurrences phi1 x = Even" ..
      with And.IH have mono1: "monotonic_in phi1 x"
        by simp
      from bothEven have "occurrences phi2 x = Even" ..
      with And.IH have mono2: "monotonic_in phi2 x"
        by simp
      from mono1 mono2 show "monotonic_in (And phi1 phi2) x"
        by (simp add: monotonic_in_def)
    qed

    show "occurrences (And phi1 phi2) x = Odd \<longrightarrow> antitonic_in (And phi1 phi2) x"
    proof (rule impI)
      assume "occurrences (And phi1 phi2) x = Odd"
      then have "merge (occurrences phi1 x) (occurrences phi2 x) = Odd"
        by simp
      then have bothOdd: "occurrences phi1 x = Odd \<and> occurrences phi2 x = Odd"
        using mergeBothOdd by blast
      from bothOdd have "occurrences phi1 x = Odd" ..
      with And.IH have anti1: "antitonic_in phi1 x"
        by simp
      from bothOdd have "occurrences phi2 x = Odd" ..
      with And.IH have anti2: "antitonic_in phi2 x"
        by simp
      from anti1 anti2 show "antitonic_in (And phi1 phi2) x"
        by (simp add: antitonic_in_def)
    qed
  qed
next
  case (Or phi1 phi2)
  show ?case
  proof
    show "occurrences (Or phi1 phi2) x = Even \<longrightarrow> monotonic_in (Or phi1 phi2) x"
    proof
      assume "occurrences (Or phi1 phi2) x = Even"
      then have "merge (occurrences phi1 x) (occurrences phi2 x) = Even"
        by simp
      then have bothEven: "occurrences phi1 x = Even \<and> occurrences phi2 x = Even"
        using mergeBothEven by blast
      from bothEven have "occurrences phi1 x = Even" ..
      with Or.IH have mono1: "monotonic_in phi1 x"
        by simp
      from bothEven have "occurrences phi2 x = Even" ..
      with Or.IH have mono2: "monotonic_in phi2 x"
        by simp
      from mono1 mono2 show "monotonic_in (Or phi1 phi2) x"
        by (simp add: monotonic_in_def)
    qed

    show "occurrences (Or phi1 phi2) x = Odd \<longrightarrow> antitonic_in (Or phi1 phi2) x"
    proof
      assume "occurrences (Or phi1 phi2) x = Odd"
      then have "merge (occurrences phi1 x) (occurrences phi2 x) = Odd"
        by simp
      then have bothOdd: "occurrences phi1 x = Odd \<and> occurrences phi2 x = Odd"
        using mergeBothOdd by blast
      from bothOdd have "occurrences phi1 x = Odd" ..
      with Or.IH have anti1: "antitonic_in phi1 x"
        by simp
      from bothOdd have "occurrences phi2 x = Odd" ..
      with Or.IH have anti2: "antitonic_in phi2 x"
        by simp
      from anti1 anti2 show "antitonic_in (Or phi1 phi2) x"
        by (simp add: antitonic_in_def)
    qed
  qed
next
  case (Imp phi1 phi2)
  show ?case
  proof
    show "occurrences (Imp phi1 phi2) x = Even \<longrightarrow> monotonic_in (Imp phi1 phi2) x"
    proof
      assume "occurrences (Imp phi1 phi2) x = Even"
      then have "merge (negate (occurrences phi1 x)) (occurrences phi2 x) = Even"
        by simp
      then have bothEven: "negate (occurrences phi1 x) = Even \<and> occurrences phi2 x = Even"
        using mergeBothEven by blast
      from bothEven have "negate (occurrences phi1 x) = Even" ..
      then have "occurrences phi1 x = Odd"
        using negateOccEvenIsOdd by simp
      with Imp.IH have anti1: "antitonic_in phi1 x"
        by simp
      from bothEven have "occurrences phi2 x = Even" ..
      with Imp.IH have mono2: "monotonic_in phi2 x"
        by simp
      from anti1 mono2 show "monotonic_in (Imp phi1 phi2) x"
        by (simp add: antitonic_in_def monotonic_in_def)
    qed

    show "occurrences (Imp phi1 phi2) x = Odd \<longrightarrow> antitonic_in (Imp phi1 phi2) x"
    proof
      assume "occurrences (Imp phi1 phi2) x = Odd"
      then have "merge (negate (occurrences phi1 x)) (occurrences phi2 x) = Odd"
        by simp
      then have bothOdd: "negate (occurrences phi1 x) = Odd \<and> occurrences phi2 x = Odd"
        using mergeBothOdd by blast
      from bothOdd have "negate (occurrences phi1 x) = Odd" ..
      then have "occurrences phi1 x = Even"
        using negateOccOddIsEven by simp
      with Imp.IH have mono1: "monotonic_in phi1 x"
        by simp
      from bothOdd have "occurrences phi2 x = Odd" ..
      with Imp.IH have anti2: "antitonic_in phi2 x"
        by simp
      from mono1 anti2 show "antitonic_in (Imp phi1 phi2) x"
        by (simp add: antitonic_in_def monotonic_in_def)
    qed
  qed
next
  case (Neg phi)
  show ?case
  proof
    show "occurrences (Neg phi) x = Even \<longrightarrow> monotonic_in (Neg phi) x"
    proof
      assume "occurrences (Neg phi) x = Even"
      then have "occurrences phi x = Odd"
        using occNegEvenIsOdd by simp
      with Neg.IH have "antitonic_in phi x"
        by simp
      then show "monotonic_in (Neg phi) x"
        by (auto simp add: antitonic_in_def monotonic_in_def)
    qed

    show "occurrences (Neg phi) x = Odd \<longrightarrow> antitonic_in (Neg phi) x"
    proof
      assume "occurrences (Neg phi) x = Odd"
      then have "occurrences phi x = Even"
        using occNegOddIsEven by simp
      with Neg.IH have "monotonic_in phi x"
        by simp
      then show "antitonic_in (Neg phi) x"
        by (auto simp add: antitonic_in_def monotonic_in_def)
    qed
  qed
qed

theorem "(occurrences phi x = Even) \<longrightarrow> (monotonic_in phi x)"
  by (simp add: aux)


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

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

datatype Nat = Z | S "Nat"

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

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

fun insert :: "Nat => Nat list => Nat list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun count :: "'a => 'a list => Nat" where
"count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (isort xs)) = (count x xs))"
  oops

end


section \<open>Root Filter via Interval Arithmetic\<close>

subsection \<open>Generic Framework\<close>

text \<open>We provide algorithms for finding all real or complex roots of a polynomial
  from a superset of the roots via interval arithmetic.
  These algorithms are much faster than just
  evaluating the polynomial via algebraic number computations.\<close>

theory Roots_via_IA
  imports
    Algebraic_Numbers.Interval_Arithmetic
begin

definition interval_of_real :: "nat \<Rightarrow> real \<Rightarrow> real interval" where
  "interval_of_real prec x =
      (if is_rat x then Interval x x
       else let n = 2 ^ prec; x' = x * of_int n
            in  Interval (of_rat (Rat.Fract \<lfloor>x'\<rfloor> n)) (of_rat (Rat.Fract \<lceil>x'\<rceil> n)))"

definition interval_of_complex :: "nat \<Rightarrow> complex \<Rightarrow> complex_interval" where
  "interval_of_complex prec z =
     Complex_Interval (interval_of_real prec (Re z)) (interval_of_real prec (Im z))"

fun poly_interval :: "'a :: {plus,times,zero} list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "poly_interval [] _ = 0"
| "poly_interval [c] _ = c"
| "poly_interval (c # cs) x = c + x * poly_interval cs x"

definition filter_fun_complex :: "complex poly \<Rightarrow> nat \<Rightarrow> complex \<Rightarrow> bool" where
  "filter_fun_complex p = (let c = coeffs p in
      (\<lambda> prec. let cs = map (interval_of_complex prec) c
      in (\<lambda> x. 0 \<in>\<^sub>c poly_interval cs (interval_of_complex prec x))))"

definition filter_fun_real :: "real poly \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> bool" where
  "filter_fun_real p = (let c = coeffs p in
      (\<lambda> prec. let cs = map (interval_of_real prec) c
      in (\<lambda> x. 0 \<in>\<^sub>i poly_interval cs (interval_of_real prec x))))"

definition genuine_roots :: "_ poly \<Rightarrow> _ list \<Rightarrow> _ list" where
  "genuine_roots p xs = filter (\<lambda>x. poly p x = 0) xs"

lemma zero_in_interval_0 [simp, intro]: "0 \<in>\<^sub>i 0"
  unfolding zero_interval_def by auto

lemma zero_in_complex_interval_0 [simp, intro]: "0 \<in>\<^sub>c 0"
  unfolding zero_complex_interval_def by (auto simp: in_complex_interval_def)

lemma length_coeffs_degree':
  "length (coeffs p) = (if p = 0 then 0 else Suc (degree p))"
  by (cases "p = 0") (auto simp: length_coeffs_degree)

lemma poly_in_poly_interval_complex:
  assumes "list_all2 (\<lambda>c ivl. c \<in>\<^sub>c ivl) (coeffs p) cs" "x \<in>\<^sub>c ivl"
  shows   "poly p x \<in>\<^sub>c poly_interval cs ivl"
proof -
  have len_eq: "length (coeffs p) = length cs"
    using assms(1) list_all2_lengthD by blast
  have "coeffs p = map (\<lambda>i. coeffs p ! i) [0..<length cs]"
    by (subst len_eq [symmetric], rule map_nth [symmetric])
  also have "\<dots> = map (poly.coeff p) [0..<length cs]"
    by (intro map_cong) (auto simp: nth_coeffs_coeff len_eq)
  finally have "list_all2 (\<lambda>c ivl. c \<in>\<^sub>c ivl) (map (poly.coeff p) [0..<length cs]) cs"
    using assms by simp
  moreover have "length cs \<ge> length (coeffs p)"
    using len_eq by simp
  ultimately show ?thesis using assms(2)
  proof (induction cs ivl arbitrary: p x rule: poly_interval.induct)
    case (1 ivl p x)
    thus ?case by auto
  next
    case (2 c ivl p x)
    have "degree p = 0"
      using 2 by (auto simp: degree_eq_length_coeffs)
    then obtain c' where [simp]: "p = [:c':]"
      by (meson degree_eq_zeroE)
    show ?case using 2 by auto
  next
    case (3 c1 c2 cs ivl p x)
    obtain q c where [simp]: "p = pCons c q"
      by (cases p rule: pCons_cases)
    have "list_all2 in_complex_interval (map (poly.coeff p) [0..<length (c1 # c2 # cs)])
                  (c1 # c2 # cs)"
      using "3.prems"(1) by simp
    also have "[0..<length (c1 # c2 # cs)] = 0 # map Suc [0..<length (c2 # cs)]"
      by (metis length_Cons map_Suc_upt upt_conv_Cons zero_less_Suc)
    also have "map (poly.coeff p) \<dots> = c # map (poly.coeff q) [0..<length (c2 # cs)]"
      by auto
    finally have "c \<in>\<^sub>c c1" and
        "list_all2 in_complex_interval (map (poly.coeff q) [0..<length (c2 # cs)]) (c2 # cs)"
      using "3.prems" by (simp_all del: upt_Suc)

    have IH: "poly q x \<in>\<^sub>c poly_interval (c2 # cs) ivl"
    proof (rule "3.IH")
      show "length (coeffs q) \<le> length (c2 # cs)"
        using "3.prems"(2) unfolding length_coeffs_degree' by auto
    qed fact+

    show ?case
      using IH "3.prems" \<open>c \<in>\<^sub>c c1\<close>
      by (auto intro!: plus_complex_interval times_complex_interval)
  qed
qed

lemma poly_in_poly_interval_real: fixes x :: real
  assumes "list_all2 (\<lambda>c ivl. c \<in>\<^sub>i ivl) (coeffs p) cs" "x \<in>\<^sub>i ivl"
  shows   "poly p x \<in>\<^sub>i poly_interval cs ivl"
proof -
  have len_eq: "length (coeffs p) = length cs"
    using assms(1) list_all2_lengthD by blast
  have "coeffs p = map (\<lambda>i. coeffs p ! i) [0..<length cs]"
    by (subst len_eq [symmetric], rule map_nth [symmetric])
  also have "\<dots> = map (poly.coeff p) [0..<length cs]"
    by (intro map_cong) (auto simp: nth_coeffs_coeff len_eq)
  finally have "list_all2 (\<lambda>c ivl. c \<in>\<^sub>i ivl) (map (poly.coeff p) [0..<length cs]) cs"
    using assms by simp
  moreover have "length cs \<ge> length (coeffs p)"
    using len_eq by simp
  ultimately show ?thesis using assms(2)
  proof (induction cs ivl arbitrary: p x rule: poly_interval.induct)
    case (1 ivl p x)
    thus ?case by auto
  next
    case (2 c ivl p x)
    have "degree p = 0"
      using 2 by (auto simp: degree_eq_length_coeffs)
    then obtain c' where [simp]: "p = [:c':]"
      by (meson degree_eq_zeroE)
    show ?case using 2 by auto
  next
    case (3 c1 c2 cs ivl p x)
    obtain q c where [simp]: "p = pCons c q"
      by (cases p rule: pCons_cases)
    have "list_all2 in_interval (map (poly.coeff p) [0..<length (c1 # c2 # cs)])
                  (c1 # c2 # cs)"
      using "3.prems"(1) by simp
    also have "[0..<length (c1 # c2 # cs)] = 0 # map Suc [0..<length (c2 # cs)]"
      by (metis length_Cons map_Suc_upt upt_conv_Cons zero_less_Suc)
    also have "map (poly.coeff p) \<dots> = c # map (poly.coeff q) [0..<length (c2 # cs)]"
      by auto
    finally have "c \<in>\<^sub>i c1" and
        "list_all2 in_interval (map (poly.coeff q) [0..<length (c2 # cs)]) (c2 # cs)"
      using "3.prems" by (simp_all del: upt_Suc)

    have IH: "poly q x \<in>\<^sub>i poly_interval (c2 # cs) ivl"
    proof (rule "3.IH")
      show "length (coeffs q) \<le> length (c2 # cs)"
        using "3.prems"(2) unfolding length_coeffs_degree' by auto
    qed fact+

    show ?case
      using IH "3.prems" \<open>c \<in>\<^sub>i c1\<close>
      by (auto intro!: plus_in_interval times_in_interval)
  qed
qed

lemma in_interval_of_real [simp, intro]: "x \<in>\<^sub>i interval_of_real prec x"
  unfolding interval_of_real_def by (auto simp: Let_def of_rat_rat field_simps)

lemma in_interval_of_complex [simp, intro]: "z \<in>\<^sub>c interval_of_complex prec z"
  unfolding interval_of_complex_def in_complex_interval_def by auto

lemma distinct_genuine_roots [simp, intro]:
  "distinct xs \<Longrightarrow> distinct (genuine_roots p xs)"
  by (simp add: genuine_roots_def)

definition filter_fun :: "'a poly \<Rightarrow> (nat \<Rightarrow> 'a :: comm_ring \<Rightarrow> bool) \<Rightarrow> bool" where
  "filter_fun p f = (\<forall> n x. poly p x = 0 \<longrightarrow> f n x)"

lemma filter_fun_complex: "filter_fun p (filter_fun_complex p)"
  unfolding filter_fun_def
proof (intro impI allI)
  fix prec x
  assume root: "poly p x = 0"
  define cs where "cs = map (interval_of_complex prec) (coeffs p)"
  have cs: "list_all2 in_complex_interval (coeffs p) cs"
    unfolding cs_def list_all2_map2 by (intro list_all2_refl in_interval_of_complex)
  define P where "P = (\<lambda>x. 0 \<in>\<^sub>c poly_interval cs (interval_of_complex prec x))"
  have "P x"
  proof -
    have "poly p x \<in>\<^sub>c poly_interval cs (interval_of_complex prec x)"
      by (intro poly_in_poly_interval_complex in_interval_of_complex cs)
    with root show ?thesis
      by (simp add: P_def)
  qed
  thus "filter_fun_complex p prec x" unfolding filter_fun_complex_def Let_def P_def
    using cs_def by blast
qed

lemma filter_fun_real: "filter_fun p (filter_fun_real p)"
  unfolding filter_fun_def
proof (intro impI allI)
  fix prec x
  assume root: "poly p x = 0"
  define cs where "cs = map (interval_of_real prec) (coeffs p)"
  have cs: "list_all2 in_interval (coeffs p) cs"
    unfolding cs_def list_all2_map2 by (intro list_all2_refl in_interval_of_real)
  define P where "P = (\<lambda>x. 0 \<in>\<^sub>i poly_interval cs (interval_of_real prec x))"
  have "P x"
  proof -
    have "poly p x \<in>\<^sub>i poly_interval cs (interval_of_real prec x)"
      by (intro poly_in_poly_interval_real in_interval_of_real cs)
    with root show ?thesis
      by (simp add: P_def)
  qed
  thus "filter_fun_real p prec x" unfolding filter_fun_real_def Let_def P_def
    using cs_def by blast
qed

context
  fixes p :: "'a :: comm_ring poly" and f
  assumes ff: "filter_fun p f"
begin

lemma genuine_roots_step:
  "genuine_roots p xs = genuine_roots p (filter (f prec) xs)"
  unfolding genuine_roots_def filter_filter
  using ff[unfolded filter_fun_def, rule_format, of _ prec] by metis

lemma genuine_roots_step_preserve_invar:
  assumes "{z. poly p z = 0} \<subseteq> set xs"
  shows   "{z. poly p z = 0} \<subseteq> set (filter (f prec) xs)"
proof -
  have "{z. poly p z = 0} = set (genuine_roots p xs)"
    using assms by (auto simp: genuine_roots_def)
  also have "\<dots> = set (genuine_roots p (filter (f prec) xs))"
    using genuine_roots_step[of _ prec] by simp
  also have "\<dots> \<subseteq> set (filter (f prec) xs)"
    by (auto simp: genuine_roots_def)
  finally show ?thesis .
qed
end

lemma genuine_roots_finish:
  fixes p :: "'a :: field_char_0 poly"
  assumes "{z. poly p z = 0} \<subseteq> set xs" "distinct xs"
  assumes "length xs = card {z. poly p z = 0}"
  shows   "genuine_roots p xs = xs"
proof -
  have [simp]: "p \<noteq> 0"
    using finite_subset[OF assms(1) finite_set] infinite_UNIV_char_0 by auto
  have "length (genuine_roots p xs) = length xs"
    unfolding genuine_roots_def using assms
    by (simp add: Int_absorb2 distinct_length_filter)
  thus ?thesis
    unfolding genuine_roots_def
    by (metis filter_True length_filter_less linorder_not_less order_eq_iff)
qed

text \<open>This is type of the initial search problem. It consists of a polynomial $p$,
  a list $xs$ of candidate roots, the cardinality of the set of roots of $p$ and a filter function to
  drop non-roots that is parametric in a precision parameter.\<close>
typedef (overloaded) 'a genuine_roots_aux =
  "{(p :: 'a :: field_char_0 poly, xs, n, ff).
    distinct xs \<and>
    {z. poly p z = 0} \<subseteq> set xs \<and>
    card {z. poly p z = 0} = n \<and>
    filter_fun p ff}"
  by (rule exI[of _ "(1, [], 0, \<lambda> _ _. False)"], auto simp: filter_fun_def)

setup_lifting type_definition_genuine_roots_aux

lift_definition genuine_roots' :: "nat \<Rightarrow> 'a :: field_char_0 genuine_roots_aux \<Rightarrow> 'a list" is
  "\<lambda>prec (p, xs, n, ff). genuine_roots p xs" .

lift_definition genuine_roots_impl_step' :: "nat \<Rightarrow> 'a :: field_char_0 genuine_roots_aux \<Rightarrow> 'a genuine_roots_aux" is
  "\<lambda>prec (p, xs, n, ff). (p, filter (ff prec) xs, n, ff)"
  by (safe, intro distinct_filter, auto simp: filter_fun_def)

lift_definition gr_poly :: "'a :: field_char_0 genuine_roots_aux \<Rightarrow> 'a poly" is
  "\<lambda>(p :: 'a poly, _, _, _). p" .

lift_definition gr_list :: "'a :: field_char_0 genuine_roots_aux \<Rightarrow> 'a list" is
  "\<lambda>(_, xs :: 'a list, _, _). xs" .

lift_definition gr_numroots :: "'a :: field_char_0 genuine_roots_aux \<Rightarrow> nat" is
  "\<lambda>(_, _, n, _). n" .

lemma genuine_roots'_code [code]:
  "genuine_roots' prec gr =
     (if length (gr_list gr) = gr_numroots gr then gr_list gr
      else genuine_roots' (2 * prec) (genuine_roots_impl_step' prec gr))"
proof (transfer, clarify)
  fix prec :: nat and p :: "'a poly" and xs :: "'a list" and ff
  assume *: "{z. poly p z = 0} \<subseteq> set xs" "distinct xs" "filter_fun p ff"
  show "genuine_roots p xs =
          (if length xs = card {z. poly p z = 0} then xs
           else genuine_roots p (filter (ff prec) xs))"
    using genuine_roots_finish[of p xs] genuine_roots_step[of p] * by auto
qed

definition initial_precision :: nat where "initial_precision = 10"

definition genuine_roots_impl :: "'a genuine_roots_aux \<Rightarrow> 'a :: field_char_0 list" where
  "genuine_roots_impl = genuine_roots' initial_precision"

lemma genuine_roots_impl: "set (genuine_roots_impl p) = {z. poly (gr_poly p) z = 0}"
  "distinct (genuine_roots_impl p)"
  unfolding genuine_roots_impl_def
  by (transfer, auto simp: genuine_roots_def, transfer, auto)

end


(*
  File:    Angles.thy
  Author:  Manuel Eberl <manuel@pruvisto.org>

  Definition of angles between vectors and between three points.
*)

section \<open>Definition of angles\<close>
theory Angles
imports
  "HOL-Analysis.Multivariate_Analysis"
begin

lemma collinear_translate_iff: "collinear (((+) a) ` A) \<longleftrightarrow> collinear A"
  by (auto simp: collinear_def)

definition vangle where
  "vangle u v = (if u = 0 \<or> v = 0 then pi / 2 else arccos (u \<bullet> v / (norm u * norm v)))"

definition angle where
  "angle a b c = vangle (a - b) (c - b)"

lemma angle_altdef: "angle a b c = arccos ((a - b) \<bullet> (c - b) / (dist a b * dist c b))"
  by (simp add: angle_def vangle_def dist_norm)

lemma vangle_0_left [simp]: "vangle 0 v = pi / 2"
  and vangle_0_right [simp]: "vangle u 0 = pi / 2"
  by (simp_all add: vangle_def)

lemma vangle_refl [simp]: "u \<noteq> 0 \<Longrightarrow> vangle u u = 0"
  by (simp add: vangle_def dot_square_norm power2_eq_square)

lemma angle_refl [simp]: "angle a a b = pi / 2" "angle a b b = pi / 2"
  by (simp_all add: angle_def)

lemma angle_refl_mid [simp]: "a \<noteq> b \<Longrightarrow> angle a b a = 0"
  by (simp add: angle_def)

lemma cos_vangle: "cos (vangle u v) = u \<bullet> v / (norm u * norm v)"
  unfolding vangle_def using Cauchy_Schwarz_ineq2[of u v] by (auto simp: field_simps)

lemma cos_angle: "cos (angle a b c) = (a - b) \<bullet> (c - b) / (dist a b * dist c b)"
  by (simp add: angle_def cos_vangle dist_norm)

lemma inner_conv_angle: "(a - b) \<bullet> (c - b) = dist a b * dist c b * cos (angle a b c)"
  by (simp add: cos_angle)

lemma vangle_commute: "vangle u v = vangle v u"
  by (simp add: vangle_def inner_commute mult.commute)

lemma vangle_nonneg: "vangle u v \<ge> 0" and vangle_le_pi: "vangle u v \<le> pi"
  using Cauchy_Schwarz_ineq2[of u v]
  by (auto simp: vangle_def field_simps intro!: arccos_lbound arccos_ubound)

lemmas vangle_bounds = vangle_nonneg vangle_le_pi

lemma angle_nonneg: "angle a b c \<ge> 0" and angle_le_pi: "angle a b c \<le> pi"
  using vangle_bounds unfolding angle_def by blast+

lemmas angle_bounds = angle_nonneg angle_le_pi

lemma sin_vangle_nonneg: "sin (vangle u v) \<ge> 0"
  using vangle_bounds by (rule sin_ge_zero)

lemma sin_angle_nonneg: "sin (angle a b c) \<ge> 0"
  using angle_bounds by (rule sin_ge_zero)

lemma vangle_eq_0D:
  assumes "vangle u v = 0"
  shows   "norm u *\<^sub>R v = norm v *\<^sub>R u"
proof -
  from assms have "u \<bullet> v = norm u * norm v"
    using arccos_eq_iff[of "(u \<bullet> v) / (norm u * norm v)" 1] Cauchy_Schwarz_ineq2[of u v]
    by (fastforce simp: vangle_def split: if_split_asm)
  thus ?thesis by (subst (asm) norm_cauchy_schwarz_eq) simp_all
qed

lemma vangle_eq_piD:
  assumes "vangle u v = pi"
  shows   "norm u *\<^sub>R v + norm v *\<^sub>R u = 0"
proof -
  from assms have "(-u) \<bullet> v = norm (-u) * norm v"
    using arccos_eq_iff[of "(u \<bullet> v) / (norm u * norm v)" "-1"] Cauchy_Schwarz_ineq2[of u v]
    by (simp add: field_simps vangle_def split: if_split_asm)
  thus ?thesis by (subst (asm) norm_cauchy_schwarz_eq) simp_all
qed

lemma dist_triangle_eq:
  fixes a b c :: "'a :: real_inner"
  shows "(dist a c = dist a b + dist b c) \<longleftrightarrow> dist a b *\<^sub>R (c - b) + dist b c *\<^sub>R (a - b) = 0"
  using norm_triangle_eq[of "b - a" "c - b"]
  by (simp add: dist_norm norm_minus_commute algebra_simps)

lemma angle_eq_pi_imp_dist_additive:
  assumes "angle a b c = pi"
  shows   "dist a c = dist a b + dist b c"
  using vangle_eq_piD[OF assms[unfolded angle_def]]
  by (subst dist_triangle_eq) (simp add: dist_norm norm_minus_commute)

lemma orthogonal_iff_vangle: "orthogonal u v \<longleftrightarrow> vangle u v = pi / 2"
  using arccos_eq_iff[of "u \<bullet> v / (norm u * norm v)" 0] Cauchy_Schwarz_ineq2[of u v]
  by (auto simp: vangle_def orthogonal_def)

lemma cos_minus1_imp_pi:
  assumes "cos x = -1" "x \<ge> 0" "x < 3 * pi"
  shows   "x = pi"
proof -
  have "cos (x - pi) = 1" by (simp add: assms)
  then obtain n :: int where n: "of_int n = (x / pi - 1) / 2"
    by (subst (asm) cos_one_2pi_int) (auto simp: field_simps)
  also from assms have "\<dots> \<in> {-1<..<1}" by (auto simp: field_simps)
  finally have "n = 0" by simp
  with n show ?thesis by simp
qed

lemma vangle_eqI:
  assumes "u \<noteq> 0" "v \<noteq> 0" "w \<noteq> 0" "x \<noteq> 0"
  assumes "(u \<bullet> v) * norm w * norm x = (w \<bullet> x) * norm u * norm v"
  shows   "vangle u v = vangle w x"
  using assms Cauchy_Schwarz_ineq2[of u v] Cauchy_Schwarz_ineq2[of w x]
  unfolding vangle_def by (auto simp: arccos_eq_iff field_simps)

lemma cos_vangle_eqD: "cos (vangle u v) = cos (vangle w x) \<Longrightarrow> vangle u v = vangle w x"
  by (rule cos_inj_pi) (simp_all add: vangle_bounds)

lemma cos_angle_eqD: "cos (angle a b c) = cos (angle d e f) \<Longrightarrow> angle a b c = angle d e f"
  unfolding angle_def by (rule cos_vangle_eqD)

lemma sin_vangle_zero_iff: "sin (vangle u v) = 0 \<longleftrightarrow> vangle u v \<in> {0, pi}"
proof
  assume "sin (vangle u v) = 0"
  then obtain n :: int where n: "of_int n = vangle u v / pi"
    by (subst (asm) sin_zero_iff_int2) auto
  also have "\<dots> \<in> {0..1}" using vangle_bounds by (auto simp: field_simps)
  finally have "n \<in> {0,1}" by auto
  thus "vangle u v \<in> {0,pi}" using n by (auto simp: field_simps)
qed auto

lemma sin_angle_zero_iff: "sin (angle a b c) = 0 \<longleftrightarrow> angle a b c \<in> {0, pi}"
  unfolding angle_def by (simp only: sin_vangle_zero_iff)

lemma vangle_collinear: "vangle u v \<in> {0, pi} \<Longrightarrow> collinear {0, u, v}"
apply (subst norm_cauchy_schwarz_equal [symmetric])
apply (subst norm_cauchy_schwarz_abs_eq)
apply (auto dest!: vangle_eq_0D vangle_eq_piD simp: eq_neg_iff_add_eq_0)
done

lemma angle_collinear: "angle a b c \<in> {0, pi} \<Longrightarrow> collinear {a, b, c}"
apply (unfold angle_def, drule vangle_collinear)
apply (subst collinear_translate_iff[symmetric, of _ "-b"])
apply (auto simp: insert_commute)
done

lemma not_collinear_vangle: "\<not>collinear {0,u,v} \<Longrightarrow> vangle u v \<in> {0<..<pi}"
  using vangle_bounds[of u v] vangle_collinear[of u v]
  by (cases "vangle u v = 0 \<or> vangle u v = pi") auto

lemma not_collinear_angle: "\<not>collinear {a,b,c} \<Longrightarrow> angle a b c \<in> {0<..<pi}"
  using angle_bounds[of a b c] angle_collinear[of a b c]
  by (cases "angle a b c = 0 \<or> angle a b c = pi") auto

subsection\<open>Contributions from Lukas Bulwahn\<close>

lemma vangle_scales:
  assumes "0 < c"
  shows "vangle (c *\<^sub>R v\<^sub>1) v\<^sub>2 = vangle v\<^sub>1 v\<^sub>2"
using assms unfolding vangle_def by auto

lemma vangle_inverse:
  "vangle (- v\<^sub>1) v\<^sub>2 = pi - vangle v\<^sub>1 v\<^sub>2"
proof -
  have "\<bar>v\<^sub>1 \<bullet> v\<^sub>2 / (norm v\<^sub>1 * norm v\<^sub>2)\<bar> \<le> 1"
  proof cases
    assume "v\<^sub>1 \<noteq> 0 \<and> v\<^sub>2 \<noteq> 0"
    from this show ?thesis by (simp add: Cauchy_Schwarz_ineq2)
  next
    assume "\<not> (v\<^sub>1 \<noteq> 0 \<and> v\<^sub>2 \<noteq> 0)"
    from this show ?thesis by auto
  qed
  from this show ?thesis
    unfolding vangle_def
    by (simp add: arccos_minus_abs)
qed

lemma orthogonal_iff_angle:
  shows "orthogonal (A - B) (C - B) \<longleftrightarrow> angle A B C = pi / 2"
unfolding angle_def by (auto simp only: orthogonal_iff_vangle)

lemma angle_inverse:
  assumes "between (A, C) B"
  assumes "A \<noteq> B" "B \<noteq> C"
  shows "angle A B D = pi - angle C B D"
proof -
  from \<open>between (A, C) B\<close> obtain u where u: "u \<ge> 0" "u \<le> 1"
    and X: "B = u *\<^sub>R A + (1 - u) *\<^sub>R C"
    by (metis add.commute betweenE between_commute)
  from \<open>A \<noteq> B\<close> \<open>B \<noteq> C\<close> X have "u \<noteq> 0" "u \<noteq> 1" by auto
  have "0 < ((1 - u) / u)"
    using \<open>u \<noteq> 0\<close> \<open>u \<noteq> 1\<close> \<open>u \<ge> 0\<close> \<open>u \<le> 1\<close> by simp
  from X have "A - B = - (1 - u) *\<^sub>R (C - A)"
    by (simp add: real_vector.scale_right_diff_distrib real_vector.scale_left_diff_distrib)
  moreover from X have "C - B = u *\<^sub>R (C - A)"
    by (simp add: scaleR_diff_left real_vector.scale_right_diff_distrib)
  ultimately have "A - B = - (((1 - u) / u) *\<^sub>R (C - B))"
    using \<open>u \<noteq> 0\<close> by simp (metis minus_diff_eq real_vector.scale_minus_left)
  from this have "vangle (A - B) (D - B) = pi - vangle (C - B) (D - B)"
    using \<open>0 < (1 - u) / u\<close> by (simp add: vangle_inverse vangle_scales)
  from this show ?thesis
    unfolding angle_def by simp
qed

lemma strictly_between_implies_angle_eq_pi:
  assumes "between (A, C) B"
  assumes "A \<noteq> B" "B \<noteq> C"
  shows "angle A B C = pi"
proof -
  from \<open>between (A, C) B\<close> obtain u where u: "u \<ge> 0" "u \<le> 1"
    and X: "B = u *\<^sub>R A + (1 - u) *\<^sub>R C"
    by (metis add.commute betweenE between_commute)
  from \<open>A \<noteq> B\<close> \<open>B \<noteq> C\<close> X have "u \<noteq> 0" "u \<noteq> 1" by auto
  from \<open>A \<noteq> B\<close> \<open>B \<noteq> C\<close> \<open>between (A, C) B\<close> have "A \<noteq> C" by auto
  from X have "A - B = - (1 - u) *\<^sub>R (C - A)"
    by (simp add: real_vector.scale_right_diff_distrib real_vector.scale_left_diff_distrib)
  moreover from this have "dist A B = norm ((1 - u) *\<^sub>R (C - A))"
    using \<open>u \<ge> 0\<close> \<open>u \<le> 1\<close> by (simp add: dist_norm)
  moreover from X have "C - B = u *\<^sub>R (C - A)"
    by (simp add: scaleR_diff_left real_vector.scale_right_diff_distrib)
  moreover from this have "dist C B = norm (u *\<^sub>R (C - A))"
    by (simp add: dist_norm)
  ultimately have "(A - B) \<bullet> (C - B) / (dist A B * dist C B) = u * (u - 1) / (\<bar>1 - u\<bar> * \<bar>u\<bar>)"
    using \<open>A \<noteq> C\<close> by (simp add: dot_square_norm power2_eq_square)
  also have "\<dots> = - 1"
    using \<open>u \<noteq> 0\<close> \<open>u \<noteq> 1\<close> \<open>u \<ge> 0\<close> \<open>u \<le> 1\<close> by (simp add: divide_eq_minus_1_iff)
  finally show ?thesis
    unfolding angle_altdef by simp
qed

end