doc-src/IsarAdvanced/Codegen/Thy/examples/tree.ML
author krauss
Thu, 17 May 2007 22:33:41 +0200
changeset 22999 c1ce129e6f9c
parent 22798 e3962371f568
child 23107 0c3c55b7c98f
permissions -rw-r--r--
Added unification case study (using new function package)
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
22490
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     1
structure ROOT = 
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     2
struct
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     3
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     4
structure Orderings = 
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     5
struct
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     6
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     7
type 'a ord = {less_eq : 'a -> 'a -> bool, less : 'a -> 'a -> bool};
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     8
fun less_eq (A_:'a ord) = #less_eq A_;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
     9
fun less (A_:'a ord) = #less A_;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    10
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    11
end; (*struct Orderings*)
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    12
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    13
structure Code_Generator = 
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    14
struct
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    15
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    16
type 'a eq = {op_eq : 'a -> 'a -> bool};
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    17
fun op_eq (A_:'a eq) = #op_eq A_;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    18
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    19
end; (*struct Code_Generator*)
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    20
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    21
structure Nat = 
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    22
struct
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    23
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    24
datatype nat = Zero_nat | Suc of nat;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    25
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    26
fun op_eq_nat Zero_nat (Suc m) = false
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    27
  | op_eq_nat (Suc n) Zero_nat = false
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    28
  | op_eq_nat (Suc n) (Suc m) = op_eq_nat n m
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    29
  | op_eq_nat Zero_nat Zero_nat = true;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    30
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    31
val eq_nat = {op_eq = op_eq_nat} : nat Code_Generator.eq;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    32
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    33
fun less_nat n (Suc m) = less_eq_nat n m
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    34
  | less_nat n Zero_nat = false
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    35
and less_eq_nat (Suc n) m = less_nat n m
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    36
  | less_eq_nat Zero_nat m = true;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    37
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    38
val ord_nat = {less_eq = less_eq_nat, less = less_nat} :
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    39
  nat Orderings.ord;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    40
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    41
end; (*struct Nat*)
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    42
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    43
structure List = 
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    44
struct
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    45
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    46
datatype nibble = Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 |
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    47
  Nibble5 | Nibble6 | Nibble7 | Nibble8 | Nibble9 | NibbleA | NibbleB |
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    48
  NibbleC | NibbleD | NibbleE | NibbleF;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    49
22798
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    50
datatype char = Char of nibble * nibble;
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    51
22490
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    52
end; (*struct List*)
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    53
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    54
structure Codegen = 
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    55
struct
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    56
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    57
datatype ('a, 'b) searchtree = Leaf of 'a * 'b |
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    58
  Branch of ('a, 'b) searchtree * 'a * ('a, 'b) searchtree;
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    59
22798
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    60
fun update (C1_, C2_) (it, entry) (Branch (t1, key, t2)) =
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    61
  (if Orderings.less_eq C2_ it key
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    62
    then Branch (update (C1_, C2_) (it, entry) t1, key, t2)
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    63
    else Branch (t1, key, update (C1_, C2_) (it, entry) t2))
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    64
  | update (C1_, C2_) (it, entry) (Leaf (key, vala)) =
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    65
    (if Code_Generator.op_eq C1_ it key then Leaf (key, entry)
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    66
      else (if Orderings.less_eq C2_ it key
22490
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    67
             then Branch (Leaf (it, entry), it, Leaf (key, vala))
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    68
             else Branch (Leaf (key, vala), it, Leaf (it, entry))));
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    69
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    70
fun example n =
22798
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    71
  update (Nat.eq_nat, Nat.ord_nat)
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    72
    (n, [List.Char (List.Nibble6, List.Nibble2),
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    73
          List.Char (List.Nibble6, List.Nibble1),
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    74
          List.Char (List.Nibble7, List.Nibble2)])
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    75
    (Leaf
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    76
      (Nat.Zero_nat,
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    77
        [List.Char (List.Nibble6, List.Nibble6),
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    78
          List.Char (List.Nibble6, List.NibbleF),
e3962371f568 updated doc
haftmann
parents: 22490
diff changeset
    79
          List.Char (List.Nibble6, List.NibbleF)]));
22490
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    80
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    81
end; (*struct Codegen*)
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    82
1822ec4fcecd added example file
haftmann
parents:
diff changeset
    83
end; (*struct ROOT*)