1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(* $Id$ *)
open Util
open Names
open Nameops
open Term
open Pattern
open Rawterm
open Libnames
open Nametab
(* Discrimination nets of terms.
See the module dn.ml for further explanations.
Eduardo (5/8/97) *)
module Make =
functor (Z : Map.OrderedType) ->
struct
module X = struct
type t = constr_pattern
let compare = Pervasives.compare
end
type term_label =
| GRLabel of global_reference
| ProdLabel
| LambdaLabel
| SortLabel of sorts option
module Y = struct
type t = term_label
let compare x y =
let make_name n =
match n with
| GRLabel(ConstRef con) ->
GRLabel(ConstRef(constant_of_kn(canonical_con con)))
| GRLabel(IndRef (kn,i)) ->
GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
| GRLabel(ConstructRef ((kn,i),j ))->
GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
| k -> k
in
Pervasives.compare (make_name x) (make_name y)
end
module Dn = Dn.Make(X)(Y)(Z)
type t = Dn.t
type 'a lookup_res = 'a Dn.lookup_res
(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
let decomp =
let rec decrec acc c = match kind_of_term c with
| App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
| Cast (c1,_,_) -> decrec acc c1
| _ -> (c,acc)
in
decrec []
let decomp_pat =
let rec decrec acc = function
| PApp (f,args) -> decrec (Array.to_list args @ acc) f
| c -> (c,acc)
in
decrec []
let constr_pat_discr t =
if not (occur_meta_pattern t) then
None
else
match decomp_pat t with
| PRef ((IndRef _) as ref), args
| PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
| PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
| _ -> None
let constr_pat_discr_st (idpred,cpred) t =
match decomp_pat t with
| PRef ((IndRef _) as ref), args
| PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
| PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) ->
Some(GRLabel ref,args)
| PVar v, args when not (Idpred.mem v idpred) ->
Some(GRLabel (VarRef v),args)
| PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
Some (GRLabel ref, args)
| PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
| PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l)
| PSort s, [] ->
let s' = match s with
| RProp c -> Some (Prop c)
| RType _ -> None
(* Don't try to be clever about type levels here *)
in Some (SortLabel s', [])
| _ -> None
open Dn
let constr_val_discr t =
let c, l = decomp t in
match kind_of_term c with
| Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
| Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
| Var id -> Label(GRLabel (VarRef id),l)
| Const _ -> Everything
| _ -> Nothing
let constr_val_discr_st (idpred,cpred) t =
let c, l = decomp t in
match kind_of_term c with
| Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
| Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
| Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
| Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l)
| Prod (n, d, c) -> Label(ProdLabel, [d; c])
| Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
| Sort s when is_small s -> Label(SortLabel (Some s), [])
| Sort _ -> Label (SortLabel None, [])
| Evar _ -> Everything
| _ -> Nothing
let create = Dn.create
let add dn st = Dn.add dn (constr_pat_discr_st st)
let rmv dn st = Dn.rmv dn (constr_pat_discr_st st)
let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t
let app f dn = Dn.app f dn
end
|
