doc-src/IsarAdvanced/Codegen/Thy/examples/tree.ML
author haftmann
Tue, 05 Jun 2007 15:16:11 +0200
changeset 23250 9886802cbbd6
parent 23132 ae52b82dc5d8
child 23850 f1434532a562
permissions -rw-r--r--
updated documentation
haftmann@22490
     1
structure ROOT = 
haftmann@22490
     2
struct
haftmann@22490
     3
haftmann@23250
     4
structure HOL = 
haftmann@23250
     5
struct
haftmann@23250
     6
haftmann@23250
     7
type 'a eq = {eq : 'a -> 'a -> bool};
haftmann@23250
     8
fun eq (A_:'a eq) = #eq A_;
haftmann@23250
     9
haftmann@23250
    10
end; (*struct HOL*)
haftmann@23250
    11
haftmann@22490
    12
structure Orderings = 
haftmann@22490
    13
struct
haftmann@22490
    14
haftmann@22490
    15
type 'a ord = {less_eq : 'a -> 'a -> bool, less : 'a -> 'a -> bool};
haftmann@22490
    16
fun less_eq (A_:'a ord) = #less_eq A_;
haftmann@22490
    17
fun less (A_:'a ord) = #less A_;
haftmann@22490
    18
haftmann@23250
    19
type 'a order = {Orderings__order_ord : 'a ord};
haftmann@23250
    20
fun order_ord (A_:'a order) = #Orderings__order_ord A_;
haftmann@23250
    21
haftmann@23250
    22
type 'a linorder = {Orderings__linorder_order : 'a order};
haftmann@23250
    23
fun linorder_order (A_:'a linorder) = #Orderings__linorder_order A_;
haftmann@23250
    24
haftmann@22490
    25
end; (*struct Orderings*)
haftmann@22490
    26
haftmann@22490
    27
structure Nat = 
haftmann@22490
    28
struct
haftmann@22490
    29
haftmann@22490
    30
datatype nat = Zero_nat | Suc of nat;
haftmann@22490
    31
haftmann@23107
    32
fun eq_nat Zero_nat (Suc m) = false
haftmann@23107
    33
  | eq_nat (Suc n) Zero_nat = false
haftmann@23107
    34
  | eq_nat (Suc n) (Suc m) = eq_nat n m
haftmann@23107
    35
  | eq_nat Zero_nat Zero_nat = true;
haftmann@22490
    36
haftmann@23250
    37
val eq_nata = {eq = eq_nat} : nat HOL.eq;
haftmann@22490
    38
haftmann@22490
    39
fun less_nat n (Suc m) = less_eq_nat n m
haftmann@22490
    40
  | less_nat n Zero_nat = false
haftmann@22490
    41
and less_eq_nat (Suc n) m = less_nat n m
haftmann@22490
    42
  | less_eq_nat Zero_nat m = true;
haftmann@22490
    43
haftmann@22490
    44
val ord_nat = {less_eq = less_eq_nat, less = less_nat} :
haftmann@22490
    45
  nat Orderings.ord;
haftmann@22490
    46
haftmann@23250
    47
val order_nat = {Orderings__order_ord = ord_nat} : nat Orderings.order;
haftmann@23250
    48
haftmann@23250
    49
val linorder_nat = {Orderings__linorder_order = order_nat} :
haftmann@23250
    50
  nat Orderings.linorder;
haftmann@23250
    51
haftmann@22490
    52
end; (*struct Nat*)
haftmann@22490
    53
haftmann@22490
    54
structure Codegen = 
haftmann@22490
    55
struct
haftmann@22490
    56
haftmann@22490
    57
datatype ('a, 'b) searchtree = Leaf of 'a * 'b |
haftmann@22490
    58
  Branch of ('a, 'b) searchtree * 'a * ('a, 'b) searchtree;
haftmann@22490
    59
haftmann@22798
    60
fun update (C1_, C2_) (it, entry) (Branch (t1, key, t2)) =
haftmann@23250
    61
  (if Orderings.less_eq
haftmann@23250
    62
        ((Orderings.order_ord o Orderings.linorder_order) C2_) it key
haftmann@22798
    63
    then Branch (update (C1_, C2_) (it, entry) t1, key, t2)
haftmann@22798
    64
    else Branch (t1, key, update (C1_, C2_) (it, entry) t2))
haftmann@22798
    65
  | update (C1_, C2_) (it, entry) (Leaf (key, vala)) =
haftmann@23250
    66
    (if HOL.eq C1_ it key then Leaf (key, entry)
haftmann@23250
    67
      else (if Orderings.less_eq
haftmann@23250
    68
                 ((Orderings.order_ord o Orderings.linorder_order) C2_) it
haftmann@23250
    69
                 key
haftmann@22490
    70
             then Branch (Leaf (it, entry), it, Leaf (key, vala))
haftmann@22490
    71
             else Branch (Leaf (key, vala), it, Leaf (it, entry))));
haftmann@22490
    72
haftmann@23132
    73
val example : (Nat.nat, (Nat.nat list)) searchtree =
haftmann@23250
    74
  update (Nat.eq_nata, Nat.linorder_nat)
haftmann@23132
    75
    (Nat.Suc (Nat.Suc (Nat.Suc (Nat.Suc Nat.Zero_nat))),
haftmann@23132
    76
      [Nat.Suc (Nat.Suc Nat.Zero_nat), Nat.Suc (Nat.Suc Nat.Zero_nat)])
haftmann@23250
    77
    (update (Nat.eq_nata, Nat.linorder_nat)
haftmann@23132
    78
      (Nat.Suc (Nat.Suc (Nat.Suc Nat.Zero_nat)),
haftmann@23132
    79
        [Nat.Suc (Nat.Suc (Nat.Suc Nat.Zero_nat))])
haftmann@23250
    80
      (update (Nat.eq_nata, Nat.linorder_nat)
haftmann@23132
    81
        (Nat.Suc (Nat.Suc Nat.Zero_nat), [Nat.Suc (Nat.Suc Nat.Zero_nat)])
haftmann@23132
    82
        (Leaf (Nat.Suc Nat.Zero_nat, []))));
haftmann@22490
    83
haftmann@22490
    84
end; (*struct Codegen*)
haftmann@22490
    85
haftmann@22490
    86
end; (*struct ROOT*)