chapter \<open>Generated by Lem from \<open>basic_classes.lem\<close>.\<close>

theory "Lem_basic_classes"

imports
  Main
  "Lem_bool"

begin

(******************************************************************************)
(* Basic Type Classes                                                         *)
(******************************************************************************)

(*open import Bool*)

(*open import {coq} `Coq.Strings.Ascii`*)
(*open import {hol} `ternaryComparisonsTheory`*)

(* ========================================================================== *)
(* Equality                                                                   *)
(* ========================================================================== *)

(* Lem`s default equality (=) is defined by the following type-class Eq.
   This typeclass should define equality on an abstract datatype 'a. It should
   always coincide with the default equality of Coq, HOL and Isabelle.
   For OCaml, it might be different, since abstract datatypes like sets
   might have fancy equalities. *)

(*class ( Eq 'a )
  val = [isEqual] : 'a -> 'a -> bool
  val <> [isInequal] : 'a -> 'a -> bool
end*)

(* (=) should for all instances be an equivalence relation
   The isEquivalence predicate of relations could be used here.
   However, this would lead to a cyclic dependency. *)

(* TODO: add later, once lemmata can be assigned to classes
lemma eq_equiv: ((forall x. (x = x)) &&
                 (forall x y. (x = y) <-> (y = x)) &&
                 (forall x y z. ((x = y) && (y = z)) --> (x = z)))
*)

(* Structural equality *)

(* Sometimes, it is also handy to be able to use structural equality.
   This equality is mapped to the build-in equality of backends. This equality
   differs significantly for each backend. For example, OCaml can`t check equality
   of function types, whereas HOL can.  When using structural equality, one should
   know what one is doing. The only guarentee is that is behaves like
   the native backend equality.

   A lengthy name for structural equality is used to discourage its direct use.
   It also ensures that users realise it is unsafe (e.g. OCaml can`t check two functions
   for equality *)
(*val unsafe_structural_equality : forall 'a. 'a -> 'a -> bool*)

(*val unsafe_structural_inequality : forall 'a. 'a -> 'a -> bool*)
(*let unsafe_structural_inequality x y=  not (unsafe_structural_equality x y)*)

(* ========================================================================== *)
(* Orderings                                                                  *)
(* ========================================================================== *)

(* The type-class Ord represents total orders (also called linear orders) *)
datatype ordering = LT | EQ | GT

fun orderingIsLess  :: " ordering \<Rightarrow> bool "        where
     " orderingIsLess LT       = ( True )"
|" orderingIsLess _       = ( False )"

fun orderingIsGreater  :: " ordering \<Rightarrow> bool "     where
     " orderingIsGreater GT    = ( True )"
|" orderingIsGreater _    = ( False )"

fun orderingIsEqual  :: " ordering \<Rightarrow> bool "       where
     " orderingIsEqual EQ      = ( True )"
|" orderingIsEqual _      = ( False )"

definition ordering_cases  :: " ordering \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a "  where
     " ordering_cases r lt eq gt = (
  if orderingIsLess r then lt else
  if orderingIsEqual r then eq else gt )"

(*val orderingEqual : ordering -> ordering -> bool*)

record 'a Ord_class=

  compare_method                 ::" 'a \<Rightarrow> 'a \<Rightarrow> ordering "

  isLess_method         ::" 'a \<Rightarrow> 'a \<Rightarrow> bool "

  isLessEqual_method    ::" 'a \<Rightarrow> 'a \<Rightarrow> bool "

  isGreater_method      ::" 'a \<Rightarrow> 'a \<Rightarrow> bool "

  isGreaterEqual_method ::" 'a \<Rightarrow> 'a \<Rightarrow> bool "

(* Ocaml provides default, polymorphic compare functions. Let's use them
   as the default. However, because used perhaps in a typeclass they must be
   defined for all targets. So, explicitly declare them as undefined for
   all other targets. If explictly declare undefined, the type-checker won't complain and
   an error will only be raised when trying to actually output the function for a certain
   target. *)
(*val defaultCompare   : forall 'a. 'a -> 'a -> ordering*)
(*val defaultLess      : forall 'a. 'a -> 'a -> bool*)
(*val defaultLessEq    : forall 'a. 'a -> 'a -> bool*)
(*val defaultGreater   : forall 'a. 'a -> 'a -> bool*)
(*val defaultGreaterEq : forall 'a. 'a -> 'a -> bool*)

definition genericCompare  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ordering "  where
     " genericCompare (less1:: 'a \<Rightarrow> 'a \<Rightarrow> bool) (equal:: 'a \<Rightarrow> 'a \<Rightarrow> bool) (x :: 'a) (y :: 'a) = (
  if less1 x y then
    LT
  else if equal x y then
    EQ
  else
    GT )"

(*
(* compare should really be a total order *)
lemma ord_OK_1: (
  (forall x y. (compare x y = EQ) <-> (compare y x = EQ)) &&
  (forall x y. (compare x y = LT) <-> (compare y x = GT)))

lemma ord_OK_2: (
  (forall x y z. (x <= y) && (y <= z) --> (x <= z)) &&
  (forall x y. (x <= y) || (y <= x))
)
*)

(* let's derive a compare function from the Ord type-class *)
(*val ordCompare : forall 'a. Eq 'a, Ord 'a => 'a -> 'a -> ordering*)
definition ordCompare  :: " 'a Ord_class \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ordering "  where
     " ordCompare dict_Basic_classes_Ord_a x y = (
  if ((isLess_method   dict_Basic_classes_Ord_a) x y) then LT else
  if (x = y) then EQ else GT )"

record 'a OrdMaxMin_class=

  max_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a "

  min_method ::" 'a \<Rightarrow> 'a \<Rightarrow> 'a "

(*val minByLessEqual : forall 'a. ('a -> 'a -> bool) -> 'a -> 'a -> 'a*)

(*val maxByLessEqual : forall 'a. ('a -> 'a -> bool) -> 'a -> 'a -> 'a*)

(*val defaultMax : forall 'a. Ord 'a => 'a -> 'a -> 'a*)

(*val defaultMin : forall 'a. Ord 'a => 'a -> 'a -> 'a*)

definition instance_Basic_classes_OrdMaxMin_var_dict  :: " 'a Ord_class \<Rightarrow> 'a OrdMaxMin_class "  where
     " instance_Basic_classes_OrdMaxMin_var_dict dict_Basic_classes_Ord_a = ((|

  max_method = ((\<lambda> x y. if (
  (isLessEqual_method   dict_Basic_classes_Ord_a) y x) then x else y)),

  min_method = ((\<lambda> x y. if (
  (isLessEqual_method   dict_Basic_classes_Ord_a) x y) then x else y))|) )"

(* ========================================================================== *)
(* SetTypes                                                                   *)
(* ========================================================================== *)

(* Set implementations use often an order on the elements. This allows the OCaml implementation
   to use trees for implementing them. At least, one needs to be able to check equality on sets.
   One could use the Ord type-class for sets. However, defining a special typeclass is cleaner
   and allows more flexibility. One can make e.g. sure, that this type-class is ignored for
   backends like HOL or Isabelle, which don't need it. Moreover, one is not forced to also instantiate
   the functions <, <= ... *)

(*class ( SetType 'a )
  val {ocaml;coq} setElemCompare : 'a -> 'a -> ordering
end*)

fun boolCompare  :: " bool \<Rightarrow> bool \<Rightarrow> ordering "  where
     " boolCompare True True = ( EQ )"
|" boolCompare True False = ( GT )"
|" boolCompare False True = ( LT )"
|" boolCompare False False = ( EQ )"

(* strings *)

(*val charEqual : char -> char -> bool*)

(*val stringEquality : string -> string -> bool*)

(* pairs *)

(*val pairEqual : forall 'a 'b. Eq 'a, Eq 'b => ('a * 'b) -> ('a * 'b) -> bool*)
(*let pairEqual (a1, b1) (a2, b2)=  (a1 = a2) && (b1 = b2)*)

(*val pairEqualBy : forall 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -> bool*)

(*val pairCompare : forall 'a 'b. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('a * 'b) -> ('a * 'b) -> ordering*)
fun pairCompare  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow> 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> ordering "  where
     " pairCompare cmpa cmpb (a1, b1) (a2, b2) = (
  (case  cmpa a1 a2 of
      LT => LT
    | GT => GT
    | EQ => cmpb b1 b2
  ))"

fun pairLess  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'b*'a \<Rightarrow> 'b*'a \<Rightarrow> bool "  where
     " pairLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b (x1, x2) (y1, y2) = ( (
  (isLess_method   dict_Basic_classes_Ord_b) x1 y1) \<or> (((isLessEqual_method   dict_Basic_classes_Ord_b) x1 y1) \<and> ((isLess_method   dict_Basic_classes_Ord_a) x2 y2)))"

fun pairLessEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'b*'a \<Rightarrow> 'b*'a \<Rightarrow> bool "  where
     " pairLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b (x1, x2) (y1, y2) = ( (
  (isLess_method   dict_Basic_classes_Ord_b) x1 y1) \<or> (((isLessEqual_method   dict_Basic_classes_Ord_b) x1 y1) \<and> ((isLessEqual_method   dict_Basic_classes_Ord_a) x2 y2)))"

definition pairGreater  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool "  where
     " pairGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b x12 y12 = ( pairLess
  dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12 x12 )"

definition pairGreaterEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool "  where
     " pairGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b x12 y12 = ( pairLessEq
  dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12 x12 )"

definition instance_Basic_classes_Ord_tup2_dict  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow>('a*'b)Ord_class "  where
     " instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b = ((|

  compare_method = (pairCompare
  (compare_method   dict_Basic_classes_Ord_a) (compare_method   dict_Basic_classes_Ord_b)),

  isLess_method =
  (pairLess dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a),

  isLessEqual_method =
  (pairLessEq dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a),

  isGreater_method =
  (pairGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b),

  isGreaterEqual_method =
  (pairGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b) |) )"

(* triples *)

(*val tripleEqual : forall 'a 'b 'c. Eq 'a, Eq 'b, Eq 'c => ('a * 'b * 'c) -> ('a * 'b * 'c) -> bool*)
(*let tripleEqual (x1, x2, x3) (y1, y2, y3)=  ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, x3)) (y1, (y2, y3)))*)

(*val tripleCompare : forall 'a 'b 'c. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) -> ('a * 'b * 'c) -> ('a * 'b * 'c) -> ordering*)
fun tripleCompare  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c \<Rightarrow> 'a*'b*'c \<Rightarrow> ordering "  where
     " tripleCompare cmpa cmpb cmpc (a1, b1, c1) (a2, b2, c2) = (
  pairCompare cmpa (pairCompare cmpb cmpc) (a1, (b1, c1)) (a2, (b2, c2)))"

fun tripleLess  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'a*'b*'c \<Rightarrow> 'a*'b*'c \<Rightarrow> bool "  where
     " tripleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c (x1, x2, x3) (y1, y2, y3) = ( pairLess
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c) dict_Basic_classes_Ord_a (x1, (x2, x3)) (y1, (y2, y3)))"

fun tripleLessEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'a*'b*'c \<Rightarrow> 'a*'b*'c \<Rightarrow> bool "  where
     " tripleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c (x1, x2, x3) (y1, y2, y3) = ( pairLessEq
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c) dict_Basic_classes_Ord_a (x1, (x2, x3)) (y1, (y2, y3)))"

definition tripleGreater  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'c*'b*'a \<Rightarrow> 'c*'b*'a \<Rightarrow> bool "  where
     " tripleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c x123 y123 = ( tripleLess
  dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123 x123 )"

definition tripleGreaterEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'c*'b*'a \<Rightarrow> 'c*'b*'a \<Rightarrow> bool "  where
     " tripleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c x123 y123 = ( tripleLessEq
  dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123 x123 )"

definition instance_Basic_classes_Ord_tup3_dict  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow>('a*'b*'c)Ord_class "  where
     " instance_Basic_classes_Ord_tup3_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c = ((|

  compare_method = (tripleCompare
  (compare_method   dict_Basic_classes_Ord_a) (compare_method   dict_Basic_classes_Ord_b) (compare_method   dict_Basic_classes_Ord_c)),

  isLess_method =
  (tripleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c),

  isLessEqual_method =
  (tripleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c),

  isGreater_method =
  (tripleGreater dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_a),

  isGreaterEqual_method =
  (tripleGreaterEq dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_a) |) )"

(* quadruples *)

(*val quadrupleEqual : forall 'a 'b 'c 'd. Eq 'a, Eq 'b, Eq 'c, Eq 'd => ('a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'd) -> bool*)
(*let quadrupleEqual (x1, x2, x3, x4) (y1, y2, y3, y4)=  ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))))*)

(*val quadrupleCompare : forall 'a 'b 'c 'd. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) ->
                                              ('d -> 'd -> ordering) -> ('a * 'b * 'c * 'd) -> ('a * 'b * 'c * 'd) -> ordering*)
fun quadrupleCompare  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow>('d \<Rightarrow> 'd \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c*'d \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> ordering "  where
     " quadrupleCompare cmpa cmpb cmpc cmpd (a1, b1, c1, d1) (a2, b2, c2, d2) = (
  pairCompare cmpa (pairCompare cmpb (pairCompare cmpc cmpd)) (a1, (b1, (c1, d1))) (a2, (b2, (c2, d2))))"

fun quadrupleLess  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> bool "  where
     " quadrupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d (x1, x2, x3, x4) (y1, y2, y3, y4) = ( pairLess
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c
        dict_Basic_classes_Ord_d)) dict_Basic_classes_Ord_a (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))))"

fun quadrupleLessEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> 'a*'b*'c*'d \<Rightarrow> bool "  where
     " quadrupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d (x1, x2, x3, x4) (y1, y2, y3, y4) = ( pairLessEq
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c
        dict_Basic_classes_Ord_d)) dict_Basic_classes_Ord_a (x1, (x2, (x3, x4))) (y1, (y2, (y3, y4))))"

definition quadrupleGreater  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> bool "  where
     " quadrupleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d x1234 y1234 = ( quadrupleLess
  dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y1234 x1234 )"

definition quadrupleGreaterEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> 'd*'c*'b*'a \<Rightarrow> bool "  where
     " quadrupleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d x1234 y1234 = ( quadrupleLessEq
  dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y1234 x1234 )"

definition instance_Basic_classes_Ord_tup4_dict  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow>('a*'b*'c*'d)Ord_class "  where
     " instance_Basic_classes_Ord_tup4_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d = ((|

  compare_method = (quadrupleCompare
  (compare_method   dict_Basic_classes_Ord_a) (compare_method   dict_Basic_classes_Ord_b) (compare_method   dict_Basic_classes_Ord_c) (compare_method   dict_Basic_classes_Ord_d)),

  isLess_method =
  (quadrupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d),

  isLessEqual_method =
  (quadrupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d),

  isGreater_method =
  (quadrupleGreater dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c
     dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a),

  isGreaterEqual_method =
  (quadrupleGreaterEq dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c
     dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a) |) )"

(* quintuples *)

(*val quintupleEqual : forall 'a 'b 'c 'd 'e. Eq 'a, Eq 'b, Eq 'c, Eq 'd, Eq 'e => ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'e) -> bool*)
(*let quintupleEqual (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5)=  ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))))*)

(*val quintupleCompare : forall 'a 'b 'c 'd 'e. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) ->
                                              ('d -> 'd -> ordering) -> ('e -> 'e -> ordering) -> ('a * 'b * 'c * 'd * 'e) -> ('a * 'b * 'c * 'd * 'e) -> ordering*)
fun quintupleCompare  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow>('d \<Rightarrow> 'd \<Rightarrow> ordering)\<Rightarrow>('e \<Rightarrow> 'e \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> ordering "  where
     " quintupleCompare cmpa cmpb cmpc cmpd cmpe (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = (
  pairCompare cmpa (pairCompare cmpb (pairCompare cmpc (pairCompare cmpd cmpe))) (a1, (b1, (c1, (d1, e1)))) (a2, (b2, (c2, (d2, e2)))))"

fun quintupleLess  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> bool "  where
     " quintupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) = ( pairLess
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c
        (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d
           dict_Basic_classes_Ord_e))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))))"

fun quintupleLessEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> 'a*'b*'c*'d*'e \<Rightarrow> bool "  where
     " quintupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) = ( pairLessEq
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c
        (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d
           dict_Basic_classes_Ord_e))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, x5)))) (y1, (y2, (y3, (y4, y5)))))"

definition quintupleGreater  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> bool "  where
     " quintupleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e x12345 y12345 = ( quintupleLess
  dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12345 x12345 )"

definition quintupleGreaterEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> 'e*'d*'c*'b*'a \<Rightarrow> bool "  where
     " quintupleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e x12345 y12345 = ( quintupleLessEq
  dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12345 x12345 )"

definition instance_Basic_classes_Ord_tup5_dict  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow>('a*'b*'c*'d*'e)Ord_class "  where
     " instance_Basic_classes_Ord_tup5_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e = ((|

  compare_method = (quintupleCompare
  (compare_method   dict_Basic_classes_Ord_a) (compare_method   dict_Basic_classes_Ord_b) (compare_method   dict_Basic_classes_Ord_c) (compare_method   dict_Basic_classes_Ord_d) (compare_method   dict_Basic_classes_Ord_e)),

  isLess_method =
  (quintupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d
     dict_Basic_classes_Ord_e),

  isLessEqual_method =
  (quintupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d
     dict_Basic_classes_Ord_e),

  isGreater_method =
  (quintupleGreater dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_a),

  isGreaterEqual_method =
  (quintupleGreaterEq dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_a) |) )"

(* sextuples *)

(*val sextupleEqual : forall 'a 'b 'c 'd 'e 'f. Eq 'a, Eq 'b, Eq 'c, Eq 'd, Eq 'e, Eq 'f => ('a * 'b * 'c * 'd * 'e * 'f) -> ('a * 'b * 'c * 'd * 'e * 'f) -> bool*)
(*let sextupleEqual (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6)=  ((Instance_Basic_classes_Eq_tup2.=) (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))))*)

(*val sextupleCompare : forall 'a 'b 'c 'd 'e 'f. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) ->
                                              ('d -> 'd -> ordering) -> ('e -> 'e -> ordering) -> ('f -> 'f -> ordering) ->
                                              ('a * 'b * 'c * 'd * 'e * 'f) -> ('a * 'b * 'c * 'd * 'e * 'f) -> ordering*)
fun sextupleCompare  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow>('b \<Rightarrow> 'b \<Rightarrow> ordering)\<Rightarrow>('c \<Rightarrow> 'c \<Rightarrow> ordering)\<Rightarrow>('d \<Rightarrow> 'd \<Rightarrow> ordering)\<Rightarrow>('e \<Rightarrow> 'e \<Rightarrow> ordering)\<Rightarrow>('f \<Rightarrow> 'f \<Rightarrow> ordering)\<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> ordering "  where
     " sextupleCompare cmpa cmpb cmpc cmpd cmpe cmpf (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = (
  pairCompare cmpa (pairCompare cmpb (pairCompare cmpc (pairCompare cmpd (pairCompare cmpe cmpf)))) (a1, (b1, (c1, (d1, (e1, f1))))) (a2, (b2, (c2, (d2, (e2, f2))))))"

fun sextupleLess  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> bool "  where
     " sextupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) = ( pairLess
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c
        (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d
           (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_e
              dict_Basic_classes_Ord_f)))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))))"

fun sextupleLessEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> 'a*'b*'c*'d*'e*'f \<Rightarrow> bool "  where
     " sextupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) = ( pairLessEq
  (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b
     (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_c
        (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_d
           (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_e
              dict_Basic_classes_Ord_f)))) dict_Basic_classes_Ord_a (x1, (x2, (x3, (x4, (x5, x6))))) (y1, (y2, (y3, (y4, (y5, y6))))))"

definition sextupleGreater  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> bool "  where
     " sextupleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f x123456 y123456 = ( sextupleLess
  dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123456 x123456 )"

definition sextupleGreaterEq  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> 'f*'e*'d*'c*'b*'a \<Rightarrow> bool "  where
     " sextupleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f x123456 y123456 = ( sextupleLessEq
  dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123456 x123456 )"

definition instance_Basic_classes_Ord_tup6_dict  :: " 'a Ord_class \<Rightarrow> 'b Ord_class \<Rightarrow> 'c Ord_class \<Rightarrow> 'd Ord_class \<Rightarrow> 'e Ord_class \<Rightarrow> 'f Ord_class \<Rightarrow>('a*'b*'c*'d*'e*'f)Ord_class "  where
     " instance_Basic_classes_Ord_tup6_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f = ((|

  compare_method = (sextupleCompare
  (compare_method   dict_Basic_classes_Ord_a) (compare_method   dict_Basic_classes_Ord_b) (compare_method   dict_Basic_classes_Ord_c) (compare_method   dict_Basic_classes_Ord_d) (compare_method   dict_Basic_classes_Ord_e) (compare_method   dict_Basic_classes_Ord_f)),

  isLess_method =
  (sextupleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d
     dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f),

  isLessEqual_method =
  (sextupleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b
     dict_Basic_classes_Ord_c dict_Basic_classes_Ord_d
     dict_Basic_classes_Ord_e dict_Basic_classes_Ord_f),

  isGreater_method =
  (sextupleGreater dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e
     dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c
     dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a),

  isGreaterEqual_method =
  (sextupleGreaterEq dict_Basic_classes_Ord_f dict_Basic_classes_Ord_e
     dict_Basic_classes_Ord_d dict_Basic_classes_Ord_c
     dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a) |) )"

end


theory prop_65
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun lt :: "Nat => Nat => bool" where
  "lt x (Z) = False"
  | "lt (Z) (S z) = True"
  | "lt (S x2) (S z) = lt x2 z"
  (*hipster plus lt *)
(*hipster lt*)(*
lemma lemma_al [thy_expl]: "lt x2 x2 = False"
by (hipster_induct_schemes lt.simps)

lemma lemma_aal [thy_expl]: "lt x2 (S x2) = True"
by (hipster_induct_schemes lt.simps)

lemma lemma_abl [thy_expl]: "lt (S x2) x2 = False"
by (hipster_induct_schemes lt.simps)
*)
lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

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

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

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

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

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

  theorem x0 :
    "lt i (S (plus m i))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory prop_13
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun half :: "Nat => Nat" where
  "half (Z) = Z"
  | "half (S (Z)) = Z"
  | "half (S (S z)) = S (half z)"
  (*hipster plus half *)

lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

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

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

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

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

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

hipster plus half
lemma lemma_aj [thy_expl]: "half (plus x1 x1) = x1"
by (hipster_induct_schemes plus.simps half.simps)

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

end


theory Approximation_Quickcheck_Ex
imports "../Approximation"
begin

lemma
  fixes x::real and y::real
  shows "sin x \<le> tan x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample]
  oops

lemma "x \<le> y \<Longrightarrow> arctan y / y \<le> arctan x / x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample]
  oops

lemma "0 < x \<Longrightarrow> x \<le> y \<Longrightarrow> arctan y / y \<le> arctan x / x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=no_counterexample]
  by (rule arctan_divide_mono)

lemma
  fixes x::real
  shows "exp (exp x + exp y + sin x * sin y) - 0.4 > 0 \<or> 0.98 - sin x / (sin x * sin y + 2)^2 > 0"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample, size=10, iterations=1000, verbose]
  oops

lemma
  fixes x::real
  shows "x > 1 \<Longrightarrow> x \<le> 2 ^ 20 * log 2 x + 1 \<and> (sin x)\<^sup>2 + (cos x)\<^sup>2 = 1"
  using [[quickcheck_approximation_custom_seed = 1]]
  using [[quickcheck_approximation_epsilon = 0.00000001]]
    \<comment> \<open>avoids spurious counterexamples in approximate computation of \<^term>\<open>(sin x)\<^sup>2 + (cos x)\<^sup>2\<close>
      and therefore avoids expensive failing attempts for certification\<close>
  quickcheck[approximation, expect=counterexample, size=20]
  oops

end


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

section {* First-Order Logic: the 'if' example *}

theory If imports FOL begin

definition "if" :: "[o,o,o]=>o" where
  "if(P,Q,R) == P&Q | ~P&R"

lemma ifI:
    "[| P ==> Q; ~P ==> R |] ==> if(P,Q,R)"
apply (simp add: if_def, blast)
done

lemma ifE:
   "[| if(P,Q,R);  [| P; Q |] ==> S; [| ~P; R |] ==> S |] ==> S"
apply (simp add: if_def, blast)
done

lemma if_commute: "if(P, if(Q,A,B), if(Q,C,D)) <-> if(Q, if(P,A,C), if(P,B,D))"
apply (rule iffI)
apply (erule ifE)
apply (erule ifE)
apply (rule ifI)
apply (rule ifI)
oops

text{*Trying again from the beginning in order to use @{text blast}*}
declare ifI [intro!]
declare ifE [elim!]

lemma if_commute: "if(P, if(Q,A,B), if(Q,C,D)) <-> if(Q, if(P,A,C), if(P,B,D))"
by blast

lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,A,B))"
by blast

text{*Trying again from the beginning in order to prove from the definitions*}
lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,A,B))"
by (simp add: if_def, blast)

text{*An invalid formula.  High-level rules permit a simpler diagnosis*}
lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,B,A))"
apply auto
  -- {*The next step will fail unless subgoals remain*}
apply (tactic all_tac)
oops

text{*Trying again from the beginning in order to prove from the definitions*}
lemma "if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,B,A))"
apply (simp add: if_def, auto)
  -- {*The next step will fail unless subgoals remain*}
apply (tactic all_tac)
oops

end


(*  Title:       Implementing field extensions of the form Q[sqrt(b)]
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
section \<open>A representation of real numbers via triples\<close>

theory Real_Impl
imports
  Sqrt_Babylonian.Sqrt_Babylonian
begin

text \<open>We represent real numbers of the form $p + q \cdot \sqrt{b}$ for $p,q \in \rats$, $n \in \nats$
by triples $(p,q,b)$. However, we require the invariant that $\sqrt{b}$ is irrational.
Most binary operations are implemented via partial functions where the common the restriction is that
the numbers $b$ in both triples have to be identical. So, we support addition of $\sqrt{2} + \sqrt{2}$,
but not $\sqrt{2} + \sqrt{3}$.\<close>

text \<open>The set of natural numbers whose sqrt is irrational\<close>

definition "sqrt_irrat = { q :: nat. \<not> (\<exists> p. p * p = rat_of_nat q)}"

lemma sqrt_irrat: assumes choice: "q = 0 \<or> b \<in> sqrt_irrat"
   and eq: "real_of_rat p + real_of_rat q * sqrt (of_nat b) = 0"
   shows "q = 0"
  using choice
proof (cases "q = 0")
  case False
  with choice have sqrt_irrat: "b \<in> sqrt_irrat" by blast
  from eq have "real_of_rat q * sqrt (of_nat b) = real_of_rat (- p)"
    by (auto simp: of_rat_minus)
  then obtain p where "real_of_rat q * sqrt (of_nat b) = real_of_rat p" by blast
  from arg_cong[OF this, of "\<lambda> x. x * x"] have "real_of_rat (q * q) * (sqrt (of_nat b) * sqrt (of_nat b)) =
    real_of_rat (p * p)" by (auto simp: field_simps of_rat_mult)
  also have "sqrt (of_nat b) * sqrt (of_nat b) = of_nat b" by simp
  finally have "real_of_rat (q * q * rat_of_nat b) = real_of_rat (p * p)" by (auto simp: of_rat_mult)
  hence "q * q * (rat_of_nat b) = p * p" by auto
  from arg_cong[OF this, of "\<lambda> x. x / (q * q)"]
  have "(p / q) * (p / q) = rat_of_nat b" using False by (auto simp: field_simps)
  with sqrt_irrat show ?thesis unfolding sqrt_irrat_def by blast
qed

text \<open>To represent  numbers of the form $p + q \cdot \sqrt{b}$, use mini algebraic numbers, i.e.,
  triples $(p,q,b)$ with irrational $\sqrt{b}$.\<close>
typedef mini_alg =
  "{(p,q,b) | (p :: rat) (q :: rat) (b :: nat).
  q = 0 \<or> b \<in> sqrt_irrat}"
  by auto

setup_lifting type_definition_mini_alg

lift_definition real_of :: "mini_alg \<Rightarrow> real" is
  "\<lambda> (p,q,b). of_rat p + of_rat q * sqrt (of_nat b)" .

lift_definition ma_of_rat :: "rat \<Rightarrow> mini_alg" is "\<lambda> x. (x,0,0)" by auto

lift_definition ma_rat :: "mini_alg \<Rightarrow> rat" is fst .
lift_definition ma_base :: "mini_alg \<Rightarrow> nat" is "snd o snd" .
lift_definition ma_coeff :: "mini_alg \<Rightarrow> rat" is "fst o snd" .

lift_definition ma_uminus :: "mini_alg \<Rightarrow> mini_alg" is
  "\<lambda> (p1,q1,b1). (- p1, - q1, b1)" by auto

lift_definition ma_compatible :: "mini_alg \<Rightarrow> mini_alg \<Rightarrow> bool" is
  "\<lambda> (p1,q1,b1) (p2,q2,b2). q1 = 0 \<or> q2 = 0 \<or> b1 = b2" .

definition ma_normalize :: "rat \<times> rat \<times> nat \<Rightarrow> rat \<times> rat \<times> nat" where
  "ma_normalize x \<equiv> case x of (a,b,c) \<Rightarrow> if b = 0 then (a,0,0) else (a,b,c)"

lemma ma_normalize_case[simp]: "(case ma_normalize r of (a,b,c) \<Rightarrow> real_of_rat a + real_of_rat b * sqrt (of_nat c))
  = (case r of (a,b,c) \<Rightarrow> real_of_rat a + real_of_rat b * sqrt (of_nat c))"
  by (cases r, auto simp: ma_normalize_def)

lift_definition ma_plus :: "mini_alg \<Rightarrow> mini_alg \<Rightarrow> mini_alg" is
  "\<lambda> (p1,q1,b1) (p2,q2,b2). if q1 = 0 then
    (p1 + p2, q2, b2) else ma_normalize (p1 + p2, q1 + q2, b1)" by (auto simp: ma_normalize_def)

lift_definition ma_times :: "mini_alg \<Rightarrow> mini_alg \<Rightarrow> mini_alg" is
  "\<lambda> (p1,q1,b1) (p2,q2,b2). if q1 = 0 then
    ma_normalize (p1*p2, p1*q2, b2) else
    ma_normalize (p1*p2 + of_nat b2*q1*q2, p1*q2 + q1*p2, b1)" by (auto simp: ma_normalize_def)

lift_definition ma_inverse :: "mini_alg \<Rightarrow> mini_alg" is
   "\<lambda> (p,q,b). let d = inverse (p * p - of_nat b * q * q) in
   ma_normalize (p * d, - q * d, b)" by (auto simp: Let_def ma_normalize_def)

lift_definition ma_floor :: "mini_alg \<Rightarrow> int" is
  "\<lambda> (p,q,b). case (quotient_of p,quotient_of q) of ((z1,n1),(z2,n2)) \<Rightarrow>
    let z2n1 = z2 * n1; z1n2 = z1 * n2; n12 = n1 * n2; prod = z2n1 * z2n1 * int b in
    (z1n2 + (if z2n1 \<ge> 0 then sqrt_int_floor_pos prod else - sqrt_int_ceiling_pos prod)) div n12" .

lift_definition ma_sqrt :: "mini_alg \<Rightarrow> mini_alg" is
   "\<lambda> (p,q,b). let (a,b) = quotient_of p; aa = abs (a * b) in
   case sqrt_int aa of [] \<Rightarrow> (0,inverse (of_int b),nat aa) | (Cons s _) \<Rightarrow> (of_int s / of_int b,0,0)"
proof (unfold Let_def)
   fix prod :: "rat \<times> rat \<times> nat"
   obtain p q b where prod: "prod = (p,q,b)" by (cases prod, auto)
   obtain a b where p: "quotient_of p = (a,b)" by force
   show "\<exists>p q b. (case prod of
                     (p, q, b) \<Rightarrow>
                       case quotient_of p of
                       (a, b) \<Rightarrow>
                         (case sqrt_int \<bar>a * b\<bar> of [] \<Rightarrow> (0, inverse (of_int b), nat \<bar>a * b\<bar>)
                         | s # x \<Rightarrow> (of_int s / of_int b, 0, 0))) =
                    (p, q, b) \<and>
                    (q = 0 \<or> b \<in> sqrt_irrat)"
   proof (cases "sqrt_int (abs (a * b))")
     case Nil
     from sqrt_int[of "abs (a * b)"] Nil have irrat: "\<not> (\<exists> y. y * y = \<bar>a * b\<bar>)" by auto
     have "nat \<bar>a * b\<bar> \<in> sqrt_irrat"
     proof (rule ccontr)
       assume "nat \<bar>a * b\<bar> \<notin> sqrt_irrat"
       then obtain x :: rat
       where "x * x = rat_of_nat (nat \<bar>a * b\<bar>)" unfolding sqrt_irrat_def by auto
       hence "x * x = rat_of_int \<bar>a * b\<bar>" by auto
       from sqr_rat_of_int[OF this] irrat show False by blast
     qed
     thus ?thesis using Nil by (auto simp: prod p)
   qed (auto simp: prod p Cons)
qed

lift_definition ma_equal :: "mini_alg \<Rightarrow> mini_alg \<Rightarrow> bool" is
   "\<lambda> (p1,q1,b1) (p2,q2,b2).
   p1 = p2 \<and> q1 = q2 \<and> (q1 = 0 \<or> b1 = b2)" .

lift_definition ma_ge_0 :: "mini_alg \<Rightarrow> bool" is
  "\<lambda> (p,q,b). let bqq = of_nat b * q * q; pp = p * p in
  0 \<le> p \<and> bqq \<le> pp \<or> 0 \<le> q \<and> pp \<le> bqq" .

lift_definition ma_is_rat :: "mini_alg \<Rightarrow> bool" is
  "\<lambda> (p,q,b). q = 0" .

definition ge_0 :: "real \<Rightarrow> bool" where [code del]: "ge_0 x = (x \<ge> 0)"

lemma ma_ge_0: "ge_0 (real_of x) = ma_ge_0 x"
proof (transfer, unfold Let_def, clarsimp)
  fix p' q' :: rat and b' :: nat
  assume b': "q' = 0 \<or> b' \<in> sqrt_irrat"
  define b where "b = real_of_nat b'"
  define p where "p = real_of_rat p'"
  define q where "q = real_of_rat q'"
  from b' have b: "0 \<le> b" "q = 0 \<or> b' \<in> sqrt_irrat" unfolding b_def q_def by auto
  define qb where "qb = q * sqrt b"
  from b have sqrt: "sqrt b \<ge> 0" by auto
  from b(2) have disj: "q = 0 \<or> b \<noteq> 0" unfolding sqrt_irrat_def b_def by auto
  have bdef: "b = real_of_rat (of_nat b')" unfolding b_def by auto
  have "(0 \<le> p + q * sqrt b) = (0 \<le> p + qb)" unfolding qb_def by simp
  also have "\<dots> \<longleftrightarrow> (0 \<le> p \<and> abs qb \<le> abs p \<or> 0 \<le> qb \<and> abs p \<le> abs qb)" by arith
  also have "\<dots> \<longleftrightarrow> (0 \<le> p \<and> qb * qb \<le> p * p \<or> 0 \<le> qb \<and> p * p \<le> qb * qb)"
    unfolding abs_lesseq_square ..
  also have "qb * qb = b * q * q" unfolding qb_def
    using b by auto
  also have "0 \<le> qb \<longleftrightarrow> 0 \<le> q" unfolding qb_def using sqrt disj
    by (metis le_cases mult_eq_0_iff mult_nonneg_nonneg mult_nonpos_nonneg order_class.order.antisym  qb_def real_sqrt_eq_zero_cancel_iff)
  also have "(0 \<le> p \<and> b * q * q \<le> p * p \<or> 0 \<le> q \<and> p * p \<le> b * q * q)
    \<longleftrightarrow> (0 \<le> p' \<and> of_nat b' * q' * q' \<le> p' * p' \<or> 0 \<le> q' \<and> p' * p' \<le> of_nat b' * q' * q')" unfolding qb_def
    by (unfold bdef p_def q_def of_rat_mult[symmetric] of_rat_less_eq, simp)
  finally
  show "ge_0 (real_of_rat p' + real_of_rat q' * sqrt (of_nat b')) =
       (0 \<le> p' \<and> of_nat b' * q' * q' \<le> p' * p' \<or> 0 \<le> q' \<and> p' * p' \<le> of_nat b' * q' * q')"
    unfolding ge_0_def p_def b_def q_def
    by (auto simp: of_rat_add of_rat_mult)
qed

lemma ma_0: "0 = real_of (ma_of_rat 0)" by (transfer, auto)

lemma ma_1: "1 = real_of (ma_of_rat 1)" by (transfer, auto)

lemma ma_uminus:
  "- (real_of x) = real_of (ma_uminus x)"
  by (transfer, auto simp: of_rat_minus)

lemma ma_inverse: "inverse (real_of r) = real_of (ma_inverse r)"
proof (transfer, unfold Let_def, clarsimp)
  fix p' q' :: rat and b' :: nat
  assume b': "q' = 0 \<or> b' \<in> sqrt_irrat"
  define b where "b = real_of_nat b'"
  define p where "p = real_of_rat p'"
  define q where "q = real_of_rat q'"
  from b' have b: "b \<ge> 0" "q = 0 \<or> b' \<in> sqrt_irrat" unfolding b_def q_def by auto
  have "inverse (p + q * sqrt b) = (p - q * sqrt b) * inverse (p * p - b * (q * q))"
  proof (cases "q = 0")
    case True thus ?thesis by (cases "p = 0", auto simp: field_simps)
  next
    case False
    from sqrt_irrat[OF b', of p'] b_def p_def q_def False have nnull: "p + q * sqrt b \<noteq> 0" by auto
    have "?thesis \<longleftrightarrow> (p + q * sqrt b) * inverse (p + q * sqrt b) =
      (p + q * sqrt b) * ((p - q * sqrt b) * inverse (p * p - b * (q * q)))"
      unfolding mult_left_cancel[OF nnull] by auto
    also have "(p + q * sqrt b) * inverse (p + q * sqrt b) = 1" using nnull by auto
    also have "(p + q * sqrt b) * ((p - q * sqrt b) * inverse (p * p - b * (q * q)))
      = (p * p - b * (q * q)) * inverse (p * p - b * (q * q))"
      using b by (auto simp: field_simps)
    also have "... = 1"
    proof (rule right_inverse, rule)
      assume eq: "p * p - b * (q * q) = 0"
      have "real_of_rat (p' * p' / (q' * q')) = p * p / (q * q)"
        unfolding p_def b_def q_def by (auto simp: of_rat_mult of_rat_divide)
      also have "\<dots> = b" using eq False by (auto simp: field_simps)
      also have "\<dots> = real_of_rat (of_nat b')" unfolding b_def by auto
      finally have "(p' / q') * (p' / q') = of_nat b'"
        unfolding of_rat_eq_iff by simp
      with b False show False unfolding sqrt_irrat_def by blast
    qed
    finally
    show ?thesis by simp
  qed
  thus "inverse (real_of_rat p' + real_of_rat q' * sqrt (of_nat b')) =
       real_of_rat (p' * inverse (p' * p' - of_nat b' * q' * q')) +
       real_of_rat (- (q' * inverse (p' * p' - of_nat b' * q' * q'))) * sqrt (of_nat b')"
    by (simp add: divide_simps of_rat_mult of_rat_divide of_rat_diff of_rat_minus b_def p_def q_def
             split: if_splits)
qed

lemma ma_sqrt_main: "ma_rat r \<ge> 0 \<Longrightarrow> ma_coeff r = 0 \<Longrightarrow> sqrt (real_of r) = real_of (ma_sqrt r)"
proof (transfer, unfold Let_def, clarsimp)
  fix p :: rat
  assume p: "0 \<le> p"
  hence abs: "abs p = p" by auto
  obtain a b where ab: "quotient_of p = (a,b)" by force
  hence pab: "p = of_int a / of_int b" by (rule quotient_of_div)
  from ab have b: "b > 0" by (rule quotient_of_denom_pos)
  with p pab have abpos: "a * b \<ge> 0"
    by (metis of_int_0_le_iff of_int_le_0_iff zero_le_divide_iff zero_le_mult_iff)
  have rab: "of_nat (nat (a * b)) = real_of_int a * real_of_int b" using abpos
    by simp
  let ?lhs = "sqrt (of_int a / of_int b)"
  let ?rhs = "(case case quotient_of p of
               (a, b) \<Rightarrow> (case sqrt_int \<bar>a * b\<bar> of [] \<Rightarrow> (0, inverse (of_int b), nat \<bar>a * b\<bar>)
                 | s # x \<Rightarrow> (of_int s / of_int b, 0, 0)) of
          (p, q, b) \<Rightarrow> of_rat p + of_rat q * sqrt (of_nat b))"
  have "sqrt (real_of_rat p) = ?lhs" unfolding pab
    by (metis of_rat_divide of_rat_of_int_eq)
  also have "\<dots> = ?rhs"
  proof (cases "sqrt_int \<bar>a * b\<bar>")
    case Nil
    define sb where "sb = sqrt (of_int b)"
    define sa where "sa = sqrt (of_int a)"
    from b sb_def have sb: "sb > 0" "real_of_int b > 0" by auto
    have sbb: "sb * sb = real_of_int b" unfolding sb_def
      by (rule sqrt_sqrt, insert b, auto)
    from Nil have "?thesis = (sa / sb =
      inverse (of_int b) * (sa * sb))" unfolding ab sa_def sb_def using abpos
      by (simp add: rab of_rat_divide real_sqrt_mult real_sqrt_divide of_rat_inverse)
    also have "\<dots> = (sa = inverse (of_int b) * sa * (sb * sb))" using sb
      by (metis b divide_real_def eq_divide_imp inverse_divide inverse_inverse_eq inverse_mult_distrib less_int_code(1) of_int_eq_0_iff real_sqrt_eq_zero_cancel_iff sb_def sbb times_divide_eq_right)
    also have "\<dots> = True" using sb(2) unfolding sbb by auto
    finally show "?thesis" by simp
  next
    case (Cons s x)
    from b have b: "real_of_int b > 0" by auto
    from Cons sqrt_int[of "abs (a * b)"] have "s * s = abs (a * b)" by auto
    with sqrt_int_pos[OF Cons] have "sqrt (real_of_int (abs (a * b))) = of_int s"
      by (metis abs_of_nonneg of_int_mult of_int_abs real_sqrt_abs2)
    with abpos have "of_int s = sqrt (real_of_int (a * b))" by auto
    thus ?thesis unfolding ab split using Cons b
      by (auto simp: of_rat_divide field_simps real_sqrt_divide real_sqrt_mult)
  qed
  finally show "sqrt (real_of_rat p) = ?rhs" .
qed

lemma ma_sqrt: "sqrt (real_of r) = (if ma_coeff r = 0 then
  (if ma_rat r \<ge> 0 then real_of (ma_sqrt r) else - real_of (ma_sqrt (ma_uminus r)))
  else Code.abort (STR ''cannot represent sqrt of irrational number'') (\<lambda> _. sqrt (real_of r)))"
proof (cases "ma_coeff r = 0")
  case True note 0 = this
  hence 00: "ma_coeff (ma_uminus r) = 0" by (transfer, auto)
  show ?thesis
  proof (cases "ma_rat r \<ge> 0")
    case True
    from ma_sqrt_main[OF this 0] 0 True show ?thesis by auto
  next
    case False
    hence "ma_rat (ma_uminus r) \<ge> 0" by (transfer, auto)
    from ma_sqrt_main[OF this 00, folded ma_uminus, symmetric] False 0
    show ?thesis by (auto simp: real_sqrt_minus)
  qed
qed auto

lemma ma_times:
  "(real_of r1 * real_of r2) = (if ma_compatible r1 r2
    then real_of (ma_times r1 r2) else
    Code.abort (STR ''different base'') (\<lambda> _. real_of r1 * real_of r2))"
  by transfer (auto split: prod.split simp: field_simps of_rat_mult of_rat_add)

lemma ma_equal:
  "HOL.equal (real_of r1) (real_of r2) = (if ma_compatible r1 r2
    then ma_equal r1 r2 else
    Code.abort (STR ''different base'') (\<lambda> _. HOL.equal (real_of r1) (real_of r2)))"
proof (transfer, unfold equal_real_def, clarsimp)
  fix p1 q1 p2 q2 :: rat and b1 b2 :: nat
  assume b1: "q1 = 0 \<or> b1 \<in> sqrt_irrat"
  assume b2: "q2 = 0 \<or> b2 \<in> sqrt_irrat"
  assume base: "q1 = 0 \<or> q2 = 0 \<or> b1 = b2"
  let ?l = "real_of_rat p1 + real_of_rat q1 * sqrt (of_nat b1) =
      real_of_rat p2 + real_of_rat q2 * sqrt (of_nat b2)"
  let ?m = "real_of_rat q1 * sqrt (of_nat b1) = real_of_rat (p2 - p1) + real_of_rat q2 * sqrt (of_nat b2)"
  let ?r = "p1 = p2 \<and> q1 = q2 \<and> (q1 = 0 \<or> b1 = b2)"
  have "?l \<longleftrightarrow> real_of_rat q1 * sqrt (of_nat b1) = real_of_rat (p2 - p1) + real_of_rat q2 * sqrt (of_nat b2)"
    by (auto simp: of_rat_add of_rat_diff of_rat_minus)
  also have "\<dots> \<longleftrightarrow> p1 = p2 \<and> q1 = q2 \<and> (q1 = 0 \<or> b1 = b2)"
  proof
    assume ?m
    from base have "q1 = 0 \<or> q1 \<noteq> 0 \<and> q2 = 0 \<or> q1 \<noteq> 0 \<and> q2 \<noteq> 0 \<and> b1 = b2" by auto
    thus "p1 = p2 \<and> q1 = q2 \<and> (q1 = 0 \<or> b1 = b2)"
    proof
      assume q1: "q1 = 0"
      with \<open>?m\<close> have "real_of_rat (p2 - p1) + real_of_rat q2 * sqrt (of_nat b2) = 0" by auto
      with sqrt_irrat b2 have q2: "q2 = 0" by auto
      with q1 \<open>?m\<close> show ?thesis by auto
    next
      assume "q1 \<noteq> 0 \<and> q2 = 0 \<or> q1 \<noteq> 0 \<and> q2 \<noteq> 0 \<and> b1 = b2"
      thus ?thesis
      proof
        assume ass: "q1 \<noteq> 0 \<and> q2 = 0"
        with \<open>?m\<close> have "real_of_rat (p1 - p2) + real_of_rat q1 * sqrt (of_nat b1) = 0"
          by (auto simp: of_rat_diff)
        with b1 have "q1 = 0" using sqrt_irrat by auto
        with ass show ?thesis by auto
      next
        assume ass: "q1 \<noteq> 0 \<and> q2 \<noteq> 0 \<and> b1 = b2"
        with \<open>?m\<close> have *: "real_of_rat (p2 - p1) + real_of_rat (q2 - q1) * sqrt (of_nat b2) = 0"
          by (auto simp: field_simps of_rat_diff)
        have "q2 - q1 = 0"
          by (rule sqrt_irrat[OF _ *], insert ass b2, auto)
        with * ass show ?thesis by auto
      qed
    qed
  qed auto
  finally show "?l = ?r" by simp
qed

lemma ma_floor: "floor (real_of r) = ma_floor r"
proof (transfer, unfold Let_def, clarsimp)
  fix p q :: rat and b :: nat
  obtain z1 n1 where qp: "quotient_of p = (z1,n1)" by force
  obtain z2 n2 where qq: "quotient_of q = (z2,n2)" by force
  from quotient_of_denom_pos[OF qp] have n1: "0 < n1" .
  from quotient_of_denom_pos[OF qq] have n2: "0 < n2" .
  from quotient_of_div[OF qp] have p: "p = of_int z1 / of_int n1" .
  from quotient_of_div[OF qq] have q: "q = of_int z2 / of_int n2" .
  have p: "p = of_int (z1 * n2) / of_int (n1 * n2)" unfolding p using n2 by auto
  have q: "q = of_int (z2 * n1) / of_int (n1 * n2)" unfolding q using n1 by auto
  define z1n2 where "z1n2 = z1 * n2"
  define z2n1 where "z2n1 = z2 * n1"
  define n12 where "n12 = n1 * n2"
  define r_add where "r_add = of_int (z2n1) * sqrt (real_of_int (int b))"
  from n1 n2 have n120: "n12 > 0" unfolding n12_def by simp
  have "floor (of_rat p + of_rat q * sqrt (real_of_nat b)) = floor ((of_int z1n2 + r_add) / of_int n12)"
    unfolding r_add_def n12_def z1n2_def z2n1_def
    unfolding p q add_divide_distrib of_rat_divide of_rat_of_int_eq of_int_of_nat_eq by simp
  also have "\<dots> = floor (of_int z1n2 + r_add) div n12"
    by (rule floor_div_pos_int[OF n120])
  also have "of_int z1n2 + r_add = r_add + of_int z1n2" by simp
  also have "floor (\<dots>) = floor r_add + z1n2" by simp
  also have "\<dots> = z1n2 + floor r_add" by simp
  finally have id: "\<lfloor>of_rat p + of_rat q * sqrt (of_nat b)\<rfloor> = (z1n2 + \<lfloor>r_add\<rfloor>) div n12" .
  show "\<lfloor>of_rat p + of_rat q * sqrt (of_nat b)\<rfloor> =
              (case quotient_of p of
               (z1, n1) \<Rightarrow>
                 case quotient_of q of
                 (z2, n2) \<Rightarrow>
                 (z1 * n2 + (if 0 \<le> z2 * n1 then sqrt_int_floor_pos (z2 * n1 * (z2 * n1) * int b) else
                    - sqrt_int_ceiling_pos (z2 * n1 * (z2 * n1) * int b))) div (n1 * n2))"
    unfolding qp qq split id n12_def z1n2_def
  proof (rule arg_cong[of _ _ "\<lambda> x. ((z1 * n2) + x) div (n1 * n2)"])
    have ge_int: "z2 * n1 * (z2 * n1) * int b \<ge> 0"
      by (metis mult_nonneg_nonneg zero_le_square of_nat_0_le_iff)
    show "\<lfloor>r_add\<rfloor> = (if 0 \<le> z2 * n1 then sqrt_int_floor_pos (z2 * n1 * (z2 * n1) * int b) else - sqrt_int_ceiling_pos (z2 * n1 * (z2 * n1) * int b))"
    proof (cases "z2 * n1 \<ge> 0")
      case True
      hence ge: "real_of_int (z2 * n1) \<ge> 0" by (metis of_int_0_le_iff)
      have radd: "r_add = sqrt (of_int (z2 * n1 * (z2 * n1) * int b))"
        unfolding r_add_def z2n1_def using sqrt_sqrt[OF ge]
        by (simp add: ac_simps real_sqrt_mult)
      show ?thesis unfolding radd sqrt_int_floor_pos[OF ge_int] using True by simp
    next
      case False
      hence ge: "real_of_int (- (z2 * n1)) \<ge> 0"
        by (metis mult_zero_left neg_0_le_iff_le of_int_0_le_iff order_refl zero_le_mult_iff)
      have "r_add = - sqrt (of_int (z2 * n1 * (z2 * n1) * int b))"
        unfolding r_add_def z2n1_def using sqrt_sqrt[OF ge]
        by (metis minus_minus minus_mult_commute minus_mult_right of_int_minus of_int_mult real_sqrt_minus real_sqrt_mult z2n1_def)
      hence radd: "floor r_add = - ceiling (sqrt (of_int (z2 * n1 * (z2 * n1) * int b)))"
        by (metis ceiling_def minus_minus)
      show ?thesis unfolding radd sqrt_int_ceiling_pos[OF ge_int] using False by simp
    qed
  qed
qed

lemma comparison_impl:
  "(x :: real) \<le> (y :: real) = ge_0 (y - x)"
  "(x :: real) < (y :: real) = (x \<noteq> y \<and> ge_0 (y - x))"
  by (simp_all add: ge_0_def, linarith+)

lemma ma_of_rat: "real_of_rat r = real_of (ma_of_rat r)"
  by (transfer, auto)

definition is_rat :: "real \<Rightarrow> bool" where
  [code_abbrev]: "is_rat x \<longleftrightarrow> x \<in> \<rat>"

lemma ma_is_rat: "is_rat (real_of x) = ma_is_rat x"
proof (transfer, unfold is_rat_def, clarsimp)
  fix p q :: rat and b :: nat
  let ?p = "real_of_rat p"
  let ?q = "real_of_rat q"
  let ?b = "real_of_nat b"
  let ?b' = "real_of_rat (of_nat b)"
  assume b: "q = 0 \<or> b \<in> sqrt_irrat"
  show "(?p + ?q * sqrt ?b \<in> \<rat>) = (q = 0)"
  proof (cases "q = 0")
    case False
    from False b have b: "b \<in> sqrt_irrat" by auto
    {
      assume "?p + ?q * sqrt ?b \<in> \<rat>"
      from this[unfolded Rats_def] obtain r where r: "?p + ?q * sqrt ?b = real_of_rat r" by auto
      let ?r = "real_of_rat r"
      from r have "real_of_rat (p - r) + ?q * sqrt ?b = 0" by (simp add: of_rat_diff)
      from sqrt_irrat[OF disjI2[OF b] this] False have False by auto
    }
    thus ?thesis by auto
  qed auto
qed

(* compute all numbers y for which y * y = x, if x \<in> \<rat>, otherwise return empty list.
   of course, one could have returned [-sqrt x, sqrt x], but this might result in runtime errors,
   e.g., if sqrt_real (sqrt 2) would be invoked. The current formulation is guaranteed to not crash. *)
definition "sqrt_real x = (if x \<in> \<rat> \<and> x \<ge> 0 then (if x = 0 then [0] else (let sx = sqrt x in [sx,-sx])) else [])"

lemma sqrt_real[simp]: assumes x: "x \<in> \<rat>"
  shows "set (sqrt_real x) = {y . y * y = x}"
proof (cases "x \<ge> 0")
  case False
  hence "\<And> y. y * y \<noteq> x" by auto
  with False show ?thesis unfolding sqrt_real_def by auto
next
  case True
  thus ?thesis using x
    by (cases "x = 0", auto simp: Let_def sqrt_real_def)
qed

code_datatype real_of

declare [[code drop:
  "plus :: real \<Rightarrow> real \<Rightarrow> real"
  "uminus :: real \<Rightarrow> real"
  "times :: real \<Rightarrow> real \<Rightarrow> real"
  "inverse :: real \<Rightarrow> real"
  "floor :: real \<Rightarrow> int"
  sqrt
  "HOL.equal :: real \<Rightarrow> real \<Rightarrow> bool"
]]

lemmas ma_code_eqns [code equation] = ma_ge_0 ma_floor ma_0 ma_1 ma_uminus ma_inverse ma_sqrt ma_plus ma_times ma_equal ma_is_rat
  comparison_impl

lemma [code equation]:
  "(x :: real) / (y :: real) = x * inverse y"
  "(x :: real) - (y :: real) = x + (- y)"
  by (simp_all add: divide_inverse)

text \<open>Some tests with small numbers. To work on larger number, one should
  additionally import the theories for efficient calculation on numbers\<close>

value "\<lfloor>101.1 * (3 * sqrt 2 + 6 * sqrt 0.5)\<rfloor>"
value "\<lfloor>606.2 * sqrt 2 + 0.001\<rfloor>"
value "101.1 * (3 * sqrt 2 + 6 * sqrt 0.5) = 606.2 * sqrt 2 + 0.001"
value "101.1 * (3 * sqrt 2 + 6 * sqrt 0.5) > 606.2 * sqrt 2 + 0.001"
value "(sqrt 0.1 \<in> \<rat>, sqrt (- 0.09) \<in> \<rat>)"

end


section \<open> Symmetric Lenses \<close>

theory Lens_Symmetric
  imports Lens_Order
begin

text \<open> A characterisation of Hofmann's ``Symmetric Lenses''~\cite{Hofmann2011}, where
  a lens is accompanied by its complement. \<close>

record ('a, 'b, 's) slens =
  view   :: "'a \<Longrightarrow> 's" ("\<V>\<index>") \<comment> \<open> The region characterised \<close>
  coview :: "'b \<Longrightarrow> 's" ("\<C>\<index>") \<comment> \<open> The complement of the region \<close>

type_notation
  slens ("<_, _> \<Longleftrightarrow> _" [0, 0, 0] 0)

declare slens.defs [lens_defs]

definition slens_compl :: "(<'a, 'c> \<Longleftrightarrow> 'b) \<Rightarrow> <'c, 'a> \<Longleftrightarrow> 'b" ("-\<^sub>L _" [81] 80) where
[lens_defs]: "slens_compl a = \<lparr> view = coview a, coview = view a \<rparr>"

lemma view_slens_compl [simp]: "\<V>\<^bsub>-\<^sub>L a\<^esub> =  \<C>\<^bsub>a\<^esub>"
  by (simp add: slens_compl_def)

lemma coview_slens_compl [simp]: "\<C>\<^bsub>-\<^sub>L a\<^esub> =  \<V>\<^bsub>a\<^esub>"
  by (simp add: slens_compl_def)

subsection \<open> Partial Symmetric Lenses \<close>

locale psym_lens =
  fixes S :: "<'a, 'b> \<Longleftrightarrow> 's" (structure)
  assumes
    mwb_region [simp]: "mwb_lens \<V>" and
    mwb_coregion [simp]: "mwb_lens \<C>" and
    indep_region_coregion [simp]: "\<V> \<bowtie> \<C>" and
    pbij_region_coregion [simp]: "pbij_lens (\<V> +\<^sub>L \<C>)"

declare psym_lens.mwb_region [simp]
declare psym_lens.mwb_coregion [simp]
declare psym_lens.indep_region_coregion [simp]

subsection \<open> Symmetric Lenses \<close>

locale sym_lens =
  fixes S :: "<'a, 'b> \<Longleftrightarrow> 's" (structure)
  assumes
    vwb_region: "vwb_lens \<V>" and
    vwb_coregion: "vwb_lens \<C>" and
    indep_region_coregion: "\<V> \<bowtie> \<C>" and
    bij_region_coregion: "bij_lens (\<V> +\<^sub>L \<C>)"
begin

sublocale psym_lens
proof (rule psym_lens.intro)
  show "mwb_lens \<V>"
    by (simp add: vwb_region)
  show "mwb_lens \<C>"
    by (simp add: vwb_coregion)
  show "\<V> \<bowtie> \<C>"
    using indep_region_coregion by blast
  show "pbij_lens (\<V> +\<^sub>L \<C>)"
    by (simp add: bij_region_coregion)
qed

lemma put_region_coregion_cover:
  "put\<^bsub>\<V>\<^esub> (put\<^bsub>\<C>\<^esub> s\<^sub>1 (get\<^bsub>\<C>\<^esub> s\<^sub>2)) (get\<^bsub>\<V>\<^esub> s\<^sub>2) = s\<^sub>2"
proof -
  have "put\<^bsub>\<V>\<^esub> (put\<^bsub>\<C>\<^esub> s\<^sub>1 (get\<^bsub>\<C>\<^esub> s\<^sub>2)) (get\<^bsub>\<V>\<^esub> s\<^sub>2) = put\<^bsub>\<V> +\<^sub>L \<C>\<^esub> s\<^sub>1 (get\<^bsub>\<V> +\<^sub>L \<C>\<^esub> s\<^sub>2)"
    by (simp add: lens_defs)
  also have "... = s\<^sub>2"
    by (simp add: bij_region_coregion)
  finally show ?thesis .
qed

end

declare sym_lens.vwb_region [simp]
declare sym_lens.vwb_coregion [simp]
declare sym_lens.indep_region_coregion [simp]

lemma sym_lens_psym [simp]: "sym_lens x \<Longrightarrow> psym_lens x"
  by (simp add: psym_lens_def sym_lens.bij_region_coregion)

lemma sym_lens_compl [simp]: "sym_lens a \<Longrightarrow> sym_lens (-\<^sub>L a)"
  apply (simp add: slens_compl_def)
  apply (rule sym_lens.intro, simp_all)
  using lens_indep_sym sym_lens.indep_region_coregion apply blast
  using bij_lens_equiv lens_plus_comm sym_lens_def apply blast
  done

end


(*  File:       Minimax_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Minimax Module\<close>

theory Minimax_Module
  imports "Component_Types/Elimination_Module"
begin

text
\<open>This is the Minimax module used by the Minimax voting rule. The Minimax rule
elects the alternatives with the highest Minimax score. The module implemented
herein only rejects the alternatives not elected by the voting rule, and defers
the alternatives that would be elected by the full voting rule.\<close>

subsection \<open>Definition\<close>

fun minimax_score :: "'a Evaluation_Function" where
  "minimax_score x A p =
    Min {prefer_count p x y |y . y \<in> A-{x}}"

fun minimax :: "'a Electoral_Module" where
  "minimax A p = max_eliminator minimax_score A p"

subsection \<open>Lemma\<close>

lemma non_cond_winner_minimax_score:
  assumes
    prof: "profile A p" and
    winner: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w: "l \<noteq> w"
  shows "minimax_score l A p \<le> prefer_count p l w"
proof -
  let
    ?set = "{prefer_count p l y |y . y \<in> A-{l}}" and
      ?lscore = "minimax_score l A p"
  have "finite A"
    using prof condorcet_winner.simps winner
    by metis
  hence "finite (A-{l})"
    using finite_Diff
    by simp
  hence finite: "finite ?set"
    by simp
  have "w \<in> A"
    using condorcet_winner.simps winner
    by metis
  hence 0: "w \<in> A-{l}"
    using l_neq_w
    by force
  hence not_empty: "?set \<noteq> {}"
    by blast
  (*from 0 not_empty, have 10 "prefer_count p l w \<in> ?set"
     by blast*)
  have "?lscore = Min ?set"
    by simp
  hence 1: "?lscore \<in> ?set \<and> (\<forall>p \<in> ?set. ?lscore \<le> p)"
    using local.finite not_empty Min_le Min_eq_iff
    by (metis (no_types, lifting))
  thus ?thesis
    using "0"
    by auto
qed

subsection \<open>Property\<close>

theorem minimax_score_cond_rating: "condorcet_rating minimax_score"
proof (unfold condorcet_rating_def minimax_score.simps prefer_count.simps, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    l :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w:"l \<noteq> w"
  show
    "Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r l))} |
        y. y \<in> A - {l}} <
      Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r w))} |
          y. y \<in> A - {w}}"
  proof (rule ccontr)
    assume
      "\<not> Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r l))} |
          y. y \<in> A - {l}} <
        Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r w))} |
            y. y \<in> A - {w}}"
    hence
      "Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r l))} |
          y. y \<in> A - {l}} \<ge>
        Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r w))} |
            y. y \<in> A - {w}}"
      by linarith
    hence 000:
      "Min {prefer_count p l y |y . y \<in> A-{l}} \<ge>
        Min {prefer_count p w y |y . y \<in> A-{w}}"
      by auto
    have prof: "profile A p"
      using condorcet_winner.simps winner
      by metis
    from prof winner l_in_A l_neq_w
    have 100:
      "prefer_count p l w  \<ge> Min {prefer_count p l y |y . y \<in> A-{l}}"
      using non_cond_winner_minimax_score minimax_score.simps
      by metis
    from l_in_A
    have l_in_A_without_w: "l \<in> A-{w}"
      by (simp add: l_neq_w)
    hence 2: "{prefer_count p w y |y . y \<in> A-{w}} \<noteq> {}"
      by blast
    have "finite (A-{w})"
      using prof condorcet_winner.simps winner finite_Diff
      by metis
    hence 3: "finite {prefer_count p w y |y . y \<in> A-{w}}"
      by simp
    from 2 3
    have 4:
      "\<exists> n \<in> A-{w} . prefer_count p w n =
        Min {prefer_count p w y |y . y \<in> A-{w}}"
      using Min_in
      by fastforce
    then obtain n where 200:
      "prefer_count p w n =
        Min {prefer_count p w y |y . y \<in> A-{w}}" and
      6: "n \<in> A-{w}"
      by metis
    hence n_in_A: "n \<in> A"
      using DiffE
      by metis
    from 6
    have n_neq_w: "n \<noteq> w"
      by auto
    from winner
    have w_in_A: "w \<in> A"
      by simp
    from 6 prof winner
    have 300: "prefer_count p w n > prefer_count p n w"
      by simp
    from 100 000 200
    have 400: "prefer_count p l w \<ge> prefer_count p w n"
      by linarith
    with prof n_in_A w_in_A l_in_A n_neq_w
         l_neq_w pref_count_sym
    have 700: "prefer_count p n w \<ge> prefer_count p w l"
      by metis
    have "prefer_count p l w > prefer_count p w l"
      using "300" "400" "700"
      by linarith
    hence "wins l p w"
      by simp
    thus False
      using condorcet_winner.simps l_in_A_without_w
            wins_antisym winner
      by metis
  qed
qed

theorem minimax_is_dcc: "defer_condorcet_consistency minimax"
unfolding defer_condorcet_consistency_def electoral_module_def
proof (safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    finA: "finite A" and
    profA: "profile A p"
  have "well_formed A (max_eliminator minimax_score A p)"
    using finA max_elim_sound par_comp_result_sound profA
    by metis
  thus "well_formed A (minimax A p)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cwin_w: "condorcet_winner A p w" and
    finA: "finite A"
  have max_mmaxscore_dcc:
    "defer_condorcet_consistency (max_eliminator minimax_score)"
    using cr_eval_imp_dcc_max_elim
    by (simp add: minimax_score_cond_rating)
  with defer_condorcet_consistency_def
  have
    "max_eliminator minimax_score A p =
      ({},
       A - defer (max_eliminator minimax_score) A p,
       {a \<in> A. condorcet_winner A p a})"
    using cwin_w finA
    by (metis (no_types))
  thus
    "minimax A p =
      ({},
       A - defer minimax A p,
       {d \<in> A. condorcet_winner A p d})"
    by simp
qed

end


(*  Title:      HOL/TLA/Memory/MemoryParameters.thy
    Author:     Stephan Merz, University of Munich
*)

section {* RPC-Memory example: Memory parameters *}

theory MemoryParameters
imports RPCMemoryParams
begin

(* the memory operations *)
datatype memOp = read Locs | "write" Locs Vals

consts
  (* memory locations and contents *)
  MemLoc         :: "Locs set"
  MemVal         :: "Vals set"

  (* some particular values *)
  OK             :: "Vals"
  BadArg         :: "Vals"
  MemFailure     :: "Vals"
  NotAResult     :: "Vals"  (* defined here for simplicity *)

  (* the initial value stored in each memory cell *)
  InitVal        :: "Vals"

axiomatization where
  (* basic assumptions about the above constants and predicates *)
  BadArgNoMemVal:    "BadArg ~: MemVal" and
  MemFailNoMemVal:   "MemFailure ~: MemVal" and
  InitValMemVal:     "InitVal : MemVal" and
  NotAResultNotVal:  "NotAResult ~: MemVal" and
  NotAResultNotOK:   "NotAResult ~= OK" and
  NotAResultNotBA:   "NotAResult ~= BadArg" and
  NotAResultNotMF:   "NotAResult ~= MemFailure"

lemmas [simp] =
  BadArgNoMemVal MemFailNoMemVal InitValMemVal NotAResultNotVal
  NotAResultNotOK NotAResultNotBA NotAResultNotMF
  NotAResultNotOK [symmetric] NotAResultNotBA [symmetric] NotAResultNotMF [symmetric]

lemma MemValNotAResultE: "[| x : MemVal; (x ~= NotAResult ==> P) |] ==> P"
  using NotAResultNotVal by blast

end