doc-src/Codegen/Thy/examples/pick1.ML
author haftmann
Tue, 03 Mar 2009 11:00:51 +0100
changeset 30226 2f4684e2ea95
parent 26513 doc-src/IsarAdvanced/Codegen/Thy/examples/pick1.ML@6f306c8c2c54
permissions -rw-r--r--
more canonical directory structure of manuals
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
24193
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     1
structure HOL = 
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     2
struct
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     3
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     4
fun leta s f = f s;
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     5
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     6
end; (*struct HOL*)
926dde4d96de updated
haftmann
parents: 23850
diff changeset
     7
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
     8
structure Nat = 
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     9
struct
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    10
24421
acfb2413faa3 updated
haftmann
parents: 24193
diff changeset
    11
datatype nat = Suc of nat | Zero_nat;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    12
26318
967323f93c67 updated generated files;
wenzelm
parents: 25056
diff changeset
    13
fun less_nat m (Suc n) = less_eq_nat m n
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    14
  | less_nat n Zero_nat = false
26318
967323f93c67 updated generated files;
wenzelm
parents: 25056
diff changeset
    15
and less_eq_nat (Suc m) n = less_nat m n
967323f93c67 updated generated files;
wenzelm
parents: 25056
diff changeset
    16
  | less_eq_nat Zero_nat n = true;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    17
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    18
fun minus_nat (Suc m) (Suc n) = minus_nat m n
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    19
  | minus_nat Zero_nat n = Zero_nat
22751
1bfd75c1f232 updated
haftmann
parents: 22386
diff changeset
    20
  | minus_nat m Zero_nat = m;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    21
25056
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    22
end; (*struct Nat*)
24193
926dde4d96de updated
haftmann
parents: 23850
diff changeset
    23
25056
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    24
structure Product_Type = 
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    25
struct
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    26
26513
6f306c8c2c54 explicit class "eq" for operational equality
haftmann
parents: 26318
diff changeset
    27
fun split f (a, b) = f a b;
25056
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    28
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    29
end; (*struct Product_Type*)
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    30
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    31
structure Codegen = 
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    32
struct
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    33
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    34
fun pick ((k, v) :: xs) n =
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    35
  (if Nat.less_nat n k then v else pick xs (Nat.minus_nat n k))
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    36
  | pick (x :: xs) n =
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    37
    let
25056
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    38
      val a = x;
743f3603ba8b updated;
wenzelm
parents: 24421
diff changeset
    39
      val (k, v) = a;
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    40
    in
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    41
      (if Nat.less_nat n k then v else pick xs (Nat.minus_nat n k))
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    42
    end;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    43
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    44
end; (*struct Codegen*)