neuper@37906
|
1 |
(* the problems and methods as stored in hierarchies
|
e0726734@41962
|
2 |
author Walther Neuper 1998, Mathias Lehnfeld
|
neuper@37906
|
3 |
(c) due to copyright terms
|
neuper@37906
|
4 |
*)
|
neuper@37906
|
5 |
|
wneuper@59269
|
6 |
signature MODEL_SPECIFY =
|
wneuper@59269
|
7 |
sig
|
wneuper@59270
|
8 |
type field
|
wneuper@59270
|
9 |
(* for calchead.sml, if below at left margin *)
|
wneuper@59316
|
10 |
val prep_ori : Selem.fmz_ -> theory -> field list -> Model.ori list * Proof.context
|
wneuper@59269
|
11 |
val add_id : 'a list -> (int * 'a) list
|
wneuper@59316
|
12 |
val add_field' : theory -> field list -> Model.ori list -> Model.ori list
|
wneuper@59316
|
13 |
val match_itms_oris : theory -> Model.itm list -> field list * term list * rls ->
|
wneuper@59316
|
14 |
Model.ori list -> bool * (Model.itm list * (bool * term) list)
|
wneuper@59316
|
15 |
val refine_ori : Model.ori list -> pblID -> pblID option
|
wneuper@59316
|
16 |
val refine_ori' : Model.ori list -> pblID -> pblID
|
wneuper@59316
|
17 |
val refine_pbl : theory -> pblID -> Model.itm list -> (pblID * (Model.itm list * (bool * term) list)) option
|
wneuper@59270
|
18 |
|
wneuper@59316
|
19 |
val appc : ('a list -> 'b list) -> 'a Model.ppc -> 'b Model.ppc
|
wneuper@59316
|
20 |
val mappc : ('a -> 'b) -> 'a Model.ppc -> 'b Model.ppc
|
wneuper@59316
|
21 |
val itms2itemppc : theory -> Model.itm list -> (bool * term) list -> Model.item Model.ppc (* for generate.sml *)
|
wneuper@59270
|
22 |
|
wneuper@59270
|
23 |
val get_pbt : pblID -> pbt
|
wneuper@59270
|
24 |
val get_met : metID -> met (* for generate.sml *)
|
wneuper@59270
|
25 |
val get_met' : theory -> metID -> met (* for pbl-met-hierarchy.sml *)
|
wneuper@59270
|
26 |
val get_the : theID -> thydata (* for inform.sml *)
|
wneuper@59270
|
27 |
|
wneuper@59270
|
28 |
type pblRD = string list (* for pbl-met-hierarchy.sml *)
|
wneuper@59270
|
29 |
val format_pblIDl : string list list -> string (* for thy-hierarchy.sml *)
|
wneuper@59270
|
30 |
val scan : string list -> 'a ptyp list -> string list list (* for thy-hierarchy.sml *)
|
wneuper@59316
|
31 |
val itm_out : theory -> Model.itm_ -> string
|
wneuper@59270
|
32 |
val dsc_unknown : term
|
wneuper@59270
|
33 |
|
wneuper@59270
|
34 |
val pblID2guh : pblID -> guh (* for datatypes.sml *)
|
wneuper@59270
|
35 |
val metID2guh : metID -> guh (* for datatypes.sml *)
|
wneuper@59270
|
36 |
val kestoreID2guh : ketype -> kestoreID -> guh (* for datatypes.sml *)
|
wneuper@59270
|
37 |
val guh2kestoreID : guh -> string list (* for interface.sml *)
|
wneuper@59270
|
38 |
(* for Knowledge/, if below at left margin *)
|
wneuper@59269
|
39 |
val prep_pbt : theory -> guh -> string list -> pblID ->
|
wneuper@59269
|
40 |
string list * (string * string list) list * rls * string option * metID list -> pbt * pblID
|
wneuper@59269
|
41 |
val prep_met : theory -> string -> string list -> pblID ->
|
wneuper@59269
|
42 |
string list * (string * string list) list *
|
wneuper@59269
|
43 |
{calc: 'a, crls: rls, errpats: errpat list, nrls: rls, prls: rls, rew_ord': rew_ord', rls': rls, srls: rls}
|
wneuper@59269
|
44 |
* string -> met * metID
|
wneuper@59310
|
45 |
(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
|
wneuper@59269
|
46 |
val show_ptyps : unit -> unit
|
wneuper@59269
|
47 |
val show_mets : unit -> unit
|
wneuper@59316
|
48 |
datatype match' = Matches' of Model.item Model.ppc | NoMatch' of Model.item Model.ppc
|
wneuper@59311
|
49 |
val match_pbl : Selem.fmz_ -> pbt -> match'
|
wneuper@59308
|
50 |
val refine : Selem.fmz_ -> pblID -> Stool.match list
|
wneuper@59269
|
51 |
val e_errpat : errpat
|
wneuper@59269
|
52 |
val show_pblguhs : unit -> unit
|
wneuper@59269
|
53 |
val sort_pblguhs : unit -> unit
|
wneuper@59311
|
54 |
(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
|
wneuper@59299
|
55 |
( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
|
wneuper@59310
|
56 |
|
wneuper@59310
|
57 |
(*----- unused code, kept as hints to design ideas ---------------------------------------------*)
|
wneuper@59311
|
58 |
val e_fillpat : string * term * string
|
wneuper@59311
|
59 |
val coll_vats : ''a list * ('b * ''a list * 'c * 'd * 'e) -> ''a list
|
wneuper@59316
|
60 |
val filter_vat : Model.ori list -> int -> Model.ori list
|
wneuper@59311
|
61 |
val show_metguhs : unit -> unit
|
wneuper@59311
|
62 |
val sort_metguhs : unit -> unit
|
wneuper@59269
|
63 |
end
|
neuper@37906
|
64 |
|
wneuper@59311
|
65 |
structure Specify(**) : MODEL_SPECIFY(**) =
|
wneuper@59269
|
66 |
struct
|
wneuper@59316
|
67 |
open Model
|
neuper@37906
|
68 |
|
wneuper@59270
|
69 |
type field = string * (term * term)
|
wneuper@59389
|
70 |
val dsc_unknown = (Thm.term_of o the o (TermC.parseold @{theory Script})) "unknown::'a => unknow";
|
neuper@37906
|
71 |
|
wneuper@59316
|
72 |
fun itm_2item (_: theory) (Model.Cor ((d, ts), _)) = Model.Correct (term2str (Model.comp_dts (d, ts)))
|
wneuper@59316
|
73 |
| itm_2item _ (Model.Syn c) = Model.SyntaxE c
|
wneuper@59316
|
74 |
| itm_2item _ (Model.Typ c) = Model.TypeE c
|
wneuper@59316
|
75 |
| itm_2item _ (Model.Inc ((d, ts), _)) = Model.Incompl (term2str (Model.comp_dts (d, ts)))
|
wneuper@59316
|
76 |
| itm_2item _ (Model.Sup (d, ts)) = Model.Superfl (term2str (Model.comp_dts (d, ts)))
|
wneuper@59316
|
77 |
| itm_2item _ (Model.Mis (d, pid)) = Model.Missing (term2str d ^ " " ^ term2str pid)
|
wneuper@59269
|
78 |
| itm_2item _ _ = error "itm_2item: uncovered definition"
|
neuper@37906
|
79 |
|
wneuper@59308
|
80 |
fun mappc f {Given = gi, Where = wh, Find = fi, With = wi, Relate = re} =
|
wneuper@59308
|
81 |
{Given= map f gi, Where = map f wh, Find = map f fi, With = map f wi, Relate = map f re}
|
wneuper@59308
|
82 |
fun appc f {Given = gi, Where = wh, Find = fi, With = wi, Relate = re} =
|
wneuper@59308
|
83 |
{Given = f gi, Where = f wh, Find = f fi, With = f wi, Relate = f re}
|
neuper@37906
|
84 |
|
wneuper@59308
|
85 |
fun add_sel_ppc (_: theory) sel {Given = gi, Where = wh, Find = fi, With = wi, Relate = re} x =
|
neuper@37906
|
86 |
case sel of
|
wneuper@59308
|
87 |
"#Given" => {Given = gi @ [x], Where = wh, Find = fi, With = wi,Relate = re}
|
wneuper@59308
|
88 |
| "#Where" => {Given = gi, Where = wh @ [x], Find = fi, With = wi, Relate = re}
|
wneuper@59308
|
89 |
| "#Find" => {Given = gi, Where = wh, Find = fi @ [x], With = wi, Relate = re}
|
wneuper@59308
|
90 |
| "#Relate"=> {Given = gi, Where = wh, Find = fi, With = wi, Relate = re @ [x]}
|
wneuper@59308
|
91 |
| "#undef" => {Given = gi @ [x], Where = wh, Find = fi, With = wi, Relate = re} (*ori2itmSup*)
|
wneuper@59269
|
92 |
| _ => error ("add_sel_ppc tried to select by \"" ^ sel ^ "\"")
|
wneuper@59308
|
93 |
fun add_where {Given = gi, Where = _, Find = fi, With = wi, Relate = re} wh =
|
wneuper@59308
|
94 |
{Given = gi, Where = wh, Find= fi ,With = wi, Relate = re}
|
neuper@37906
|
95 |
|
wneuper@59269
|
96 |
(* split a term into description and (id | structured variable) for pbt, met.ppc *)
|
neuper@37906
|
97 |
fun split_did t =
|
wneuper@59270
|
98 |
let
|
wneuper@59311
|
99 |
val (hd, arg) = case strip_comb t of
|
wneuper@59311
|
100 |
(hd, [arg]) => (hd, arg)
|
wneuper@59270
|
101 |
| _ => error ("split_did: doesn't match (hd,[arg]) for t = " ^ term2str t)
|
wneuper@59270
|
102 |
in (hd, arg) end
|
neuper@37906
|
103 |
|
neuper@37906
|
104 |
(*create output-string for itm_*)
|
wneuper@59316
|
105 |
fun itm_out _ (Model.Cor ((d, ts), _)) = term2str (Model.comp_dts (d, ts))
|
wneuper@59316
|
106 |
| itm_out _ (Model.Syn c) = c
|
wneuper@59316
|
107 |
| itm_out _ (Model.Typ c) = c
|
wneuper@59316
|
108 |
| itm_out _ (Model.Inc ((d, ts), _)) = term2str (Model.comp_dts (d, ts))
|
wneuper@59316
|
109 |
| itm_out _ (Model.Sup (d, ts)) = term2str (Model.comp_dts (d, ts))
|
wneuper@59316
|
110 |
| itm_out _ (Model.Mis (d, pid)) = term2str d ^ " " ^ term2str pid
|
wneuper@59269
|
111 |
| itm_out _ _ = error "itm_out: uncovered definition"
|
neuper@37906
|
112 |
|
wneuper@59316
|
113 |
fun boolterm2item (true, term) = Model.Correct (term2str term)
|
wneuper@59316
|
114 |
| boolterm2item (false, term) = Model.False (term2str term);
|
neuper@37906
|
115 |
|
wneuper@59308
|
116 |
fun itms2itemppc thy itms pre =
|
neuper@37906
|
117 |
let
|
neuper@37906
|
118 |
fun coll ppc [] = ppc
|
wneuper@59269
|
119 |
| coll ppc ((_,_,_,field,itm_)::itms) =
|
wneuper@59269
|
120 |
coll (add_sel_ppc thy field ppc (itm_2item thy itm_)) itms;
|
wneuper@59316
|
121 |
val gfr = coll Model.empty_ppc itms;
|
neuper@37906
|
122 |
in add_where gfr (map boolterm2item pre) end;
|
neuper@37906
|
123 |
|
wneuper@59269
|
124 |
(* compare d and dsc in pbt and transfer field to pre-ori *)
|
wneuper@59269
|
125 |
fun add_field (_: theory) pbt (d,ts) =
|
neuper@37906
|
126 |
let fun eq d pt = (d = (fst o snd) pt);
|
neuper@37906
|
127 |
in case filter (eq d) pbt of
|
wneuper@59269
|
128 |
[(fi, (_, _))] => (fi, d, ts)
|
wneuper@59269
|
129 |
| [] => ("#undef", d, ts) (*may come with met.ppc*)
|
neuper@38053
|
130 |
| _ => error ("add_field: " ^ term2str d ^ " more than once in pbt")
|
neuper@37906
|
131 |
end;
|
neuper@37906
|
132 |
|
wneuper@59269
|
133 |
(* take over field from met.ppc at 'Specify_Method' into ori,
|
wneuper@59269
|
134 |
i.e. also removes "#undef" fields *)
|
wneuper@59308
|
135 |
fun add_field' (_: theory) mpc ori =
|
neuper@37906
|
136 |
let fun eq d pt = (d = (fst o snd) pt);
|
wneuper@59269
|
137 |
fun repl mpc (i, v, _, d, ts) =
|
neuper@37906
|
138 |
case filter (eq d) mpc of
|
wneuper@59269
|
139 |
[(fi, (_, _))] => [(i, v, fi, d, ts)]
|
neuper@37906
|
140 |
| [] => [] (*25.2.02: dsc in ori, but not in met -> superfluous*)
|
neuper@38053
|
141 |
| _ => error ("add_field': " ^ term2str d ^ " more than once in met");
|
wneuper@59308
|
142 |
in flat ((map (repl mpc)) ori) end;
|
neuper@37906
|
143 |
|
wneuper@59269
|
144 |
(* mark an element with the position within a plateau;
|
wneuper@59269
|
145 |
a plateau with length 1 is marked with 0 *)
|
wneuper@59269
|
146 |
fun mark _ [] = error "mark []"
|
wneuper@59269
|
147 |
| mark eq xs =
|
wneuper@59269
|
148 |
let
|
wneuper@59269
|
149 |
fun mar xx _ [x] n = xx @ [(if n = 1 then 0 else n, x)]
|
wneuper@59269
|
150 |
| mar _ _ [] _ = error "mark []"
|
wneuper@59269
|
151 |
| mar xx eq (x:: x' :: xs) n =
|
wneuper@59269
|
152 |
if eq(x, x') then mar (xx @ [(n, x)]) eq (x' :: xs) (n + 1)
|
wneuper@59269
|
153 |
else mar (xx @ [(if n = 1 then 0 else n, x)]) eq (x' :: xs) 1;
|
wneuper@59269
|
154 |
in mar [] eq xs 1 end;
|
neuper@37906
|
155 |
|
wneuper@59269
|
156 |
(* assumes equal descriptions to be in adjacent 'plateaus',
|
neuper@37906
|
157 |
items at a certain position within the plateaus form a variant;
|
wneuper@59269
|
158 |
length = 1 ... marked with 0: covers all variants *)
|
neuper@37906
|
159 |
fun add_variants fdts =
|
neuper@37906
|
160 |
let
|
wneuper@59269
|
161 |
fun eq (a, b) = curry op= (snd3 a) (snd3 b);
|
neuper@37906
|
162 |
in mark eq fdts end;
|
neuper@37906
|
163 |
|
neuper@38031
|
164 |
fun max [] = error "max of []"
|
wneuper@59269
|
165 |
| max (y :: ys) =
|
neuper@37906
|
166 |
let fun mx x [] = x
|
wneuper@59269
|
167 |
| mx x (y :: ys) = if x < y then mx y ys else mx x ys;
|
neuper@37906
|
168 |
in mx y ys end;
|
neuper@37906
|
169 |
|
wneuper@59269
|
170 |
fun coll_variants (((v,x) :: vxs)) =
|
wneuper@59269
|
171 |
let
|
wneuper@59269
|
172 |
fun col xs (vs, x) [] = xs @ [(vs, x)]
|
wneuper@59269
|
173 |
| col xs (vs, x) ((v', x') :: vxs') =
|
wneuper@59269
|
174 |
if x = x' then col xs (vs @ [v'], x') vxs'
|
wneuper@59269
|
175 |
else col (xs @ [(vs, x)]) ([v'], x') vxs';
|
wneuper@59269
|
176 |
in col [] ([v], x) vxs end
|
wneuper@59269
|
177 |
| coll_variants _ = error "coll_variants: called with []";
|
neuper@37906
|
178 |
|
neuper@37906
|
179 |
fun replace_0 vm [0] = intsto vm
|
wneuper@59269
|
180 |
| replace_0 _ vs = vs;
|
neuper@37906
|
181 |
|
neuper@38031
|
182 |
fun add_id [] = error "add_id []"
|
neuper@37906
|
183 |
| add_id xs =
|
wneuper@59269
|
184 |
let
|
wneuper@59269
|
185 |
fun add _ [] = []
|
wneuper@59269
|
186 |
| add n (x :: xs) = (n, x) :: add (n + 1) xs;
|
wneuper@59269
|
187 |
in add 1 xs end;
|
neuper@37906
|
188 |
|
wneuper@59269
|
189 |
fun flattup (a, (b, (c, d, e))) = (a, b, c, d, e);
|
bonzai@41952
|
190 |
|
wneuper@59301
|
191 |
fun prep_ori [] _ _ = ([], Selem.e_ctxt)
|
neuper@41990
|
192 |
| prep_ori fmz thy pbt =
|
wneuper@59269
|
193 |
let
|
wneuper@59308
|
194 |
val ctxt = Proof_Context.init_global thy |> fold Stool.declare_constraints fmz;
|
wneuper@59389
|
195 |
val ori = map (add_field thy pbt o Model.split_dts o the o TermC.parseNEW ctxt) fmz |> add_variants;
|
wneuper@59269
|
196 |
val maxv = map fst ori |> max;
|
wneuper@59269
|
197 |
val maxv = if maxv = 0 then 1 else maxv;
|
wneuper@59269
|
198 |
val oris = coll_variants ori
|
wneuper@59269
|
199 |
|> map (replace_0 maxv |> apfst)
|
wneuper@59269
|
200 |
|> add_id
|
wneuper@59269
|
201 |
|> map flattup;
|
wneuper@59269
|
202 |
in (oris, ctxt) end;
|
neuper@37906
|
203 |
|
wneuper@59389
|
204 |
val e_errpat = ("e_errpatID", [TermC.parse_patt @{theory} "?a = ?b"], [@{thm refl}]): errpat
|
wneuper@59389
|
205 |
val e_fillpat = ("e_fillpatID", TermC.parse_patt @{theory} "?a = _", "e_errpatID")
|
neuper@42424
|
206 |
|
wneuper@59269
|
207 |
(** breadth-first search on hierarchy of problem-types **)
|
neuper@37906
|
208 |
|
wneuper@59269
|
209 |
(* pblID are reverted _on calling_ the retrieve-funs *)
|
wneuper@59367
|
210 |
type pblRD = (*e.g. ["equations","univariate","normalise"] for internal retrieval *)
|
wneuper@59367
|
211 |
pblID; (*e.g. ["normalise","univariate","equations"] presented to student *)
|
neuper@37906
|
212 |
|
wneuper@59269
|
213 |
(* apply a fun to a ptyps node *)
|
s1210629013@55338
|
214 |
fun app_ptyp x = app_py (get_ptyps ()) x;
|
s1210629013@55321
|
215 |
|
wneuper@59269
|
216 |
(* TODO: generalize search for subthy *)
|
wneuper@59269
|
217 |
fun get_pbt (pblID: pblID) = get_py (get_ptyps ()) pblID (rev pblID)
|
neuper@37906
|
218 |
|
wneuper@59269
|
219 |
(* TODO: throws exn 'get_pbt not found: ' ... confusing !! take 'ketype' as an argument *)
|
neuper@55490
|
220 |
fun get_met (metID : metID) = get_py (get_mets ()) metID metID;
|
neuper@55490
|
221 |
fun get_met' thy (metID : metID) = get_py (KEStore_Elems.get_mets thy) metID metID;
|
neuper@55490
|
222 |
fun get_the (theID : theID) = get_py (get_thes ()) theID theID;
|
neuper@37906
|
223 |
|
wneuper@59269
|
224 |
(* lookup a guh in hierarchy of problems / methods depending on fst 4 chars in guh *)
|
wneuper@59269
|
225 |
fun guh2kestoreID (guh: guh) =
|
wneuper@59269
|
226 |
case (implode o (take_fromto 1 4) o Symbol.explode) guh of
|
wneuper@59269
|
227 |
"pbl_" =>
|
wneuper@59269
|
228 |
let
|
wneuper@59269
|
229 |
fun node ids gu (Ptyp (id, [{guh, ...} : pbt], ns)) =
|
wneuper@59269
|
230 |
if gu = guh then SOME ((ids @ [id]) : kestoreID) else nodes (ids @ [id]) gu ns
|
wneuper@59269
|
231 |
| node _ _ _ = error "guh2kestoreID node: uncovered fun def."
|
wneuper@59269
|
232 |
and nodes _ _ [] = NONE
|
wneuper@59269
|
233 |
| nodes ids gu (n :: ns) = case node ids gu n of
|
wneuper@59269
|
234 |
SOME id => SOME id
|
wneuper@59269
|
235 |
| NONE => nodes ids gu ns
|
wneuper@59269
|
236 |
in case nodes [] guh (get_ptyps ()) of
|
wneuper@59269
|
237 |
SOME id => rev id
|
wneuper@59269
|
238 |
| NONE => error ("guh2kestoreID: \"" ^ guh ^ "\" " ^ "not found in ptyps")
|
wneuper@59269
|
239 |
end
|
wneuper@59269
|
240 |
| "met_" =>
|
wneuper@59269
|
241 |
let
|
wneuper@59269
|
242 |
fun node ids gu (Ptyp (id, [{guh, ...} : met], ns)) =
|
wneuper@59269
|
243 |
if gu = guh then SOME ((ids @ [id]) : kestoreID) else nodes (ids @ [id]) gu ns
|
wneuper@59269
|
244 |
| node _ _ _ = error "guh2kestoreID node: uncovered fun def."
|
wneuper@59269
|
245 |
and nodes _ _ [] = NONE
|
wneuper@59269
|
246 |
| nodes ids gu (n :: ns) = case node ids gu n of
|
wneuper@59269
|
247 |
SOME id => SOME id
|
wneuper@59269
|
248 |
| NONE => nodes ids gu ns
|
wneuper@59269
|
249 |
in case nodes [] guh (get_mets ()) of
|
wneuper@59269
|
250 |
SOME id => id
|
wneuper@59269
|
251 |
| NONE => error ("guh2kestoreID: \"" ^ guh ^ "\" " ^ "not found in mets")
|
wneuper@59269
|
252 |
end
|
wneuper@59269
|
253 |
| _ => error ("guh2kestoreID called with \"" ^ guh ^ "\":");
|
neuper@37906
|
254 |
|
wneuper@59269
|
255 |
(* prepare problem-types before storing in pbltypes;
|
wneuper@59269
|
256 |
dont forget to "check_guh_unique" before ins *)
|
wneuper@59269
|
257 |
fun prep_pbt thy guh maa init
|
wneuper@59269
|
258 |
(pblID, dsc_dats: (string * (string list)) list, ev: rls, ca: string option, metIDs: metID list) =
|
wneuper@59269
|
259 |
let
|
wneuper@59269
|
260 |
fun eq f (f', _) = f = f';
|
wneuper@59269
|
261 |
val gi = filter (eq "#Given") dsc_dats;
|
wneuper@59269
|
262 |
val gi = (case gi of
|
wneuper@59269
|
263 |
[] => []
|
wneuper@59389
|
264 |
| ((_, gi') :: []) => (map (split_did o Thm.term_of o the o (TermC.parse thy)) gi'
|
wneuper@59269
|
265 |
handle _ => error ("prep_pbt: syntax error in '#Given' of " ^ strs2str pblID))
|
wneuper@59269
|
266 |
| _ => error ("prep_pbt: more than one '#Given' in " ^ strs2str pblID));
|
wneuper@59269
|
267 |
val gi = map (pair "#Given") gi;
|
neuper@37906
|
268 |
|
wneuper@59269
|
269 |
val fi = filter (eq "#Find") dsc_dats;
|
wneuper@59269
|
270 |
val fi = (case fi of
|
wneuper@59269
|
271 |
[] => []
|
wneuper@59389
|
272 |
| ((_, fi') :: []) => (map (split_did o Thm.term_of o the o (TermC.parse thy)) fi'
|
wneuper@59269
|
273 |
handle _ => error ("prep_pbt: syntax error in '#Find' of " ^ strs2str pblID))
|
wneuper@59269
|
274 |
| _ => error ("prep_pbt: more than one '#Find' in " ^ strs2str pblID));
|
wneuper@59269
|
275 |
val fi = map (pair "#Find") fi;
|
neuper@37906
|
276 |
|
wneuper@59269
|
277 |
val re = filter (eq "#Relate") dsc_dats;
|
wneuper@59269
|
278 |
val re = (case re of
|
wneuper@59269
|
279 |
[] => []
|
wneuper@59389
|
280 |
| ((_, re') :: []) => (map (split_did o Thm.term_of o the o (TermC.parse thy)) re'
|
wneuper@59269
|
281 |
handle _ => error ("prep_pbt: syntax error in '#Relate' of " ^ strs2str pblID))
|
wneuper@59269
|
282 |
| _ => error ("prep_pbt: more than one '#Relate' in " ^ strs2str pblID));
|
wneuper@59269
|
283 |
val re = map (pair "#Relate") re;
|
neuper@37906
|
284 |
|
wneuper@59269
|
285 |
val wh = filter (eq "#Where") dsc_dats;
|
wneuper@59269
|
286 |
val wh = (case wh of
|
wneuper@59269
|
287 |
[] => []
|
wneuper@59389
|
288 |
| ((_, wh') :: []) => (map (TermC.parse_patt thy) wh'
|
wneuper@59269
|
289 |
handle _ => error ("prep_pbt: syntax error in '#Where' of " ^ strs2str pblID))
|
wneuper@59269
|
290 |
| _ => error ("prep_pbt: more than one '#Where' in " ^ strs2str pblID));
|
wneuper@59269
|
291 |
in
|
wneuper@59269
|
292 |
({guh = guh, mathauthors = maa, init = init, thy = thy,
|
wneuper@59269
|
293 |
cas= case ca of
|
wneuper@59269
|
294 |
NONE => NONE
|
wneuper@59389
|
295 |
| SOME s => SOME ((Thm.term_of o the o (TermC.parse thy)) s),
|
wneuper@59269
|
296 |
prls = ev, where_ = wh, ppc = gi @ fi @ re, met = metIDs}, pblID): pbt * pblID
|
neuper@37906
|
297 |
end;
|
neuper@37906
|
298 |
|
wneuper@59269
|
299 |
(* prepare met for storage analogous to pbt *)
|
wneuper@59269
|
300 |
fun prep_met thy guh maa init
|
wneuper@59269
|
301 |
(metID, ppc: (string * string list) list,
|
wneuper@59311
|
302 |
{rew_ord' = ro, rls' = rls, srls = srls, prls = prls, calc = _(*scr_isa_fns*), crls = cr,
|
wneuper@59269
|
303 |
errpats = ep, nrls = nr}, scr) =
|
wneuper@59269
|
304 |
let
|
wneuper@59269
|
305 |
fun eq f (f', _) = f = f';
|
wneuper@59269
|
306 |
val gi = filter (eq "#Given") ppc;
|
wneuper@59269
|
307 |
val gi = (case gi of
|
wneuper@59269
|
308 |
[] => (writeln ("prep_met: in " ^ guh ^ " #Given is empty ?!?"); [])
|
wneuper@59389
|
309 |
| ((_, gi') :: []) => (map (split_did o Thm.term_of o the o (TermC.parse thy)) gi'
|
wneuper@59269
|
310 |
handle _ => error ("prep_pbt: syntax error in '#Given' of " ^ strs2str metID))
|
wneuper@59269
|
311 |
| _ => error ("prep_pbt: more than one '#Given' in " ^ strs2str metID));
|
wneuper@59269
|
312 |
val gi = map (pair "#Given") gi;
|
neuper@37906
|
313 |
|
wneuper@59269
|
314 |
val fi = filter (eq "#Find") ppc;
|
wneuper@59269
|
315 |
val fi = (case fi of
|
wneuper@59269
|
316 |
[] => (writeln ("prep_met: in " ^ guh ^ " #Find is empty ?!?"); [])
|
wneuper@59389
|
317 |
| ((_, fi') :: []) => (map (split_did o Thm.term_of o the o (TermC.parse thy)) fi'
|
wneuper@59269
|
318 |
handle _ => error ("prep_pbt: syntax error in '#Find' of " ^ strs2str metID))
|
wneuper@59269
|
319 |
| _ => error ("prep_pbt: more than one '#Find' in " ^ strs2str metID));
|
wneuper@59269
|
320 |
val fi = map (pair "#Find") fi;
|
neuper@37906
|
321 |
|
wneuper@59269
|
322 |
val re = filter (eq "#Relate") ppc;
|
wneuper@59269
|
323 |
val re = (case re of
|
wneuper@59269
|
324 |
[] => (writeln ("prep_met: in " ^ guh ^ " #Relate is empty ?!?"); [])
|
wneuper@59389
|
325 |
| ((_,re') :: []) => (map (split_did o Thm.term_of o the o (TermC.parse thy)) re'
|
wneuper@59269
|
326 |
handle _ => error ("prep_pbt: syntax error in '#Relate' of " ^ strs2str metID))
|
wneuper@59269
|
327 |
| _ => error ("prep_pbt: more than one '#Relate' in " ^ strs2str metID));
|
wneuper@59269
|
328 |
val re = map (pair "#Relate") re;
|
wneuper@59269
|
329 |
|
wneuper@59269
|
330 |
val wh = filter (eq "#Where") ppc;
|
wneuper@59269
|
331 |
val wh = (case wh of
|
wneuper@59269
|
332 |
[] => (writeln ("prep_met: in " ^ guh ^ " #Where is empty ?!?"); [])
|
wneuper@59389
|
333 |
| ((_, wh') :: []) => (map (TermC.parse_patt thy) wh'
|
wneuper@59269
|
334 |
handle _ => error ("prep_pbt: syntax error in '#Where' of " ^ strs2str metID))
|
wneuper@59269
|
335 |
| _ => error ("prep_pbt: more than one '#Where' in " ^ strs2str metID));
|
wneuper@59393
|
336 |
val sc = ((TermC.inst_abs o Thm.term_of o the o (TermC.parse thy)) scr)
|
wneuper@59377
|
337 |
val calc = if scr = "empty_script" then [] else LTool.get_calcs thy sc
|
wneuper@59269
|
338 |
in
|
wneuper@59269
|
339 |
({guh = guh, mathauthors = maa, init = init, ppc = gi @ fi @ re, pre = wh, rew_ord' = ro,
|
wneuper@59376
|
340 |
erls = rls, srls = srls, prls = prls, calc = calc,
|
wneuper@59269
|
341 |
crls = cr, errpats = ep, nrls = nr, scr = Prog sc}: met, metID: metID)
|
wneuper@59269
|
342 |
end;
|
wneuper@59269
|
343 |
|
wneuper@59269
|
344 |
|
wneuper@59269
|
345 |
(** get pblIDs of all entries in mat3D **)
|
neuper@37906
|
346 |
|
neuper@37906
|
347 |
fun format_pblID strl = enclose " [" "]" (commas_quote strl);
|
wneuper@59269
|
348 |
fun format_pblIDl strll = enclose "[\n" "\n]\n" (space_implode ",\n" (map format_pblID strll));
|
neuper@37906
|
349 |
|
neuper@37906
|
350 |
fun scan _ [] = [] (* no base case, for empty doms only *)
|
wneuper@59269
|
351 |
| scan id ((Ptyp ((i, _, []))) :: []) = [id @ [i]]
|
wneuper@59269
|
352 |
| scan id ((Ptyp ((i, _, pl))) :: []) = scan (id @ [i]) pl
|
wneuper@59269
|
353 |
| scan id ((Ptyp ((i, _, []))) :: ps) = [id @ [i]] @ (scan id ps)
|
wneuper@59269
|
354 |
| scan id ((Ptyp ((i, _, pl))) :: ps) = (scan (id @ [i]) pl) @ (scan id ps);
|
neuper@37906
|
355 |
|
wneuper@59270
|
356 |
fun show_ptyps () = (writeln o format_pblIDl o (scan [])) (get_ptyps ()); (* for tests *)
|
wneuper@59270
|
357 |
fun show_mets () = (writeln o format_pblIDl o (scan [])) (get_mets ()); (* for tests *)
|
neuper@37906
|
358 |
|
wneuper@59269
|
359 |
(* transform oris *)
|
neuper@37906
|
360 |
|
wneuper@59308
|
361 |
fun coll_vats (vats, (_, vs, _, _, _)) = union op = vats vs;
|
wneuper@59316
|
362 |
fun filter_vat oris i = filter ((member_swap op = i) o (#2 : Model.ori -> int list)) oris;
|
neuper@37906
|
363 |
|
wneuper@59269
|
364 |
(** check a problem (ie. itm list) for matching a problemtype **)
|
neuper@37906
|
365 |
|
wneuper@59269
|
366 |
fun eq1 d (_, (d', _)) = (d = d');
|
wneuper@59316
|
367 |
fun ori2itmSup (i, v, _, d, ts) = (i, v, true, "#Given", Model.Sup (d, ts));
|
wneuper@59269
|
368 |
(*see + add_sel_ppc ~~~~~~~*)
|
neuper@37906
|
369 |
|
wneuper@59308
|
370 |
fun field_eq f (_, _, f', _, _) = f = f';
|
neuper@37906
|
371 |
|
wneuper@59269
|
372 |
(* check an item (with arbitrary itm_ from previous matchings)
|
wneuper@59269
|
373 |
for matching a problemtype; returns true only for itms found in pbt *)
|
wneuper@59316
|
374 |
fun chk_ (_: theory) pbt (i, vats, b, f, Model.Cor ((d, vs), _)) =
|
wneuper@59269
|
375 |
(case find_first (eq1 d) pbt of
|
wneuper@59316
|
376 |
SOME (_, (_, id)) => (i, vats, b, f, Model.Cor ((d, vs), (id, Model.pbl_ids' d vs)))
|
wneuper@59316
|
377 |
| NONE => (i, vats, false, f, Model.Sup (d, vs)))
|
wneuper@59316
|
378 |
| chk_ _ pbt (i, vats, b, f, Model.Inc ((d, vs), _)) =
|
wneuper@59269
|
379 |
(case find_first (eq1 d) pbt of
|
wneuper@59316
|
380 |
SOME (_, (_, id)) => (i, vats, b, f, Model.Cor ((d, vs), (id, Model.pbl_ids' d vs)))
|
wneuper@59316
|
381 |
| NONE => (i, vats, false, f, Model.Sup (d, vs)))
|
wneuper@59316
|
382 |
| chk_ _ _ (itm as (_, _, _, _, Model.Syn _)) = itm
|
wneuper@59316
|
383 |
| chk_ _ _ (itm as (_, _, _, _, Model.Typ _)) = itm
|
wneuper@59316
|
384 |
| chk_ _ pbt (i, vats, b, f, Model.Sup (d, vs)) =
|
wneuper@59269
|
385 |
(case find_first (eq1 d) pbt of
|
wneuper@59316
|
386 |
SOME (_, (_, id)) => (i, vats, b, f, Model.Cor ((d,vs), (id, Model.pbl_ids' d vs)))
|
wneuper@59316
|
387 |
| NONE => (i, vats, false, f, Model.Sup (d, vs)))
|
wneuper@59316
|
388 |
| chk_ _ pbt (i, vats, _, f, Model.Mis (d, vs)) =
|
wneuper@59269
|
389 |
(case find_first (eq1 d) pbt of
|
wneuper@59316
|
390 |
SOME (_, _) => error "chk_: ((i,vats,b,f,Model.Cor ((d,vs),(id, Model.pbl_ids' d vs))):itm)"
|
wneuper@59316
|
391 |
| NONE => (i, vats, false, f, Model.Sup (d, [vs])))
|
wneuper@59269
|
392 |
| chk_ _ _ _ = error "chk_: uncovered fun def.";
|
neuper@37906
|
393 |
|
wneuper@59316
|
394 |
fun eq2 (_, (d, _)) (_, _, _, _, itm_) = d = Model.d_in itm_;
|
wneuper@59308
|
395 |
fun eq2' (_, (d, _)) (_, _, _, d', _) = d = d';
|
wneuper@59308
|
396 |
fun eq0 (0, _, _, _, _) = true
|
neuper@37906
|
397 |
| eq0 _ = false;
|
neuper@37906
|
398 |
fun max_i i [] = i
|
wneuper@59269
|
399 |
| max_i i ((id, _, _, _, _) :: is) = if i > id then max_i i is else max_i id is;
|
wneuper@59308
|
400 |
fun max_id [] = 0
|
wneuper@59269
|
401 |
| max_id ((id, _, _, _, _) :: is) = max_i id is;
|
wneuper@59308
|
402 |
fun add_idvat itms _ _ [] = itms
|
wneuper@59308
|
403 |
| add_idvat itms i mvat ((_, _, b, f, itm_) :: its) =
|
wneuper@59308
|
404 |
add_idvat (itms @ [(i,[],b,f,itm_)]) (i + 1) mvat its;
|
wneuper@59269
|
405 |
(* ^^ mvat ...meaningless with pbl-identifier *)
|
neuper@37906
|
406 |
|
wneuper@59269
|
407 |
(* find elements of pbt not contained in itms;
|
wneuper@59269
|
408 |
if such one is untouched, return this one, otherwise create new itm *)
|
wneuper@59308
|
409 |
fun chk_m itms untouched (p as (f, (d, id))) =
|
wneuper@59269
|
410 |
case find_first (eq2 p) itms of
|
wneuper@59269
|
411 |
SOME _ => []
|
wneuper@59269
|
412 |
| NONE =>
|
wneuper@59269
|
413 |
(case find_first (eq2 p) untouched of
|
wneuper@59269
|
414 |
SOME itm => [itm]
|
wneuper@59316
|
415 |
| NONE => [(0, [], false, f, Model.Mis (d, id))]);
|
neuper@37906
|
416 |
|
neuper@37906
|
417 |
fun chk_mis mvat itms untouched pbt =
|
neuper@37906
|
418 |
let val mis = (flat o (map (chk_m itms untouched))) pbt;
|
neuper@37906
|
419 |
val mid = max_id itms;
|
neuper@37906
|
420 |
in add_idvat [] (mid + 1) mvat mis end;
|
neuper@37906
|
421 |
|
wneuper@59269
|
422 |
(* check a problem (ie. itm list) for matching a problemtype,
|
wneuper@59316
|
423 |
takes the Model.max_vt for concluding completeness (could be another!) *)
|
wneuper@59269
|
424 |
fun match_itms thy itms (pbt, pre, prls) =
|
wneuper@59269
|
425 |
let
|
wneuper@59269
|
426 |
fun okv mvat (_, vats, b, _, _) = member op = vats mvat andalso b;
|
wneuper@59269
|
427 |
val itms' = map (chk_ thy pbt) itms; (* all found are #3 true *)
|
wneuper@59316
|
428 |
val mvat = Model.max_vt itms';
|
wneuper@59269
|
429 |
val itms'' = filter (okv mvat) itms';
|
wneuper@59269
|
430 |
val untouched = filter eq0 itms; (* i.e. dsc only (from init)*)
|
wneuper@59269
|
431 |
val mis = chk_mis mvat itms'' untouched pbt;
|
wneuper@59308
|
432 |
val pre' = Stool.check_preconds' prls pre itms'' mvat
|
wneuper@59269
|
433 |
val pb = foldl and_ (true, map fst pre')
|
wneuper@59269
|
434 |
in (length mis = 0 andalso pb, (itms'@ mis, pre')) end;
|
neuper@37906
|
435 |
|
wneuper@59269
|
436 |
(* check a problem pbl (ie. itm list) for matching a problemtype pbt,
|
wneuper@59269
|
437 |
for missing items get data from formalization (ie. ori list);
|
wneuper@59316
|
438 |
takes the Model.max_vt for concluding completeness (could be another!)
|
wneuper@59269
|
439 |
|
wneuper@59269
|
440 |
(0) determine the most frequent variant mv in pbl
|
wneuper@59269
|
441 |
ALL pbt. (1) dsc(pbt) notmem dsc(pbls) =>
|
wneuper@59269
|
442 |
(2) filter (dsc(pbt) = dsc(oris)) oris; -> news;
|
wneuper@59269
|
443 |
(3) newitms = filter (mv mem vat(news)) news
|
wneuper@59269
|
444 |
(4) pbt @ newitms *)
|
wneuper@59308
|
445 |
fun match_itms_oris (_: theory) pbl (pbt, pre, prls) oris =
|
neuper@37906
|
446 |
let
|
wneuper@59316
|
447 |
(*0*)val mv = Model.max_vt pbl;
|
neuper@37906
|
448 |
|
wneuper@59316
|
449 |
fun eqdsc_pbt_itm ((_,(d,_))) (_, _, _, _, itm_) = d = Model.d_in itm_;
|
neuper@37906
|
450 |
fun notmem pbl pbt1 = case find_first (eqdsc_pbt_itm pbt1) pbl of
|
neuper@37926
|
451 |
SOME _ => false | NONE => true;
|
wneuper@59269
|
452 |
(*1*)val mis = (filter (notmem pbl)) pbt;
|
neuper@37906
|
453 |
|
wneuper@59308
|
454 |
fun eqdsc_ori (_,(d,_)) (_, _, _, d', _) = d = d';
|
wneuper@59316
|
455 |
fun ori2itmMis (f, (d, pid)) (i, v, _, _, _) = (i, v, false, f, Model.Mis (d, pid));
|
wneuper@59269
|
456 |
(*2*)fun oris2itms oris mis1 = ((map (ori2itmMis mis1)) o (filter (eqdsc_ori mis1))) oris;
|
neuper@37906
|
457 |
val news = (flat o (map (oris2itms oris))) mis;
|
wneuper@59269
|
458 |
(*3*)fun mem_vat (_, vats, _, _, _) = member op = vats mv;
|
neuper@37906
|
459 |
val newitms = filter mem_vat news;
|
neuper@37906
|
460 |
(*4*)val itms' = pbl @ newitms;
|
wneuper@59308
|
461 |
val pre' = Stool.check_preconds' prls pre itms' mv;
|
wneuper@59269
|
462 |
val pb = foldl and_ (true, map fst pre');
|
neuper@37906
|
463 |
in (length mis = 0 andalso pb, (itms', pre')) end;
|
neuper@37906
|
464 |
|
neuper@37906
|
465 |
|
wneuper@59269
|
466 |
(** check a problem (ie. itm list) for matching a problemtype **)
|
neuper@37906
|
467 |
|
wneuper@59269
|
468 |
(* check an ori for matching a problemtype by description;
|
wneuper@59269
|
469 |
returns true only for itms found in pbt *)
|
wneuper@59308
|
470 |
fun chk1_ (_: theory) pbt (i, vats, f, d, vs) =
|
wneuper@59269
|
471 |
case find_first (eq1 d) pbt of
|
wneuper@59316
|
472 |
SOME (_, (_, id)) => [(i, vats, true, f, Model.Cor ((d, vs), (id, Model.pbl_ids' d vs)))]
|
wneuper@59269
|
473 |
| NONE => [];
|
neuper@37906
|
474 |
|
neuper@37906
|
475 |
(* elem 'p' of pbt contained in itms ? *)
|
wneuper@59308
|
476 |
fun chk1_m itms p = case find_first (eq2 p) itms of SOME _ => true | NONE => false;
|
wneuper@59308
|
477 |
fun chk1_m' oris (p as (f, (d, t))) =
|
wneuper@59269
|
478 |
case find_first (eq2' p) oris of
|
wneuper@59269
|
479 |
SOME _ => []
|
wneuper@59316
|
480 |
| NONE => [(f, Model.Mis (d, t))];
|
wneuper@59308
|
481 |
fun pair0vatsfalse (f, itm_) = (0, [], false, f, itm_);
|
neuper@37906
|
482 |
|
wneuper@59269
|
483 |
fun chk1_mis _(*mvat*) itms ppc = foldl and_ (true, map (chk1_m itms) ppc);
|
wneuper@59269
|
484 |
fun chk1_mis' oris ppc = map pair0vatsfalse ((flat o (map (chk1_m' oris))) ppc);
|
wneuper@59269
|
485 |
|
wneuper@59269
|
486 |
(* check a problem (ie. ori list) for matching a problemtype,
|
wneuper@59316
|
487 |
takes the Model.max_vt for concluding completeness (FIXME could be another!) *)
|
wneuper@59269
|
488 |
fun match_oris thy prls oris (pbt,pre) =
|
wneuper@59269
|
489 |
let
|
wneuper@59269
|
490 |
val itms = (flat o (map (chk1_ thy pbt))) oris;
|
wneuper@59316
|
491 |
val mvat = Model.max_vt itms;
|
wneuper@59269
|
492 |
val complete = chk1_mis mvat itms pbt;
|
wneuper@59308
|
493 |
val pre' = Stool.check_preconds' prls pre itms mvat;
|
wneuper@59269
|
494 |
val pb = foldl and_ (true, map fst pre');
|
wneuper@59269
|
495 |
in if complete andalso pb then true else false end;
|
neuper@37906
|
496 |
|
wneuper@59269
|
497 |
(* check a problem (ie. ori list) for matching a problemtype,
|
wneuper@59269
|
498 |
returns items for output to math-experts *)
|
wneuper@59269
|
499 |
fun match_oris' thy oris (ppc,pre,prls) =
|
wneuper@59269
|
500 |
let
|
wneuper@59269
|
501 |
val itms = (flat o (map (chk1_ thy ppc))) oris;
|
wneuper@59269
|
502 |
val sups = ((map ori2itmSup) o (filter (field_eq "#undef"))) oris;
|
wneuper@59316
|
503 |
val mvat = Model.max_vt itms;
|
wneuper@59269
|
504 |
val miss = chk1_mis' oris ppc;
|
wneuper@59308
|
505 |
val pre' = Stool.check_preconds' prls pre itms mvat;
|
wneuper@59269
|
506 |
val pb = foldl and_ (true, map fst pre');
|
wneuper@59269
|
507 |
in (miss = [] andalso pb, (itms @ miss @ sups, pre')) end;
|
neuper@37906
|
508 |
|
wneuper@59269
|
509 |
datatype match' = (* for the user *)
|
wneuper@59316
|
510 |
Matches' of Model.item Model.ppc
|
wneuper@59316
|
511 |
| NoMatch' of Model.item Model.ppc;
|
neuper@37906
|
512 |
|
wneuper@59270
|
513 |
(* match a formalization with a problem type, for tests *)
|
wneuper@59298
|
514 |
fun match_pbl fmz ({thy = thy, where_ = pre, ppc, prls = er, ...}: pbt) =
|
wneuper@59269
|
515 |
let
|
wneuper@59269
|
516 |
val oris = prep_ori fmz thy ppc |> #1;
|
wneuper@59269
|
517 |
val (bool, (itms, pre')) = match_oris' thy oris (ppc, pre, er);
|
wneuper@59269
|
518 |
in
|
wneuper@59269
|
519 |
if bool
|
wneuper@59269
|
520 |
then Matches' (itms2itemppc thy itms pre')
|
wneuper@59269
|
521 |
else NoMatch' (itms2itemppc thy itms pre')
|
wneuper@59269
|
522 |
end;
|
neuper@37906
|
523 |
|
wneuper@59269
|
524 |
(* refine a problem; construct pblRD while scanning *)
|
wneuper@59269
|
525 |
fun refin (pblRD: pblRD) ori ((Ptyp (pI, [py], [])): pbt ptyp) =
|
neuper@37906
|
526 |
if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py)
|
wneuper@59269
|
527 |
then SOME ((pblRD @ [pI]): pblRD)
|
neuper@37926
|
528 |
else NONE
|
wneuper@59269
|
529 |
| refin pblRD ori (Ptyp (pI, [py], pys)) =
|
neuper@37906
|
530 |
if match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py)
|
neuper@37906
|
531 |
then (case refins (pblRD @ [pI]) ori pys of
|
neuper@37926
|
532 |
SOME pblRD' => SOME pblRD'
|
neuper@37926
|
533 |
| NONE => SOME (pblRD @ [pI]))
|
neuper@37926
|
534 |
else NONE
|
wneuper@59269
|
535 |
| refin _ _ _ = error "refin: uncovered fun def."
|
wneuper@59269
|
536 |
and refins _ _ [] = NONE
|
wneuper@59269
|
537 |
| refins pblRD ori ((p as Ptyp _) :: pts) =
|
neuper@37906
|
538 |
(case refin pblRD ori p of
|
wneuper@59269
|
539 |
SOME pblRD' => SOME pblRD'
|
wneuper@59269
|
540 |
| NONE => refins pblRD ori pts);
|
neuper@37906
|
541 |
|
wneuper@59269
|
542 |
(* refine a problem; version providing output for math-experts *)
|
wneuper@59269
|
543 |
fun refin' (pblRD: pblRD) fmz pbls ((Ptyp (pI, [py], [])): pbt ptyp) =
|
neuper@42391
|
544 |
let
|
wneuper@59269
|
545 |
val _ = (tracing o ((curry op ^) "*** pass ") o strs2str) (pblRD @ [pI])
|
neuper@42391
|
546 |
val {thy, ppc, where_, prls, ...} = py
|
neuper@42391
|
547 |
val oris = prep_ori fmz thy ppc |> #1;
|
wneuper@59269
|
548 |
(* WN020803: itms!: oris might _not_ be complete here *)
|
neuper@42391
|
549 |
val (b, (itms, pre')) = match_oris' thy oris (ppc, where_, prls)
|
wneuper@59269
|
550 |
in
|
wneuper@59269
|
551 |
if b
|
wneuper@59308
|
552 |
then pbls @ [Stool.Matches (rev (pblRD @ [pI]), itms2itemppc thy itms pre')]
|
wneuper@59308
|
553 |
else pbls @ [Stool.NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')]
|
neuper@37906
|
554 |
end
|
neuper@42391
|
555 |
| refin' pblRD fmz pbls (Ptyp (pI, [py], pys)) =
|
neuper@42391
|
556 |
let
|
neuper@42391
|
557 |
val _ = (tracing o ((curry op ^)"*** pass ") o strs2str) (pblRD @ [pI])
|
neuper@42391
|
558 |
val {thy, ppc, where_, prls, ...} = py
|
neuper@42391
|
559 |
val oris = prep_ori fmz thy ppc |> #1;
|
wneuper@59269
|
560 |
(* WN020803: itms!: oris might _not_ be complete here *)
|
neuper@42391
|
561 |
val(b, (itms, pre')) = match_oris' thy oris (ppc,where_,prls);
|
wneuper@59269
|
562 |
in
|
wneuper@59269
|
563 |
if b
|
wneuper@59269
|
564 |
then
|
wneuper@59308
|
565 |
let val pbl = Stool.Matches (rev (pblRD @ [pI]), itms2itemppc thy itms pre')
|
neuper@42391
|
566 |
in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end
|
wneuper@59308
|
567 |
else (pbls @ [Stool.NoMatch (rev (pblRD @ [pI]), itms2itemppc thy itms pre')])
|
neuper@37906
|
568 |
end
|
wneuper@59269
|
569 |
| refin' _ _ _ _ = error "refin': uncovered fun def."
|
wneuper@59269
|
570 |
and refins' _ _ pbls [] = pbls
|
wneuper@59269
|
571 |
| refins' pblRD fmz pbls ((p as Ptyp _) :: pts) =
|
wneuper@59269
|
572 |
let
|
wneuper@59269
|
573 |
val pbls' = refin' pblRD fmz pbls p
|
wneuper@59269
|
574 |
in
|
wneuper@59269
|
575 |
case last_elem pbls' of
|
wneuper@59308
|
576 |
Stool.Matches _ => pbls'
|
wneuper@59308
|
577 |
| Stool.NoMatch _ => refins' pblRD fmz pbls' pts
|
neuper@42391
|
578 |
end;
|
neuper@37906
|
579 |
|
wneuper@59269
|
580 |
(* refine a problem; version for tactic Refine_Problem *)
|
wneuper@59269
|
581 |
fun refin'' _ (pblRD: pblRD) itms pbls ((Ptyp (pI, [py], [])): pbt ptyp) =
|
wneuper@59269
|
582 |
let
|
wneuper@59269
|
583 |
val {thy, ppc, where_, prls, ...} = py
|
wneuper@59269
|
584 |
val (b, (itms', pre')) = match_itms thy itms (ppc, where_, prls);
|
wneuper@59269
|
585 |
in
|
wneuper@59269
|
586 |
if b
|
wneuper@59308
|
587 |
then pbls @ [Stool.Match_ (rev (pblRD @ [pI]), (itms', pre'))]
|
wneuper@59308
|
588 |
else pbls @ [Stool.NoMatch_]
|
neuper@37906
|
589 |
end
|
wneuper@59269
|
590 |
| refin'' _ pblRD itms pbls (Ptyp (pI, [py], pys)) =
|
wneuper@59269
|
591 |
let
|
wneuper@59269
|
592 |
val {thy, ppc, where_, prls, ...} = py
|
wneuper@59269
|
593 |
val (b, (itms', pre')) = match_itms thy itms (ppc, where_, prls);
|
neuper@37906
|
594 |
in if b
|
wneuper@59308
|
595 |
then let val pbl = Stool.Match_ (rev (pblRD @ [pI]), (itms', pre'))
|
neuper@37906
|
596 |
in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end
|
wneuper@59308
|
597 |
else (pbls @ [Stool.NoMatch_])
|
neuper@37906
|
598 |
end
|
wneuper@59269
|
599 |
| refin'' _ _ _ _ _ = error "refin': uncovered fun def."
|
wneuper@59269
|
600 |
and refins'' _ _ _ pbls [] = pbls
|
wneuper@59269
|
601 |
| refins'' thy pblRD itms pbls ((p as Ptyp _) :: pts) =
|
wneuper@59269
|
602 |
let
|
wneuper@59269
|
603 |
val pbls' = refin'' thy pblRD itms pbls p
|
neuper@37906
|
604 |
in case last_elem pbls' of
|
wneuper@59308
|
605 |
Stool.Match_ _ => pbls'
|
wneuper@59308
|
606 |
| Stool.NoMatch_ => refins'' thy pblRD itms pbls' pts
|
wneuper@59269
|
607 |
end;
|
neuper@37906
|
608 |
|
wneuper@59269
|
609 |
(* for tactic Refine_Tacitly
|
wneuper@59269
|
610 |
oris are already created wrt. some pbt; pbt contains thy for parsing *)
|
wneuper@59269
|
611 |
fun refine_ori oris (pblID: pblID) =
|
wneuper@59269
|
612 |
let
|
wneuper@59269
|
613 |
val opt = app_ptyp (refin ((rev o tl) pblID) oris) pblID (rev pblID);
|
neuper@37906
|
614 |
in case opt of
|
wneuper@59269
|
615 |
SOME pblRD =>
|
wneuper@59269
|
616 |
let val pblID': pblID = rev pblRD
|
wneuper@59269
|
617 |
in if pblID' = pblID then NONE else SOME pblID' end
|
wneuper@59269
|
618 |
| NONE => NONE
|
wneuper@59269
|
619 |
end;
|
neuper@37906
|
620 |
fun refine_ori' oris pI = (the (refine_ori oris pI)) handle _ => pI;
|
neuper@37906
|
621 |
|
wneuper@59269
|
622 |
(* for tactic Refine_Problem
|
wneuper@59269
|
623 |
10.03: returnvalue -> (pIrefined, itm list) would be sufficient *)
|
wneuper@59269
|
624 |
fun refine_pbl thy (pblID: pblID) itms =
|
wneuper@59308
|
625 |
case Stool.refined_ (app_ptyp (refin'' thy ((rev o tl) pblID) itms []) pblID (rev pblID)) of
|
wneuper@59269
|
626 |
NONE => NONE
|
wneuper@59308
|
627 |
| SOME (Stool.Match_ (rfd as (pI', _))) => if pblID = pI' then NONE else SOME rfd
|
wneuper@59269
|
628 |
| _ => error "refine_pbl: uncovered case refined_";
|
neuper@37906
|
629 |
|
neuper@37906
|
630 |
|
wneuper@59270
|
631 |
(* for math-experts and test;
|
wneuper@59269
|
632 |
FIXME.WN021019: needs thy for parsing fmz *)
|
wneuper@59298
|
633 |
fun refine fmz pblID =
|
s1210629013@55321
|
634 |
app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID);
|
neuper@37906
|
635 |
|
wneuper@59269
|
636 |
(* make a guh from a reference to an element in the kestore;
|
wneuper@59269
|
637 |
EXCEPT theory hierarchy ... compare 'fun keref2xml' *)
|
wneuper@59269
|
638 |
fun pblID2guh (pblID:pblID) = (((#guh o get_pbt) pblID)
|
wneuper@59269
|
639 |
handle _ => error ("pblID2guh: not for \"" ^ strs2str' pblID ^ "\""));
|
wneuper@59269
|
640 |
fun metID2guh (metID:metID) = (((#guh o get_met) metID)
|
wneuper@59269
|
641 |
handle _ => error ("metID2guh: no 'Met_' for \"" ^ strs2str' metID ^ "\""));
|
wneuper@59269
|
642 |
fun kestoreID2guh Pbl_ (kestoreID: kestoreID) = pblID2guh kestoreID
|
wneuper@59269
|
643 |
| kestoreID2guh Met_ (kestoreID: kestoreID) = metID2guh kestoreID
|
neuper@37906
|
644 |
| kestoreID2guh ketype kestoreID =
|
wneuper@59269
|
645 |
error ("kestoreID2guh: \"" ^ ketype2str ketype ^ "\" not for \"" ^ strs2str' kestoreID ^ "\"");
|
neuper@37906
|
646 |
|
wneuper@59270
|
647 |
fun show_pblguhs () = (* for tests *)
|
wneuper@59336
|
648 |
(tracing o strs2str o (map linefeed)) (coll_pblguhs (get_ptyps ()))
|
wneuper@59270
|
649 |
fun sort_pblguhs () = (* for tests *)
|
wneuper@59336
|
650 |
(tracing o strs2str o (map linefeed)) (((sort string_ord) o coll_pblguhs) (get_ptyps ()))
|
neuper@37906
|
651 |
|
wneuper@59270
|
652 |
fun show_metguhs () = (* for tests *)
|
wneuper@59336
|
653 |
(tracing o strs2str o (map linefeed)) (coll_metguhs (get_mets ()))
|
wneuper@59270
|
654 |
fun sort_metguhs () = (* for tests *)
|
wneuper@59336
|
655 |
(tracing o strs2str o (map linefeed)) (((sort string_ord) o coll_metguhs) (get_mets ()))
|
wneuper@59269
|
656 |
|
wneuper@59269
|
657 |
end
|