/[ascend]/trunk/ascend4/TK/methods.tcl
ViewVC logotype

Contents of /trunk/ascend4/TK/methods.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (17 years, 1 month ago) by aw0a
File MIME type: text/x-tcl
File size: 18790 byte(s)
Setting up web subdirectory in repository
1 # methods.tcl: METHOD suggestion generation
2 # By Benjamin A Allan
3 # Created May 14, 1998
4 # Part of ASCEND
5 # Revision: $Revision: 1.3 $
6 # Last modified on: $Date: 1998/06/18 15:55:31 $
7 # Last modified by: $Author: mthomas $
8 # Revision control file: $RCSfile: methods.tcl,v $
9 #
10 # This file is part of the ASCEND Tcl/Tk Interface.
11 #
12 # Copyright (C) 1998 Carnegie Mellon University
13 #
14 # The ASCEND Tcl/Tk Interface is free software; you can redistribute
15 # it and/or modify it under the terms of the GNU General Public
16 # License as published by the Free Software Foundation; either
17 # version 2 of the License, or (at your option) any later version.
18 #
19 # The ASCEND Tcl/Tk Interface is distributed in hope that it will be
20 # useful, but WITHOUT ANY WARRANTY; without even the implied warranty
21 # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
23 #
24 # You should have received a copy of the GNU General Public License
25 # along with the program; if not, write to the Free Software
26 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
27 # file named COPYING. COPYING is found in ../compiler.
28
29 # Goal is to suggest method bodies for the user to
30 # improve upon and thus feel useful.
31 # Since method generation is a messy business and a separate
32 # concept from window management, these functions are in
33 # a separate file.
34
35 # To be called from LibraryProc.tcl defaults function.
36 proc set_MethodsDefaults {} {
37 global ascLibrVect
38 set ascLibrVect(dofmethods) seqmod
39 set ascLibrVect(standardmethods) [list \
40 default_self \
41 check_self \
42 scale_self \
43 bound_self \
44 default_all \
45 check_all \
46 bound_all \
47 scale_all \
48 specify \
49 ]
50 set ascLibrVect(varmethods) [list bound scale default]
51 # check, specify are not concerned with vars mostly.
52 set ascLibrVect(generate_ADDMETHOD) 0
53 set metainfo [libr_query -childinfo]
54 set infoindex 0
55 foreach i $metainfo {
56 set ikey [lindex [split $i -] 0]
57 set ascLibrVect(cinfo.$ikey) $infoindex
58 incr infoindex
59 }
60 }
61
62 # args: opened file fid, loaded type type
63 # Main entry point for clients.
64 # The goal of this method, besides generating methods semi-intelligently,
65 # is to do it without being dependent on hardcoded numeric positions
66 # of elements in the list of type childinfo. We manage this by using
67 # the syntactic information -childinfo returns when called with no args.
68 # We have given up on true genericity of method generation for this attempt.
69 proc asc_suggest_methods {fid type} {
70 global ascLibrVect gmvect ascDispVect
71 catch {unset gmvect}
72 #gmvect is a global that does no persist across calls to be examined after
73
74 set gmvect(comment) $ascDispVect(ShowComments)
75 set gmvect(firstdone) 0
76 set newmethods [libr_query -methods -type $type]
77 set gmvect(newisavar) {} ;# list of newly declared local variables
78 set gmvect(newwillbevar) {} ;# list of new passed variables
79 set gmvect(newisa) {} ;# list of newly declared local parts
80 set gmvect(newwillbe) {} ;# list of newly received by pointer parts
81 set newchildren [libr_query -childnames -type $type] ;# all children
82 set ancestorlist [libr_query -ancestors -type $type] ;# all ancestors
83 set gmvect(oldisavar) {} ;# list of local variables in ancestor
84 set gmvect(oldwillbevar) {} ;# list of passed variables in ancestor
85 set gmvect(oldisa) {} ;# list of local parts in ancestor
86 set gmvect(oldwillbe) {} ;# list of passed parts in ancestor
87 set gmvect(ancestor) {} ;# last ancestor of type
88 set oldmethods {} ;# list of methods in ancestor
89 set oldchildren {} ;# list of all children in ancestor
90 if {[llength $ancestorlist]} {
91 set ancestor [lindex $ancestorlist 0]
92 set gmvect(ancestor) $ancestor
93 set oldchildren [libr_query -childnames -type $ancestor]
94 set oldmethods [libr_query -methods -type $ancestor]
95 }
96 foreach c $oldchildren {
97 set cinfo [libr_query -childinfo -type $ancestor -child $c]
98 set willbe [lindex $cinfo $ascLibrVect(cinfo.willbe)]
99 set isa [lindex $cinfo $ascLibrVect(cinfo.isa)]
100 set kind [lindex $cinfo $ascLibrVect(cinfo.basetype)] ;# array base
101 switch $kind {
102 MODEL {
103 if {$isa} {
104 lappend gmvect(oldisa) $c
105 }
106 if {$willbe} {
107 lappend gmvect(oldwillbe) $c
108 }
109 }
110 when -
111 relation -
112 logrelation -
113 real_constant -
114 integer_constant -
115 symbol_constant -
116 boolean_constant -
117 set {
118 # do nothing for constants
119 }
120 default {
121 # variable type
122 if {$isa} {
123 lappend gmvect(oldisavar) $c
124 }
125 if {$willbe} {
126 lappend gmvect(oldwillbevar) $c
127 }
128 }
129 }
130 }
131 foreach c $newchildren {
132 if {[lsearch $oldchildren $c] != -1} { # old part
133 continue;
134 }
135 set cinfo [libr_query -childinfo -type $type -child $c]
136 set willbe [lindex $cinfo $ascLibrVect(cinfo.willbe)]
137 set isa [lindex $cinfo $ascLibrVect(cinfo.isa)]
138 set kind [lindex $cinfo $ascLibrVect(cinfo.basetype)]
139 switch $kind {
140 MODEL {
141 if {$isa} {
142 lappend gmvect(newisa) $c
143 }
144 if {$willbe} {
145 lappend gmvect(newwillbe) $c
146 }
147 }
148 when -
149 relation -
150 logrelation -
151 real_constant -
152 integer_constant -
153 symbol_constant -
154 boolean_constant -
155 set {
156 # do nothing for constants
157 }
158 default {
159 # variable type
160 if {$isa} {
161 lappend gmvect(newisavar) $c
162 }
163 if {$willbe} {
164 lappend gmvect(newwillbevar) $c
165 }
166 }
167 }
168 }
169 foreach m $ascLibrVect(standardmethods) {
170 set needed 0
171 set suffix [lindex [split $m _] end]
172 set prefix [lindex [split $m _] 0]
173 if {[lsearch $newmethods $m] == -1} {
174 # not inherited
175 set needed 1
176 }
177 switch $suffix {
178 all {
179 if {[llength $gmvect(newwillbe)] || \
180 [llength $gmvect(newwillbevar)] || \
181 $needed} {
182 # call the particular method generation
183 generate_$m $fid $type
184 } else {
185 generate_inheritance $fid $m
186 }
187 }
188 self {
189 if {[llength $gmvect(newisa)] || \
190 [llength $gmvect(newisavar)] || \
191 $needed} {
192 generate_$m $fid $type
193 } else {
194 generate_inheritance $fid $m
195 }
196 }
197 default {
198 generate_$m $fid $type
199 }
200 }
201 }
202 if {$ascLibrVect(generate_ADDMETHOD)} {
203 puts $fid "END METHODS;"
204 }
205 }
206
207 proc generate_inheritance {fid m} {
208 puts $fid "(* METHOD $m is already written or is inherited properly. *)"
209 }
210
211 # This method should account for arrayness from childinfo.
212 # at present it is stupid. User may need to put FOR loops
213 # and indices on array children. Probably should at least
214 # echo the array children named.
215 # sep should be "" . or :: as needed.
216 proc generate_run {fid type child sep m} {
217 if {[string compare $sep "::"] != 0} {
218 set child [generate_fullname $type $child]
219 }
220 puts $fid "\tRUN $child$sep$m;"
221 }
222
223 # generate method opening
224 proc generate_header {fid type m} {
225 global ascLibrVect gmvect
226
227 if {!$gmvect(firstdone)} {
228 if {$ascLibrVect(generate_ADDMETHOD)} {
229 puts $fid "ADD METHODS IN $type;"
230 } else {
231 puts $fid "METHODS"
232 }
233 puts $fid \
234 "(* generated code for $type to be customized or corrected. *)"
235 set gmvect(firstdone) 1
236 }
237 puts $fid "METHOD $m;"
238 }
239
240 # generate method closing
241 proc generate_footer {fid type m} {
242 global ascLibrVect gmvect
243 puts $fid "END $m;"
244 puts $fid ""
245 }
246
247 # generate scaling update (child.nominal) heuristically
248 proc generate_NominaL {fid type child} {
249 if {![generate_is_solver_var $type $child]} {
250 return
251 }
252 set child [generate_fullname $type $child]
253 puts $fid "\t$child.nominal := abs($child) * 1.001 + 1.0e-4{?};"
254 }
255
256 # generate_is_solver_var type child returns 1 if child is a solvervar
257 proc generate_is_solver_var {type child} {
258 global ascLibrVect
259 set cinfo [libr_query -childinfo -type $type -child $child]
260 set type [lindex $cinfo $ascLibrVect(cinfo.guesstype)]
261 set ancestors [libr_query -ancestors -type $type]
262 if {[lsearch -exact $ancestors solver_var] == -1} {
263 return 0
264 }
265 set fullname [lindex $cinfo $ascLibrVect(cinfo.fullname)]
266 return 1
267 }
268
269 # lookup the indexed name of an array child
270 proc generate_fullname {type child} {
271 global ascLibrVect
272 if {[string compare $child ""]==0} {return ""}
273 set cinfo [libr_query -childinfo -type $type -child $child]
274 set fullname [lindex $cinfo $ascLibrVect(cinfo.fullname)]
275 return $fullname
276 }
277
278 # generate bounds update (child.*_bound) heuristically
279 proc generate_BoundS {fid type child} {
280 if {![generate_is_solver_var $type $child]} {
281 return
282 }
283 set child [generate_fullname $type $child]
284 puts $fid "\t$child.lower_bound := $child - boundwidth*$child.nominal;"
285 puts $fid "\t$child.upper_bound := $child + boundwidth*$child.nominal;"
286 }
287
288 # generate default values stupidly
289 proc generate_DefaulT {fid type child} {
290 set child [generate_fullname $type $child]
291 puts $fid "\t$child\t:= ;"
292 }
293
294 # Returns the dof name first found in methods of child from
295 # those in doflist. If doflist empty, will return reset.
296 # In any case, if child is not a MODEL or array thereof,
297 # returns the empty string. Also returns empty string if
298 # child is 'passed down'.
299 proc generate_dofname {type child doflist} {
300 global ascLibrVect gmvect
301 set cinfo [libr_query -childinfo -type $type -child $child]
302 if {[string compare [lindex $cinfo $ascLibrVect(cinfo.basetype)] "MODEL"]} {
303 return ""; # not a MODEL means no reset, duh.
304 }
305 if {[lindex $cinfo $ascLibrVect(cinfo.passed)]} {
306 return ""
307 }
308 set mlist [libr_query -methods \
309 -type [lindex $cinfo $ascLibrVect(cinfo.guesstype)]]
310 foreach m $doflist {
311 if {[lsearch -exact $mlist $m] >= 0 && $m != {}} {
312 return $m
313 }
314 }
315 return reset
316 }
317 # ---------------------------------------------------------------------
318 # The following procs mirror our conventions for writing methods.
319 # Unfortunately the conventions and generated comments are specific
320 # for each method. Each method m in $ascLibrVect(standardmethods) should
321 # have a generate_$m function here.
322 # ---------------------------------------------------------------------
323
324 # call check_all on passed in parts, call check_self.
325 proc generate_check_all {fid type} {
326 global gmvect
327
328 generate_header $fid $type check_all
329 if {$gmvect(comment)} {
330 puts $fid \
331 "\t(* Array parts and variables need subscripts and FOR/DO loops. *)"
332 }
333
334 foreach child $gmvect(oldwillbe) {
335 generate_run $fid $type $child . check_all
336 }
337 foreach child $gmvect(newwillbe) {
338 generate_run $fid $type $child . check_all
339 }
340
341 generate_run $fid $type "" "" check_self
342 generate_footer $fid $type check_all
343 }
344
345 # call check_all on passed in parts, call check_self.
346 proc generate_check_self {fid type} {
347 global gmvect
348
349 generate_header $fid $type check_self
350 if {[llength $gmvect(newisa)]} {
351 if {$gmvect(comment)} {
352 puts $fid \
353 "\t(* Put new high-level checks here before checking new parts. *)"
354 puts $fid \
355 "\t(* Array parts probably need subscripts and FOR/DO loops. *)"
356 }
357 } else {
358 if {$gmvect(comment)} {
359 puts $fid "\t(* Put new high-level checks here. *)"
360 }
361 }
362
363 if {[llength $gmvect(oldisa)]} {
364 generate_run $fid $type $gmvect(ancestor) :: check_self
365 }
366 foreach child $gmvect(newisa) {
367 generate_run $fid $type $child . check_self
368 }
369
370 generate_footer $fid $type check_self
371 }
372
373 # call scale_all on passed in parts, rescale passed in vars, call scale_self.
374 proc generate_scale_all {fid type} {
375 global gmvect
376
377 generate_header $fid $type scale_all
378 if {$gmvect(comment)} {
379 puts $fid \
380 "\t(* Array parts and variables need subscripts and FOR/DO loops. *)"
381 }
382
383 foreach child $gmvect(oldwillbe) {
384 generate_run $fid $type $child . scale_all
385 }
386 foreach child $gmvect(newwillbe) {
387 generate_run $fid $type $child . scale_all
388 }
389
390 if {[llength $gmvect(oldwillbevar)] || [llength $gmvect(newwillbevar)]} {
391 if {$gmvect(comment)} {
392 puts $fid \
393 "\t(* .nominal assignments may need value/units corrected for 1.0e-4."
394 puts $fid "\t * Some .nominal assignments may need to be deleted."
395 puts $fid "\t *)"
396 }
397 }
398 foreach child $gmvect(oldwillbevar) {
399 generate_NominaL $fid $type $child
400 }
401 foreach child $gmvect(newwillbevar) {
402 generate_NominaL $fid $type $child
403 }
404
405 generate_run $fid $type "" "" scale_self
406 generate_footer $fid $type scale_all
407 }
408
409 # call old scale method, call new parts, new vars scalings.
410 proc generate_scale_self {fid type} {
411 global gmvect
412
413 generate_header $fid $type scale_self
414 if {[llength $gmvect(oldisavar)] || [llength $gmvect(oldisa)]} {
415 generate_run $fid $type $gmvect(ancestor) :: scale_self
416 }
417
418 foreach child $gmvect(newisa) {
419 generate_run $fid $type $child . scale_self
420 }
421
422 if {[llength $gmvect(newisavar)]} {
423 if {$gmvect(comment)} {
424 puts $fid \
425 "\t(* .nominal assignments may need value/units corrected for 1.0e-4."
426 puts $fid "\t * Some .nominal assignments may need to be deleted."
427 puts $fid "\t *)"
428 }
429 }
430 foreach child $gmvect(newisavar) {
431 generate_NominaL $fid $type $child
432 }
433
434 generate_footer $fid $type scale_self
435 }
436
437 # call bound_all on passed in parts, rebound passed in vars, call bound_self.
438 # whither boundwidth?
439 proc generate_bound_all {fid type} {
440 global gmvect
441
442 generate_header $fid $type bound_all
443 if {$gmvect(comment)} {
444 puts $fid \
445 "\t(* Array parts and variables need subscripts and FOR/DO loops."
446 puts $fid \
447 "\t * Generated code assumes boundwidth IS_A bound_width; in $type."
448 puts $fid \
449 "\t *)"
450 }
451
452 foreach child $gmvect(oldwillbe) {
453 generate_run $fid $type $child . bound_all
454 }
455 foreach child $gmvect(newwillbe) {
456 generate_run $fid $type $child . bound_all
457 }
458
459
460 if {[llength $gmvect(oldwillbevar)] || [llength $gmvect(newwillbevar)]} {
461 if {$gmvect(comment)} {
462 puts $fid "\t(* Bound assignments may need units corrected."
463 puts $fid "\t * Some assignments may need to be deleted or checked for"
464 puts $fid "\t * physical niceness. Replace with good physics if possible."
465 puts $fid "\t *)"
466 }
467 }
468 foreach child $gmvect(oldwillbevar) {
469 generate_BoundS $fid $type $child
470 }
471 foreach child $gmvect(newwillbevar) {
472 generate_BoundS $fid $type $child
473 }
474
475 generate_run $fid $type "" "" bound_self
476 generate_footer $fid $type bound_all
477 }
478
479 # call bound_self on IS_A'd parts, rebound IS_A'd vars
480 # call old boundself.
481 # whither boundwidth?
482 proc generate_bound_self {fid type} {
483 global gmvect
484
485 generate_header $fid $type bound_self
486 if {[llength $gmvect(oldisavar)] || [llength $gmvect(oldisa)]} {
487 generate_run $fid $type $gmvect(ancestor) :: bound_self
488 }
489 if {$gmvect(comment)} {
490 puts $fid \
491 "\t(* Array parts and variables need subscripts and FOR/DO loops."
492 puts $fid \
493 "\t * Generated code assumes boundwidth IS_A bound_width; in $type."
494 puts $fid \
495 "\t *)"
496 }
497
498 foreach child $gmvect(newisa) {
499 generate_run $fid $type $child . bound_self
500 }
501
502 if {[llength $gmvect(newisavar)] && $gmvect(comment)} {
503 puts $fid "\t(* Bound assignments may need units corrected."
504 puts $fid "\t * Some assignments may need to be deleted or checked for"
505 puts $fid "\t * physical niceness. Replace with good physics if possible."
506 puts $fid "\t *)"
507 }
508 foreach child $gmvect(newisavar) {
509 generate_BoundS $fid $type $child
510 }
511
512 generate_footer $fid $type bound_self
513 }
514
515 # call scale_all on passed in parts, rescale passed in vars, call scale_self.
516 proc generate_default_all {fid type} {
517 global gmvect
518
519 generate_header $fid $type default_all
520 if {$gmvect(comment)} {
521 puts $fid \
522 "\t(* Array parts and variables need subscripts, perhaps FOR/DO loops. *)"
523 }
524
525 foreach child $gmvect(oldwillbe) {
526 generate_run $fid $type $child . default_all
527 }
528 foreach child $gmvect(newwillbe) {
529 generate_run $fid $type $child . default_all
530 }
531
532
533 if {[llength $gmvect(oldwillbevar)] || [llength $gmvect(newwillbevar)]} {
534 if {$gmvect(comment)} {
535 puts $fid "\t(* Default assignments need to be corrected or deleted."
536 puts $fid "\t * Assignments to variables are incomplete."
537 puts $fid "\t *)"
538 }
539 }
540 foreach child $gmvect(oldwillbevar) {
541 generate_DefaulT $fid $type $child
542 }
543 foreach child $gmvect(newwillbevar) {
544 generate_DefaulT $fid $type $child
545 }
546
547 generate_run $fid $type "" "" default_self
548 generate_footer $fid $type default_all
549 }
550
551 proc generate_default_self {fid type} {
552 global gmvect
553
554 generate_header $fid $type default_self
555 if {[llength $gmvect(oldisavar)] || [llength $gmvect(oldisa)]} {
556 generate_run $fid $type $gmvect(ancestor) :: default_self
557 }
558
559 if {$gmvect(comment)} {
560 puts $fid \
561 "\t(* Array parts and variables need subscripts, perhaps FOR/DO loops. *)"
562 }
563 foreach child $gmvect(newisa) {
564 generate_run $fid $type $child . default_self
565 }
566
567 if {[llength $gmvect(newisavar)] && $gmvect(comment)} {
568 puts $fid "\t(* Default assignments need to be corrected or deleted."
569 puts $fid "\t * Assignments to variables are incomplete."
570 puts $fid "\t *)"
571 }
572 foreach child $gmvect(newisavar) {
573 generate_DefaulT $fid $type $child
574 }
575
576 generate_footer $fid $type default_self
577 }
578
579 # This method is hell. Runs reset for locally defined,
580 # unpassed parts and first found member of
581 # ascLibrVect(dofmethods) for parameters. reset should
582 # not be among dofmethods as we assume it.
583 proc generate_specify {fid type} {
584 global gmvect ascLibrVect
585
586 generate_header $fid $type specify
587 if {$gmvect(comment)} {
588 puts $fid "\t(* Boolean, integer, symbol, and set variables"
589 puts $fid "\t * controlling WHENs should be assigned here."
590 puts $fid "\t * Some variables may need .fixed := TRUE assigned."
591 puts $fid "\t *)"
592 }
593 set clist {}
594 foreach child $gmvect(oldwillbe) {
595 lappend clist $child
596 }
597 foreach child $gmvect(newwillbe) {
598 lappend clist $child
599 }
600 foreach child $clist {
601 set m [generate_dofname $type $child $ascLibrVect(dofmethods)]
602 if {[string compare $m ""]} {
603 generate_run $fid $type $child . $m
604 }
605 }
606 set clist {}
607 foreach child $gmvect(oldisa) {
608 lappend clist $child
609 }
610 foreach child $gmvect(newisa) {
611 lappend clist $child
612 }
613 foreach child $clist {
614 set m [generate_dofname $type $child $ascLibrVect(dofmethods)]
615 if {[string compare $m ""]} {
616 generate_run $fid $type $child . $m
617 }
618 }
619 generate_footer $fid $type specify
620 }
621

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22