doc-src/IsarAdvanced/Codegen/Thy/examples/pick1.ML
author wenzelm
Thu, 10 May 2007 00:39:56 +0200
changeset 22910 54d231cbc19a
parent 22751 1bfd75c1f232
child 23850 f1434532a562
permissions -rw-r--r--
moved conversions to structure Conv; get_axiom_i;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     1
structure ROOT = 
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     2
struct
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     3
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
     4
structure Nat = 
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     5
struct
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     6
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
     7
datatype nat = Zero_nat | Suc of nat;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
     8
22386
4ebe883b02ff new code theorems
haftmann
parents: 21994
diff changeset
     9
fun less_nat n (Suc m) = less_eq_nat n m
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    10
  | less_nat n Zero_nat = false
22386
4ebe883b02ff new code theorems
haftmann
parents: 21994
diff changeset
    11
and less_eq_nat (Suc n) m = less_nat n m
4ebe883b02ff new code theorems
haftmann
parents: 21994
diff changeset
    12
  | less_eq_nat Zero_nat m = true;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    13
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    14
fun minus_nat (Suc m) (Suc n) = minus_nat m n
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    15
  | minus_nat Zero_nat n = Zero_nat
22751
1bfd75c1f232 updated
haftmann
parents: 22386
diff changeset
    16
  | minus_nat m Zero_nat = m;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    17
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
    18
end; (*struct Nat*)
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    19
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    20
structure Codegen = 
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    21
struct
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    22
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    23
fun pick ((k, v) :: xs) n =
21994
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    24
  (if Nat.less_nat n k then v else pick xs (Nat.minus_nat n k))
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    25
  | pick (x :: xs) n =
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    26
    let
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    27
      val (k, v) = x;
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    28
    in
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    29
      (if Nat.less_nat n k then v else pick xs (Nat.minus_nat n k))
dfa5133dbe73 updated manual
haftmann
parents: 21993
diff changeset
    30
    end;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    31
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    32
end; (*struct Codegen*)
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    33
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    34
end; (*struct ROOT*)