doc-src/IsarAdvanced/Classes/Thy/code_examples/classes.ML
author wenzelm
Sat, 10 Nov 2007 14:31:18 +0100
changeset 25369 5200374fda5d
parent 24991 c6f5cc939c29
child 26318 967323f93c67
permissions -rw-r--r--
replaced @{const} (allows name only) by proper @{term};
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
24628
33137422d7fd updated
haftmann
parents: 23956
diff changeset
     4
datatype nat = Suc of nat | Zero_nat;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
     5
24628
33137422d7fd updated
haftmann
parents: 23956
diff changeset
     6
datatype bit = B1 | B0;
22813
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
24991
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    22
type 'a monoid = {Classes__monoidl_monoid : 'a monoidl};
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    23
fun monoidl_monoid (A_:'a monoid) = #Classes__monoidl_monoid A_;
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    24
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    25
type 'a group = {Classes__monoid_group : 'a monoid, inverse : 'a -> 'a};
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    26
fun monoid_group (A_:'a group) = #Classes__monoid_group A_;
22479
de15ea8fb348 updated code generation sections
haftmann
parents: 22317
diff changeset
    27
fun inverse (A_:'a group) = #inverse A_;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    28
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    29
fun inverse_int i = IntInf.~ i;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    30
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    31
val neutral_int : IntInf.int = (0 : IntInf.int);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    32
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    33
fun mult_int i j = IntInf.+ (i, j);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    34
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    35
val semigroup_int = {mult = mult_int} : IntInf.int semigroup;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    36
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    37
val monoidl_int =
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    38
  {Classes__semigroup_monoidl = semigroup_int, neutral = neutral_int} :
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    39
  IntInf.int monoidl;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    40
24991
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    41
val monoid_int = {Classes__monoidl_monoid = monoidl_int} :
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    42
  IntInf.int monoid;
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    43
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    44
val group_int =
24991
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    45
  {Classes__monoid_group = monoid_int, inverse = inverse_int} :
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    46
  IntInf.int group;
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    47
24991
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    48
fun pow_nat A_ (Suc n) x =
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    49
  mult ((semigroup_monoidl o monoidl_monoid) A_) x (pow_nat A_ n x)
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    50
  | pow_nat A_ Zero_nat x = neutral (monoidl_monoid A_);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    51
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    52
fun pow_int A_ k x =
24991
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    53
  (if IntInf.<= ((0 : IntInf.int), k)
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    54
    then pow_nat (monoid_group A_) (nat k) x
c6f5cc939c29 added subclass command
haftmann
parents: 24628
diff changeset
    55
    else inverse A_ (pow_nat (monoid_group A_) (nat (IntInf.~ k)) x));
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    56
23956
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    57
val example : IntInf.int =
48494ccfabaf updated
haftmann
parents: 22813
diff changeset
    58
  pow_int group_int (10 : IntInf.int) (~2 : IntInf.int);
22317
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    59
b550d2c6ca90 continued class tutorial
haftmann
parents:
diff changeset
    60
end; (*struct Classes*)