doc-src/IsarAdvanced/Codegen/Thy/examples/pick1.ML
author urbanc
Fri, 17 Nov 2006 17:32:30 +0100
changeset 21405 26b51f724fe6
parent 21190 08ec81dfc7fb
child 21993 4b802a9e0738
permissions -rw-r--r--
added an intro lemma for freshness of products; set up the simplifier so that it can deal with the compact and long notation for freshness constraints (FIXME: it should also be able to deal with the special case of freshness of atoms)
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
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
     9
fun less_nat Zero_nat (Suc n) = true
21172
eea3c9048c7a updated;
wenzelm
parents: 21147
diff changeset
    10
  | less_nat n Zero_nat = false
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
    11
  | less_nat (Suc m) (Suc n) = less_nat m n;
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    12
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
    13
fun minus_nat (Suc m) (Suc n) = minus_nat m n
21172
eea3c9048c7a updated;
wenzelm
parents: 21147
diff changeset
    14
  | minus_nat Zero_nat n = Zero_nat
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    15
  | minus_nat y Zero_nat = y;
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    16
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
    17
end; (*struct Nat*)
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    18
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    19
structure Codegen = 
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    20
struct
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    21
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    22
fun pick ((k, v) :: xs) n =
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
    23
  (if Nat.less_nat n k then v else pick xs (Nat.minus_nat n k))
21172
eea3c9048c7a updated;
wenzelm
parents: 21147
diff changeset
    24
  | pick (x :: xs) n =
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    25
    let
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    26
      val (ka, va) = x;
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    27
    in
21190
08ec81dfc7fb (continued)
haftmann
parents: 21172
diff changeset
    28
      (if Nat.less_nat n ka then va else pick xs (Nat.minus_nat n ka))
21147
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    29
    end;
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    30
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    31
end; (*struct Codegen*)
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    32
737a94f047e3 continued tutorial
haftmann
parents:
diff changeset
    33
end; (*struct ROOT*)