doc-src/IsarAdvanced/Classes/Thy/code_examples/classes.ML
author haftmann
Fri, 24 Aug 2007 14:14:17 +0200
changeset 24421 acfb2413faa3
parent 23956 48494ccfabaf
child 24628 33137422d7fd
permissions -rw-r--r--
updated
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
     1
structure Classes = 
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
     2
struct
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
     3
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
     4
datatype nat = Zero_nat | Suc of nat;
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
     5
22813
882513df2472 updated;
wenzelm
parents: 22479
diff changeset
     6
datatype bit = B0 | B1;
882513df2472 updated;
wenzelm
parents: 22479
diff changeset
     7
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
     8
fun nat_aux i n =
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
     9
  (if IntInf.<= (i, (0 : IntInf.int)) then n
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    10
    else nat_aux (IntInf.- (i, (1 : IntInf.int))) (Suc n));
22813
882513df2472 updated;
wenzelm
parents: 22479
diff changeset
    11
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    12
fun nat i = nat_aux i Zero_nat;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    13
22479
de15ea8fb348 updated code generation sections
haftmann
parents: 22317
diff changeset
    14
type 'a semigroup = {mult : 'a -> 'a -> 'a};
de15ea8fb348 updated code generation sections
haftmann
parents: 22317
diff changeset
    15
fun mult (A_:'a semigroup) = #mult A_;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    16
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    17
type 'a monoidl =
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    18
  {Classes__semigroup_monoidl : 'a semigroup, neutral : 'a};
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    19
fun semigroup_monoidl (A_:'a monoidl) = #Classes__semigroup_monoidl A_;
22479
de15ea8fb348 updated code generation sections
haftmann
parents: 22317
diff changeset
    20
fun neutral (A_:'a monoidl) = #neutral A_;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    21
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    22
type 'a group = {Classes__monoidl_group : 'a monoidl, inverse : 'a -> 'a};
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    23
fun monoidl_group (A_:'a group) = #Classes__monoidl_group A_;
22479
de15ea8fb348 updated code generation sections
haftmann
parents: 22317
diff changeset
    24
fun inverse (A_:'a group) = #inverse A_;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    25
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    26
fun inverse_int i = IntInf.~ i;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    27
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    28
val neutral_int : IntInf.int = (0 : IntInf.int);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    29
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    30
fun mult_int i j = IntInf.+ (i, j);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    31
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    32
val semigroup_int = {mult = mult_int} : IntInf.int semigroup;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    33
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    34
val monoidl_int =
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    35
  {Classes__semigroup_monoidl = semigroup_int, neutral = neutral_int} :
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    36
  IntInf.int monoidl;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    37
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    38
val group_int =
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    39
  {Classes__monoidl_group = monoidl_int, inverse = inverse_int} :
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    40
  IntInf.int group;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    41
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    42
fun pow_nat B_ (Suc n) x =
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    43
  mult ((semigroup_monoidl o monoidl_group) B_) x (pow_nat B_ n x)
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    44
  | pow_nat B_ Zero_nat x = neutral (monoidl_group B_);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    45
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    46
fun pow_int A_ k x =
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    47
  (if IntInf.<= ((0 : IntInf.int), k) then pow_nat A_ (nat k) x
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    48
    else inverse A_ (pow_nat A_ (nat (IntInf.~ k)) x));
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    49
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    50
val example : IntInf.int =
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    51
  pow_int group_int (10 : IntInf.int) (~2 : IntInf.int);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    52
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    53
end; (*struct Classes*)