theory Basics_Vectors3DSpace_E1A
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"binary_inverse\", \"antisym\", \"refl\", \"trans\",
     \"subtype_def\", \"subtype_pred_def\", \"ga_assoc___Xx__\",
     \"ga_right_unit___Xx__\", \"ga_left_unit___Xx__\", \"inv_Group\",
     \"rinv_Group\", \"ga_comm___Xx__\", \"ga_assoc___Xx___1\",
     \"ga_right_unit___Xx___1\", \"ga_left_unit___Xx___1\",
     \"distr1_Ring\", \"distr2_Ring\", \"left_zero\", \"right_zero\",
     \"ga_comm___Xx___1\", \"noZeroDiv\", \"zeroNeqOne\", \"Ax1\",
     \"ga_assoc___Xx___2\", \"ga_right_unit___Xx___2\",
     \"ga_left_unit___Xx___2\", \"inv_Group_1\", \"rinv_Group_1\",
     \"binary_inverse_1\", \"Ax1_1\", \"refl_1\", \"trans_1\",
     \"antisym_1\", \"dichotomy_TotalOrder\", \"FWO_plus_left\",
     \"FWO_times_left\", \"FWO_plus_right\", \"FWO_times_right\",
     \"FWO_plus\", \"inf_def\", \"Real_completeness\",
     \"geq_def_ExtPartialOrder\", \"less_def_ExtPartialOrder\",
     \"greater_def_ExtPartialOrder\", \"ga_comm_inf\", \"ga_comm_sup\",
     \"inf_def_ExtPartialOrder\", \"sup_def_ExtPartialOrder\",
     \"ga_comm_min\", \"ga_comm_max\", \"ga_assoc_min\",
     \"ga_assoc_max\", \"ga_left_comm_min\", \"ga_left_comm_max\",
     \"min_def_ExtTotalOrder\", \"max_def_ExtTotalOrder\",
     \"min_inf_relation\", \"max_sup_relation\",
     \"RealNonNeg_pred_def\", \"RealPos_pred_def\", \"Ax3\", \"Ax4\",
     \"RealNonNeg_subtype\", \"RealPos_subtype\", \"abs_def\",
     \"times_cancel_right_nonneg_leq\", \"times_leq_nonneg_cond\",
     \"sqr_def\", \"sqrt_def\", \"Pos_def\", \"X2_def_Real\",
     \"X3_def_Real\", \"X4_def_Real\", \"X5_def_Real\", \"X6_def_Real\",
     \"X7_def_Real\", \"X8_def_Real\", \"X9_def_Real\",
     \"ZeroToNine_type\", \"decimal_def\", \"ga_select_C1\",
     \"ga_select_C2\", \"ga_select_C3\", \"Zero_Vector\",
     \"VectorStar_pred_def\", \"Ax7\", \"VectorStar_subtype\",
     \"def_of_vector_addition\", \"def_of_minus_vector\",
     \"binary_inverse_2\", \"scalar_multiplication\",
     \"scalar_product\", \"vector_product\", \"ONB1\", \"ONB2\",
     \"ONB3\", \"cross_left_homogenity\",
     \"cross_product_antisymmetric\", \"binary_inverse_1_1\",
     \"distributive\", \"homogeneous\", \"symmetric\", \"pos_definite\",
     \"unit\", \"mix_assoc\", \"distr_Field\", \"distr_Space\"]"

typedecl NonZero
typedecl Real
typedecl RealNonNeg
typedecl RealPos
typedecl VectorStar
typedecl ZeroToNine

datatype Vector = X_V "Real" "Real" "Real" ("V/'(_,/ _,/ _')" [3,3,3] 999)

consts
X0X1 :: "Real" ("0''")
X0X2 :: "Vector" ("0''''")
X1X1 :: "NonZero" ("1''")
X1X2 :: "Real" ("1''''")
X2 :: "Real" ("2''")
X3 :: "Real" ("3''")
X4 :: "Real" ("4''")
X5 :: "Real" ("5''")
X6 :: "Real" ("6''")
X7 :: "Real" ("7''")
X8 :: "Real" ("8''")
X9 :: "Real" ("9''")
XMinus__XX1 :: "Real => Real" ("(-''/ _)" [56] 56)
XMinus__XX2 :: "Vector => Vector" ("(-''''/ _)" [56] 56)
X_C1 :: "Vector => Real" ("C1/'(_')" [3] 999)
X_C2 :: "Vector => Real" ("C2/'(_')" [3] 999)
X_C3 :: "Vector => Real" ("C3/'(_')" [3] 999)
X_Pos :: "Real => bool" ("Pos/'(_')" [3] 999)
X_RealNonNeg_inj :: "RealNonNeg => Real" ("RealNonNeg'_inj/'(_')" [3] 999)
X_RealNonNeg_pred :: "Real => bool" ("RealNonNeg'_pred/'(_')" [3] 999)
X_RealNonNeg_proj :: "Real => RealNonNeg" ("RealNonNeg'_proj/'(_')" [3] 999)
X_RealPos_inj :: "RealPos => Real" ("RealPos'_inj/'(_')" [3] 999)
X_RealPos_pred :: "Real => bool" ("RealPos'_pred/'(_')" [3] 999)
X_RealPos_proj :: "Real => RealPos" ("RealPos'_proj/'(_')" [3] 999)
X_VectorStar_inj :: "VectorStar => Vector" ("VectorStar'_inj/'(_')" [3] 999)
X_VectorStar_pred :: "Vector => bool" ("VectorStar'_pred/'(_')" [3] 999)
X_VectorStar_proj :: "Vector => VectorStar" ("VectorStar'_proj/'(_')" [3] 999)
X__XAtXAt__X :: "ZeroToNine => Real => Real" ("(_/ @@/ _)" [54,54] 52)
X__XGtXEq__X :: "Real => Real => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "Real => Real => bool" ("(_/ >''/ _)" [44,44] 42)
X__XHash__X :: "Vector => Vector => Vector" ("(_/ #''/ _)" [54,54] 52)
X__XLtXEq__X :: "Real => Real => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "Real => Real => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinus__XX1 :: "Real => Real => Real" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Vector => Vector => Vector" ("(_/ -''''/ _)" [54,54] 52)
X__XPlus__XX1 :: "Real => Real => Real" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Vector => Vector => Vector" ("(_/ +''''/ _)" [54,54] 52)
X__XSlash__X :: "Real => NonZero => Real" ("(_/ '/''/ _)" [54,54] 52)
X__Xx__XX1 :: "NonZero => NonZero => NonZero" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Real => Real => Real" ("(_/ *''''/ _)" [54,54] 52)
X__Xx__XX3 :: "Real => Vector => Vector" ("(_/ *'_3/ _)" [54,54] 52)
X__Xx__XX4 :: "Vector => Vector => Real" ("(_/ *'_4/ _)" [54,54] 52)
X_abs :: "Real => RealNonNeg" ("abs''/'(_')" [3] 999)
X_gn_inj :: "'a => 'b" ("gn'_inj/'(_')" [3] 999)
X_gn_proj :: "'a => 'b partial" ("gn'_proj/'(_')" [3] 999)
X_inv :: "NonZero => NonZero" ("inv''/'(_')" [3] 999)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)
X_max :: "Real => Real => Real" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "Real => Real => Real" ("min''/'(_,/ _')" [3,3] 999)
X_sqr :: "Real => RealNonNeg" ("sqr/'(_')" [3] 999)
X_sqrt :: "RealNonNeg => RealNonNeg" ("sqrt/'(_')" [3] 999)
X_sup :: "Real => Real => Real partial" ("sup/'(_,/ _')" [3,3] 999)
e1 :: "Vector"
e2 :: "Vector"
e3 :: "Vector"
infX1 :: "Real => Real => Real partial" ("inf''/'(_,/ _')" [3,3] 999)
infX2 :: "(Real => bool) => Real partial" ("inf''''/'(_')" [3] 999)

axioms
binary_inverse [rule_format] :
"ALL x. ALL y. x /' y = x *'' inv'(y)"

antisym [rule_format] :
"ALL x. ALL y. __~__ x y & __~__ y x --> x = y"

refl [rule_format] : "ALL x. __~__ x x"

trans [rule_format] :
"ALL x. ALL y. ALL z. __~__ x y & __~__ y z --> __~__ x z"

subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. P x --> x = injection (projection x))) &
  (ALL x. P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 0' +' x = x"

inv_Group [rule_format] : "ALL x. -' x +' x = 0'"

rinv_Group [rule_format] : "ALL x. x +' -' x = 0'"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1'' *'' x = x"

distr1_Ring [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) *'' z = (x *'' z) +' (y *'' z)"

distr2_Ring [rule_format] :
"ALL x. ALL y. ALL z. z *'' (x +' y) = (z *'' x) +' (z *'' y)"

left_zero [rule_format] : "ALL x. 0' *'' x = 0'"

right_zero [rule_format] : "ALL x. x *'' 0' = 0'"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

noZeroDiv [rule_format] :
"ALL x. ALL y. x *'' y = 0' --> x = 0' | y = 0'"

zeroNeqOne [rule_format] : "~ 1'' = 0'"

Ax1 [rule_format] : "ALL x. defOp (gn_proj(x)) = (~ x = 0')"

ga_assoc___Xx___2 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___2 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___2 [rule_format] : "ALL x. 1' *' x = x"

inv_Group_1 [rule_format] : "ALL x. inv'(x) *' x = 1'"

rinv_Group_1 [rule_format] : "ALL x. x *' inv'(x) = 1'"

binary_inverse_1 [rule_format] : "ALL x. ALL y. x -' y = x +' -' y"

Ax1_1 [rule_format] :
"ALL x. ALL y. x /' y = x *'' gn_inj(inv'(y))"

refl_1 [rule_format] : "ALL x. x <=' x"

trans_1 [rule_format] :
"ALL x. ALL y. ALL z. x <=' y & y <=' z --> x <=' z"

antisym_1 [rule_format] :
"ALL x. ALL y. x <=' y & y <=' x --> x = y"

dichotomy_TotalOrder [rule_format] :
"ALL x. ALL y. x <=' y | y <=' x"

FWO_plus_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b --> a +' c <=' b +' c"

FWO_times_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b & 0' <=' c --> a *'' c <=' b *'' c"

FWO_plus_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c --> a +' b <=' a +' c"

FWO_times_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c & 0' <=' a --> a *'' b <=' a *'' c"

FWO_plus [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a <=' c & b <=' d --> a +' b <=' c +' d"

inf_def [rule_format] :
"ALL S.
 ALL m.
 inf''(S) = makePartial m =
 (ALL m2. (ALL x. S x --> x <=' m2) --> m <=' m2)"

Real_completeness [rule_format] :
"ALL S.
 (EX x. S x) & (EX B. ALL x. S x --> x <=' B) -->
 (EX m. makePartial m = inf''(S))"

geq_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >=' y) = (y <=' x)"

less_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x <' y) = (x <=' y & ~ x = y)"

greater_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >' y) = (y <' x)"

ga_comm_inf [rule_format] : "ALL x. ALL y. inf'(x, y) = inf'(y, x)"

ga_comm_sup [rule_format] : "ALL x. ALL y. sup(x, y) = sup(y, x)"

inf_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 inf'(x, y) = makePartial z =
 (z <=' x & z <=' y & (ALL t. t <=' x & t <=' y --> t <=' z))"

sup_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 sup(x, y) = makePartial z =
 (x <=' z & y <=' z & (ALL t. x <=' t & y <=' t --> z <=' t))"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

min_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. min'(x, y) = (if x <=' y then x else y)"

max_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. max'(x, y) = (if x <=' y then y else x)"

min_inf_relation [rule_format] :
"ALL x. ALL y. makePartial (min'(x, y)) = inf'(x, y)"

max_sup_relation [rule_format] :
"ALL x. ALL y. makePartial (max'(x, y)) = sup(x, y)"

RealNonNeg_pred_def [rule_format] :
"ALL x. RealNonNeg_pred(x) = (x >=' 0')"

RealPos_pred_def [rule_format] :
"ALL x. RealPos_pred(x) = (x >' 0')"

Ax3 [rule_format] :
"ALL x. defOp (gn_proj(x)) = RealNonNeg_pred(x)"

Ax4 [rule_format] : "ALL x. defOp (gn_proj(x)) = RealPos_pred(x)"

RealNonNeg_subtype [rule_format] :
"isSubtypeWithPred(X_RealNonNeg_pred, X_RealNonNeg_inj,
 X_RealNonNeg_proj)"

RealPos_subtype [rule_format] :
"isSubtypeWithPred(X_RealPos_pred, X_RealPos_inj, X_RealPos_proj)"

abs_def [rule_format] :
"ALL x.
 makePartial (abs'(x)) =
 (if 0' <=' x then gn_proj(x) else gn_proj(-' x))"

times_cancel_right_nonneg_leq [rule_format] :
"ALL a. ALL b. ALL c. a *'' b <=' c *'' b & b >=' 0' --> a <=' c"

times_leq_nonneg_cond [rule_format] :
"ALL a. ALL b. 0' <=' a *'' b & b >=' 0' --> 0' <=' a"

sqr_def [rule_format] :
"ALL r. gn_inj(sqr(r)) = makePartial (r *'' r)"

sqrt_def [rule_format] : "ALL q. sqr(gn_inj(sqrt(q))) = q"

Pos_def [rule_format] : "ALL x. Pos(x) = (0' <=' x)"

X2_def_Real [rule_format] : "2' = gn_inj(1') +' gn_inj(1')"

X3_def_Real [rule_format] : "3' = 2' +' gn_inj(1')"

X4_def_Real [rule_format] : "4' = 3' +' gn_inj(1')"

X5_def_Real [rule_format] : "5' = 4' +' gn_inj(1')"

X6_def_Real [rule_format] : "6' = 5' +' gn_inj(1')"

X7_def_Real [rule_format] : "7' = 6' +' gn_inj(1')"

X8_def_Real [rule_format] : "8' = 7' +' gn_inj(1')"

X9_def_Real [rule_format] : "9' = 8' +' gn_inj(1')"

ZeroToNine_type [rule_format] :
"ALL x.
 defOp (gn_proj(x)) =
 (((((((((x = 0' | makePartial x = gn_inj(1')) | x = 2') | x = 3') |
       x = 4') |
      x = 5') |
     x = 6') |
    x = 7') |
   x = 8') |
  x = 9')"

decimal_def [rule_format] :
"ALL m.
 ALL X_n. m @@ X_n = (gn_inj(m) *'' (9' +' gn_inj(1'))) +' X_n"

ga_select_C1 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C1(V(x_1, x_2, x_3)) = x_1"

ga_select_C2 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C2(V(x_1, x_2, x_3)) = x_2"

ga_select_C3 [rule_format] :
"ALL x_1. ALL x_2. ALL x_3. C3(V(x_1, x_2, x_3)) = x_3"

Zero_Vector [rule_format] : "0'' = V(0', 0', 0')"

VectorStar_pred_def [rule_format] :
"ALL x. VectorStar_pred(x) = (~ x = 0'')"

Ax7 [rule_format] :
"ALL x. defOp (gn_proj(x)) = VectorStar_pred(x)"

VectorStar_subtype [rule_format] :
"isSubtypeWithPred(X_VectorStar_pred, X_VectorStar_inj,
 X_VectorStar_proj)"

def_of_vector_addition [rule_format] :
"ALL x.
 ALL y. x +'' y = V(C1(x) +' C1(y), C2(x) +' C2(y), C3(x) +' C3(y))"

def_of_minus_vector [rule_format] :
"ALL x. -'' x = V(-' C1(x), -' C2(x), -' C3(x))"

binary_inverse_2 [rule_format] :
"ALL x. ALL y. x -'' y = x +'' -'' y"

scalar_multiplication [rule_format] :
"ALL x. ALL y. x *_3 y = V(x *'' C1(y), x *'' C2(y), x *'' C3(y))"

scalar_product [rule_format] :
"ALL x.
 ALL y.
 x *_4 y =
 ((C1(x) *'' C1(y)) +' (C2(x) *'' C2(y))) +' (C3(x) *'' C3(y))"

vector_product [rule_format] :
"ALL x.
 ALL y.
 x #' y =
 V((C2(x) *'' C3(y)) -' (C2(y) *'' C3(x)),
 (C3(x) *'' C1(y)) -' (C3(y) *'' C1(x)),
 (C1(x) *'' C2(y)) -' (C1(y) *'' C2(x)))"

ONB1 [rule_format] : "e1 = V(gn_inj(1'), 0', 0')"

ONB2 [rule_format] : "e2 = V(0', gn_inj(1'), 0')"

ONB3 [rule_format] : "e3 = V(0', 0', gn_inj(1'))"

cross_left_homogenity [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x #' y) = (r *_3 x) #' y"

cross_product_antisymmetric [rule_format] :
"ALL x. ALL y. x #' y = -'' (y #' x)"

declare refl [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group [simp]
declare rinv_Group [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare left_zero [simp]
declare right_zero [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___2 [simp]
declare ga_right_unit___Xx___2 [simp]
declare ga_left_unit___Xx___2 [simp]
declare inv_Group_1 [simp]
declare rinv_Group_1 [simp]
declare refl_1 [simp]
declare FWO_plus_left [simp]
declare FWO_plus_right [simp]
declare ga_comm_inf [simp]
declare ga_comm_sup [simp]
declare ga_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_min [simp]
declare ga_assoc_max [simp]
declare ga_left_comm_min [simp]
declare ga_left_comm_max [simp]
declare min_inf_relation [simp]
declare max_sup_relation [simp]
declare Ax3 [simp]
declare Ax4 [simp]
declare RealNonNeg_subtype [simp]
declare RealPos_subtype [simp]
declare sqrt_def [simp]
declare ga_select_C1 [simp]
declare ga_select_C2 [simp]
declare ga_select_C3 [simp]
declare Ax7 [simp]
declare VectorStar_subtype [simp]

theorem binary_inverse_1_1 :
"ALL x. ALL y. x /' y = __*__ x (inv'(y))"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"binary_inverse_1_1\""

theorem distributive :
"ALL v. ALL v'. ALL w. (v +'' v') *_4 w = (v *_4 w) +' (v' *_4 w)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"distributive\""

theorem homogeneous :
"ALL a. ALL v. ALL w. (a *_3 v) *_4 w = a *'' (v *_4 w)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"homogeneous\""

theorem symmetric : "ALL v. ALL w. v *_4 w = w *_4 v"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"symmetric\""

theorem pos_definite : "ALL v. ~ v = 0'' --> v *_4 v >' 0'"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"pos_definite\""

theorem unit : "ALL x. gn_inj(1') *_3 x = x"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"unit\""

theorem mix_assoc :
"ALL r. ALL s. ALL x. (r *'' s) *_3 x = r *_3 (s *_3 x)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"mix_assoc\""

theorem distr_Field :
"ALL r. ALL s. ALL x. (r +' s) *_3 x = (r *_3 x) +'' (s *_3 x)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"distr_Field\""

theorem distr_Space :
"ALL r. ALL x. ALL y. r *_3 (x +'' y) = (r *_3 x) +'' (r *_3 y)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def sqr_def sqrt_def
      Pos_def X2_def_Real X3_def_Real X4_def_Real X5_def_Real X6_def_Real
      X7_def_Real X8_def_Real X9_def_Real decimal_def Zero_Vector
      VectorStar_pred_def scalar_multiplication scalar_product
      vector_product ONB1 ONB2 ONB3
by (auto)

ML "Header.record \"distr_Space\""

end


(*<*)
theory Misc
imports Complex_Main
begin

chapter \<open>Basic lemmas which do not belong to the particular domain of Timed Automata\<close>

section \<open>Reals\<close>

subsection \<open>Properties of fractions\<close>

lemma frac_add_le_preservation:
  fixes a d :: real and b :: nat
  assumes "a < b" "d < 1 - frac a"
  shows "a + d < b"
proof -
  from assms have "a + d < a + 1 - frac a" by auto
  also have "\<dots> = (a - frac a) + 1" by auto
  also have "\<dots> = floor a + 1" unfolding frac_def by auto
  also have "\<dots> \<le> b" using \<open>a < b\<close>
  by (metis floor_less_iff int_less_real_le of_int_1 of_int_add of_int_of_nat_eq)
  finally show "a + d < b" .
qed

lemma lt_lt_1_ccontr:
  "(a :: int) < b \<Longrightarrow> b < a + 1 \<Longrightarrow> False" by auto

lemma int_intv_frac_gt0:
  "(a :: int) < b \<Longrightarrow> b < a + 1 \<Longrightarrow> frac b > 0" by auto

lemma floor_frac_add_preservation:
  fixes a d :: real
  assumes "0 < d" "d < 1 - frac a"
  shows "floor a = floor (a + d)"
proof -
  have "frac a \<ge> 0" by auto
  with assms(2) have "d < 1" by linarith
  from assms have "a + d < a + 1 - frac a" by auto
  also have "\<dots> = (a - frac a) + 1" by auto
  also have "\<dots> = (floor a) + 1" unfolding frac_def by auto
  finally have *: "a + d < floor a + 1" .
  have "floor (a + d) \<ge> floor a" using \<open>d > 0\<close> by linarith
  moreover from * have "floor (a + d) < floor a + 1" by linarith
  ultimately show "floor a = floor (a + d)" by auto
qed

lemma frac_distr:
  fixes a d :: real
  assumes "0 < d" "d < 1 - frac a"
  shows "frac (a + d) > 0" "frac a + d = frac (a + d)"
proof -
  have "frac a \<ge> 0" by auto
  with assms(2) have "d < 1" by linarith
  from assms have "a + d < a + 1 - frac a" by auto
  also have "\<dots> = (a - frac a) + 1" by auto
  also have "\<dots> = (floor a) + 1" unfolding frac_def by auto
  finally have *: "a + d < floor a + 1" .
  have **: "floor a < a + d" using assms(1) by linarith
  have "frac (a + d) \<noteq> 0"
  proof (rule ccontr, auto, goal_cases)
    case 1
    then obtain b :: int where "b = a + d" by (metis Ints_cases)
    with * ** have "b < floor a + 1" "floor a < b" by auto
    with lt_lt_1_ccontr show ?case by blast
  qed
  then show "frac (a + d) > 0" by auto
  from floor_frac_add_preservation assms have "floor a = floor (a + d)" by auto
  then show "frac a + d = frac (a + d)" unfolding frac_def by force
qed

lemma frac_add_leD:
  fixes a d :: real
  assumes "0 < d" "d < 1 - frac a" "d < 1 - frac b" "frac (a + d) \<le> frac (b + d)"
  shows "frac a \<le> frac b"
proof -
  from floor_frac_add_preservation assms have
    "floor a = floor (a + d)" "floor b = floor (b + d)"
  by auto
  with assms(4) show "frac a \<le> frac b" unfolding frac_def by auto
qed

lemma floor_frac_add_preservation':
  fixes a d :: real
  assumes "0 \<le> d" "d < 1 - frac a"
  shows "floor a = floor (a + d)"
using assms floor_frac_add_preservation by (cases "d = 0") auto

lemma frac_add_leIFF:
  fixes a d :: real
  assumes "0 \<le> d" "d < 1 - frac a" "d < 1 - frac b"
  shows "frac a \<le> frac b \<longleftrightarrow> frac (a + d) \<le> frac (b + d)"
proof -
  from floor_frac_add_preservation' assms have
    "floor a = floor (a + d)" "floor b = floor (b + d)"
  by auto
  then show ?thesis unfolding frac_def by auto
qed

lemma nat_intv_frac_gt0:
  fixes c :: nat fixes x :: real
  assumes "c < x" "x < real (c + 1)"
  shows "frac x > 0"
proof (rule ccontr, auto, goal_cases)
  case 1
  then obtain d :: int where d: "x = d" by (metis Ints_cases)
  with assms have "c < d" "d < int c + 1" by auto
  with int_intv_frac_gt0[OF this] 1 d show False by auto
qed

lemma nat_intv_frac_decomp:
  fixes c :: nat and d :: real
  assumes "c < d" "d < c + 1"
  shows "d = c + frac d"
proof -
  from assms have "int c = \<lfloor>d\<rfloor>" by linarith
  thus ?thesis by (simp add: frac_def)
qed

lemma nat_intv_not_int:
  fixes c :: nat
  assumes "real c < d" "d < c + 1"
  shows "d \<notin> \<int>"
proof (standard, goal_cases)
  case 1
  then obtain k :: int where "d = k" using Ints_cases by auto
  then have "frac d = 0" by auto
  moreover from nat_intv_frac_decomp[OF assms] have *: "d = c + frac d" by auto
  ultimately have "d = c" by linarith
  with assms show ?case by auto
qed

lemma frac_idempotent: "frac (frac x) = frac x" by (simp add: frac_eq frac_lt_1)

lemma frac_nat_add_id: "frac ((n :: nat) + (r :: real)) = frac r" \<comment> \<open>Found by sledgehammer\<close>
proof -
  have "\<And>r. frac (r::real) < 1"
    by (meson frac_lt_1)
  then show ?thesis
    by (simp add: floor_add frac_def)
qed

lemma floor_nat_add_id: "0 \<le> (r :: real) \<Longrightarrow> r < 1 \<Longrightarrow> floor (real (n::nat) + r) = n" by linarith

lemma int_intv_frac_gt_0':
  "(a :: real) \<in> \<int> \<Longrightarrow> (b :: real) \<in> \<int> \<Longrightarrow> a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<le> b - 1"
proof (goal_cases)
  case 1
  then have "a < b" by auto
  from 1(1,2) obtain k l :: int where "a = real_of_int k" "b = real_of_int l" by (metis Ints_cases)
  with \<open>a < b\<close> show ?case by auto
qed

lemma int_lt_Suc_le:
  "(a :: real) \<in> \<int> \<Longrightarrow> (b :: real) \<in> \<int> \<Longrightarrow> a < b + 1 \<Longrightarrow> a \<le> b"
proof (goal_cases)
  case 1
  from 1(1,2) obtain k l :: int where "a = real_of_int k" "b = real_of_int l" by (metis Ints_cases)
  with \<open>a < b + 1\<close> show ?case by auto
qed

lemma int_lt_neq_Suc_lt:
  "(a :: real) \<in> \<int> \<Longrightarrow> (b :: real) \<in> \<int> \<Longrightarrow> a < b \<Longrightarrow> a + 1 \<noteq> b \<Longrightarrow> a + 1 < b"
proof (goal_cases)
  case 1
  from 1(1,2) obtain k l :: int where "a = real_of_int k" "b = real_of_int l" by (metis Ints_cases)
  with 1 show ?case by auto
qed

lemma int_lt_neq_prev_lt:
  "(a :: real) \<in> \<int> \<Longrightarrow> (b :: real) \<in> \<int> \<Longrightarrow> a - 1 < b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a < b"
proof (goal_cases)
  case 1
  from 1(1,2) obtain k l :: int where "a = real_of_int k" "b = real_of_int l" by (metis Ints_cases)
  with 1 show ?case by auto
qed

lemma ints_le_add_frac1:
  fixes a b x :: real
  assumes "0 < x" "x < 1" "a \<in> \<int>" "b \<in> \<int>" "a + x \<le> b"
  shows "a \<le> b"
using assms by auto

lemma ints_le_add_frac2:
  fixes a b x :: real
  assumes "0 \<le> x" "x < 1" "a \<in> \<int>" "b \<in> \<int>" "b \<le> a + x"
  shows "b \<le> a"
using assms
by (metis add.commute add_le_cancel_left add_mono_thms_linordered_semiring(1) int_lt_Suc_le leD le_less_linear)

section \<open>Ordering Fractions\<close>

lemma distinct_twice_contradiction:
  "xs ! i = x \<Longrightarrow> xs ! j = x \<Longrightarrow> i < j \<Longrightarrow> j < length xs \<Longrightarrow> \<not> distinct xs"
proof (rule ccontr, simp, induction xs arbitrary: i j)
  case Nil thus ?case by auto
next
  case (Cons y xs)
  show ?case
  proof (cases "i = 0")
    case True
    with Cons have "y = x" by auto
    moreover from True Cons have "x \<in> set xs" by auto
    ultimately show False using Cons(6) by auto
  next
    case False
    with Cons have
      "xs ! (i - 1) = x" "xs ! (j - 1) = x" "i - 1 < j - 1" "j - 1 < length xs" "distinct xs"
    by auto
    from Cons.IH[OF this] show False .
  qed
qed

lemma distinct_nth_unique:
  "xs ! i = xs ! j \<Longrightarrow> i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> distinct xs \<Longrightarrow> i = j"
  apply (rule ccontr)
  apply (cases "i < j")
  apply auto
  apply (auto dest: distinct_twice_contradiction)
using distinct_twice_contradiction by fastforce

lemma (in linorder) linorder_order_fun:
  fixes S :: "'a set"
  assumes "finite S"
  obtains f :: "'a \<Rightarrow> nat"
  where "(\<forall> x \<in> S. \<forall> y \<in> S. f x \<le> f y \<longleftrightarrow> x \<le> y)" and "range f \<subseteq> {0..card S - 1}"
proof -
  obtain l where l_def: "l = sorted_list_of_set S" by auto
  with assms have l: "set l = S" "sorted l" "distinct l" by auto
  from l(1,3) \<open>finite S\<close> have len: "length l = card S" using distinct_card by force
  let ?f = "\<lambda> x. if x \<notin> S then 0 else THE i. i < length l \<and> l ! i = x"
  { fix x y assume A: "x \<in> S" "y \<in> S" "x < y"
    with l(1) obtain i j where *: "l ! i = x" "l ! j = y" "i < length l" "j < length l"
    by (meson in_set_conv_nth)
    have "i < j"
    proof (rule ccontr, goal_cases)
      case 1
      with sorted_nth_mono[OF l(2)] \<open>i < length l\<close> have "l ! j \<le> l ! i" by auto
      with * A(3) show False by auto
    qed
    moreover have "?f x = i" using * l(3) A(1) by (auto) (rule, auto intro: distinct_nth_unique)
    moreover have "?f y = j" using * l(3) A(2) by (auto) (rule, auto intro: distinct_nth_unique)
    ultimately have "?f x < ?f y" by auto
  } moreover
  { fix x y assume A: "x \<in> S" "y \<in> S" "?f x < ?f y"
    with l(1) obtain i j where *: "l ! i = x" "l ! j = y" "i < length l" "j < length l"
    by (meson in_set_conv_nth)
    moreover have "?f x = i" using * l(3) A(1) by (auto) (rule, auto intro: distinct_nth_unique)
    moreover have "?f y = j" using * l(3) A(2) by (auto) (rule, auto intro: distinct_nth_unique)
    ultimately have **: "l ! ?f x = x" "l ! ?f y = y" "i < j" using A(3) by auto
    have "x < y"
    proof (rule ccontr, goal_cases)
      case 1
      then have "y \<le> x" by simp
      moreover from sorted_nth_mono[OF l(2), of i j] **(3) * have "x \<le> y" by auto
      ultimately show False using distinct_nth_unique[OF _ *(3,4) l(3)] *(1,2) **(3) by fastforce
    qed
  }
  ultimately have "\<forall> x \<in> S. \<forall> y \<in> S. ?f x \<le> ?f y \<longleftrightarrow> x \<le> y" by force
  moreover have "range ?f \<subseteq> {0..card S - 1}"
  proof (auto, goal_cases)
    case (1 x)
    with l(1) obtain i where *: "l ! i = x" "i < length l" by (meson in_set_conv_nth)
    then have "?f x = i" using l(3) 1 by (auto) (rule, auto intro: distinct_nth_unique)
    with len show ?case using *(2) 1 by auto
  qed
  ultimately show ?thesis ..
qed

locale enumerateable =
  fixes T :: "'a set"
  fixes less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes finite: "finite T"
  assumes total:  "\<forall> x \<in> T. \<forall> y \<in> T. x \<noteq> y \<longrightarrow> (x \<prec> y) \<or> (y \<prec> x)"
  assumes trans:  "\<forall>x \<in> T. \<forall> y \<in> T. \<forall> z \<in> T. (x :: 'a) \<prec> y \<longrightarrow> y \<prec> z \<longrightarrow> x \<prec> z"
  assumes asymmetric: "\<forall> x \<in> T. \<forall> y \<in> T. x \<prec> y \<longrightarrow> \<not> (y \<prec> x)"
begin

lemma non_empty_set_has_least'':
  "S \<subseteq> T \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>! x \<in> S. \<forall> y \<in> S. x \<noteq> y \<longrightarrow> \<not> y \<prec> x"
proof (intro ex_ex1I, goal_cases)
  case 1
  with non_empty_set_has_least'[OF this] show ?case by auto
next
  case (2 x y)
  show ?case
  proof (rule ccontr)
    assume "x \<noteq> y"
    with 2 total have "x \<prec> y \<or> y \<prec> x" by blast
    with 2(2-) \<open>x \<noteq> y\<close> show False by auto
  qed
qed

abbreviation "least S \<equiv> THE t :: 'a. t \<in> S \<and> (\<forall> y \<in> S. t \<noteq> y \<longrightarrow> \<not> y \<prec> t)"

lemma non_empty_set_has_least:
  "S \<subseteq> T \<Longrightarrow> S \<noteq> {} \<Longrightarrow> least S \<in> S \<and> (\<forall> y \<in> S. least S \<noteq> y \<longrightarrow> \<not> y \<prec> least S)"
proof goal_cases
  case 1
  note A = this
  show ?thesis
  proof (rule theI', goal_cases)
    case 1
    from non_empty_set_has_least''[OF A] show ?case .
  qed
qed

fun f :: "'a set \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "f S 0 = []" |
  "f S (Suc n) = least S # f (S - {least S}) n"

inductive sorted :: "'a list \<Rightarrow> bool" where
  Nil [iff]: "sorted []"
| Cons: "\<forall>y\<in>set xs. x \<prec> y \<Longrightarrow> sorted xs \<Longrightarrow> sorted (x # xs)"

lemma f_set:
  "S \<subseteq> T \<Longrightarrow> n = card S \<Longrightarrow> set (f S n) = S"
proof (induction n arbitrary: S)
  case 0 then show ?case using finite by (auto simp: finite_subset)
next
  case (Suc n)
  then have fin: "finite S" using finite by (auto simp: finite_subset)
  with Suc.prems have "S \<noteq> {}" by auto
  from non_empty_set_has_least[OF Suc.prems(1) this] have least: "least S \<in> S" by blast
  let ?S = "S - {least S}"
  from fin least Suc.prems have "?S \<subseteq> T" "n = card ?S" by auto
  from Suc.IH[OF this] have "set (f ?S n) = ?S" .
  with least show ?case by auto
qed

lemma f_distinct:
  "S \<subseteq> T \<Longrightarrow> n = card S \<Longrightarrow> distinct (f S n)"
proof (induction n arbitrary: S)
  case 0 then show ?case using finite by (auto simp: finite_subset)
next
  case (Suc n)
  then have fin: "finite S" using finite by (auto simp: finite_subset)
  with Suc.prems have "S \<noteq> {}" by auto
  from non_empty_set_has_least[OF Suc.prems(1) this] have least: "least S \<in> S" by blast
  let ?S = "S - {least S}"
  from fin least Suc.prems have "?S \<subseteq> T" "n = card ?S" by auto
  from Suc.IH[OF this] f_set[OF this] have "distinct (f ?S n)" "set (f ?S n) = ?S" .
  then show ?case by simp
qed

lemma f_sorted:
  "S \<subseteq> T \<Longrightarrow> n = card S \<Longrightarrow> sorted (f S n)"
proof (induction n arbitrary: S)
  case 0 then show ?case by auto
next
  case (Suc n)
  then have fin: "finite S" using finite by (auto simp: finite_subset)
  with Suc.prems have "S \<noteq> {}" by auto
  from non_empty_set_has_least[OF Suc.prems(1) this] have least:
    "least S \<in> S" "(\<forall> y \<in> S. least S \<noteq> y \<longrightarrow> \<not> y \<prec> least S)"
  by blast+
  let ?S = "S - {least S}"
  { fix x assume x: "x \<in> ?S"
    with least have "\<not> x \<prec> least S" by auto
    with total x Suc.prems(1) least(1) have "least S \<prec> x" by blast
  } note le = this
  from fin least Suc.prems have "?S \<subseteq> T" "n = card ?S" by auto
  from f_set[OF this] Suc.IH[OF this] have *: "set (f ?S n) = ?S" "sorted (f ?S n)" .
  with le have "\<forall> x \<in> set (f ?S n). least S \<prec> x" by auto
  with *(2) show ?case by (auto intro: Cons)
qed

lemma sorted_nth_mono:
  "sorted xs \<Longrightarrow> i < j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<prec> xs!j"
proof (induction xs arbitrary: i j)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "i = 0")
    case True
    with Cons.prems show ?thesis by (auto elim: sorted.cases)
  next
    case False
    from Cons.prems have "sorted xs" by (auto elim: sorted.cases)
    from Cons.IH[OF this] Cons.prems False show ?thesis by auto
  qed
qed

lemma order_fun:
  fixes S :: "'a set"
  assumes "S \<subseteq> T"
  obtains f :: "'a \<Rightarrow> nat" where "\<forall> x \<in> S. \<forall> y \<in> S. f x < f y \<longleftrightarrow> x \<prec> y" and "range f \<subseteq> {0..card S - 1}"
proof -
  obtain l where l_def: "l = f S (card S)" by auto
  with f_set f_distinct f_sorted assms have l: "set l = S" "sorted l" "distinct l" by auto
  then have len: "length l = card S" using distinct_card by force
  let ?f = "\<lambda> x. if x \<notin> S then 0 else THE i. i < length l \<and> l ! i = x"
  { fix x y :: 'a assume A: "x \<in> S" "y \<in> S" "x \<prec> y"
    with l(1) obtain i j where *: "l ! i = x" "l ! j = y" "i < length l" "j < length l"
    by (meson in_set_conv_nth)
    have "i \<noteq> j"
    proof (rule ccontr, goal_cases)
      case 1
      with A * have "x \<prec> x" by auto
      with asymmetric A assms show False by auto
    qed
    have "i < j"
    proof (rule ccontr, goal_cases)
      case 1
      with \<open>i \<noteq> j\<close> sorted_nth_mono[OF l(2)] \<open>i < length l\<close> have "l ! j \<prec> l ! i" by auto
      with * A(3) A assms asymmetric show False by auto
    qed
    moreover have "?f x = i" using * l(3) A(1) by (auto) (rule, auto intro: distinct_nth_unique)
    moreover have "?f y = j" using * l(3) A(2) by (auto) (rule, auto intro: distinct_nth_unique)
    ultimately have "?f x < ?f y" by auto
  } moreover
  { fix x y assume A: "x \<in> S" "y \<in> S" "?f x < ?f y"
    with l(1) obtain i j where *: "l ! i = x" "l ! j = y" "i < length l" "j < length l"
    by (meson in_set_conv_nth)
    moreover have "?f x = i" using * l(3) A(1) by (auto) (rule, auto intro: distinct_nth_unique)
    moreover have "?f y = j" using * l(3) A(2) by (auto) (rule, auto intro: distinct_nth_unique)
    ultimately have **: "l ! ?f x = x" "l ! ?f y = y" "i < j" using A(3) by auto
    from sorted_nth_mono[OF l(2), of i j] **(3) * have "x \<prec> y" by auto
  }
  ultimately have "\<forall> x \<in> S. \<forall> y \<in> S. ?f x < ?f y \<longleftrightarrow> x \<prec> y" by force
  moreover have "range ?f \<subseteq> {0..card S - 1}"
  proof (auto, goal_cases)
    case (1 x)
    with l(1) obtain i where *: "l ! i = x" "i < length l" by (meson in_set_conv_nth)
    then have "?f x = i" using l(3) 1 by (auto) (rule, auto intro: distinct_nth_unique)
    with len show ?case using *(2) 1 by auto
  qed
  ultimately show ?thesis ..
qed

end

lemma finite_total_preorder_enumeration:
  fixes X :: "'a set"
  fixes r :: "'a rel"
  assumes fin:   "finite X"
  assumes tot:   "total_on X r"
  assumes refl:  "refl_on X r"
  assumes trans: "trans r"
  obtains f :: "'a \<Rightarrow> nat" where "\<forall> x \<in> X. \<forall> y \<in> X. f x \<le> f y \<longleftrightarrow> (x, y) \<in> r"
proof -
  let ?A = "\<lambda> x. {y \<in> X . (y, x) \<in> r \<and> (x, y) \<in> r}"
  have ex: "\<forall> x \<in> X. x \<in> ?A x" using refl unfolding refl_on_def by auto
  let ?R = "\<lambda> S. SOME y. y \<in> S"
  let ?T = "{?A x | x.  x \<in> X}"
  { fix A assume A: "A \<in> ?T"
    then obtain x where x: "x \<in> X" "?A x = A" by auto
    then have "x \<in> A" using refl unfolding refl_on_def by auto
    then have "?R A \<in> A" by (auto intro: someI)
    with x(2) have "(?R A, x) \<in> r" "(x, ?R A) \<in> r" by auto
    with trans have "(?R A, ?R A) \<in> r" unfolding trans_def by blast
  } note refl_lifted = this
  { fix A assume A: "A \<in> ?T"
    then obtain x where x: "x \<in> X" "?A x = A" by auto
    then have "x \<in> A" using refl unfolding refl_on_def by auto
    then have "?R A \<in> A" by (auto intro: someI)
  } note R_in = this
  { fix A y z assume A: "A \<in> ?T" and y: "y \<in> A" and z: "z \<in> A"
    from A obtain x where x: "x \<in> X" "?A x = A" by auto
    then have "x \<in> A" using refl unfolding refl_on_def by auto
    with x y have "(x, y) \<in> r" "(y, x) \<in> r" by auto
    moreover from x z have "(x,z) \<in> r" "(z,x) \<in> r" by auto
    ultimately have "(y, z) \<in> r" "(z, y) \<in> r" using trans unfolding trans_def by blast+
  } note A_dest' = this
  { fix A y assume "A \<in> ?T" and "y \<in> A"
    with A_dest'[OF _ _ R_in] have "(?R A, y) \<in> r" "(y, ?R A) \<in> r" by blast+
  } note A_dest = this
  { fix A y z assume A: "A \<in> ?T" and y: "y \<in> A" and z: "z \<in> X" and r: "(y, z) \<in> r" "(z, y) \<in> r"
    from A obtain x where x: "x \<in> X" "?A x = A" by auto
    then have "x \<in> A" using refl unfolding refl_on_def by auto
    with x y have "(x,y) \<in> r" "(y, x) \<in> r" by auto
    with r have "(x,z) \<in> r" "(z,x) \<in> r" using trans unfolding trans_def by blast+
    with x z have "z \<in> A" by auto
  } note A_intro' = this
  { fix A y assume A: "A \<in> ?T" and y: "y \<in> X" and r: "(?R A, y) \<in> r" "(y, ?R A) \<in> r"
    with A_intro' R_in have "y \<in> A" by blast
  } note A_intro = this
  { fix A B C
    assume r1: "(?R A, ?R B) \<in> r" and r2: "(?R B, ?R C) \<in> r"
    with trans have "(?R A, ?R C) \<in> r" unfolding trans_def by blast
  } note trans_lifted[intro] = this
  { fix A B a b
    assume A: "A \<in> ?T" and B: "B \<in> ?T"
    and a: "a \<in> A" and b: "b \<in> B"
    and r: "(a, b) \<in> r" "(b, a) \<in> r"
    with R_in have "?R A \<in> A" "?R B \<in> B" by blast+
    have "A = B"
    proof auto
      fix x assume x: "x \<in> A"
      with A have "x \<in> X" by auto
      from A_intro'[OF B b this] A_dest'[OF A x a] r trans[unfolded trans_def] show "x \<in> B" by blast
    next
      fix x assume x: "x \<in> B"
      with B have "x \<in> X" by auto
      from A_intro'[OF A a this] A_dest'[OF B x b] r trans[unfolded trans_def] show "x \<in> A" by blast
    qed
  } note eq_lifted'' = this
  { fix A B C
    assume A: "A \<in> ?T" and B: "B \<in> ?T" and r: "(?R A, ?R B) \<in> r" "(?R B, ?R A) \<in> r"
    with eq_lifted'' R_in have "A = B" by blast
  } note eq_lifted' = this
  { fix A B C
    assume A: "A \<in> ?T" and B: "B \<in> ?T" and eq: "?R A = ?R B"
    from R_in[OF A] A have "?R A \<in> X" by auto
    with refl have "(?R A, ?R A) \<in> r" unfolding refl_on_def by auto
    with eq_lifted'[OF A B] eq have "A = B" by auto
  } note eq_lifted = this
  { fix A B
    assume A: "A \<in> ?T" and B: "B \<in> ?T" and neq: "A \<noteq> B"
    from neq eq_lifted[OF A B] have "?R A \<noteq> ?R B" by metis
    moreover from A B R_in have "?R A \<in> X" "?R B \<in> X" by auto
    ultimately have "(?R A, ?R B) \<in> r \<or> (?R B, ?R A) \<in> r" using tot unfolding total_on_def by auto
  } note total_lifted = this
  { fix x y assume x: "x \<in> X" and y: "y \<in> X"
    from x y have "?A x \<in> ?T" "?A y \<in> ?T" by auto
    from R_in[OF this(1)] R_in[OF this(2)] have "?R (?A x) \<in> ?A x" "?R (?A y) \<in> ?A y" by auto
    then have "(x, ?R (?A x)) \<in> r" "(?R (?A y), y) \<in> r" "(?R (?A x), x) \<in> r" "(y, ?R (?A y)) \<in> r" by auto
    with trans[unfolded trans_def] have "(x, y) \<in> r \<longleftrightarrow> (?R (?A x), ?R (?A y)) \<in> r" by meson
  } note repr = this
  interpret interp: enumerateable "{?A x | x.  x \<in> X}" "\<lambda> A B. A \<noteq> B \<and> (?R A, ?R B) \<in> r"
  proof (standard, goal_cases)
    case 1
    from fin show ?case by auto
  next
    case 2
    with total_lifted show ?case by auto
  next
    case 3
    then show ?case unfolding transp_def
    proof (standard, standard, standard, standard, standard, goal_cases)
      case (1 A B C)
      note A = this
      with trans_lifted have "(?R A,?R C) \<in> r" by blast
      moreover have "A \<noteq> C"
      proof (rule ccontr, goal_cases)
        case 1
        with A have "(?R A,?R B) \<in> r" "(?R B,?R A) \<in> r" by auto
        with eq_lifted'[OF A(1,2)] A show False by auto
      qed
      ultimately show ?case by auto
    qed
  next
    case 4
    { fix A B assume A: "A \<in> ?T" and B: "B \<in> ?T" and neq: "A \<noteq> B" "(?R A, ?R B) \<in> r"
      with eq_lifted'[OF A B] neq have "\<not> (?R B, ?R A) \<in> r" by auto
    }
    then show ?case by auto
  qed
  from interp.order_fun[OF subset_refl] obtain f :: "'a set \<Rightarrow> nat" where
    f: "\<forall> x \<in> ?T. \<forall> y \<in> ?T. f x < f y \<longleftrightarrow> x \<noteq> y \<and> (?R x, ?R y) \<in> r" "range f \<subseteq> {0..card ?T - 1}"
  by auto
  let ?f = "\<lambda> x. if x \<in> X then f (?A x) else 0"
  { fix x y assume x: "x \<in> X" and y: "y \<in> X"
    have "?f x \<le> ?f y \<longleftrightarrow> (x, y) \<in> r"
    proof (cases "x = y")
      case True
      with refl x show ?thesis unfolding refl_on_def by auto
    next
      case False
      note F = this
      from ex x y have *: "?A x \<in> ?T" "?A y \<in> ?T" "x \<in> ?A x" "y \<in> ?A y" by auto
      show ?thesis
      proof (cases "(x, y) \<in> r \<and> (y, x) \<in> r")
        case True
        from eq_lifted''[OF *] True x y have "?f x = ?f y" by auto
        with True show ?thesis by auto
      next
        case False
        with A_dest'[OF *(1,3), of y] *(4) have **: "?A x \<noteq> ?A y" by auto
        from total_lifted[OF *(1,2) this] have "(?R (?A x), ?R (?A y)) \<in> r \<or> (?R (?A y), ?R (?A x)) \<in> r" .
        then have neq: "?f x \<noteq> ?f y"
        proof (standard, goal_cases)
          case 1
          with f *(1,2) ** have "f (?A x) < f (?A y)" by auto
          with * show ?case by auto
        next
          case 2
          with f *(1,2) ** have "f (?A y) < f (?A x)" by auto
          with * show ?case by auto
        qed
        then have "?thesis = (?f x < ?f y \<longleftrightarrow> (x, y) \<in> r)" by linarith
        moreover from f ** * have "(?f x < ?f y \<longleftrightarrow> (?R (?A x), ?R (?A y)) \<in> r)" by auto
        moreover from repr * have "\<dots> \<longleftrightarrow> (x, y) \<in> r" by auto
        ultimately show ?thesis by auto
      qed
    qed
  }
  then have "\<forall> x \<in> X. \<forall> y \<in> X. ?f x \<le> ?f y \<longleftrightarrow> (x, y) \<in> r" by blast
  then show ?thesis ..
qed

section \<open>Finiteness\<close>

lemma pairwise_finiteI:
  assumes "finite {b. \<exists>a. P a b}" (is "finite ?B")
  assumes "finite {a. \<exists>b. P a b}"
  shows "finite {(a,b). P a b}" (is "finite ?C")
proof -
  from assms(1) have "finite ?B" .
  let ?f = "\<lambda> b. {(a,b) | a. P a b}"
  { fix b
    have "?f b \<subseteq> {(a,b) | a. \<exists>b. P a b}" by blast
    moreover have "finite \<dots>" using assms(2) by auto
    ultimately have "finite (?f b)" by (blast intro: finite_subset)
  }
  with assms(1) have "finite (\<Union> (?f ` ?B))" by auto
  moreover have "?C \<subseteq> \<Union> (?f ` ?B)" by auto
  ultimately show ?thesis by (blast intro: finite_subset)
qed

lemma finite_ex_and1:
  assumes "finite {b. \<exists>a. P a b}" (is "finite ?A")
  shows "finite {b. \<exists>a. P a b \<and> Q a b}" (is "finite ?B")
proof -
  have "?B \<subseteq> ?A" by auto
  with assms show ?thesis by (blast intro: finite_subset)
qed

lemma finite_ex_and2:
  assumes "finite {b. \<exists>a. Q a b}" (is "finite ?A")
  shows "finite {b. \<exists>a. P a b \<and> Q a b}" (is "finite ?B")
proof -
  have "?B \<subseteq> ?A" by auto
  with assms show ?thesis by (blast intro: finite_subset)
qed

section \<open>Numbering the elements of finite sets\<close>

lemma upt_last_append: "a \<le> b \<Longrightarrow> [a..<b] @ [b] = [a ..< Suc b]" by (induction b) auto

lemma map_of_zip_dom_to_range:
  "a \<in> set A \<Longrightarrow> length B = length A \<Longrightarrow> the (map_of (zip A B) a) \<in> set B"
by (metis map_of_SomeD map_of_zip_is_None option.collapse set_zip_rightD)

lemma zip_range_id:
  "length A = length B \<Longrightarrow> snd ` set (zip A B) = set B"
by (metis map_snd_zip set_map)

lemma map_of_zip_in_range:
  "distinct A \<Longrightarrow> length B = length A \<Longrightarrow> b \<in> set B \<Longrightarrow> \<exists> a \<in> set A. the (map_of (zip A B) a) = b"
proof goal_cases
  case 1
  from ran_distinct[of "zip A B"] 1(1,2) have
    "ran (map_of (zip A B)) = set B"
  by (auto simp: zip_range_id)
  with 1(3) obtain a where "map_of (zip A B) a = Some b" unfolding ran_def by auto
  with map_of_zip_is_Some[OF 1(2)[symmetric]] have "the (map_of (zip A B) a) = b" "a \<in> set A" by auto
  then show ?case by blast
qed

lemma distinct_zip_inj:
  "distinct ys \<Longrightarrow> (a, b) \<in> set (zip xs ys) \<Longrightarrow> (c, b) \<in> set (zip xs ys) \<Longrightarrow> a = c"
proof (induction ys arbitrary: xs)
  case Nil then show ?case by auto
next
  case (Cons y ys)
  from this(3) have "xs \<noteq> []" by auto
  then obtain z zs where xs: "xs = z # zs" by (cases xs) auto
  show ?case
  proof (cases "(a, b) \<in> set (zip zs ys)")
    case True
    note T = this
    then have b: "b \<in> set ys" by (meson in_set_zipE)
    show ?thesis
    proof (cases "(c, b) \<in> set (zip zs ys)")
      case True
      with T Cons show ?thesis by auto
    next
      case False
      with Cons.prems xs b show ?thesis by auto
    qed
  next
    case False
    with Cons.prems xs have b: "a = z" "b = y" by auto
    show ?thesis
    proof (cases "(c, b) \<in> set (zip zs ys)")
      case True
      then have "b \<in> set ys" by (meson in_set_zipE)
      with b \<open>distinct (y#ys)\<close> show ?thesis by auto
    next
      case False
      with Cons.prems xs b show ?thesis by auto
    qed
  qed
qed

lemma map_of_zip_distinct_inj:
  "distinct B \<Longrightarrow> length A = length B \<Longrightarrow> inj_on (the o map_of (zip A B)) (set A)"
unfolding inj_on_def proof (clarify, goal_cases)
  case (1 x y)
  with map_of_zip_is_Some[OF 1(2)] obtain a where
    "map_of (zip A B) x = Some a" "map_of (zip A B) y = Some a"
  by auto
  then have "(x, a) \<in> set (zip A B)" "(y, a) \<in> set (zip A B)" using map_of_SomeD by metis+
  from distinct_zip_inj[OF _ this] 1 show ?case by auto
qed

lemma nat_not_ge_1D: "\<not> Suc 0 \<le> x \<Longrightarrow> x = 0" by auto

lemma standard_numbering:
  assumes "finite A"
  obtains v :: "'a \<Rightarrow> nat" and n where "bij_betw v A {1..n}"
  and "\<forall> c \<in> A. v c > 0"
  and "\<forall> c. c \<notin> A \<longrightarrow> v c > n"
proof -
  from assms obtain L where L: "distinct L" "set L = A" by (meson finite_distinct_list)
  let ?N = "length L + 1"
  let ?P = "zip L [1..<?N]"
  let ?v = "\<lambda> x. let v = map_of ?P x in if v = None then ?N else the v"
  from length_upt have len: "length [1..<?N] = length L" by auto (cases L, auto)
  then have lsimp: "length [Suc 0 ..<Suc (length L)] = length L" by simp
  note * = map_of_zip_dom_to_range[OF _ len]
  have "bij_betw ?v A {1..length L}" unfolding bij_betw_def
  proof
    show "?v ` A = {1..length L}" apply auto
      apply (auto simp: L)[]
      apply (auto simp only: upt_last_append)[] using * apply force
      using * apply (simp only: upt_last_append) apply force
      apply (simp only: upt_last_append) using L(2) apply (auto dest: nat_not_ge_1D)
      apply (subgoal_tac "x \<in> set [1..< length L +1]")
      apply (force dest!: map_of_zip_in_range[OF L(1) len])
      apply auto
    done
  next
    from L map_of_zip_distinct_inj[OF distinct_upt, of L 1 "length L + 1"] len
    have "inj_on (the o map_of ?P) A" by auto
    moreover have "inj_on (the o map_of ?P) A = inj_on ?v A"
    using len L(2) by - (rule inj_on_cong, auto)
    ultimately show "inj_on ?v A" by blast
  qed
  moreover have "\<forall> c \<in> A. ?v c > 0"
  proof
    fix c
    show "?v c > 0"
    proof (cases "c \<in> set L")
      case False
      then show ?thesis by auto
    next
      case True
      with dom_map_of_zip[OF len[symmetric]] obtain x where
        "Some x = map_of ?P c" "x \<in> set [1..<length L + 1]"
      by (metis * domIff option.collapse)
      then have "?v c \<in> set [1..<length L + 1]" using * True len by auto
      then show ?thesis by auto
    qed
  qed
  moreover have "\<forall> c. c \<notin> A \<longrightarrow> ?v c > length L" using L by auto
  ultimately show ?thesis ..
qed

end
(*>*)


theory Examples
imports Main
begin

(*
text {* The following presentation will use notation of
  Isabelle's meta logic, hence a few sentences to explain this.
  The logical
  primitives are universal quantification (@{text "\<And>"}), entailment
  (@{text "\<Longrightarrow>"}) and equality (@{text "\<equiv>"}).  Variables (not bound
  variables) are sometimes preceded by a question mark.  The logic is
  typed.  Type variables are denoted by~@{text "'a"},~@{text "'b"}
  etc., and~@{text "\<Rightarrow>"} is the function type.  Double brackets~@{text
  "\<lbrakk>"} and~@{text "\<rbrakk>"} are used to abbreviate nested entailment.
*}
*)

section \<open>Introduction\<close>

text \<open>
  Locales are based on contexts.  A \emph{context} can be seen as a
  formula schema
\[
  @{text "\<And>x\<^sub>1\<dots>x\<^sub>n. \<lbrakk> A\<^sub>1; \<dots> ;A\<^sub>m \<rbrakk> \<Longrightarrow> \<dots>"}
\]
  where the variables~@{text "x\<^sub>1"}, \ldots,~@{text "x\<^sub>n"} are called
  \emph{parameters} and the premises $@{text "A\<^sub>1"}, \ldots,~@{text
  "A\<^sub>m"}$ \emph{assumptions}.  A formula~@{text "C"}
  is a \emph{theorem} in the context if it is a conclusion
\[
  @{text "\<And>x\<^sub>1\<dots>x\<^sub>n. \<lbrakk> A\<^sub>1; \<dots> ;A\<^sub>m \<rbrakk> \<Longrightarrow> C"}.
\]
  Isabelle/Isar's notion of context goes beyond this logical view.
  Its contexts record, in a consecutive order, proved
  conclusions along with \emph{attributes}, which can provide context
  specific configuration information for proof procedures and concrete
  syntax.  From a logical perspective, locales are just contexts that
  have been made persistent.  To the user, though, they provide
  powerful means for declaring and combining contexts, and for the
  reuse of theorems proved in these contexts.
\<close>

section \<open>Simple Locales\<close>

text \<open>
  In its simplest form, a
  \emph{locale declaration} consists of a sequence of context elements
  declaring parameters (keyword \isakeyword{fixes}) and assumptions
  (keyword \isakeyword{assumes}).  The following is the specification of
  partial orders, as locale @{text partial_order}.
\<close>

  locale partial_order =
    fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
    assumes refl [intro, simp]: "x \<sqsubseteq> x"
      and anti_sym [intro]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> x \<rbrakk> \<Longrightarrow> x = y"
      and trans [trans]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"

text (in partial_order) \<open>The parameter of this locale is~@{text le},
  which is a binary predicate with infix syntax~@{text \<sqsubseteq>}.  The
  parameter syntax is available in the subsequent
  assumptions, which are the familiar partial order axioms.

  Isabelle recognises unbound names as free variables.  In locale
  assumptions, these are implicitly universally quantified.  That is,
  @{term "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"} in fact means
  @{term "\<And>x y z. \<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"}.

  Two commands are provided to inspect locales:
  \isakeyword{print\_locales} lists the names of all locales of the
  current theory; \isakeyword{print\_locale}~$n$ prints the parameters
  and assumptions of locale $n$; the variation \isakeyword{print\_locale!}~$n$
  additionally outputs the conclusions that are stored in the locale.
  We may inspect the new locale
  by issuing \isakeyword{print\_locale!} @{term partial_order}.  The output
  is the following list of context elements.
\begin{small}
\begin{alltt}
  \isakeyword{fixes} le :: "'a \(\Rightarrow\) 'a \(\Rightarrow\)  bool" (\isakeyword{infixl} "\(\sqsubseteq\)" 50)
  \isakeyword{assumes} "partial_order op \(\sqsubseteq\)"
  \isakeyword{notes} assumption
    refl [intro, simp] = `?x \(\sqsubseteq\) ?x`
    \isakeyword{and}
    anti_sym [intro] = `\(\isasymlbrakk\)?x \(\sqsubseteq\) ?y; ?y \(\sqsubseteq\) ?x\(\isasymrbrakk\) \(\Longrightarrow\) ?x = ?y`
    \isakeyword{and}
    trans [trans] = `\(\isasymlbrakk\)?x \(\sqsubseteq\) ?y; ?y \(\sqsubseteq\) ?z\(\isasymrbrakk\) \(\Longrightarrow\) ?x \(\sqsubseteq\) ?z`
\end{alltt}
\end{small}

  This differs from the declaration.  The assumptions have turned into
  conclusions, denoted by the keyword \isakeyword{notes}.  Also,
  there is only one assumption, namely @{term "partial_order le"}.
  The locale declaration has introduced the predicate @{term
  partial_order} to the theory.  This predicate is the
  \emph{locale predicate}.  Its definition may be inspected by
  issuing \isakeyword{thm} @{thm [source] partial_order_def}.
  @{thm [display, indent=2] partial_order_def}
  In our example, this is a unary predicate over the parameter of the
  locale.  It is equivalent to the original assumptions, which have
  been turned into conclusions and are
  available as theorems in the context of the locale.  The names and
  attributes from the locale declaration are associated to these
  theorems and are effective in the context of the locale.

  Each conclusion has a \emph{foundational theorem} as counterpart
  in the theory.  Technically, this is simply the theorem composed
  of context and conclusion.  For the transitivity theorem, this is
  @{thm [source] partial_order.trans}:
  @{thm [display, indent=2] partial_order.trans}
\<close>

subsection \<open>Targets: Extending Locales\<close>

text \<open>
  The specification of a locale is fixed, but its list of conclusions
  may be extended through Isar commands that take a \emph{target} argument.
  In the following, \isakeyword{definition} and
  \isakeyword{theorem} are illustrated.
  Table~\ref{tab:commands-with-target} lists Isar commands that accept
  a target.  Isar provides various ways of specifying the target.  A
  target for a single command may be indicated with keyword
  \isakeyword{in} in the following way:

\begin{table}
\hrule
\vspace{2ex}
\begin{center}
\begin{tabular}{ll}
  \isakeyword{definition} & definition through an equation \\
  \isakeyword{inductive} & inductive definition \\
  \isakeyword{primrec} & primitive recursion \\
  \isakeyword{fun}, \isakeyword{function} & general recursion \\
  \isakeyword{abbreviation} & syntactic abbreviation \\
  \isakeyword{theorem}, etc.\ & theorem statement with proof \\
  \isakeyword{theorems}, etc.\ & redeclaration of theorems \\
  \isakeyword{text}, etc.\ & document markup
\end{tabular}
\end{center}
\hrule
\caption{Isar commands that accept a target.}
\label{tab:commands-with-target}
\end{table}
\<close>

  definition (in partial_order)
    less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50)
    where "(x \<sqsubset> y) = (x \<sqsubseteq> y \<and> x \<noteq> y)"

text (in partial_order) \<open>The strict order @{text less} with infix
  syntax~@{text \<sqsubset>} is
  defined in terms of the locale parameter~@{text le} and the general
  equality of the object logic we work in.  The definition generates a
  \emph{foundational constant}
  @{term partial_order.less} with definition @{thm [source]
  partial_order.less_def}:
  @{thm [display, indent=2] partial_order.less_def}
  At the same time, the locale is extended by syntax transformations
  hiding this construction in the context of the locale.  Here, the
  abbreviation @{text less} is available for
  @{text "partial_order.less le"}, and it is printed
  and parsed as infix~@{text \<sqsubset>}.  Finally, the conclusion @{thm [source]
  less_def} is added to the locale:
  @{thm [display, indent=2] less_def}
\<close>

text \<open>The treatment of theorem statements is more straightforward.
  As an example, here is the derivation of a transitivity law for the
  strict order relation.\<close>

  lemma (in partial_order) less_le_trans [trans]:
    "\<lbrakk> x \<sqsubset> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubset> z"
    unfolding %visible less_def by %visible (blast intro: trans)

text \<open>In the context of the proof, conclusions of the
  locale may be used like theorems.  Attributes are effective: @{text
  anti_sym} was
  declared as introduction rule, hence it is in the context's set of
  rules used by the classical reasoner by default.\<close>

subsection \<open>Context Blocks\<close>

text \<open>When working with locales, sequences of commands with the same
  target are frequent.  A block of commands, delimited by
  \isakeyword{begin} and \isakeyword{end}, makes a theory-like style
  of working possible.  All commands inside the block refer to the
  same target.  A block may immediately follow a locale
  declaration, which makes that locale the target.  Alternatively the
  target for a block may be given with the \isakeyword{context}
  command.

  This style of working is illustrated in the block below, where
  notions of infimum and supremum for partial orders are introduced,
  together with theorems about their uniqueness.\<close>

  context partial_order
  begin

  definition
    is_inf where "is_inf x y i =
      (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

  definition
    is_sup where "is_sup x y s =
      (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

  lemma %invisible is_infI [intro?]: "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow>
      (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> is_inf x y i"
    by (unfold is_inf_def) blast

  lemma %invisible is_inf_lower [elim?]:
    "is_inf x y i \<Longrightarrow> (i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
    by (unfold is_inf_def) blast

  lemma %invisible is_inf_greatest [elim?]:
      "is_inf x y i \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i"
    by (unfold is_inf_def) blast

  theorem is_inf_uniq: "\<lbrakk>is_inf x y i; is_inf x y i'\<rbrakk> \<Longrightarrow> i = i'"
    proof -
    assume inf: "is_inf x y i"
    assume inf': "is_inf x y i'"
    show ?thesis
    proof (rule anti_sym)
      from inf' show "i \<sqsubseteq> i'"
      proof (rule is_inf_greatest)
        from inf show "i \<sqsubseteq> x" ..
        from inf show "i \<sqsubseteq> y" ..
      qed
      from inf show "i' \<sqsubseteq> i"
      proof (rule is_inf_greatest)
        from inf' show "i' \<sqsubseteq> x" ..
        from inf' show "i' \<sqsubseteq> y" ..
      qed
    qed
  qed

  theorem %invisible is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
  proof -
    assume "x \<sqsubseteq> y"
    show ?thesis
    proof
      show "x \<sqsubseteq> x" ..
      show "x \<sqsubseteq> y" by fact
      fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
    qed
  qed

  lemma %invisible is_supI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
      (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> is_sup x y s"
    by (unfold is_sup_def) blast

  lemma %invisible is_sup_least [elim?]:
      "is_sup x y s \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z"
    by (unfold is_sup_def) blast

  lemma %invisible is_sup_upper [elim?]:
      "is_sup x y s \<Longrightarrow> (x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow> C) \<Longrightarrow> C"
    by (unfold is_sup_def) blast

  theorem is_sup_uniq: "\<lbrakk>is_sup x y s; is_sup x y s'\<rbrakk> \<Longrightarrow> s = s'"
    proof -
    assume sup: "is_sup x y s"
    assume sup': "is_sup x y s'"
    show ?thesis
    proof (rule anti_sym)
      from sup show "s \<sqsubseteq> s'"
      proof (rule is_sup_least)
        from sup' show "x \<sqsubseteq> s'" ..
        from sup' show "y \<sqsubseteq> s'" ..
      qed
      from sup' show "s' \<sqsubseteq> s"
      proof (rule is_sup_least)
        from sup show "x \<sqsubseteq> s" ..
        from sup show "y \<sqsubseteq> s" ..
      qed
    qed
  qed

  theorem %invisible is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
  proof -
    assume "x \<sqsubseteq> y"
    show ?thesis
    proof
      show "x \<sqsubseteq> y" by fact
      show "y \<sqsubseteq> y" ..
      fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
      show "y \<sqsubseteq> z" by fact
    qed
  qed

  end

text \<open>The syntax of the locale commands discussed in this tutorial is
  shown in Table~\ref{tab:commands}.  The grammar is complete with the
  exception of the context elements \isakeyword{constrains} and
  \isakeyword{defines}, which are provided for backward
  compatibility.  See the Isabelle/Isar Reference
  Manual @{cite IsarRef} for full documentation.\<close>

section \<open>Import \label{sec:import}\<close>

text \<open>
  Algebraic structures are commonly defined by adding operations and
  properties to existing structures.  For example, partial orders
  are extended to lattices and total orders.  Lattices are extended to
  distributive lattices.\<close>

text \<open>
  With locales, this kind of inheritance is achieved through
  \emph{import} of locales.  The import part of a locale declaration,
  if present, precedes the context elements.  Here is an example,
  where partial orders are extended to lattices.
\<close>

  locale lattice = partial_order +
    assumes ex_inf: "\<exists>inf. is_inf x y inf"
      and ex_sup: "\<exists>sup. is_sup x y sup"
  begin

text \<open>These assumptions refer to the predicates for infimum
  and supremum defined for @{text partial_order} in the previous
  section.  We now introduce the notions of meet and join,
  together with an example theorem.\<close>

  definition
    meet (infixl "\<sqinter>" 70) where "x \<sqinter> y = (THE inf. is_inf x y inf)"
  definition
    join (infixl "\<squnion>" 65) where "x \<squnion> y = (THE sup. is_sup x y sup)"

  lemma %invisible meet_equality [elim?]: "is_inf x y i \<Longrightarrow> x \<sqinter> y = i"
  proof (unfold meet_def)
    assume "is_inf x y i"
    then show "(THE i. is_inf x y i) = i"
      by (rule the_equality) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
  qed

  lemma %invisible meetI [intro?]:
      "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> x \<sqinter> y = i"
    by (rule meet_equality, rule is_infI) blast+

  lemma %invisible is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
  proof (unfold meet_def)
    from ex_inf obtain i where "is_inf x y i" ..
    then show "is_inf x y (THE i. is_inf x y i)"
      by (rule theI) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
  qed

  lemma meet_left(*<*)[intro?](*>*): "x \<sqinter> y \<sqsubseteq> x"
    by (rule is_inf_lower) (rule is_inf_meet)

  lemma %invisible meet_right [intro?]:
    "x \<sqinter> y \<sqsubseteq> y"
    by (rule is_inf_lower) (rule is_inf_meet)

  lemma %invisible meet_le [intro?]:
    "\<lbrakk> z \<sqsubseteq> x; z \<sqsubseteq> y \<rbrakk> \<Longrightarrow> z \<sqsubseteq> x \<sqinter> y"
    by (rule is_inf_greatest) (rule is_inf_meet)

  lemma %invisible join_equality [elim?]: "is_sup x y s \<Longrightarrow> x \<squnion> y = s"
  proof (unfold join_def)
    assume "is_sup x y s"
    then show "(THE s. is_sup x y s) = s"
      by (rule the_equality) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
  qed

  lemma %invisible joinI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
      (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = s"
    by (rule join_equality, rule is_supI) blast+

  lemma %invisible is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
  proof (unfold join_def)
    from ex_sup obtain s where "is_sup x y s" ..
    then show "is_sup x y (THE s. is_sup x y s)"
      by (rule theI) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
  qed

  lemma %invisible join_left [intro?]:
    "x \<sqsubseteq> x \<squnion> y"
    by (rule is_sup_upper) (rule is_sup_join)

  lemma %invisible join_right [intro?]:
    "y \<sqsubseteq> x \<squnion> y"
    by (rule is_sup_upper) (rule is_sup_join)

  lemma %invisible join_le [intro?]:
    "\<lbrakk> x \<sqsubseteq> z; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<squnion> y \<sqsubseteq> z"
    by (rule is_sup_least) (rule is_sup_join)

  theorem %invisible meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  proof (rule meetI)
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
    proof
      show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
      show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
      proof -
        have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
    qed
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> z" ..
      finally show ?thesis .
    qed
    fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
    show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
    proof
      show "w \<sqsubseteq> x"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> x" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> y \<sqinter> z"
      proof
        show "w \<sqsubseteq> y"
        proof -
          have "w \<sqsubseteq> x \<sqinter> y" by fact
          also have "\<dots> \<sqsubseteq> y" ..
          finally show ?thesis .
        qed
        show "w \<sqsubseteq> z" by fact
      qed
    qed
  qed

  theorem %invisible meet_commute: "x \<sqinter> y = y \<sqinter> x"
  proof (rule meetI)
    show "y \<sqinter> x \<sqsubseteq> x" ..
    show "y \<sqinter> x \<sqsubseteq> y" ..
    fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
    then show "z \<sqsubseteq> y \<sqinter> x" ..
  qed

  theorem %invisible meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
  proof (rule meetI)
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> x \<squnion> y" ..
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
    show "z \<sqsubseteq> x" by fact
  qed

  theorem %invisible join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  proof (rule joinI)
    show "x \<squnion> y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof
      show "x \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      show "y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
      proof -
        have "y \<sqsubseteq> y \<squnion> z" ..
        also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
        finally show ?thesis .
      qed
    qed
    show "z \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof -
      have "z \<sqsubseteq> y \<squnion> z"  ..
      also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      finally show ?thesis .
    qed
    fix w assume "x \<squnion> y \<sqsubseteq> w" and "z \<sqsubseteq> w"
    show "x \<squnion> (y \<squnion> z) \<sqsubseteq> w"
    proof
      show "x \<sqsubseteq> w"
      proof -
        have "x \<sqsubseteq> x \<squnion> y" ..
        also have "\<dots> \<sqsubseteq> w" by fact
        finally show ?thesis .
      qed
      show "y \<squnion> z \<sqsubseteq> w"
      proof
        show "y \<sqsubseteq> w"
        proof -
          have "y \<sqsubseteq> x \<squnion> y" ..
          also have "... \<sqsubseteq> w" by fact
          finally show ?thesis .
        qed
        show "z \<sqsubseteq> w" by fact
      qed
    qed
  qed

  theorem %invisible join_commute: "x \<squnion> y = y \<squnion> x"
  proof (rule joinI)
    show "x \<sqsubseteq> y \<squnion> x" ..
    show "y \<sqsubseteq> y \<squnion> x" ..
    fix z assume "y \<sqsubseteq> z" and "x \<sqsubseteq> z"
    then show "y \<squnion> x \<sqsubseteq> z" ..
  qed

  theorem %invisible join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
  proof (rule joinI)
    show "x \<sqsubseteq> x" ..
    show "x \<sqinter> y \<sqsubseteq> x" ..
    fix z assume "x \<sqsubseteq> z" and "x \<sqinter> y \<sqsubseteq> z"
    show "x \<sqsubseteq> z" by fact
  qed

  theorem %invisible meet_idem: "x \<sqinter> x = x"
  proof -
    have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
    also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
    finally show ?thesis .
  qed

  theorem %invisible meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
  proof (rule meetI)
    assume "x \<sqsubseteq> y"
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
    show "z \<sqsubseteq> x" by fact
  qed

  theorem %invisible meet_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<sqinter> y = y"
    by (drule meet_related) (simp add: meet_commute)

  theorem %invisible join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
  proof (rule joinI)
    assume "x \<sqsubseteq> y"
    show "y \<sqsubseteq> y" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed

  theorem %invisible join_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
    by (drule join_related) (simp add: join_commute)

  theorem %invisible meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
  proof
    assume "x \<sqsubseteq> y"
    then have "is_inf x y x" ..
    then show "x \<sqinter> y = x" ..
  next
    have "x \<sqinter> y \<sqsubseteq> y" ..
    also assume "x \<sqinter> y = x"
    finally show "x \<sqsubseteq> y" .
  qed

  theorem %invisible join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
  proof
    assume "x \<sqsubseteq> y"
    then have "is_sup x y y" ..
    then show "x \<squnion> y = y" ..
  next
    have "x \<sqsubseteq> x \<squnion> y" ..
    also assume "x \<squnion> y = y"
    finally show "x \<sqsubseteq> y" .
  qed

  theorem %invisible meet_connection2: "(x \<sqsubseteq> y) = (y \<sqinter> x = x)"
    using meet_commute meet_connection by simp

  theorem %invisible join_connection2: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
    using join_commute join_connection by simp

  text %invisible \<open>Naming according to Jacobson I, p.\ 459.\<close>
  lemmas %invisible L1 = join_commute meet_commute
  lemmas %invisible L2 = join_assoc meet_assoc
  (* lemmas L3 = join_idem meet_idem *)
  lemmas %invisible L4 = join_meet_absorb meet_join_absorb

  end

text \<open>Locales for total orders and distributive lattices follow to
  establish a sufficiently rich landscape of locales for
  further examples in this tutorial.\<close>

  locale total_order = partial_order +
    assumes total: "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

  lemma (in total_order) less_total: "x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x"
    using total
    by (unfold less_def) blast

  locale distrib_lattice = lattice +
    assumes meet_distr: "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z"

  lemma (in distrib_lattice) join_distr:
    "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"  (* txt {* Jacobson I, p.\ 462 *} *)
    proof -
    have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by (simp add: L4)
    also have "... = x \<squnion> ((x \<sqinter> z) \<squnion> (y \<sqinter> z))" by (simp add: L2)
    also have "... = x \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 meet_distr)
    also have "... = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 L4)
    also have "... = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by (simp add: meet_distr)
    finally show ?thesis .
  qed

text \<open>
  The locale hierarchy obtained through these declarations is shown in
  Figure~\ref{fig:lattices}(a).

\begin{figure}
\hrule \vspace{2ex}
\begin{center}
\subfigure[Declared hierarchy]{
\begin{tikzpicture}
  \node (po) at (0,0) {@{text partial_order}};
  \node (lat) at (-1.5,-1) {@{text lattice}};
  \node (dlat) at (-1.5,-2) {@{text distrib_lattice}};
  \node (to) at (1.5,-1) {@{text total_order}};
  \draw (po) -- (lat);
  \draw (lat) -- (dlat);
  \draw (po) -- (to);
%  \draw[->, dashed] (lat) -- (to);
\end{tikzpicture}
} \\
\subfigure[Total orders are lattices]{
\begin{tikzpicture}
  \node (po) at (0,0) {@{text partial_order}};
  \node (lat) at (0,-1) {@{text lattice}};
  \node (dlat) at (-1.5,-2) {@{text distrib_lattice}};
  \node (to) at (1.5,-2) {@{text total_order}};
  \draw (po) -- (lat);
  \draw (lat) -- (dlat);
  \draw (lat) -- (to);
%  \draw[->, dashed] (dlat) -- (to);
\end{tikzpicture}
} \quad
\subfigure[Total orders are distributive lattices]{
\begin{tikzpicture}
  \node (po) at (0,0) {@{text partial_order}};
  \node (lat) at (0,-1) {@{text lattice}};
  \node (dlat) at (0,-2) {@{text distrib_lattice}};
  \node (to) at (0,-3) {@{text total_order}};
  \draw (po) -- (lat);
  \draw (lat) -- (dlat);
  \draw (dlat) -- (to);
\end{tikzpicture}
}
\end{center}
\hrule
\caption{Hierarchy of Lattice Locales.}
\label{fig:lattices}
\end{figure}
\<close>

section \<open>Changing the Locale Hierarchy
  \label{sec:changing-the-hierarchy}\<close>

text \<open>
  Locales enable to prove theorems abstractly, relative to
  sets of assumptions.  These theorems can then be used in other
  contexts where the assumptions themselves, or
  instances of the assumptions, are theorems.  This form of theorem
  reuse is called \emph{interpretation}.  Locales generalise
  interpretation from theorems to conclusions, enabling the reuse of
  definitions and other constructs that are not part of the
  specifications of the locales.

  The first form of interpretation we will consider in this tutorial
  is provided by the \isakeyword{sublocale} command.  It enables to
  modify the import hierarchy to reflect the \emph{logical} relation
  between locales.

  Consider the locale hierarchy from Figure~\ref{fig:lattices}(a).
  Total orders are lattices, although this is not reflected here, and
  definitions, theorems and other conclusions
  from @{term lattice} are not available in @{term total_order}.  To
  obtain the situation in Figure~\ref{fig:lattices}(b), it is
  sufficient to add the conclusions of the latter locale to the former.
  The \isakeyword{sublocale} command does exactly this.
  The declaration \isakeyword{sublocale} $l_1
  \subseteq l_2$ causes locale $l_2$ to be \emph{interpreted} in the
  context of $l_1$.  This means that all conclusions of $l_2$ are made
  available in $l_1$.

  Of course, the change of hierarchy must be supported by a theorem
  that reflects, in our example, that total orders are indeed
  lattices.  Therefore the \isakeyword{sublocale} command generates a
  goal, which must be discharged by the user.  This is illustrated in
  the following paragraphs.  First the sublocale relation is stated.
\<close>

  sublocale %visible total_order \<subseteq> lattice

txt \<open>\normalsize
  This enters the context of locale @{text total_order}, in
  which the goal @{subgoals [display]} must be shown.
  Now the
  locale predicate needs to be unfolded --- for example, using its
  definition or by introduction rules
  provided by the locale package.  For automation, the locale package
  provides the methods @{text intro_locales} and @{text
  unfold_locales}.  They are aware of the
  current context and dependencies between locales and automatically
  discharge goals implied by these.  While @{text unfold_locales}
  always unfolds locale predicates to assumptions, @{text
  intro_locales} only unfolds definitions along the locale
  hierarchy, leaving a goal consisting of predicates defined by the
  locale package.  Occasionally the latter is of advantage since the goal
  is smaller.

  For the current goal, we would like to get hold of
  the assumptions of @{text lattice}, which need to be shown, hence
  @{text unfold_locales} is appropriate.\<close>

  proof unfold_locales

txt \<open>\normalsize
  Since the fact that both lattices and total orders are partial
  orders is already reflected in the locale hierarchy, the assumptions
  of @{text partial_order} are discharged automatically, and only the
  assumptions introduced in @{text lattice} remain as subgoals
  @{subgoals [display]}
  The proof for the first subgoal is obtained by constructing an
  infimum, whose existence is implied by totality.\<close>

    fix x y
    from total have "is_inf x y (if x \<sqsubseteq> y then x else y)"
      by (auto simp: is_inf_def)
    then show "\<exists>inf. is_inf x y inf" ..
txt \<open>\normalsize
   The proof for the second subgoal is analogous and not
  reproduced here.\<close>
  next %invisible
    fix x y
    from total have "is_sup x y (if x \<sqsubseteq> y then y else x)"
      by (auto simp: is_sup_def)
    then show "\<exists>sup. is_sup x y sup" .. qed %visible

text \<open>Similarly, we may establish that total orders are distributive
  lattices with a second \isakeyword{sublocale} statement.\<close>

  sublocale total_order \<subseteq> distrib_lattice
    proof unfold_locales
    fix %"proof" x y z
    show "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z" (is "?l = ?r")
      txt \<open>Jacobson I, p.\ 462\<close>
    proof -
      { assume c: "y \<sqsubseteq> x" "z \<sqsubseteq> x"
        from c have "?l = y \<squnion> z"
          by (metis c join_connection2 join_related2 meet_related2 total)
        also from c have "... = ?r" by (metis meet_related2)
        finally have "?l = ?r" . }
      moreover
      { assume c: "x \<sqsubseteq> y \<or> x \<sqsubseteq> z"
        from c have "?l = x"
          by (metis join_connection2 join_related2 meet_connection total trans)
        also from c have "... = ?r"
          by (metis join_commute join_related2 meet_connection meet_related2 total)
        finally have "?l = ?r" . }
      moreover note total
      ultimately show ?thesis by blast
    qed
  qed

text \<open>The locale hierarchy is now as shown in
  Figure~\ref{fig:lattices}(c).\<close>

text \<open>
  Locale interpretation is \emph{dynamic}.  The statement
  \isakeyword{sublocale} $l_1 \subseteq l_2$ will not just add the
  current conclusions of $l_2$ to $l_1$.  Rather the dependency is
  stored, and conclusions that will be
  added to $l_2$ in future are automatically propagated to $l_1$.
  The sublocale relation is transitive --- that is, propagation takes
  effect along chains of sublocales.  Even cycles in the sublocale relation are
  supported, as long as these cycles do not lead to infinite chains.
  Details are discussed in the technical report @{cite Ballarin2006a}.
  See also Section~\ref{sec:infinite-chains} of this tutorial.\<close>

end


(*  Title:      ZF/Trancl.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section{*Relations: Their General Properties and Transitive Closure*}

theory Trancl imports Fixedpt Perm begin

definition
  refl     :: "[i,i]=>o"  where
    "refl(A,r) == (\<forall>x\<in>A. <x,x> \<in> r)"

definition
  irrefl   :: "[i,i]=>o"  where
    "irrefl(A,r) == \<forall>x\<in>A. <x,x> \<notin> r"

definition
  sym      :: "i=>o"  where
    "sym(r) == \<forall>x y. <x,y>: r \<longrightarrow> <y,x>: r"

definition
  asym     :: "i=>o"  where
    "asym(r) == \<forall>x y. <x,y>:r \<longrightarrow> ~ <y,x>:r"

definition
  antisym  :: "i=>o"  where
    "antisym(r) == \<forall>x y.<x,y>:r \<longrightarrow> <y,x>:r \<longrightarrow> x=y"

definition
  trans    :: "i=>o"  where
    "trans(r) == \<forall>x y z. <x,y>: r \<longrightarrow> <y,z>: r \<longrightarrow> <x,z>: r"

definition
  trans_on :: "[i,i]=>o"  ("trans[_]'(_')")  where
    "trans[A](r) == \<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A.
                          <x,y>: r \<longrightarrow> <y,z>: r \<longrightarrow> <x,z>: r"

definition
  rtrancl :: "i=>i"  ("(_^*)" [100] 100)  (*refl/transitive closure*)  where
    "r^* == lfp(field(r)*field(r), %s. id(field(r)) \<union> (r O s))"

definition
  trancl  :: "i=>i"  ("(_^+)" [100] 100)  (*transitive closure*)  where
    "r^+ == r O r^*"

definition
  equiv    :: "[i,i]=>o"  where
    "equiv(A,r) == r \<subseteq> A*A & refl(A,r) & sym(r) & trans(r)"

subsection{*General properties of relations*}

subsubsection{*irreflexivity*}

lemma irreflI:
    "[| !!x. x \<in> A ==> <x,x> \<notin> r |] ==> irrefl(A,r)"
by (simp add: irrefl_def)

lemma irreflE: "[| irrefl(A,r);  x \<in> A |] ==>  <x,x> \<notin> r"
by (simp add: irrefl_def)

subsubsection{*symmetry*}

lemma symI:
     "[| !!x y.<x,y>: r ==> <y,x>: r |] ==> sym(r)"
by (unfold sym_def, blast)

lemma symE: "[| sym(r); <x,y>: r |]  ==>  <y,x>: r"
by (unfold sym_def, blast)

subsubsection{*antisymmetry*}

lemma antisymI:
     "[| !!x y.[| <x,y>: r;  <y,x>: r |] ==> x=y |] ==> antisym(r)"
by (simp add: antisym_def, blast)

lemma antisymE: "[| antisym(r); <x,y>: r;  <y,x>: r |]  ==>  x=y"
by (simp add: antisym_def, blast)

subsubsection{*transitivity*}

lemma transD: "[| trans(r);  <a,b>:r;  <b,c>:r |] ==> <a,c>:r"
by (unfold trans_def, blast)

lemma trans_onD:
    "[| trans[A](r);  <a,b>:r;  <b,c>:r;  a \<in> A;  b \<in> A;  c \<in> A |] ==> <a,c>:r"
by (unfold trans_on_def, blast)

lemma trans_imp_trans_on: "trans(r) ==> trans[A](r)"
by (unfold trans_def trans_on_def, blast)

lemma trans_on_imp_trans: "[|trans[A](r); r \<subseteq> A*A|] ==> trans(r)"
by (simp add: trans_on_def trans_def, blast)

subsection{*Transitive closure of a relation*}

lemma rtrancl_bnd_mono:
     "bnd_mono(field(r)*field(r), %s. id(field(r)) \<union> (r O s))"
by (rule bnd_monoI, blast+)

lemma rtrancl_mono: "r<=s ==> r^* \<subseteq> s^*"
apply (unfold rtrancl_def)
apply (rule lfp_mono)
apply (rule rtrancl_bnd_mono)+
apply blast
done

(* @{term"r^* = id(field(r)) \<union> ( r O r^* )"}    *)
lemmas rtrancl_unfold =
     rtrancl_bnd_mono [THEN rtrancl_def [THEN def_lfp_unfold]]

(** The relation rtrancl **)

(*  @{term"r^* \<subseteq> field(r) * field(r)"}  *)
lemmas rtrancl_type = rtrancl_def [THEN def_lfp_subset]

lemma relation_rtrancl: "relation(r^*)"
apply (simp add: relation_def)
apply (blast dest: rtrancl_type [THEN subsetD])
done

(*Reflexivity of rtrancl*)
lemma rtrancl_refl: "[| a \<in> field(r) |] ==> <a,a> \<in> r^*"
apply (rule rtrancl_unfold [THEN ssubst])
apply (erule idI [THEN UnI1])
done

(*Closure under composition with r  *)
lemma rtrancl_into_rtrancl: "[| <a,b> \<in> r^*;  <b,c> \<in> r |] ==> <a,c> \<in> r^*"
apply (rule rtrancl_unfold [THEN ssubst])
apply (rule compI [THEN UnI2], assumption, assumption)
done

(*rtrancl of r contains all pairs in r  *)
lemma r_into_rtrancl: "<a,b> \<in> r ==> <a,b> \<in> r^*"
by (rule rtrancl_refl [THEN rtrancl_into_rtrancl], blast+)

(*The premise ensures that r consists entirely of pairs*)
lemma r_subset_rtrancl: "relation(r) ==> r \<subseteq> r^*"
by (simp add: relation_def, blast intro: r_into_rtrancl)

lemma rtrancl_field: "field(r^*) = field(r)"
by (blast intro: r_into_rtrancl dest!: rtrancl_type [THEN subsetD])

(** standard induction rule **)

lemma rtrancl_full_induct [case_names initial step, consumes 1]:
  "[| <a,b> \<in> r^*;
      !!x. x \<in> field(r) ==> P(<x,x>);
      !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |]  ==>  P(<x,z>) |]
   ==>  P(<a,b>)"
by (erule def_induct [OF rtrancl_def rtrancl_bnd_mono], blast)

(*nice induction rule.
  Tried adding the typing hypotheses y,z \<in> field(r), but these
  caused expensive case splits!*)
lemma rtrancl_induct [case_names initial step, induct set: rtrancl]:
  "[| <a,b> \<in> r^*;
      P(a);
      !!y z.[| <a,y> \<in> r^*;  <y,z> \<in> r;  P(y) |] ==> P(z)
   |] ==> P(b)"
(*by induction on this formula*)
apply (subgoal_tac "\<forall>y. <a,b> = <a,y> \<longrightarrow> P (y) ")
(*now solve first subgoal: this formula is sufficient*)
apply (erule spec [THEN mp], rule refl)
(*now do the induction*)
apply (erule rtrancl_full_induct, blast+)
done

(*transitivity of transitive closure!! -- by induction.*)
lemma trans_rtrancl: "trans(r^*)"
apply (unfold trans_def)
apply (intro allI impI)
apply (erule_tac b = z in rtrancl_induct, assumption)
apply (blast intro: rtrancl_into_rtrancl)
done

lemmas rtrancl_trans = trans_rtrancl [THEN transD]

(*elimination of rtrancl -- by induction on a special formula*)
lemma rtranclE:
    "[| <a,b> \<in> r^*;  (a=b) ==> P;
        !!y.[| <a,y> \<in> r^*;   <y,b> \<in> r |] ==> P |]
     ==> P"
apply (subgoal_tac "a = b | (\<exists>y. <a,y> \<in> r^* & <y,b> \<in> r) ")
(*see HOL/trancl*)
apply blast
apply (erule rtrancl_induct, blast+)
done

(**** The relation trancl ****)

(*Transitivity of r^+ is proved by transitivity of r^*  *)
lemma trans_trancl: "trans(r^+)"
apply (unfold trans_def trancl_def)
apply (blast intro: rtrancl_into_rtrancl
                    trans_rtrancl [THEN transD, THEN compI])
done

lemmas trans_on_trancl = trans_trancl [THEN trans_imp_trans_on]

lemmas trancl_trans = trans_trancl [THEN transD]

(** Conversions between trancl and rtrancl **)

lemma trancl_into_rtrancl: "<a,b> \<in> r^+ ==> <a,b> \<in> r^*"
apply (unfold trancl_def)
apply (blast intro: rtrancl_into_rtrancl)
done

(*r^+ contains all pairs in r  *)
lemma r_into_trancl: "<a,b> \<in> r ==> <a,b> \<in> r^+"
apply (unfold trancl_def)
apply (blast intro!: rtrancl_refl)
done

(*The premise ensures that r consists entirely of pairs*)
lemma r_subset_trancl: "relation(r) ==> r \<subseteq> r^+"
by (simp add: relation_def, blast intro: r_into_trancl)

(*intro rule by definition: from r^* and r  *)
lemma rtrancl_into_trancl1: "[| <a,b> \<in> r^*;  <b,c> \<in> r |]   ==>  <a,c> \<in> r^+"
by (unfold trancl_def, blast)

(*intro rule from r and r^*  *)
lemma rtrancl_into_trancl2:
    "[| <a,b> \<in> r;  <b,c> \<in> r^* |]   ==>  <a,c> \<in> r^+"
apply (erule rtrancl_induct)
 apply (erule r_into_trancl)
apply (blast intro: r_into_trancl trancl_trans)
done

(*Nice induction rule for trancl*)
lemma trancl_induct [case_names initial step, induct set: trancl]:
  "[| <a,b> \<in> r^+;
      !!y.  [| <a,y> \<in> r |] ==> P(y);
      !!y z.[| <a,y> \<in> r^+;  <y,z> \<in> r;  P(y) |] ==> P(z)
   |] ==> P(b)"
apply (rule compEpair)
apply (unfold trancl_def, assumption)
(*by induction on this formula*)
apply (subgoal_tac "\<forall>z. <y,z> \<in> r \<longrightarrow> P (z) ")
(*now solve first subgoal: this formula is sufficient*)
 apply blast
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_into_trancl1)+
done

(*elimination of r^+ -- NOT an induction rule*)
lemma tranclE:
    "[| <a,b> \<in> r^+;
        <a,b> \<in> r ==> P;
        !!y.[| <a,y> \<in> r^+; <y,b> \<in> r |] ==> P
     |] ==> P"
apply (subgoal_tac "<a,b> \<in> r | (\<exists>y. <a,y> \<in> r^+ & <y,b> \<in> r) ")
apply blast
apply (rule compEpair)
apply (unfold trancl_def, assumption)
apply (erule rtranclE)
apply (blast intro: rtrancl_into_trancl1)+
done

lemma trancl_type: "r^+ \<subseteq> field(r)*field(r)"
apply (unfold trancl_def)
apply (blast elim: rtrancl_type [THEN subsetD, THEN SigmaE2])
done

lemma relation_trancl: "relation(r^+)"
apply (simp add: relation_def)
apply (blast dest: trancl_type [THEN subsetD])
done

lemma trancl_subset_times: "r \<subseteq> A * A ==> r^+ \<subseteq> A * A"
by (insert trancl_type [of r], blast)

lemma trancl_mono: "r<=s ==> r^+ \<subseteq> s^+"
by (unfold trancl_def, intro comp_mono rtrancl_mono)

lemma trancl_eq_r: "[|relation(r); trans(r)|] ==> r^+ = r"
apply (rule equalityI)
 prefer 2 apply (erule r_subset_trancl, clarify)
apply (frule trancl_type [THEN subsetD], clarify)
apply (erule trancl_induct, assumption)
apply (blast dest: transD)
done

(** Suggested by Sidi Ould Ehmety **)

lemma rtrancl_idemp [simp]: "(r^*)^* = r^*"
apply (rule equalityI, auto)
 prefer 2
 apply (frule rtrancl_type [THEN subsetD])
 apply (blast intro: r_into_rtrancl )
txt{*converse direction*}
apply (frule rtrancl_type [THEN subsetD], clarify)
apply (erule rtrancl_induct)
apply (simp add: rtrancl_refl rtrancl_field)
apply (blast intro: rtrancl_trans)
done

lemma rtrancl_subset: "[| R \<subseteq> S; S \<subseteq> R^* |] ==> S^* = R^*"
apply (drule rtrancl_mono)
apply (drule rtrancl_mono, simp_all, blast)
done

lemma rtrancl_Un_rtrancl:
     "[| relation(r); relation(s) |] ==> (r^* \<union> s^*)^* = (r \<union> s)^*"
apply (rule rtrancl_subset)
apply (blast dest: r_subset_rtrancl)
apply (blast intro: rtrancl_mono [THEN subsetD])
done

(*** "converse" laws by Sidi Ould Ehmety ***)

(** rtrancl **)

lemma rtrancl_converseD: "<x,y>:converse(r)^* ==> <x,y>:converse(r^*)"
apply (rule converseI)
apply (frule rtrancl_type [THEN subsetD])
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_refl)
apply (blast intro: r_into_rtrancl rtrancl_trans)
done

lemma rtrancl_converseI: "<x,y>:converse(r^*) ==> <x,y>:converse(r)^*"
apply (drule converseD)
apply (frule rtrancl_type [THEN subsetD])
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_refl)
apply (blast intro: r_into_rtrancl rtrancl_trans)
done

lemma rtrancl_converse: "converse(r)^* = converse(r^*)"
apply (safe intro!: equalityI)
apply (frule rtrancl_type [THEN subsetD])
apply (safe dest!: rtrancl_converseD intro!: rtrancl_converseI)
done

(** trancl **)

lemma trancl_converseD: "<a, b>:converse(r)^+ ==> <a, b>:converse(r^+)"
apply (erule trancl_induct)
apply (auto intro: r_into_trancl trancl_trans)
done

lemma trancl_converseI: "<x,y>:converse(r^+) ==> <x,y>:converse(r)^+"
apply (drule converseD)
apply (erule trancl_induct)
apply (auto intro: r_into_trancl trancl_trans)
done

lemma trancl_converse: "converse(r)^+ = converse(r^+)"
apply (safe intro!: equalityI)
apply (frule trancl_type [THEN subsetD])
apply (safe dest!: trancl_converseD intro!: trancl_converseI)
done

lemma converse_trancl_induct [case_names initial step, consumes 1]:
"[| <a, b>:r^+; !!y. <y, b> :r ==> P(y);
      !!y z. [| <y, z> \<in> r; <z, b> \<in> r^+; P(z) |] ==> P(y) |]
       ==> P(a)"
apply (drule converseI)
apply (simp (no_asm_use) add: trancl_converse [symmetric])
apply (erule trancl_induct)
apply (auto simp add: trancl_converse)
done

end