« back to all changes in this revision
Viewing changes to src/gui.tcl
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Fernando Ike de Oliveira
- Date: 2006-02-07 22:45:12 UTC
- Revision ID: james.westby@ubuntu.com-20060207224512-k9up4q9l3ffs8qx8
Tags: upstream-0.6
Import upstream version 0.6
- files added:
- gerwinml
- src
- widgets
- widgets/icons
- widgets/tablelist
- widgets/tablelist/scripts
added
removed
src/gui.tcl
1
;# gui.tcl -- Gerwin
2
;#
3
;# GUI implementation
4
;#
5
;# Copyright (C) Jose E. Marchesi
6
;#
7
;# Time-stamp: "2003-11-11 14:45:16 jemarch"
8
9
;# This program is free software; you can redistribute it and/or
10
;# modify it under the terms of the GNU General Public License as
11
;# published by the Free Software Foundation; either version 2 of
12
;# the License, or (at your option) any later version.
13
14
;# This program is distributed in the hope that it will be useful,
15
;# but WITHOUT ANY WARRANTY; without even the implied warranty of
16
;# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17
;# GNU General Public License for more details.
18
19
;# You should have received a copy of the GNU General Public
20
;# License along with this program; if not, write to the Free
21
;# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
22
;# MA 02111-1307 USA
23
24
25
;#
26
;# gui_create_fonts
27
;#
28
;# Creates the default fonts for Gerwin
29
30
proc gui_create_fonts {} {
31
32
global gfonts
33
34
35
;# Default application font
36
set gfonts(default) \
37
[font create -family Helvetica -size 11]
38
39
40
;# Fonts for the ER Diagram
41
set gfonts(ercanvas_default) \
42
[font create -family Courier -size 8]
43
set gfonts(ercanvas_titles) \
44
[font create -family Courier -size 11]
45
set gfonts(ercanvas_minilabels) \
46
[font create -family Times -size 8]
47
}
48
49
50
;#
51
;# gui_gcanvas_make_zoom CANVAS FACTOR
52
;#
53
;# Makes a zoom on CANVAS, by FACTOR
54
;# Manages fonts sizes
55
;#
56
;# CANVAS can be er or td
57
58
proc gui_gcanvas_make_zoom {what_canvas factor} {
59
60
global gcanvas
61
global gcanvas_td
62
global gfonts
63
64
switch $what_canvas {
65
66
er {
67
68
;# First of all, scale the canvas itself
69
${gcanvas} scale all 0.0 0.0 $factor $factor
70
71
;# Scale the fonts
72
set fontfactor [expr ([font actual $gfonts(ercanvas_default) -size] \
73
* $factor)]
74
75
regsub {([0-9]+)\.[0-9]} $fontfactor "\\1" fontfactor
76
77
font configure $gfonts(ercanvas_default) \
78
-size $fontfactor
79
80
set fontfactor [expr ([font actual $gfonts(ercanvas_titles) -size] \
81
* $factor)]
82
83
regsub {([0-9]+)\.[0-9]} $fontfactor "\\1" fontfactor
84
85
font configure $gfonts(ercanvas_titles) \
86
-size $fontfactor
87
88
;# Reconfigure all entities and relations dimensions
89
90
}
91
92
td {
93
94
95
}
96
97
}
98
99
100
}
101
102
103
104
;#
105
;# gui_init WIDGET
106
;#
107
;# Initializes the gerwin widgets, into WIDGET
108
109
proc gui_init {widget} {
110
111
global fontselwidget
112
global gmainframe
113
global gcanvas
114
global gerwin_version
115
global gerwin_editionarea
116
global apparea
117
118
set gmainframe ${widget}
119
120
;# Title
121
wm title . "Gerwin $gerwin_version"
122
123
;# Create the fonts
124
gui_create_fonts
125
126
;# Make the mainframe
127
MainFrame ${gmainframe} -separator both \
128
-textvariable gerwin_state -menu [gui_create_mainmenu]
129
130
${gmainframe} addindicator -text "Tcl Gerwin"
131
${gmainframe} addindicator -text $gerwin_version
132
133
;# Create the button-area
134
set fbarea [${gmainframe} addtoolbar]
135
gui_create_button_area $fbarea
136
137
138
set userframe [${gmainframe} getframe]
139
140
141
;# Create the app area
142
gui_create_app_area ${userframe}.apparea
143
144
145
146
;# Create the edition area
147
;# The edition area is a notebook widget, that contain frames.
148
;# The first frame is that one with the project properties
149
150
;#set gerwin_editionarea ${userframe}.editionarea
151
;#gui_create_edition_area ${userframe}.editionarea
152
153
;# Launch the bindings
154
;#gui_launch_bindings
155
156
;#pack ${userframe}.editionarea -side top -fill x
157
pack ${gmainframe} -fill both -expand true
158
159
;# Now there is not any project opened, so disable all the buttons
160
;# except the one with new-project and the one with load-project
161
gui_no_project_opened
162
163
}
164
165
166
;#
167
;# gui_create_app_area WIDGET
168
;#
169
;# Create the app area with all the pages
170
171
proc gui_create_app_area {widget} {
172
173
global gmainframe
174
global apparea
175
global apptree
176
177
178
set userframe [${gmainframe} getframe]
179
180
;# Create the apptree
181
;# gui_create_apptree ${userframe}.apptree
182
183
;# Create the notebook
184
NoteBook ${userframe}.apparea
185
set apparea ${userframe}.apparea
186
187
;# Pack the apptree
188
;# pack ${apptree} -fill y -side left
189
190
;# Pack the apparea
191
pack ${apparea} -fill both -expand true -side right
192
193
}
194
195
196
;#
197
;# gui_create_apptree PATH
198
;#
199
;# Create the apptree at PATH
200
;#
201
202
proc gui_create_apptree {path} {
203
204
global apptree
205
206
set apptree $path
207
208
;# Create the Tree widget
209
Tree ${path} -showlines true -dragenabled false
210
211
;##############################
212
;# Create the application nodes
213
;##############################
214
215
;# Gerwin -> Settings at right
216
gui_apptree_insert 0 root Gerwin
217
218
}
219
220
;#
221
;# gui_apptree_insert INDEX PARENT NODE
222
;#
223
;# Insert NODe into the apptree
224
225
proc gui_apptree_insert {index parent node} {
226
227
global apptree
228
global gfonts
229
230
${apptree} insert $index $parent apptree-{$node} \
231
-text $node -font $gfonts(default) -image [Bitmap::get save]
232
233
234
}
235
236
237
;#
238
;# gui_app_area_raise_Project_page
239
;#
240
;# Raises the project page on the app area
241
242
proc gui_app_area_raise_Project_page {} {
243
244
global apparea
245
246
${apparea} raise Project
247
248
249
}
250
251
;#
252
;# gui_app_area_destroy_ER_page
253
;#
254
;# Destroys the app area TD page
255
256
proc gui_app_area_destroy_ER_page {} {
257
258
global apparea
259
260
${apparea} delete ER
261
262
263
}
264
265
266
;#
267
;# gui_app_area_destroy_TD_page
268
;#
269
;# Destroys the app area TD page
270
271
proc gui_app_area_destroy_TD_page {} {
272
273
global apparea
274
275
${apparea} delete TD
276
277
278
}
279
280
;#
281
;# gui_app_area_destroy_Output_page
282
;#
283
;# Destroys the app area Output page
284
285
proc gui_app_area_destroy_Output_page {} {
286
287
global apparea
288
289
${apparea} delete Output
290
291
292
}
293
294
;#
295
;# gui_app_area_destroy_Project_page
296
;#
297
;# Destroys the app area Project page
298
299
proc gui_app_area_destroy_Project_page {} {
300
301
global apparea
302
303
${apparea} delete Project
304
305
}
306
307
;#
308
;# gui_app_area_create_Project_page
309
;#
310
;# Creates the app area Project page, with page information
311
312
proc gui_app_area_create_Project_page {} {
313
314
global apparea
315
316
global gerwin_cproject_name
317
global gerwin_cproject_file
318
global gerwin_cproject_author
319
320
;# Create the new page, if it is not created
321
${apparea} insert 0 Project -text "Project"
322
${apparea} raise Project
323
324
;# Put here the project attributes
325
set widget [${apparea} getframe Project]
326
327
TitleFrame ${widget}.editframe -side center -text "Project Properties"
328
329
set editwidget [${widget}.editframe getframe]
330
331
;# Project name
332
frame ${editwidget}.nameline
333
LabelEntry ${editwidget}.nameline.label -label "Project Name:" -labelwidth 16 \
334
-textvariable gerwin_cproject_name \
335
-helptext "Name of the current project" -width 50
336
337
;# Project file
338
frame ${editwidget}.fileline
339
LabelEntry ${editwidget}.fileline.label -label "Project File:" -labelwidth 16 \
340
-textvariable gerwin_cproject_file \
341
-helptext "Storage file of the current project" -editable false \
342
-width 50
343
344
Button ${editwidget}.fileline.button -text "select file" \
345
-helptext "Select a file to store the project in" \
346
-command "set tempfile \[gui_select_file_to_save\] ; \
347
348
if {\$tempfile != {}} then {
349
set gerwin_cproject_file \$tempfile
350
gerwin_save_project_file
351
} " \
352
-relief groove
353
354
355
;# Project author
356
frame ${editwidget}.authorline
357
LabelEntry ${editwidget}.authorline.label -label "Project Author:" -labelwidth 16 \
358
-textvariable gerwin_cproject_author \
359
-helptext "Author of the current project" -width 50
360
361
pack ${editwidget}.nameline.label -side left -anchor w
362
pack ${editwidget}.nameline -side top -anchor w
363
364
pack ${editwidget}.fileline.label -side left -anchor w
365
pack ${editwidget}.fileline.button -side left
366
pack ${editwidget}.fileline -side top -anchor w
367
368
pack ${editwidget}.authorline.label -side left -anchor w
369
pack ${editwidget}.authorline -side top -anchor w
370
371
pack ${editwidget} -side left
372
373
pack ${widget}.editframe -side left -fill both -expand true
374
375
;# Scale the notebook
376
NoteBook::compute_size ${apparea}
377
378
379
}
380
381
;#
382
;# gui_app_area_raise_ER_page
383
;#
384
;# Raises the ER page
385
386
proc gui_app_area_raise_ER_page {} {
387
388
global apparea
389
390
${apparea} raise ER
391
392
}
393
394
;#
395
;# gui_app_area_raise_TD_page
396
;#
397
;# Raises the TD page
398
399
proc gui_app_area_raise_TD_page {} {
400
401
global apparea
402
403
${apparea} raise TD
404
405
406
}
407
408
409
410
;#
411
;# gui_app_area_raise_Output_page
412
;#
413
;# Raises the Output page
414
415
proc gui_app_area_raise_Output_page {} {
416
417
global apparea
418
419
${apparea} raise Output
420
421
}
422
423
424
;#
425
;# gui_app_area_create_Domain_page
426
;#
427
;# Create the app area Domain page, with the Domain Manager
428
429
proc gui_app_area_create_Domain_page {} {
430
431
global apparea
432
global gcanvas
433
434
;# Create the new page
435
${apparea} insert 0 Domain -text "Domains and Types"
436
437
438
;# Include here the new
439
440
}
441
442
443
;#
444
;# gui_app_area_destroy_Domain_page
445
;#
446
;# Delete the Domain page from the app area, and destroy its contents
447
448
proc gui_app_area_destroy_Domain_page {} {
449
450
global apparea
451
global gerwin_domains
452
global gerwin_domain
453
454
;# Delete the page and destroy the contents
455
${apparea} delete Domain
456
457
;# Purge all domains on the system
458
foreach d $gerwin_domains {
459
460
gob_domain_delete $d
461
462
}
463
set gerwin_domains {}
464
465
}
466
467
;#
468
;# gui_app_area_create_ER_page
469
;#
470
;# Create the app area ER page
471
472
proc gui_app_area_create_ER_page {} {
473
474
global apparea
475
global gcanvas
476
global gerwin_editionarea
477
478
;# Buttons globals
479
global gui_button_bbox_elements
480
global gui_button_bbox_tools
481
global gui_button_bbox_print_ER
482
global gui_button_bbox_zoom_ER
483
484
485
;# Create the new page
486
${apparea} insert end ER -text "ER Diagram"
487
488
;# Now, the scrolled canvas and the editionarea into two paned windows
489
set pw [${apparea} getframe ER].pw
490
PanedWindow $pw -side left -weights extra
491
492
;# Frame for the ER toolbar and scrolled canvas
493
;# Create the toolbar for ER
494
set erframe [${pw} add]
495
frame ${erframe}.toolbar
496
set bbox [ButtonBox ${erframe}.toolbar.tb2 -spacing 0 -padx 1 -pady 1]
497
set gui_button_bbox_elements $bbox
498
499
$bbox add -text entity \
500
-helptype balloon -helptext "Insert a new entity object" \
501
-relief groove \
502
-command {gerwin_set_state "Inserting entity"}
503
504
$bbox add -text relation \
505
-helptype balloon -helptext "Insert a new relation object" \
506
-relief groove \
507
-command {gerwin_set_state "Inserting relation begin"}
508
509
Separator ${erframe}.toolbar.sep2 -orient vertical
510
511
512
set bbox [ButtonBox ${erframe}.toolbar.tb3 -spacing 0 -padx 1 -pady 1]
513
set gui_button_bbox_tools $bbox
514
515
$bbox add -text move \
516
-helptype balloon -helptext "Move an object" \
517
-relief groove \
518
-command {gerwin_set_state "Moving"}
519
520
$bbox add -text edit \
521
-helptype balloon -helptext "Edit the properties of an object" \
522
-relief groove \
523
-command {gerwin_set_state "Editing"}
524
525
$bbox add -text delete \
526
-helptype balloon -helptext "Delete an object" \
527
-command {gerwin_set_state "Deleting"} -relief groove
528
;#-image [Bitmap::get cut] -relief groove \
529
530
Separator ${erframe}.toolbar.sep1 -orient vertical
531
532
set bbox [ButtonBox ${erframe}.toolbar.tb7 -spacing 0 -padx 1 -pady 1]
533
set gui_button_bbox_print_ER $bbox
534
535
$bbox add -text "print" -helptype balloon \
536
-helptext "Print the ER diagram" \
537
-relief groove -command gerwin_print_ER
538
539
# set bbox [ButtonBox ${erframe}.toolbar.tb8 -spacing 0 -padx 1 -pady 1]
540
# set gui_button_bbox_zoom_ER $bbox
541
542
# $bbox add -text "+" -helptype balloon \
543
# -helptext "Positive zoom" \
544
# -relief groove -command [list gui_gcanvas_make_zoom er 1.1]
545
# $bbox add -text "-" -helptype balloon \
546
# -helptext "Negative zoom" \
547
# -relief groove -command [list gui_gcanvas_make_zoom er 0.9]
548
549
550
# Separator ${erframe}.toolbar.sep3 -orient vertical
551
552
pack ${erframe}.toolbar.tb2 -side left -anchor w
553
pack ${erframe}.toolbar.sep2 -side left -padx 4 -fill y
554
pack ${erframe}.toolbar.tb3 -side left -anchor w
555
pack ${erframe}.toolbar.sep1 -side left -padx 4 -fill y
556
pack ${erframe}.toolbar.tb7 -side left -anchor w
557
# pack ${erframe}.toolbar.sep3 -side left -padx 4 -fill y
558
# pack ${erframe}.toolbar.tb8 -side left -anchor w
559
560
gui_create_scrolled_canvas [frame ${erframe}.fcanvas] ;#-bg white
561
set gcanvas ${erframe}.fcanvas.canvas
562
563
pack ${erframe}.toolbar -side top -fill x
564
pack ${erframe}.fcanvas -side top -fill both -expand true
565
566
;# Set the canvas enter and leave bindings
567
bind ${gcanvas} <Enter> gui_enter_canvas_bind
568
bind ${gcanvas} <Leave> gui_leave_canvas_bind
569
570
;# Set the canvas dimensions bindings
571
bind . <Key-Right> gui_expand_canvas_to_right
572
bind . <Key-Down> gui_expand_canvas_to_down
573
bind . <Key-Left> gui_shrink_canvas_to_left
574
bind . <Key-Up> gui_shrink_canvas_to_up
575
576
;# Create the editionarea
577
set gerwin_editionarea [${pw} add].editionarea
578
gui_create_edition_area ${gerwin_editionarea}
579
580
581
;# Pack it
582
pack ${gerwin_editionarea} -side bottom -fill x
583
584
;# Pack it
585
pack ${erframe} -fill both -expand true
586
pack ${pw} -fill both -expand true
587
588
;# Update the notebook size
589
NoteBook::compute_size ${apparea}
590
}
591
592
;#
593
;# gui_app_area_create_TD_page
594
;#
595
;# Create the app area TD page
596
597
proc gui_app_area_create_TD_page {} {
598
599
global apparea
600
global gcanvas_td
601
602
;# Buttons globals
603
global gui_button_bbox_print_TD
604
global gui_button_bbox_gen_TD
605
606
;# Create the new page
607
${apparea} insert end TD -text "Table Diagram"
608
609
set bbutton_frame [frame [${apparea} getframe TD].toolbar]
610
611
set bbox [ButtonBox ${bbutton_frame}.tb1 -spacing 0 -padx 1 -pady 1]
612
set gui_button_bbox_gen_TD $bbox
613
614
$bbox add -text "Update" \
615
-helptype balloon -helptext "Generate the table diagram" \
616
-relief groove -command {gen_ER_to_TD}
617
618
Separator ${bbutton_frame}.sep1 -orient vertical
619
620
set bbox [ButtonBox ${bbutton_frame}.tb2 -spacing 0 -padx 1 -pady 1]
621
set gui_button_bbox_print_TD $bbox
622
623
$bbox add -text "print" -helptype balloon \
624
-helptext "Print the Table diagram" \
625
-relief groove -command gerwin_print_TD
626
627
pack ${bbutton_frame}.tb1 -side left -anchor w
628
pack ${bbutton_frame}.sep1 -side left -padx 4 -fill y
629
pack ${bbutton_frame}.tb2 -side left -anchor w
630
631
632
set erframe [frame [${apparea} getframe TD].fcanvas]
633
gui_create_scrolled_canvas ${erframe}
634
635
set gcanvas_td ${erframe}.canvas
636
637
;# Set the canvas enter and leave bindings
638
bind ${gcanvas_td} <Enter> {. configure -cursor fleur}
639
bind ${gcanvas_td} <Leave> {. configure -cursor ""}
640
641
;# Set the bind for marking
642
${gcanvas_td} bind all <Button-1> {gui_mark_td %x %y}
643
644
;# Pack it
645
pack ${bbutton_frame} -fill x
646
pack ${erframe} -fill both -expand true
647
648
}
649
650
;#
651
;# gui_app_area_create_Output_page
652
;#
653
;# Create the app area Output page
654
655
proc gui_app_area_create_Output_page {} {
656
657
global apparea
658
global gtext_output
659
global gerwin_output_formats
660
global gerwin_output_active_format
661
global output_pages
662
global output_pages_widget
663
664
;# Buttons globals
665
global gui_button_bbox_gen_output
666
667
;# Create the new page
668
${apparea} insert end Output -text "Output"
669
670
;# Create the toolbar
671
set bbutton_frame [frame [${apparea} getframe Output].toolbar]
672
set bbox [ButtonBox ${bbutton_frame}.tb1 -spacing 0 -padx 1 -pady 1]
673
set gui_button_bbox_gen_output $bbox
674
675
$bbox add -text "Create output" \
676
-helptype balloon -helptext "Generate the selected output format" \
677
-relief groove -command "gen_TD_to_Output \$gerwin_output_active_format"
678
679
680
;# Replace it with a ComboBox
681
Label ${bbutton_frame}.label -text "output format: "
682
ComboBox ${bbutton_frame}.formats -values $gerwin_output_formats -expand tab \
683
-editable false \
684
-modifycmd "set gerwin_output_active_format \[lindex \$gerwin_output_formats \[${bbutton_frame}.formats getvalue\]\]"
685
686
687
pack ${bbutton_frame}.label -side left -anchor w
688
pack ${bbutton_frame}.formats -side left
689
pack ${bbutton_frame}.tb1 -side left -anchor w -padx 4
690
691
;# Now, create the notebook with the several output gtexts
692
set outputs [NoteBook [${apparea} getframe Output].nb]
693
set output_pages_widget $outputs
694
695
;# Pack it
696
pack ${bbutton_frame} -fill x
697
pack ${outputs} -fill both -expand true
698
;#pack ${erframe} -fill both -expand true
699
}
700
701
702
;#
703
;# gui_destroy_output_page FORMAT
704
;#
705
;# Destroy the FORMAT output page
706
707
proc gui_destroy_output_page {format} {
708
709
global output_pages
710
global output_pages_widget
711
global gtext_output
712
713
;# First of all, clean output_pages and gtext_output(FORMAT)
714
set index [lsearch $output_pages $format]
715
set output_pages [lreplace $output_pages $index $index]
716
717
unset gtext_output($format)
718
719
;# Ok, then destroy the widget
720
${output_pages_widget} delete $format
721
722
723
}
724
725
;#
726
;# gui_create_output_page FORMAT
727
;#
728
;# Creates a new output page for FORMAT on the output_pages_widget notebook
729
730
proc gui_create_output_page {format} {
731
732
global output_pages
733
global output_pages_widget
734
global gtext_output
735
global gerwin_output_active_format
736
737
738
;# First of all, update output_pages
739
lappend output_pages $format
740
741
;# Second, create the page into the notebook
742
${output_pages_widget} insert end $format -text $format
743
744
;# Good. Next, create the button bar
745
set toolbar [frame [${output_pages_widget} getframe $format].toolbar]
746
747
;# Update button
748
set bbox [ButtonBox ${toolbar}.tb3 -spacing 0 -padx 1 -pady 1]
749
750
$bbox add -text update \
751
-helptype balloon -helptext "Update this output from the tables" \
752
-relief groove \
753
-command "set ftemp \$gerwin_output_active_format
754
set gerwin_output_active_format $format
755
gen_TD_to_Output $format
756
set gerwin_output_active_format \$ftemp"
757
758
Separator ${toolbar}.sep3 -orient vertical
759
760
;# Save and print buttons
761
set bbox [ButtonBox ${toolbar}.tb1 -spacing 0 -padx 1 -pady 1]
762
763
$bbox add -text save \
764
-helptype balloon -helptext "Save this output to a file" \
765
-relief groove \
766
-command [list gerwin_save_output_file $format]
767
768
# $bbox add -text print \
769
# -helptype balloon -helptext "Print this output to a printer" \
770
# -relief groove \
771
# -command [list gerwin_print_output $format]
772
773
;# Close page button
774
set bbox [ButtonBox ${toolbar}.tb2 -spacing 0 -padx 1 -pady 1]
775
776
$bbox add -text close \
777
-helptype balloon -helptext "Close this output page" \
778
-relief groove \
779
-command [list gui_destroy_output_page $format]
780
781
782
pack ${toolbar}.tb3 -side left -anchor w
783
pack ${toolbar}.sep3 -side left
784
pack ${toolbar}.tb1 -side left -anchor w
785
pack ${toolbar}.tb2 -side right -anchor w
786
787
;# Now create the scrolled text
788
set stext [frame [${output_pages_widget} getframe $format].stext]
789
790
gui_create_scrolled_text ${stext}
791
792
;# Pack it
793
pack ${toolbar} -side top -fill x
794
pack ${stext} -side top -fill both -expand true
795
796
;# Finally, raise the page and update gtext_output
797
${output_pages_widget} raise $format
798
set gtext_output($format) ${stext}.text
799
800
;# Put the background
801
$gtext_output($format) configure -bg white
802
803
;# Make the text widget not editable
804
$gtext_output($format) configure -state disabled
805
}
806
807
808
;#
809
;# gui_enter_canvas_bind
810
;#
811
812
proc gui_enter_canvas_bind {} {
813
814
global gerwin_state
815
816
;# Change the cursor
817
switch $gerwin_state {
818
819
"Inserting entity" {
820
821
. configure -cursor crosshair
822
823
}
824
"Inserting relation begin" {
825
826
. configure -cursor left_side
827
828
}
829
830
"Inserting relation end" {
831
832
. configure -cursor right_side
833
834
}
835
836
Deleting {
837
838
. configure -cursor pirate
839
840
}
841
842
Moving {
843
844
. configure -cursor fleur
845
846
}
847
848
Editing {
849
850
. configure -cursor hand1
851
}
852
853
854
default {
855
856
. configure -cursor ""
857
}
858
859
}
860
861
862
}
863
864
;#
865
;# gui_leave_canvas_bind
866
;#
867
868
proc gui_leave_canvas_bind {} {
869
870
. configure -cursor ""
871
872
}
873
874
875
876
;#
877
;# gui_update_font FONT
878
;#
879
;# Updates the application global font
880
881
proc gui_update_font {newfont} {
882
883
global gui_font
884
global fontselwidget
885
global gmainframe
886
887
. configure -cursor watch
888
889
;# Update the fonts of all widgets
890
if { $gui_font != $newfont } then {
891
892
$fontselwidget configure -font $newfont
893
set gui_font $newfont
894
}
895
896
. configure -cursor ""
897
898
}
899
900
;#
901
;# gui_create_edition_area WIDGET
902
;#
903
;# Creates the edition area
904
905
proc gui_create_edition_area {widget} {
906
907
;# Create the notebook
908
NoteBook ${widget}
909
910
}
911
912
913
914
915
;#
916
;# gui_create_mainmenu
917
;#
918
;# Create the main menu string
919
920
proc gui_create_mainmenu {} {
921
922
923
;# Prepare the menu
924
set mainmenu {
925
"&Gerwin" {} {} 0 {
926
{separator}
927
{command "&Exit Gerwin" {} "exit the application" {Ctrl e} -command gerwin_quit}
928
}
929
930
"&Project" {} {} 0 {
931
{command "&New Project" {} "new project" {Ctrl n} -command gerwin_new_project}
932
{command "&Open Project" {} "open a new project" {Ctrl o} -command gerwin_open_project}
933
{command "&Save Project" {} "save the current project" {Ctrl s} -command gerwin_save_project}
934
{command "&Close Project" {} "close the current project" {Ctrl c} -command gerwin_close_project}
935
}
936
937
}
938
939
return $mainmenu
940
941
}
942
943
;#
944
;# gui_create_button_area WIDGET
945
;#
946
;# Create the button area widget
947
;#
948
949
proc gui_create_button_area {widget} {
950
951
global gui_button_bbox_project
952
953
global gerwin_output_formats
954
955
;# Project area
956
set bbox [ButtonBox ${widget}.tb1 -spacing 0 -padx 1 -pady 1]
957
set gui_button_bbox_project $bbox
958
959
$bbox add -text "new" -helptype balloon \
960
-helptext "New project" \
961
-relief groove \
962
-command "gerwin_new_project"
963
964
$bbox add -text "open" -helptype balloon \
965
-helptext "Open a project" \
966
-relief groove \
967
-command "gerwin_open_project"
968
969
$bbox add -text "save" -helptype balloon \
970
-helptext "Save the current project" \
971
-relief groove \
972
-command "gerwin_save_project"
973
974
975
pack ${widget}.tb1 -side left -anchor w
976
977
978
# set bbox [ButtonBox ${widget}.tb5 -spacing 0 -padx 1 -pady 1]
979
# set gui_button_bbox_ssql $bbox
980
981
# $bbox add -text "save sql" \
982
# -helptype balloon -helptext "Saves the SQL list" \
983
# -relief groove -command {gerwin_save_sql}
984
985
}
986
987
;#
988
;# gui_create_scrolled_text FRAME ARGS
989
;#
990
;# Create a scrolled text widget
991
992
proc gui_create_scrolled_text {widget args} {
993
994
995
;# Create the text widget
996
eval {text ${widget}.text \
997
-xscrollcommand [list ${widget}.xscroll set] \
998
-yscrollcommand [list ${widget}.yscroll set] \
999
-borderwidth 0} $args
1000
1001
;# Create the scroll widgets
1002
scrollbar ${widget}.xscroll -orient horizontal \
1003
-command [list ${widget}.text xview]
1004
scrollbar ${widget}.yscroll -orient vertical \
1005
-command [list ${widget}.text yview]
1006
1007
;# Pack the widgets
1008
grid ${widget}.text ${widget}.yscroll -sticky news
1009
grid ${widget}.xscroll -sticky ew
1010
grid rowconfigure ${widget} 0 -weight 1
1011
grid columnconfigure ${widget} 0 -weight 1
1012
1013
}
1014
1015
1016
;#
1017
;# gui_shrink_canvas_to_left
1018
;#
1019
1020
proc gui_shrink_canvas_to_left {} {
1021
1022
global gcanvas
1023
1024
set sarea [${gcanvas} cget -scrollregion]
1025
1026
${gcanvas} configure -scrollregion \
1027
[list [lindex $sarea 0] [lindex $sarea 1] \
1028
[expr [lindex $sarea 2] - 100] [lindex $sarea 3]]
1029
1030
1031
}
1032
1033
1034
1035
;#
1036
;# gui_expand_canvas_to_right
1037
;#
1038
1039
proc gui_expand_canvas_to_right {} {
1040
1041
global gcanvas
1042
1043
set sarea [${gcanvas} cget -scrollregion]
1044
1045
${gcanvas} configure -scrollregion \
1046
[list [lindex $sarea 0] [lindex $sarea 1] \
1047
[expr [lindex $sarea 2] + 100] [lindex $sarea 3]]
1048
1049
1050
}
1051
1052
1053
;#
1054
;# gui_shrink_canvas_to_up
1055
;#
1056
1057
proc gui_shrink_canvas_to_up {} {
1058
1059
global gcanvas
1060
1061
set sarea [${gcanvas} cget -scrollregion]
1062
1063
${gcanvas} configure -scrollregion \
1064
[list [lindex $sarea 0] [lindex $sarea 1] \
1065
[lindex $sarea 2] [expr [lindex $sarea 3] - 100]]
1066
1067
1068
}
1069
1070
1071
;#
1072
;# gui_expand_canvas_to_down
1073
;#
1074
1075
proc gui_expand_canvas_to_down {} {
1076
1077
global gcanvas
1078
1079
set sarea [${gcanvas} cget -scrollregion]
1080
1081
${gcanvas} configure -scrollregion \
1082
[list [lindex $sarea 0] [lindex $sarea 1] \
1083
[lindex $sarea 2] [expr [lindex $sarea 3] + 100]]
1084
1085
1086
}
1087
1088
;#
1089
;# gui_create_scrolled_canvas FRAME ARGS
1090
;#
1091
;# Create a scrolled canvas widget
1092
1093
proc gui_create_scrolled_canvas { widget args } {
1094
1095
1096
;# Create the canvas widget
1097
eval {canvas ${widget}.canvas \
1098
-xscrollcommand [list ${widget}.xscroll set] \
1099
-yscrollcommand [list ${widget}.yscroll set] \
1100
-highlightthickness 0 \
1101
-borderwidth 0 -bg white} $args
1102
1103
;# Create the scroll widgets
1104
scrollbar ${widget}.xscroll -orient horizontal \
1105
-command [list ${widget}.canvas xview]
1106
scrollbar ${widget}.yscroll -orient vertical \
1107
-command [list ${widget}.canvas yview]
1108
1109
;# Pack the widgets (with grid)
1110
grid ${widget}.canvas ${widget}.yscroll -sticky news
1111
grid ${widget}.xscroll -sticky ew
1112
grid rowconfigure ${widget} 0 -weight 1
1113
grid columnconfigure ${widget} 0 -weight 1
1114
1115
}
1116
1117
1118
;#
1119
;# gui_change_state TEXT
1120
;#
1121
;# Change the state to TEXT
1122
;# Now this is a nop
1123
1124
proc gui_change_state {text} {
1125
1126
1127
}
1128
1129
;#
1130
;# gui_yes_no_cancel TEXT
1131
;#
1132
1133
proc gui_yes_no_cancel {text} {
1134
1135
global gmainframe
1136
1137
MessageDlg ${gmainframe}.notice -title "I am asking you, dude!" -justify left -icon info \
1138
-message $text -type yesnocancel
1139
1140
}
1141
1142
1143
;#
1144
;# gui_notice TEXT
1145
;#
1146
;# Notice about something.
1147
1148
proc gui_notice {text} {
1149
1150
global gmainframe
1151
1152
MessageDlg ${gmainframe}.notice -title "Notice" -justify left -icon info \
1153
-message $text -type ok
1154
}
1155
1156
;#
1157
;# gui_fatal TEXT
1158
;#
1159
;# Notice a fatal error and exit
1160
1161
proc gui_fatal {text} {
1162
1163
global gmainframe
1164
1165
toplevel ${gmainframe}.fatal -bg red
1166
1167
label ${gmainframe}.fatal.label -text "Fatal Error: $text" \
1168
-bg red -fg white
1169
button ${gmainframe}.fatal.button -text "Quit Gerwin" \
1170
-command {exit}
1171
1172
pack ${gmainframe}.fatal.label -side top
1173
pack ${gmainframe}.fatal.button -side top
1174
1175
focus ${gmainframe}.fatal
1176
}
1177
1178
1179
;#
1180
;# gui_project_opened
1181
;#
1182
;# Enables some buttons and canvas and text backgrounds
1183
1184
proc gui_project_opened {} {
1185
1186
global gui_button_bbox_project
1187
global gui_button_bbox_elements
1188
global gui_button_bbox_tools
1189
global gui_button_bbox_gen_TD
1190
global gui_button_bbox_gen_output
1191
global gui_button_bbox_gen_GerwinML
1192
global gui_button_bbox_ssql
1193
global gui_button_bbox_print_ER
1194
global gui_button_bbox_print_TD
1195
1196
global gcanvas
1197
global gcanvas_td
1198
global gtext_sql
1199
1200
;# Enable some buttons
1201
1202
# $gui_button_bbox_project itemconfigure 0 -state active ;# New Project
1203
# $gui_button_bbox_project itemconfigure 1 -state active ;# Open Project
1204
$gui_button_bbox_project itemconfigure 2 -state active ;# Save project
1205
# ;#$gui_button_bbox_project itemconfigure 3 -state active ;# Close project
1206
1207
# $gui_button_bbox_elements itemconfigure 0 -state active ;# Insert entity
1208
# $gui_button_bbox_elements itemconfigure 1 -state active ;# Insert relation
1209
# ;#$gui_button_bbox_elements itemconfigure 2 -state active ;# Insert label
1210
1211
# $gui_button_bbox_tools itemconfigure 0 -state active ;# Move
1212
# $gui_button_bbox_tools itemconfigure 1 -state active ;# Edit properties
1213
# $gui_button_bbox_tools itemconfigure 2 -state active ;# Delete
1214
1215
# $gui_button_bbox_gen_TD itemconfigure 0 -state active ;# Generate tables
1216
# $gui_button_bbox_gen_output itemconfigure 0 -state active ;# Generate Output
1217
1218
# ;#$gui_button_bbox_ssql itemconfigure 0 -state active ;# Save SQL
1219
1220
# $gui_button_bbox_print_ER itemconfigure 0 -state active ;# Print ER
1221
# $gui_button_bbox_print_TD itemconfigure 0 -state active ;# Print TD
1222
1223
# ;# Change some backgrounds
1224
# ${gcanvas} configure -bg white
1225
# ${gcanvas_td} configure -bg white
1226
1227
1228
;# Create the app area pages
1229
;#gui_app_area_create_Domain_page
1230
gui_app_area_create_Project_page
1231
gui_app_area_create_ER_page
1232
gui_app_area_create_TD_page
1233
gui_app_area_create_Output_page
1234
1235
;# Launch the bindings
1236
gui_launch_bindings
1237
1238
;# Set the editing state
1239
gerwin_set_state Editing
1240
}
1241
1242
1243
1244
;#
1245
;# gui_no_project_opened
1246
;#
1247
;# Disables some buttons and the color of some objects
1248
1249
proc gui_no_project_opened {} {
1250
1251
global gui_button_bbox_project
1252
global gui_button_bbox_elements
1253
global gui_button_bbox_tools
1254
global gui_button_bbox_gen_TD
1255
global gui_button_bbox_gen_output
1256
global gui_button_bbox_gen_GerwinML
1257
global gui_button_bbox_ssql
1258
global gui_button_bbox_print_ER
1259
global gui_button_bbox_print_TD
1260
1261
global gcanvas
1262
global gcanvas_td
1263
global gtext_sql
1264
1265
;# Disable some buttons
1266
1267
$gui_button_bbox_project itemconfigure 2 -state disabled ;# Save project
1268
;#$gui_button_bbox_project itemconfigure 3 -state disabled ;# Close project
1269
1270
# $gui_button_bbox_elements itemconfigure 0 -state disabled ;# Insert entity
1271
# $gui_button_bbox_elements itemconfigure 1 -state disabled ;# Insert relation
1272
;#$gui_button_bbox_elements itemconfigure 2 -state disabled ;# Insert label
1273
1274
# $gui_button_bbox_tools itemconfigure 0 -state disabled ;# Move
1275
# $gui_button_bbox_tools itemconfigure 1 -state disabled ;# Edit properties
1276
# $gui_button_bbox_tools itemconfigure 2 -state disabled ;# Delete
1277
1278
# $gui_button_bbox_gen_TD itemconfigure 0 -state disabled ;# Gen TD
1279
# $gui_button_bbox_gen_output itemconfigure 0 -state disabled ;# Gen Output
1280
1281
# ;#$gui_button_bbox_ssql itemconfigure 0 -state disabled
1282
1283
# $gui_button_bbox_print_ER itemconfigure 0 -state disabled ;# Print ER
1284
# $gui_button_bbox_print_TD itemconfigure 0 -state disabled ;# Print TD
1285
1286
1287
# ;# Change the color of the canvas and text widget to grey
1288
# ${gcanvas} configure -bg grey
1289
# ${gcanvas_td} configure -bg grey
1290
;#${gtext_sql} configure -bg grey
1291
}
1292
1293
;#
1294
;# gui_launch_bindings
1295
;#
1296
;# Launch the bindings of the canvas
1297
1298
proc gui_launch_bindings {} {
1299
1300
global gcanvas
1301
global gmainframe
1302
1303
set userframe [${gmainframe} getframe]
1304
1305
;# The button-1 (mark) binding
1306
${gcanvas} bind all <Button-1> {gui_mark %x %y}
1307
1308
}
1309
1310
;#
1311
;# gui_drag XPOS YPOS
1312
;#
1313
;# Event to mouse-drag-1 on the canvas
1314
1315
proc gui_drag {xpos ypos} {
1316
1317
global gerwin_state
1318
global gmainframe
1319
global gerwin_premov_x
1320
global gerwin_premov_y
1321
global gerwin_premov_object
1322
global gerwin_obj_moving
1323
global gerwin_obj_type_moving
1324
global gm_entity
1325
global gm_relation
1326
global gerwin_relation
1327
global gcanvas
1328
1329
;# See if we are really moving
1330
if {$gerwin_state != "Moving"} then {
1331
return
1332
}
1333
1334
set userframe [${gmainframe} getframe]
1335
1336
;# Map from view coordinates to canvas coordinates
1337
set xpos [${gcanvas} canvasx $xpos]
1338
set ypos [${gcanvas} canvasy $ypos]
1339
1340
1341
;# Move the current object
1342
set dx [expr $xpos - $gerwin_premov_x]
1343
set dy [expr $ypos - $gerwin_premov_y]
1344
1345
;# Move the widget
1346
${gcanvas} move $gerwin_premov_object $dx $dy
1347
1348
1349
;# Actualize premov coordinates
1350
set gerwin_premov_x $xpos
1351
set gerwin_premov_y $ypos
1352
1353
;# Actualize the widget coordinates
1354
switch $gerwin_obj_type_moving {
1355
1356
1357
"Relation" {
1358
set gm_relation($gerwin_obj_moving,xpos) [lindex [${gcanvas} bbox \
1359
$gm_relation($gerwin_obj_moving,grouptag)] 0]
1360
set gm_relation($gerwin_obj_moving,ypos) [lindex [${gcanvas} bbox \
1361
$gm_relation($gerwin_obj_moving,grouptag)] 1]
1362
1363
1364
;# Update the links
1365
if {$gerwin_relation($gerwin_obj_moving,reflexive)} then {
1366
;# It is a reflexive relation
1367
gm_relation_update_links_reflexive $gerwin_obj_moving
1368
} else {
1369
;# Non-reflexive relation
1370
gm_relation_update_links $gerwin_obj_moving
1371
}
1372
1373
}
1374
1375
"Entity" {
1376
set gm_entity($gerwin_obj_moving,xpos) [lindex [${gcanvas} bbox \
1377
$gm_entity($gerwin_obj_moving,grouptag)] 0]
1378
set gm_entity($gerwin_obj_moving,ypos) [lindex [${gcanvas} bbox \
1379
$gm_entity($gerwin_obj_moving,grouptag)] 1]
1380
1381
;# Update all the links
1382
foreach r [gob_entity_get_relations $gerwin_obj_moving] {
1383
1384
if {$gerwin_relation($r,reflexive)} then {
1385
;# Reflexive relation
1386
gm_relation_update_links_reflexive $r
1387
} else {
1388
gm_relation_update_links $r
1389
}
1390
1391
}
1392
1393
}
1394
1395
}
1396
1397
}
1398
1399
1400
;#
1401
;# gui_drag_td XPOS YPOS
1402
;#
1403
;# Event to mouse-drag-1 on the TD canvas
1404
1405
proc gui_drag_td {xpos ypos} {
1406
1407
global gmainframe
1408
global gerwin_premov_x
1409
global gerwin_premov_y
1410
global gerwin_premov_object
1411
global gerwin_obj_moving
1412
global gerwin_obj_type_moving
1413
global gm_table
1414
1415
global gcanvas_td
1416
1417
;# We are always moving here
1418
;# (for now :P) [jemarch]
1419
1420
set userframe [${gmainframe} getframe]
1421
1422
;# Map from view coordinates to canvas coordinates
1423
set xpos [${gcanvas_td} canvasx $xpos]
1424
set ypos [${gcanvas_td} canvasy $ypos]
1425
1426
;# Move the current object
1427
set dx [expr $xpos - $gerwin_premov_x]
1428
set dy [expr $ypos - $gerwin_premov_y]
1429
1430
;# Actualize premov coordinates
1431
set gerwin_premov_x $xpos
1432
set gerwin_premov_y $ypos
1433
1434
;# Move the widget
1435
${gcanvas_td} move $gerwin_premov_object $dx $dy
1436
1437
;# Actualize the coordinates
1438
switch $gerwin_obj_type_moving {
1439
1440
"Flkey" {
1441
;# Get the name of the two linked tables
1442
regsub {(.+)-([^-]+)} $gerwin_obj_moving "\\1" rtable
1443
regsub {(.+)-([^-]+)} $gerwin_obj_moving "\\2" table
1444
1445
;# Update the position of the corresponding flkey
1446
gm_flkey_set_xpos $rtable $table [lindex [${gcanvas_td} bbox \
1447
"taggroup-Flkey-$rtable-$table"] 0]
1448
gm_flkey_set_ypos $rtable $table [lindex [${gcanvas_td} bbox \
1449
"taggroup-Flkey-$rtable-$table"] 1]
1450
1451
;# Update the links of the flkey
1452
1453
;# Delete old links
1454
foreach t [gob_table_get_foreign_keys $table] {
1455
1456
set rtable [lindex $t 1]
1457
1458
;#${gcanvas_td} delete "taggroup-Flkey-$rtable-$table"
1459
${gcanvas_td} delete "taggroup-Flkey-link-$rtable-$table"
1460
1461
}
1462
1463
;# For each foreign key
1464
foreach t [gob_table_get_foreign_keys $table] {
1465
1466
set nrtable [lindex $t 1]
1467
set rattribute [lindex $t 0]
1468
1469
if {$nrtable == $rtable} then {
1470
lappend rattributes($rtable) $rattribute
1471
}
1472
1473
}
1474
1475
gm_draw_link_td $table $rtable $rattributes($rtable)
1476
1477
}
1478
1479
1480
"Table" {
1481
1482
1483
1484
;# Actualize the table coordinates
1485
set gm_table($gerwin_obj_moving,xpos) [lindex [${gcanvas_td} bbox \
1486
$gm_table($gerwin_obj_moving,grouptag)] 0]
1487
set gm_table($gerwin_obj_moving,ypos) [lindex [${gcanvas_td} bbox \
1488
$gm_table($gerwin_obj_moving,grouptag)] 1]
1489
1490
;# Update the table links
1491
gm_table_update_links $gerwin_obj_moving
1492
}
1493
}
1494
1495
1496
}
1497
1498
1499
;#
1500
;# gui_mark_td XPOS YPOS
1501
;#
1502
;# Evento to mouse-pointer-1 on the td canvas
1503
1504
proc gui_mark_td {xpos ypos} {
1505
1506
global gmainframe
1507
global gerwin_tables
1508
global gerwin_premov_x
1509
global gerwin_premov_y
1510
global gerwin_premov_object
1511
global gerwin_obj_moving
1512
global gerwin_obj_type_moving
1513
1514
global gcanvas_td
1515
1516
set userframe [${gmainframe} getframe]
1517
1518
;# Get the coords onto the widget
1519
set xpos [${gcanvas_td} canvasx $xpos]
1520
set ypos [${gcanvas_td} canvasy $ypos]
1521
1522
;# Now, figure out what WGOB we want to delete
1523
set wgob [${gcanvas_td} find closest $xpos $ypos]
1524
1525
;# Get the taggroup from the WGOB
1526
set wgobtags [${gcanvas_td} gettags $wgob]
1527
set index [lsearch -glob $wgobtags "taggroup-*"]
1528
set taggroup [lindex $wgobtags $index]
1529
1530
;# Get the object name
1531
regsub {taggroup-([^-]+)-.+} $taggroup "\\1" gm_type
1532
1533
if {$gm_type == "Flkey"} then {
1534
1535
regsub {taggroup-[^-]+-(.+)} $taggroup "\\1" gm_name
1536
1537
} else {
1538
regsub {taggroup-.*-(.+)} $taggroup "\\1" gm_name
1539
}
1540
1541
set gerwin_obj_type_moving $gm_type
1542
set gerwin_obj_moving $gm_name
1543
1544
set gerwin_premov_x $xpos
1545
set gerwin_premov_y $ypos
1546
set gerwin_premov_object $taggroup
1547
}
1548
1549
1550
1551
;#
1552
;# gui_mark XPOS YPOS
1553
;#
1554
;# Event to mouse-pointer-1 on the canvas
1555
1556
proc gui_mark {xpos ypos} {
1557
1558
global gerwin_state
1559
global gmainframe
1560
global gerwin_entities
1561
global gerwin_relations
1562
global gerwin_relation
1563
global gerwin_premov_x
1564
global gerwin_premov_y
1565
global gerwin_premov_object
1566
global gerwin_entity_seq
1567
global gerwin_relation_seq
1568
global gerwin_obj_moving
1569
global gerwin_obj_type_moving
1570
global gui_entity1
1571
global gui_entity2
1572
global gcanvas
1573
global gm_entity
1574
global earea_pages
1575
1576
1577
set userframe [${gmainframe} getframe]
1578
1579
;# Switch over the actual state
1580
switch $gerwin_state {
1581
1582
"Inserting relation begin" {
1583
1584
;# Get the coords onto the widget
1585
set xpos [${gcanvas} canvasx $xpos]
1586
set ypos [${gcanvas} canvasy $ypos]
1587
1588
;# Figure out what WGOB is the first entity
1589
set wgob [${gcanvas} find closest $xpos $ypos]
1590
1591
;# Get the taggroup tag from the WGOB
1592
set wgobtags [${gcanvas} gettags $wgob]
1593
set index [lsearch -glob $wgobtags "taggroup-*"]
1594
set taggroup [lindex $wgobtags $index]
1595
1596
;# Get the object name and type from the taggroup
1597
regsub {taggroup-([^-]+)-.+} $taggroup "\\1" gm_type
1598
regsub {taggroup-[^-]+-(.+)} $taggroup "\\1" gm_name
1599
1600
;# Do nothing if this is not an entity
1601
if {$gm_type != "Entity"} then {
1602
1603
return
1604
1605
}
1606
1607
;# Set the first entity, and then switch to "Inserting relation end" state
1608
set gui_entity1 $gm_name
1609
1610
gerwin_set_state "Inserting relation end"
1611
1612
. configure -cursor right_side
1613
}
1614
1615
"Inserting relation end" {
1616
1617
;# Get the coords onto the widget
1618
set xpos [${gcanvas} canvasx $xpos]
1619
set ypos [${gcanvas} canvasy $ypos]
1620
1621
;# Figure out what WGOB is the first entity
1622
set wgob [${gcanvas} find closest $xpos $ypos]
1623
1624
;# Get the taggroup tag from the WGOB
1625
set wgobtags [${gcanvas} gettags $wgob]
1626
set index [lsearch -glob $wgobtags "taggroup-*"]
1627
set taggroup [lindex $wgobtags $index]
1628
1629
;# Get the object name and type from the taggroup
1630
regsub {taggroup-([^-]+)-.+} $taggroup "\\1" gm_type
1631
regsub {taggroup-[^-]+-(.+)} $taggroup "\\1" gm_name
1632
1633
if {$gm_type != "Entity"} then {
1634
1635
;# See if we are adding an entity to a n-relation
1636
if {$gm_type == "Relation"} then {
1637
1638
;# If the relation is reflexive, abort inmediatly
1639
if {$gerwin_relation($gm_name,reflexive)} then {
1640
gui_notice "You cannot add a new entity to a reflexive relation!"
1641
1642
;# Goto Editing state
1643
gerwin_set_state "Editing"
1644
1645
. configure -cursor hand1
1646
return
1647
}
1648
1649
;# If the entity is already part of the relation, abort inmediatly
1650
if {[lsearch -glob [gob_relation_get_entities $gm_name] "$gui_entity1 *"] != -1} then {
1651
gui_notice "Sorry, $gui_entity1 already have a link to $gm_name"
1652
1653
;# Goto Editing state
1654
gerwin_set_state "Editing"
1655
1656
. configure -cursor hand1
1657
return
1658
}
1659
1660
;# Add a link to gui_entity1 to the relation
1661
;# Cardinality is always _/N
1662
gob_relation_add_entity $gm_name $gui_entity1 1 N
1663
1664
;# Add the relation to the entity's relation list
1665
gob_entity_add_relation $gui_entity1 $gm_name
1666
1667
;# Now, all entities have cardinality 1/N
1668
;# The _ is a fake value
1669
foreach e [gob_relation_get_entities $gm_name] {
1670
set e [lindex $e 0]
1671
1672
gob_relation_set_entity_min_card $gm_name $e _
1673
gob_relation_set_entity_max_card $gm_name $e N
1674
1675
1676
}
1677
1678
;# Actualize the edition page for the relation
1679
;# But only if it visible
1680
if {[lsearch $earea_pages $gm_name] != -1} then {
1681
gui_edition_area_delete_page $gm_name
1682
gui_edit_relation $gm_name
1683
}
1684
1685
;# Update the links in the screen
1686
gm_relation_update_links $gm_name
1687
1688
;# Goto Editing state
1689
gerwin_set_state "Editing"
1690
1691
. configure -cursor hand1
1692
}
1693
1694
return
1695
}
1696
1697
;# Set the second entity
1698
set gui_entity2 $gm_name
1699
1700
;# Create the new relation
1701
set rname "relation$gerwin_relation_seq"
1702
incr gerwin_relation_seq
1703
gob_create_relation $rname {} {}
1704
gob_relation_add_entity $rname $gui_entity1 1 1
1705
gob_relation_add_entity $rname $gui_entity2 1 1
1706
1707
;# Add the relations to the entities
1708
if {$gui_entity1 == $gui_entity2} then {
1709
;# Reflexive relation
1710
set gerwin_relation($rname,reflexive) 1
1711
gob_entity_add_relation $gui_entity1 $rname
1712
} else {
1713
;# Non-reflexive relation
1714
gob_entity_add_relation $gui_entity1 $rname
1715
gob_entity_add_relation $gui_entity2 $rname
1716
}
1717
1718
;# Draw it
1719
;# Find an approximative good starting point
1720
1721
if {$gui_entity1 != $gui_entity2} then {
1722
;# Non reflexive relation
1723
set bbox1 [$gcanvas bbox taggroup-Entity-${gui_entity1}]
1724
set bbox2 [$gcanvas bbox taggroup-Entity-${gui_entity2}]
1725
1726
set rp1x [expr \
1727
[lindex $bbox1 0] + \
1728
(([lindex $bbox1 2] - [lindex $bbox1 0]) / 2)]
1729
1730
set rp1y [expr \
1731
[lindex $bbox1 1] + \
1732
(([lindex $bbox1 3] - [lindex $bbox1 1]) / 2)]
1733
1734
set rp2x [expr \
1735
[lindex $bbox2 0] + \
1736
(([lindex $bbox2 2] - [lindex $bbox2 0]) / 2)]
1737
1738
set rp2y [expr \
1739
[lindex $bbox2 1] + \
1740
(([lindex $bbox2 3] - [lindex $bbox2 1]) / 2)]
1741
1742
set spx \
1743
[expr ($rp1x + (($rp2x - $rp1x) / 2))]
1744
set spy \
1745
[expr ($rp1y + (($rp2y - $rp1y) / 2))]
1746
1747
} else {
1748
;# Reflexive relation
1749
set spx [expr $gm_entity($gui_entity1,xpos) + 100]
1750
set spy [expr $gm_entity($gui_entity1,ypos) - 50]
1751
1752
}
1753
1754
gm_draw_relation $rname $spx $spy
1755
1756
if {$gui_entity1 == $gui_entity2} then {
1757
;# Reflexive relation
1758
gm_relation_update_links_reflexive $rname
1759
} else {
1760
;# No reflexive relation
1761
gm_relation_update_links $rname
1762
}
1763
1764
;# Goto Editing state
1765
gerwin_set_state "Editing"
1766
1767
. configure -cursor hand1
1768
}
1769
1770
"Inserting entity" {
1771
1772
;# Get the coords onto the widget
1773
set xpos [${gcanvas} canvasx $xpos]
1774
set ypos [${gcanvas} canvasy $ypos]
1775
1776
;# Create a new entity, with a sequential name and
1777
;# Without any attribute, and with the key empty.
1778
set ename "entity$gerwin_entity_seq"
1779
incr gerwin_entity_seq
1780
gob_create_entity $ename {} {} {}
1781
1782
;# Draw it
1783
gm_draw_entity $ename $xpos $ypos
1784
1785
;# Goto Editing state
1786
gerwin_set_state "Editing"
1787
1788
. configure -cursor hand1
1789
1790
}
1791
1792
"Moving" {
1793
1794
;# Get the coords onto the widget
1795
set xpos [${gcanvas} canvasx $xpos]
1796
set ypos [${gcanvas} canvasy $ypos]
1797
1798
;# Now, figure out what WGOB we want to delete
1799
set wgob [${gcanvas} find closest $xpos $ypos]
1800
1801
1802
;# Get the taggroup tag from the WGOB
1803
set wgobtags [${gcanvas} gettags $wgob]
1804
set index [lsearch -glob $wgobtags "taggroup-*"]
1805
set taggroup [lindex $wgobtags $index]
1806
1807
;# Get the object name and type from the taggroup
1808
regsub {taggroup-([^-]+)-.+} $taggroup "\\1" gm_type
1809
regsub {taggroup-[^-]+-(.+)} $taggroup "\\1" gm_name
1810
1811
set gerwin_obj_moving $gm_name
1812
set gerwin_obj_type_moving $gm_type
1813
1814
set gerwin_premov_x $xpos
1815
set gerwin_premov_y $ypos
1816
set gerwin_premov_object $taggroup
1817
1818
}
1819
1820
"Editing" {
1821
1822
;# Get the coords onto the widget
1823
set xpos [${gcanvas} canvasx $xpos]
1824
set ypos [${gcanvas} canvasy $ypos]
1825
1826
;# Now, figure out what WGOB we want to delete
1827
set wgob [${gcanvas} find closest $xpos $ypos]
1828
1829
1830
;# Get the taggroup tag from the WGOB
1831
set wgobtags [${gcanvas} gettags $wgob]
1832
set index [lsearch -glob $wgobtags "taggroup-*"]
1833
set taggroup [lindex $wgobtags $index]
1834
1835
;# Get the object name and type from the taggroup
1836
regsub {taggroup-([^-]+)-.+} $taggroup "\\1" gm_type
1837
regsub {taggroup-[^-]+-(.+)} $taggroup "\\1" gm_name
1838
1839
;# Switch over the type
1840
switch $gm_type {
1841
1842
"Relation" {
1843
1844
gui_edit_relation $gm_name
1845
1846
}
1847
1848
"Entity" {
1849
1850
gui_edit_entity $gm_name
1851
1852
}
1853
}
1854
1855
}
1856
1857
"Deleting" {
1858
1859
;# Get the coords onto the widget
1860
set xpos [${gcanvas} canvasx $xpos]
1861
set ypos [${gcanvas} canvasy $ypos]
1862
1863
;# Now, figure out what WGOB we want to delete
1864
set wgob [${gcanvas} find closest $xpos $ypos]
1865
1866
1867
;# Get the taggroup tag from the WGOB
1868
set wgobtags [${gcanvas} gettags $wgob]
1869
set index [lsearch -glob $wgobtags "taggroup-*"]
1870
set taggroup [lindex $wgobtags $index]
1871
1872
;# Get the object name and type from the taggroup
1873
regsub {taggroup-([^-]+)-.+} $taggroup "\\1" gm_type
1874
regsub {taggroup-[^-]+-(.+)} $taggroup "\\1" gm_name
1875
1876
;# Switch over the type
1877
switch $gm_type {
1878
1879
"Relation" {
1880
;# Delete the relation from the canvas
1881
gm_delete_relation $gm_name
1882
1883
;# Delete the relation from all entities that haves that relation registered
1884
foreach e [gob_relation_get_entities $gm_name] {
1885
1886
gob_entity_delete_relation [lindex $e 0] $gm_name
1887
1888
}
1889
1890
;# Delete relation's links
1891
${gcanvas} delete "taggroup-Link-$gm_name"
1892
1893
;# Delete the GOB
1894
gob_delete_relation $gm_name
1895
1896
;# Delete the relation page from the editionarea
1897
gui_edition_area_delete_page $gm_name
1898
}
1899
1900
"Entity" {
1901
;# Delete the entity from the canvas
1902
gm_delete_entity $gm_name
1903
1904
;# Delete all relations with num_entities equal to two
1905
foreach r [gob_entity_get_relations $gm_name] {
1906
1907
if {[gob_relation_get_num_entities $r] == 2} then {
1908
1909
;# Delete the relation from the canvas
1910
gm_delete_relation $r
1911
1912
;# Delete the relation from all entities that haves that relation registered
1913
foreach e [gob_relation_get_entities $r] {
1914
1915
gob_entity_delete_relation [lindex $e 0] $r
1916
1917
}
1918
1919
;# Delete relation's links
1920
${gcanvas} delete "taggroup-Link-$r"
1921
1922
;# Delete the GOB
1923
gob_delete_relation $r
1924
1925
;# Delete the relation page from the editionarea
1926
gui_edition_area_delete_page $r
1927
1928
1929
} else {
1930
1931
;# Quit the entity from the relation
1932
gob_relation_delete_entity $r $gm_name
1933
1934
;# Update the relation links
1935
;# Note that this relation can not be reflexive
1936
gm_relation_update_links $r
1937
1938
}
1939
1940
}
1941
1942
;# Delete the GOB
1943
gob_delete_entity $gm_name
1944
1945
;# Delete the entity page from the editionarea
1946
gui_edition_area_delete_page $gm_name
1947
1948
}
1949
1950
1951
}
1952
}
1953
}
1954
1955
}
1956
1957
;#
1958
;# gui_edition_area_delete_page PNAME
1959
;#
1960
;# Deletes the page named PNAME from the edition area
1961
1962
proc gui_edition_area_delete_page {pname} {
1963
1964
global gmainframe
1965
global earea_pages
1966
global gerwin_editionarea
1967
1968
set userframe [${gmainframe} getframe]
1969
1970
;# Find the page to delete
1971
set index [lsearch $earea_pages $pname]
1972
1973
if {$index != -1} then {
1974
1975
set w [${gerwin_editionarea} getframe $pname]
1976
;#set w [${userframe}.editionarea getframe $pname]
1977
1978
1979
;# Delete the page from the list
1980
set earea_pages [lreplace $earea_pages $index $index]
1981
1982
;# Update the notebook
1983
${gerwin_editionarea} delete $pname
1984
;#${userframe}.editionarea delete $pname
1985
1986
;# Destroy the widgets
1987
destroy $w
1988
}
1989
1990
}
1991
1992
1993
;#
1994
;# gui_attribute_is_not_key LISTBOX ENTITY
1995
;#
1996
;# Remove the current LISTBOX selection from the ENTITY key
1997
1998
proc gui_attribute_is_not_key {lb entity} {
1999
2000
global gm_entity
2001
global gerwin_relation
2002
2003
set attribute [$lb curselection]
2004
2005
if {! [string equal $attribute ""]} then {
2006
2007
set attribute [$lb get $attribute]
2008
2009
gob_entity_delete_attribute_from_key $entity $attribute
2010
set xpos $gm_entity($entity,xpos)
2011
set ypos $gm_entity($entity,ypos)
2012
gm_delete_entity $entity
2013
gm_draw_entity $entity $xpos $ypos
2014
2015
foreach r [gob_entity_get_relations $entity] {
2016
2017
if {$gerwin_relation($r,reflexive)} then {
2018
gm_relation_update_links_reflexive $r
2019
} else {
2020
gm_relation_update_links $r
2021
}
2022
2023
}
2024
}
2025
}
2026
2027
;#
2028
;# gui_attribute_delete_relation LISTBOX RELATION
2029
;#
2030
;# Delete the LISTBOX selected attribute from RELATION
2031
2032
proc gui_attribute_delete_relation {lb relation} {
2033
2034
global gm_relation
2035
global gerwin_relation
2036
global gerwin_editionarea
2037
2038
set attribute [$lb curselection]
2039
2040
if {! [string equal $attribute ""]} then {
2041
2042
set attribute [$lb get $attribute]
2043
set vattribute $attribute
2044
2045
# Support delete or Edit
2046
set editframe [${gerwin_editionarea} getframe $relation]
2047
set aframe [${editframe}.attributes getframe]
2048
2049
${aframe}.nattribute.faux.ftop.label configure -text $vattribute
2050
2051
set dfr [${aframe}.nattribute.faux.fdown.domframe getframe]
2052
${dfr}.label configure -text [gob_relation_get_attribute_domain $relation $vattribute]
2053
2054
2055
2056
gob_relation_delete_attribute $relation $attribute
2057
set xpos $gm_relation($relation,xpos)
2058
set ypos $gm_relation($relation,ypos)
2059
gm_delete_relation $relation
2060
gm_draw_relation $relation $xpos $ypos
2061
gui_edition_area_delete_page $relation
2062
gui_edit_relation $relation
2063
2064
if {$gerwin_relation($relation,reflexive)} then {
2065
gm_relation_update_links_reflexive $relation
2066
} else {
2067
gm_relation_update_links $relation
2068
}
2069
2070
2071
}
2072
2073
}
2074
2075
2076
;#
2077
;# gui_attribute_delete_entity LISTBOX ENTITY
2078
;#
2079
;# Delete the LISTBOX selected attribute from ENTITY
2080
2081
proc gui_attribute_delete_entity {lb entity} {
2082
2083
global gm_entity
2084
global gerwin_relation
2085
global gerwin_editionarea
2086
2087
set attribute [$lb curselection]
2088
2089
2090
2091
if {! [string equal $attribute ""]} then {
2092
2093
set vattribute [$lb get $attribute]
2094
2095
# Support delete or Edit
2096
set editframe [${gerwin_editionarea} getframe $entity]
2097
set aframe [${editframe}.attributes getframe]
2098
2099
${aframe}.nattribute.faux.ftop.label configure -text $vattribute
2100
2101
set dfr [${aframe}.nattribute.faux.fdown.domframe getframe]
2102
${dfr}.label configure -text [gob_entity_get_attribute_domain $entity $vattribute]
2103
2104
2105
set attribute [$lb get $attribute]
2106
2107
gob_entity_delete_attribute $entity $attribute
2108
set xpos $gm_entity($entity,xpos)
2109
set ypos $gm_entity($entity,ypos)
2110
gm_delete_entity $entity
2111
gm_draw_entity $entity $xpos $ypos
2112
gui_edition_area_delete_page $entity
2113
gui_edit_entity $entity
2114
2115
foreach r [gob_entity_get_relations $entity] {
2116
2117
if {$gerwin_relation($r,reflexive)} then {
2118
gm_relation_update_links_reflexive $r
2119
} else {
2120
gm_relation_update_links $r
2121
}
2122
2123
}
2124
2125
}
2126
}
2127
2128
2129
;#
2130
;# gui_attribute_is_key LISTBOX ENTITY
2131
;#
2132
;# Add the attribute selected in LISTBOX as a new key on ENTITY
2133
2134
proc gui_attribute_is_key {lb entity} {
2135
2136
global gm_entity
2137
global gerwin_relation
2138
2139
set attribute [$lb curselection]
2140
2141
if {! [string equal $attribute ""]} then {
2142
2143
set attribute [$lb get $attribute]
2144
2145
;# We exit if the attribute is already a key
2146
if {[gob_entity_is_key $entity $attribute]} then {
2147
return
2148
}
2149
2150
2151
gob_entity_add_attribute_to_key $entity $attribute
2152
set xpos $gm_entity($entity,xpos)
2153
set ypos $gm_entity($entity,ypos)
2154
gm_delete_entity $entity
2155
gm_draw_entity $entity $xpos $ypos
2156
2157
foreach r [gob_entity_get_relations $entity] {
2158
2159
if {$gerwin_relation($r,reflexive)} then {
2160
gm_relation_update_links_reflexive $r
2161
} else {
2162
gm_relation_update_links $r
2163
}
2164
2165
}
2166
2167
}
2168
}
2169
2170
2171
;#
2172
;# gui_edit_relation_add_attribute RELATION
2173
;#
2174
;# Add a new attribute with ANAME and ADOMAIN to RELATION
2175
;#
2176
;# ANAME and ADOMAIN cannot be emtpy.
2177
;# All blanks in ANAME and ADOMAIN are transformed to "-" characters.
2178
2179
proc gui_edit_relation_add_attribute {relation} {
2180
2181
global gm_relation
2182
global gerwin_relation
2183
2184
set aname $gm_relation($relation,nattribute)
2185
set adomain $gm_relation($relation,ndomain)
2186
2187
;# First of all, make sure both ANAME and ADOMAIN are not empty
2188
if {($aname == "")} then {
2189
2190
gui_notice "Please fill the Name field if you want to add an attribute to the relation."
2191
return
2192
}
2193
2194
if {($adomain == "")} then {
2195
2196
gui_notice "Please fill the Domain field if you want to add an attribute to the relation."
2197
return
2198
}
2199
2200
;# Replace all blanks with scores
2201
set aname [string map {{ } -} $aname]
2202
set adomain [string map {{ } -} $adomain]
2203
2204
;# Add the attribute to the gob
2205
gob_relation_add_attribute $relation $aname $adomain
2206
2207
set gm_relation($relation,ndomain) {}
2208
set gm_relation($relation,nattribute) {}
2209
2210
set xpos $gm_relation($relation,xpos)
2211
set ypos $gm_relation($relation,ypos)
2212
2213
gm_delete_relation $relation
2214
gm_draw_relation $relation $xpos $ypos
2215
2216
if {$gerwin_relation($relation,reflexive)} then {
2217
2218
gm_relation_update_links_reflexive $relation
2219
2220
} else {
2221
2222
gm_relation_update_links $relation
2223
2224
}
2225
2226
gui_edition_area_delete_page $relation
2227
gui_edit_relation $relation
2228
2229
}
2230
2231
2232
2233
;#
2234
;# gui_edit_entity_add_attribute ENTITY
2235
;#
2236
;# Add a new attribute with ANAME and ADOMAIN to ENTITY
2237
;#
2238
;# ANAME and ADOMAIN cannot be emtpy.
2239
;# All blanks in ANAME and ADOMAIN are transformed to "-" characters.
2240
2241
proc gui_edit_entity_add_attribute {entity} {
2242
2243
global gm_entity
2244
global gerwin_relation
2245
2246
set aname $gm_entity($entity,nattribute)
2247
set adomain $gm_entity($entity,ndomain)
2248
2249
;# First of all, make sure both ANAME and ADOMAIN are not empty
2250
if {($aname == "")} then {
2251
2252
gui_notice "Please fill the Name field if you want to add an attribute to the entity."
2253
return
2254
}
2255
2256
if {($adomain == "")} then {
2257
2258
gui_notice "Please fill the Domain field if you want to add an attribute to the entity."
2259
return
2260
}
2261
2262
;# Replace all blanks with scores
2263
set aname [string map {{ } -} $aname]
2264
set adomain [string map {{ } -} $adomain]
2265
2266
;# Add the attribute to the gob
2267
gob_entity_add_attribute $entity $aname $adomain
2268
2269
set gm_entity($entity,ndomain) {}
2270
set gm_entity($entity,nattribute) {}
2271
2272
set xpos $gm_entity($entity,xpos)
2273
set ypos $gm_entity($entity,ypos)
2274
2275
gm_delete_entity $entity
2276
gm_draw_entity $entity $xpos $ypos
2277
2278
foreach r [gob_entity_get_relations $entity] {
2279
2280
if {$gerwin_relation($r,reflexive)} then {
2281
2282
gm_relation_update_links_reflexive $r
2283
2284
} else {
2285
2286
2287
gm_relation_update_links $r
2288
2289
}
2290
}
2291
2292
gui_edition_area_delete_page $entity
2293
gui_edit_entity $entity
2294
2295
}
2296
2297
2298
2299
2300
;#
2301
;# gui_edit_relation_change_name RELATION
2302
;#
2303
;# Changes the name of RELATION to gm_relation(RELATION,nname)
2304
2305
proc gui_edit_relation_change_name {relation} {
2306
2307
global gcanvas
2308
global gm_relation
2309
global earea_pages
2310
global gerwin_relation
2311
2312
;# See if the new name is empty
2313
if {$gm_relation($relation,nname) == ""} then {
2314
2315
gui_notice "The name of the relation cannot be empty!"
2316
return
2317
}
2318
2319
;# Change spaces for underscores
2320
set gm_relation($relation,nname) [string map {{ } _} $gm_relation($relation,nname)]
2321
2322
if {([gob_entity_exist $gm_relation($relation,nname)] ||
2323
[gob_relation_exist $gm_relation($relation,nname)])} then {
2324
2325
gui_notice "The name of any relation or entity must be unique in all the model!"
2326
return
2327
}
2328
2329
;# Change the name of the gob
2330
gob_relation_change_name $relation $gm_relation($relation,nname)
2331
set nname $gm_relation($relation,nname)
2332
gui_edition_area_delete_page $relation
2333
2334
gm_relation_change_name $relation $nname
2335
set gm_relation($relation,nname) {}
2336
2337
gui_edit_relation $nname
2338
2339
set xpos $gm_relation($nname,xpos)
2340
set ypos $gm_relation($nname,ypos)
2341
2342
gm_delete_relation $nname
2343
${gcanvas} delete taggroup-Link-$relation
2344
gm_draw_relation $nname $xpos $ypos
2345
2346
if {$gerwin_relation($nname,reflexive)} then {
2347
2348
gm_relation_update_links_reflexive $nname
2349
2350
} else {
2351
2352
gm_relation_update_links $nname
2353
}
2354
2355
2356
}
2357
2358
;#
2359
;# gui_edit_entity_change_name ENTITY
2360
;#
2361
;# Changes the name of ENTITY to gm_entity(ENTITY,nname)
2362
2363
2364
proc gui_edit_entity_change_name {entity} {
2365
2366
global gm_entity
2367
global earea_pages
2368
global gerwin_relation
2369
2370
;# See if the new name is empty
2371
if {$gm_entity($entity,nname) == ""} then {
2372
2373
gui_notice "The name of the entity cannot be empty!"
2374
return
2375
}
2376
2377
;# Change spaces for underscores
2378
set gm_entity($entity,nname) [string map {{ } _} $gm_entity($entity,nname)]
2379
2380
if {([gob_entity_exist $gm_entity($entity,nname)]) ||
2381
([gob_relation_exist $gm_entity($entity,nname)])} then {
2382
2383
gui_notice "The name of any entity or relation must be unique in all the model!"
2384
return
2385
}
2386
2387
;# Change the name of the gob
2388
gob_entity_change_name $entity $gm_entity($entity,nname)
2389
2390
set nname $gm_entity($entity,nname)
2391
gui_edition_area_delete_page $entity
2392
2393
;# Change the name in all relation edition areas
2394
foreach r [gob_entity_get_relations $nname] {
2395
2396
if {[lsearch $earea_pages $r] != -1} then {
2397
2398
gui_edition_area_delete_page $r
2399
gui_edit_relation $r
2400
}
2401
}
2402
2403
2404
gui_edit_entity $nname
2405
2406
set xpos $gm_entity($entity,xpos)
2407
set ypos $gm_entity($entity,ypos)
2408
2409
2410
gm_entity_change_name $entity $nname
2411
gm_delete_entity $nname
2412
gm_draw_entity $nname $xpos $ypos
2413
2414
foreach r [gob_entity_get_relations $nname] {
2415
2416
;# TODO: change to simply gm_relation_update_links
2417
if {$gerwin_relation($r,reflexive)} then {
2418
gm_relation_update_links_reflexive $r
2419
} else {
2420
gm_relation_update_links $r
2421
2422
}
2423
2424
}
2425
}
2426
2427
2428
;#
2429
;# gui_edit_entity ENTITY
2430
;#
2431
;# Edit all aspects of a given entity, in a page on the
2432
;# editionarea
2433
2434
proc gui_edit_entity {entity} {
2435
2436
global gmainframe
2437
global gerwin_entity
2438
global gm_entity
2439
global gm_relation
2440
global gerwin_relation
2441
2442
global earea_pages
2443
global gerwin_editionarea
2444
2445
set userframe [${gmainframe} getframe]
2446
2447
;# See if the entity already have a page in the edition area
2448
set index [lsearch $earea_pages $entity]
2449
if {$index != -1} then {
2450
2451
;# Make the page visible
2452
${gerwin_editionarea} raise [lindex $earea_pages $index]
2453
;#${userframe}.editionarea raise [lindex $earea_pages $index]
2454
2455
return
2456
2457
}
2458
2459
;# Create a new page for this entity
2460
lappend earea_pages $entity
2461
${gerwin_editionarea} insert end $entity -text $entity
2462
;#${userframe}.editionarea insert end $entity -text $entity
2463
2464
;# Make the entries into the frame
2465
set editframe [${gerwin_editionarea} getframe $entity]
2466
;#set editframe [${userframe}.editionarea getframe $entity]
2467
2468
2469
;##### PROPERTIES FRAME
2470
2471
TitleFrame ${editframe}.properties -side center -text "Entity Properties"
2472
set pframe [${editframe}.properties getframe]
2473
2474
;# ENTITY NAME
2475
frame ${pframe}.nameline
2476
2477
LabelEntry ${pframe}.nameline.label -label "Name: " -labelwidth 6 \
2478
-text $entity -textvariable gm_entity($entity,nname) \
2479
-helptext "Name of the entity"
2480
2481
button ${pframe}.nameline.button -text "change" -relief groove \
2482
-command [list gui_edit_entity_change_name $entity]
2483
2484
2485
frame ${pframe}.typeline
2486
LabelEntry ${pframe}.typeline.label -label "Type:" -labelwidth 6 \
2487
-textvariable gm_entity($entity,ntype) \
2488
-helptext "Type of the entity"
2489
button ${pframe}.typeline.button -text "change" -relief groove \
2490
-command "gob_entity_change_type $entity \$gm_entity($entity,ntype); \
2491
set ttype \$gm_entity($entity,ntype) ; \
2492
gui_edition_area_delete_page $entity ; \
2493
gm_entity_change_type $entity \$gm_entity($entity,ntype); \
2494
gui_edit_entity $entity ; \
2495
set xpos \$gm_entity($entity,xpos); \
2496
set ypos \$gm_entity($entity,ypos); \
2497
gm_delete_entity $entity; \
2498
gm_draw_entity $entity \$xpos \$ypos ; " \
2499
-state disabled
2500
2501
2502
2503
;# pack it
2504
pack ${pframe}.nameline.label -side left
2505
pack ${pframe}.nameline.button -side left
2506
2507
2508
pack ${pframe}.typeline.label -side left
2509
pack ${pframe}.typeline.button -side left
2510
2511
pack ${pframe}.nameline -side top
2512
pack ${pframe}.typeline -side top
2513
pack ${pframe} -side left -anchor nw
2514
2515
;#### ATTRIBUTES FRAME
2516
2517
TitleFrame ${editframe}.attributes -side center -text "Attributes"
2518
set aframe [${editframe}.attributes getframe]
2519
2520
frame ${aframe}.nattribute
2521
label ${aframe}.nattribute.label -text "New Attribute"
2522
frame ${aframe}.nattribute.faux
2523
frame ${aframe}.nattribute.faux.ftop
2524
frame ${aframe}.nattribute.faux.fdown
2525
LabelEntry ${aframe}.nattribute.faux.ftop.label -label "Name:" -labelwidth 7 \
2526
-labelanchor w -textvariable gm_entity($entity,nattribute) \
2527
-helptext "name for the new attribute"
2528
2529
# LabelEntry ${aframe}.nattribute.faux.fdown.label -label "Domain:" -labelwidth 7 \
2530
# -labelanchor w -textvariable gm_entity($entity,ndomain) \
2531
# -helptext "domain for the new attribute"
2532
2533
LabelFrame ${aframe}.nattribute.faux.fdown.domframe -text "Domain:" \
2534
-side left
2535
2536
set dfr [${aframe}.nattribute.faux.fdown.domframe getframe]
2537
2538
ComboBox $dfr.label -editable true \
2539
-textvariable gm_entity($entity,ndomain) \
2540
-helptext "domain for the new attribute" \
2541
-width 18 \
2542
-values {varchar(8) varchar(16) varchar(32) int bigint text date}
2543
2544
pack $dfr.label -side top -anchor e
2545
2546
2547
2548
Button ${aframe}.nattribute.button -text "Add" -relief groove \
2549
-command [list gui_edit_entity_add_attribute $entity]
2550
2551
2552
Separator ${aframe}.sep1 -orient vertical
2553
2554
frame ${aframe}.attributes
2555
2556
frame ${aframe}.attributes.frame
2557
scrollbar ${aframe}.attributes.frame.scrollbar \
2558
-command [list ${aframe}.attributes.frame.lbox yview]
2559
2560
2561
2562
set lb [listbox ${aframe}.attributes.frame.lbox \
2563
-yscrollcommand [list ${aframe}.attributes.frame.scrollbar set]]
2564
2565
;# Insert the listbox elements
2566
foreach a [gob_entity_get_attributes $entity] {
2567
2568
set aname [lindex $a 0]
2569
;# Make the embedded window
2570
$lb insert end $aname
2571
2572
}
2573
2574
2575
;# make the bbox
2576
set bbox [ButtonBox ${aframe}.bbox -spacing 0 -padx 1 -pady 0 \
2577
-orient vertical]
2578
2579
${bbox} add -text "Is key" -command [list gui_attribute_is_key $lb $entity] -relief groove
2580
${bbox} add -text "Is not key" -command [list gui_attribute_is_not_key $lb $entity] -relief groove
2581
${bbox} add -text "Del/Edit" -command [list gui_attribute_delete_entity $lb $entity] -relief groove
2582
2583
pack ${aframe}.nattribute.label -side top
2584
pack ${aframe}.nattribute.faux.ftop.label -side top -anchor w
2585
pack ${aframe}.nattribute.faux.ftop -side top
2586
pack ${aframe}.nattribute.faux.fdown.domframe -side top -anchor w
2587
pack ${aframe}.nattribute.faux.fdown -side top
2588
pack ${aframe}.nattribute.faux -side left
2589
pack ${aframe}.nattribute.button -side right
2590
2591
2592
pack ${aframe}.nattribute -side left
2593
2594
pack ${aframe}.sep1 -fill y -padx 8 -side left
2595
2596
pack ${aframe}.attributes.frame.scrollbar -side right -fill y
2597
pack ${aframe}.attributes.frame.lbox -side left
2598
pack ${aframe}.attributes.frame
2599
2600
pack ${aframe}.attributes -side left
2601
2602
pack ${aframe}.bbox -side right
2603
2604
button ${editframe}.quit -text "Close page" -relief groove \
2605
-command "destroy ${editframe} ; \
2606
gui_edition_area_delete_page $entity"
2607
2608
;# Pack the frames
2609
pack ${editframe}.properties -side left -fill both -padx 10
2610
pack ${editframe}.attributes -side left -fill both -padx 10
2611
pack ${editframe}.quit -side right
2612
pack ${editframe}
2613
2614
2615
;# Make the page visible
2616
${gerwin_editionarea} raise $entity
2617
2618
;# Scale the notebook
2619
NoteBook::compute_size ${gerwin_editionarea}
2620
}
2621
2622
;#
2623
;# gui_edit_relation
2624
;#
2625
;# Edit all aspects of a given relation, in a page on the
2626
;# editionarea
2627
2628
proc gui_edit_relation {relation} {
2629
2630
global gmainframe
2631
global gerwin_relation
2632
global gm_relation
2633
global gcanvas
2634
2635
global earea_pages
2636
global gerwin_editionarea
2637
2638
set userframe [${gmainframe} getframe]
2639
2640
;# See if the relation already have a page in the edition area
2641
set index [lsearch $earea_pages $relation]
2642
if {$index != -1} then {
2643
2644
;# Make the page visible
2645
${gerwin_editionarea} raise [lindex $earea_pages $index]
2646
;#${userframe}.editionarea raise [lindex $earea_pages $index]
2647
2648
return
2649
}
2650
2651
;# Create a new page for this relation
2652
lappend earea_pages $relation
2653
${gerwin_editionarea} insert end $relation -text $relation
2654
;#${userframe}.editionarea insert end $relation -text $relation
2655
2656
;# Make the entries into the frame
2657
set editframe [${gerwin_editionarea} getframe $relation]
2658
;#set editframe [${userframe}.editionarea getframe $relation]
2659
2660
;##### PROPERTIES FRAME
2661
2662
TitleFrame ${editframe}.properties -side center -text "Relation Properties"
2663
set pframe [${editframe}.properties getframe]
2664
2665
;# RELATION NAME
2666
frame ${pframe}.nameline
2667
2668
LabelEntry ${pframe}.nameline.label -label "Name: " -labelwidth 6 \
2669
-text $relation -textvariable gm_relation($relation,nname) \
2670
-helptext "Name of the relation"
2671
2672
button ${pframe}.nameline.button -text "change" -relief groove \
2673
-command [list gui_edit_relation_change_name $relation]
2674
2675
2676
;# pack it
2677
pack ${pframe}.nameline.label -side left
2678
pack ${pframe}.nameline.button -side left
2679
pack ${pframe}.nameline -side top
2680
2681
2682
;# RELATION ENTITIES and cardinality (entities 0 and 1 only)
2683
frame ${pframe}.cards
2684
2685
2686
if {[gob_relation_get_num_entities $relation] > 2} then {
2687
;# Show a short label
2688
;#label ${pframe}.cards.label -text "All entitities cardinality X/N"
2689
;#pack ${pframe}.cards.label
2690
2691
} else {
2692
;# Binary relation: show cardinality
2693
2694
frame ${pframe}.cards.entity1
2695
2696
set entities [gob_relation_get_entities $relation]
2697
set entity1_name [lindex [lindex $entities 0] 0]
2698
set entity1_mincard [lindex [lindex [lindex $entities 0] 1] 0]
2699
set entity1_maxcard [lindex [lindex [lindex $entities 0] 1] 1]
2700
set entity2_name [lindex [lindex $entities 1] 0]
2701
set entity2_mincard [lindex [lindex [lindex $entities 1] 1] 0]
2702
set entity2_maxcard [lindex [lindex [lindex $entities 1] 1] 1]
2703
2704
Label ${pframe}.cards.entity1.ename -text $entity1_name
2705
2706
;# Set up the variables
2707
set gerwin_relation($relation,e1mincard) $entity1_mincard
2708
set gerwin_relation($relation,e1maxcard) $entity1_maxcard
2709
2710
;# Minimal card
2711
radiobutton ${pframe}.cards.entity1.rbmin0 -text "0" \
2712
-variable gerwin_relation($relation,e1mincard) -value 0 \
2713
-command "gob_relation_set_entity_min_card $relation $entity1_name \$gerwin_relation($relation,e1mincard) ; \
2714
set xpos \$gm_relation($relation,xpos); \
2715
set ypos \$gm_relation($relation,ypos); \
2716
gm_delete_relation $relation ; \
2717
gm_draw_relation $relation \$xpos \$ypos ; \
2718
if {\$gerwin_relation($relation,reflexive)} then {
2719
gm_relation_update_links_reflexive $relation
2720
} else {
2721
gm_relation_update_links $relation
2722
}"
2723
2724
radiobutton ${pframe}.cards.entity1.rbmin1 -text "1" \
2725
-variable gerwin_relation($relation,e1mincard) -value 1 \
2726
-command "gob_relation_set_entity_min_card $relation $entity1_name \$gerwin_relation($relation,e1mincard) ; \
2727
set xpos \$gm_relation($relation,xpos); \
2728
set ypos \$gm_relation($relation,ypos); \
2729
gm_delete_relation $relation ; \
2730
gm_draw_relation $relation \$xpos \$ypos ; \
2731
if {\$gerwin_relation($relation,reflexive)} then {
2732
gm_relation_update_links_reflexive $relation
2733
} else {
2734
gm_relation_update_links $relation
2735
}"
2736
2737
;# Separator
2738
label ${pframe}.cards.entity1.sep -text "/"
2739
2740
;# Maximal card
2741
radiobutton ${pframe}.cards.entity1.rbmax1 -text "1" \
2742
-variable gerwin_relation($relation,e1maxcard) -value 1 \
2743
-command "gob_relation_set_entity_max_card $relation $entity1_name \$gerwin_relation($relation,e1maxcard) ; \
2744
set xpos \$gm_relation($relation,xpos); \
2745
set ypos \$gm_relation($relation,ypos); \
2746
gm_delete_relation $relation ; \
2747
gm_draw_relation $relation \$xpos \$ypos ; \
2748
if {\$gerwin_relation($relation,reflexive)} then {
2749
gm_relation_update_links_reflexive $relation
2750
} else {
2751
gm_relation_update_links $relation
2752
}"
2753
2754
2755
radiobutton ${pframe}.cards.entity1.rbmaxN -text "N" \
2756
-variable gerwin_relation($relation,e1maxcard) -value N \
2757
-command "gob_relation_set_entity_max_card $relation $entity1_name \$gerwin_relation($relation,e1maxcard) ; \
2758
set xpos \$gm_relation($relation,xpos); \
2759
set ypos \$gm_relation($relation,ypos); \
2760
gm_delete_relation $relation ; \
2761
gm_draw_relation $relation \$xpos \$ypos ; \
2762
if {\$gerwin_relation($relation,reflexive)} then {
2763
gm_relation_update_links_reflexive $relation
2764
} else {
2765
gm_relation_update_links $relation
2766
}"
2767
2768
;# Set gui_e1mincard and gui_e1maxcard as appropiate
2769
set qui_e1mincard [gob_relation_get_entity_min_card $relation $entity1_name]
2770
set gui_e1maxcard [gob_relation_get_entity_max_card $relation $entity1_name]
2771
2772
2773
pack ${pframe}.cards.entity1.ename -side top
2774
pack ${pframe}.cards.entity1.rbmin0 -side left
2775
pack ${pframe}.cards.entity1.rbmin1 -side left
2776
pack ${pframe}.cards.entity1.sep -side left
2777
pack ${pframe}.cards.entity1.rbmax1 -side left
2778
pack ${pframe}.cards.entity1.rbmaxN -side left
2779
2780
pack ${pframe}.cards.entity1 -side left
2781
2782
frame ${pframe}.cards.entity2
2783
2784
;# Set up the variables
2785
set gerwin_relation($relation,e2mincard) $entity2_mincard
2786
set gerwin_relation($relation,e2maxcard) $entity2_maxcard
2787
2788
Label ${pframe}.cards.entity2.ename -text $entity2_name
2789
2790
;# Minimal card
2791
radiobutton ${pframe}.cards.entity2.rbmin0 -text "0" \
2792
-variable gerwin_relation($relation,e2mincard) -value 0 \
2793
-command "
2794
set entities \[gob_relation_get_entities $relation\]
2795
set e1 \[lindex \$entities 0\]
2796
set e2 \[lindex \$entities 1\]
2797
set e2name \[lindex \$e2 0\]
2798
set e2cards \[lindex \$e2 1\]
2799
set gerwin_relation($relation,entities) \[list \$e1 \[list \$e2name \[list \$gerwin_relation($relation,e2mincard) \[lindex \$e2cards 1\]\]\]\]
2800
set xpos \$gm_relation($relation,xpos); \
2801
set ypos \$gm_relation($relation,ypos); \
2802
gm_delete_relation $relation ; \
2803
gm_draw_relation $relation \$xpos \$ypos ; \
2804
if {\$gerwin_relation($relation,reflexive)} then {
2805
gm_relation_update_links_reflexive $relation
2806
} else {
2807
gm_relation_update_links $relation
2808
}"
2809
2810
radiobutton ${pframe}.cards.entity2.rbmin1 -text "1" \
2811
-variable gerwin_relation($relation,e2mincard) -value 1 \
2812
-command "
2813
set entities \[gob_relation_get_entities $relation\]
2814
set e1 \[lindex \$entities 0\]
2815
set e2 \[lindex \$entities 1\]
2816
set e2name \[lindex \$e2 0\]
2817
set e2cards \[lindex \$e2 1\]
2818
set gerwin_relation($relation,entities) \[list \$e1 \[list \$e2name \[list \$gerwin_relation($relation,e2mincard) \[lindex \$e2cards 1\]\]\]\]
2819
set xpos \$gm_relation($relation,xpos); \
2820
set ypos \$gm_relation($relation,ypos); \
2821
gm_delete_relation $relation ; \
2822
gm_draw_relation $relation \$xpos \$ypos ; \
2823
if {\$gerwin_relation($relation,reflexive)} then {
2824
gm_relation_update_links_reflexive $relation
2825
} else {
2826
gm_relation_update_links $relation
2827
}"
2828
2829
;# Separator
2830
label ${pframe}.cards.entity2.sep -text "/"
2831
2832
;# Maximal card
2833
radiobutton ${pframe}.cards.entity2.rbmax1 -text "1" \
2834
-variable gerwin_relation($relation,e2maxcard) -value 1 \
2835
-command "
2836
set entities \[gob_relation_get_entities $relation\]
2837
set e1 \[lindex \$entities 0\]
2838
set e2 \[lindex \$entities 1\]
2839
set e2name \[lindex \$e2 0\]
2840
set e2cards \[lindex \$e2 1\]
2841
set gerwin_relation($relation,entities) \[list \$e1 \[list \$e2name \[list \[lindex \$e2cards 0\] \$gerwin_relation($relation,e2maxcard) \]\]\]
2842
set xpos \$gm_relation($relation,xpos); \
2843
set ypos \$gm_relation($relation,ypos); \
2844
gm_delete_relation $relation ; \
2845
gm_draw_relation $relation \$xpos \$ypos ; \
2846
if {\$gerwin_relation($relation,reflexive)} then {
2847
gm_relation_update_links_reflexive $relation
2848
} else {
2849
gm_relation_update_links $relation
2850
}"
2851
2852
2853
radiobutton ${pframe}.cards.entity2.rbmaxN -text "N" \
2854
-variable gerwin_relation($relation,e2maxcard) -value N \
2855
-command "
2856
set entities \[gob_relation_get_entities $relation\]
2857
set e1 \[lindex \$entities 0\]
2858
set e2 \[lindex \$entities 1\]
2859
set e2name \[lindex \$e2 0\]
2860
set e2cards \[lindex \$e2 1\]
2861
set gerwin_relation($relation,entities) \[list \$e1 \[list \$e2name \[list \[lindex \$e2cards 0\] \$gerwin_relation($relation,e2maxcard) \]\]\]
2862
set xpos \$gm_relation($relation,xpos); \
2863
set ypos \$gm_relation($relation,ypos); \
2864
gm_delete_relation $relation ; \
2865
gm_draw_relation $relation \$xpos \$ypos ; \
2866
2867
if {\$gerwin_relation($relation,reflexive)} then {
2868
gm_relation_update_links_reflexive $relation
2869
} else {
2870
gm_relation_update_links $relation
2871
}"
2872
2873
2874
;# Set gui_e2maxcard as appropiate
2875
set gui_e2maxcard [gob_relation_get_entity_card $relation $entity2_name]
2876
2877
pack ${pframe}.cards.entity2.ename -side top
2878
pack ${pframe}.cards.entity2.rbmin0 -side left
2879
pack ${pframe}.cards.entity2.rbmin1 -side left
2880
pack ${pframe}.cards.entity2.sep -side left
2881
pack ${pframe}.cards.entity2.rbmax1 -side left
2882
pack ${pframe}.cards.entity2.rbmaxN -side left
2883
2884
Separator ${pframe}.cards.sep2 -orient vertical
2885
pack ${pframe}.cards.sep2 -fill y -padx 4 -side left
2886
2887
pack ${pframe}.cards.entity2 -side right
2888
2889
2890
pack ${pframe}.cards -side left
2891
2892
pack ${pframe}.cards -side top
2893
}
2894
2895
pack ${pframe} -side left -anchor w
2896
2897
;#### ATTRIBUTES FRAME
2898
2899
TitleFrame ${editframe}.attributes -side center -text "Attributes"
2900
set aframe [${editframe}.attributes getframe]
2901
2902
frame ${aframe}.nattribute
2903
label ${aframe}.nattribute.label -text "New Attribute"
2904
frame ${aframe}.nattribute.faux
2905
frame ${aframe}.nattribute.faux.ftop
2906
frame ${aframe}.nattribute.faux.fdown
2907
LabelEntry ${aframe}.nattribute.faux.ftop.label -label "Name:" -labelwidth 7 \
2908
-labelanchor w -textvariable gm_relation($relation,nattribute) \
2909
-helptext "name for the new attribute"
2910
# LabelEntry ${aframe}.nattribute.faux.fdown.label -label "Domain:" -labelwidth 7 \
2911
# -labelanchor w -textvariable gm_relation($relation,ndomain) \
2912
# -helptext "domain for the new attribute"
2913
2914
LabelFrame ${aframe}.nattribute.faux.fdown.domframe -text "Domain:" \
2915
-side left
2916
2917
set dfr [${aframe}.nattribute.faux.fdown.domframe getframe]
2918
2919
ComboBox $dfr.label -editable true \
2920
-textvariable gm_relation($relation,ndomain) \
2921
-helptext "domain for the new attribute" \
2922
-width 18 \
2923
-values {varchar(8) varchar(16) varchar(32) int bigint text date}
2924
2925
pack $dfr.label -side top -anchor e
2926
2927
Button ${aframe}.nattribute.button -text "Add" -relief groove \
2928
-command [list gui_edit_relation_add_attribute $relation]
2929
2930
2931
Separator ${aframe}.sep1 -orient vertical
2932
2933
frame ${aframe}.attributes
2934
2935
frame ${aframe}.attributes.frame
2936
scrollbar ${aframe}.attributes.frame.scrollbar \
2937
-command [list ${aframe}.attributes.frame.lbox yview]
2938
2939
2940
2941
set lb [listbox ${aframe}.attributes.frame.lbox \
2942
-yscrollcommand [list ${aframe}.attributes.frame.scrollbar set]]
2943
2944
;# Insert the listbox elements
2945
foreach a [gob_relation_get_attributes $relation] {
2946
2947
set aname [lindex $a 0]
2948
;# Make the embedded window
2949
$lb insert end $aname
2950
2951
}
2952
2953
2954
;# make the bbox
2955
set bbox [ButtonBox ${aframe}.bbox -spacing 0 -padx 1 -pady 0 \
2956
-orient vertical]
2957
2958
${bbox} add -text "Del/Edit" -command [list gui_attribute_delete_relation $lb $relation] -relief groove
2959
2960
pack ${aframe}.nattribute.label -side top
2961
pack ${aframe}.nattribute.faux.ftop.label -side top -anchor w
2962
pack ${aframe}.nattribute.faux.ftop -side top
2963
pack ${aframe}.nattribute.faux.fdown.domframe -side top -anchor w
2964
pack ${aframe}.nattribute.faux.fdown -side top
2965
pack ${aframe}.nattribute.faux -side left
2966
pack ${aframe}.nattribute.button -side right
2967
2968
2969
pack ${aframe}.nattribute -side left
2970
2971
pack ${aframe}.sep1 -fill y -padx 8 -side left
2972
2973
pack ${aframe}.attributes.frame.scrollbar -side right -fill y
2974
pack ${aframe}.attributes.frame.lbox -side left
2975
pack ${aframe}.attributes.frame
2976
2977
pack ${aframe}.attributes -side left
2978
2979
pack ${aframe}.bbox -side right
2980
2981
button ${editframe}.quit -text "Close page" -relief groove \
2982
-command "destroy ${editframe} ; \
2983
gui_edition_area_delete_page $relation"
2984
2985
;# Pack the frames
2986
pack ${editframe}.properties -side left -fill both -padx 10
2987
pack ${editframe}.attributes -side left -fill both -padx 10
2988
pack ${editframe}.quit -side right
2989
pack ${editframe}
2990
2991
2992
;# Make the page visible
2993
${gerwin_editionarea} raise $relation
2994
;#${userframe}.editionarea raise $relation
2995
2996
;# Scale the notebook
2997
NoteBook::compute_size ${gerwin_editionarea}
2998
}
2999
3000
3001
;#
3002
;# gui_select_file_to_save_sql
3003
;#
3004
;# Select a file to save the generated SQL
3005
3006
proc gui_select_file_to_save_sql {} {
3007
3008
set filetypes {{"SQL File" {.sql}}}
3009
3010
set f [tk_getSaveFile -initialdir "." \
3011
-filetypes $filetypes -title "Select a SQL file"]
3012
3013
;# Switch over the result
3014
switch $f {
3015
3016
"" {
3017
;# Do nothing
3018
return
3019
}
3020
default {
3021
;# Put the .sql suffix if it is not done
3022
if {! [string match "*.sql" $f] } then {
3023
append f ".sql"
3024
}
3025
3026
return $f
3027
3028
}
3029
3030
}
3031
}
3032
3033
3034
;#
3035
;# gui_select_file_to_save
3036
;#
3037
;# Select a file to save the project
3038
3039
proc gui_select_file_to_save {} {
3040
3041
set filetypes {{"Gerwin Project" {.ger}}}
3042
3043
set f [tk_getSaveFile -initialdir "." \
3044
-filetypes $filetypes -title "Select a project file"]
3045
3046
;# Switch over the result
3047
switch $f {
3048
3049
"" {
3050
;# Do nothing
3051
return
3052
}
3053
default {
3054
;# Put the .ger suffix if it is not done
3055
if {! [string match "*.ger" $f] } then {
3056
append f ".ger"
3057
}
3058
3059
return $f
3060
3061
}
3062
3063
}
3064
}
3065
3066
;#
3067
;# gui_edit_project
3068
;#
3069
;# Edit the actual Project parameters
3070
;# Another edit widget can be put at the right of that.
3071
3072
proc gui_edit_project {} {
3073
3074
global gerwin_cproject_name
3075
global gerwin_cproject_file
3076
global gerwin_editionarea
3077
global earea_pages
3078
3079
lappend earea_pages Project
3080
3081
${gerwin_editionarea} insert end Project -text Project
3082
${gerwin_editionarea} raise Project
3083
3084
set widget [${gerwin_editionarea} getframe Project]
3085
3086
TitleFrame ${widget}.editframe -side center -text "Project Properties"
3087
3088
set editwidget [${widget}.editframe getframe]
3089
3090
;# Project name
3091
frame ${editwidget}.nameline
3092
LabelEntry ${editwidget}.nameline.label -label "Project Name:" -labelwidth 16 \
3093
-textvariable gerwin_cproject_name \
3094
-helptext "Name of the current project" -width 50
3095
3096
;# Project file
3097
frame ${editwidget}.fileline
3098
LabelEntry ${editwidget}.fileline.label -label "Project File:" -labelwidth 16 \
3099
-textvariable gerwin_cproject_file \
3100
-helptext "Storage file of the current project" -editable false \
3101
-width 50
3102
3103
Button ${editwidget}.fileline.button -text "select file" \
3104
-helptext "Select a file to store the project in" \
3105
-command "set tempfile \[gui_select_file_to_save\] ; \
3106
3107
if {\$tempfile != {}} then {
3108
set gerwin_cproject_file \$tempfile
3109
gerwin_save_project_file
3110
} " \
3111
-relief groove
3112
3113
3114
;# Project author
3115
frame ${editwidget}.authorline
3116
LabelEntry ${editwidget}.authorline.label -label "Project Author:" -labelwidth 16 \
3117
-textvariable gerwin_cproject_author \
3118
-helptext "Author of the current project" -width 50
3119
3120
pack ${editwidget}.nameline.label -side left -anchor w
3121
pack ${editwidget}.nameline -side top -anchor w
3122
3123
pack ${editwidget}.fileline.label -side left -anchor w
3124
pack ${editwidget}.fileline.button -side left
3125
pack ${editwidget}.fileline -side top -anchor w
3126
3127
pack ${editwidget}.authorline.label -side left -anchor w
3128
pack ${editwidget}.authorline -side top -anchor w
3129
3130
pack ${editwidget} -side top -fill both -expand true
3131
3132
pack ${widget}.editframe -side top ;#-fill both -expand true
3133
3134
;# Scale the notebook
3135
NoteBook::compute_size ${gerwin_editionarea}
3136
3137
}
3138
3139
3140
;#
3141
;# gui_get_free_oct OBJ TYPE CUAD
3142
;#
3143
;# Get a free oct on CUAD for OBJ-TYPE
3144
3145
proc gui_get_free_oct {obj type cuad} {
3146
3147
global gerwin_entity
3148
3149
switch $cuad {
3150
3151
1 {
3152
;# oct for obj must be o2 or o1
3153
if {[gui_oct_is_busy $obj $type 1]} then {
3154
3155
return 2
3156
3157
} else {
3158
3159
return 1
3160
}
3161
3162
}
3163
3164
2 {
3165
3166
;# oct for obj must be o3 or o4
3167
if {[gui_oct_is_busy $obj $type 3]} then {
3168
3169
return 4
3170
3171
} else {
3172
3173
return 3
3174
}
3175
}
3176
3177
3 {
3178
3179
;# oct for object 1 must be o5 or o6
3180
if {[gui_oct_is_busy $obj $type 5]} then {
3181
3182
return 6
3183
3184
} else {
3185
3186
return 5
3187
}
3188
3189
}
3190
3191
3192
4 {
3193
3194
;# oct for object 1 must be o7 or o8
3195
if {[gui_oct_is_busy $obj $type 8]} then {
3196
3197
return 7
3198
3199
} else {
3200
3201
return 8
3202
}
3203
3204
}
3205
3206
}
3207
3208
}
3209
3210
3211
3212
3213
;#
3214
;# gui_oct_is_busy OBJ TYPE OCT
3215
;#
3216
;# See if OCT is busy for OBJ-TYPE
3217
3218
proc gui_oct_is_busy {obj type oct} {
3219
3220
global gerwin_entity
3221
3222
switch $type {
3223
3224
3225
"Entity" {
3226
3227
;# Get the oct array from the entity
3228
set octarray $gerwin_entity($obj,octs)
3229
3230
if {[lindex $octarray [expr $oct - 1]] != ""} then {
3231
3232
;# oct busy
3233
return 1
3234
3235
} else {
3236
3237
return 0
3238
3239
}
3240
}
3241
3242
3243
}
3244
}
3245
3246
;#
3247
;# gui_get_link_point_from_oct {obj type oct}
3248
;#
3249
3250
proc gui_get_link_point_from_oct {obj type oct} {
3251
3252
global gerwin_entity
3253
global gcanvas
3254
3255
3256
switch $type {
3257
3258
3259
"Entity" {
3260
3261
;# Get the bbox of the entity
3262
set bbox [${gcanvas} bbox taggroup-$type-$obj]
3263
set x1 [lindex $bbox 0]
3264
set y1 [lindex $bbox 1]
3265
set x2 [lindex $bbox 2]
3266
set y2 [lindex $bbox 3]
3267
3268
3269
;# Calculate the link point based on the oct
3270
switch $oct {
3271
3272
1 {
3273
return [list $x2 [expr ($y1 + (($y2 - $y1) / 4))]]
3274
}
3275
2 {
3276
return [list [expr ($x1 + ((($x2 - $x1) / 4) * 3))] $y1]
3277
}
3278
3 {
3279
return [list [expr ($x1 + (($x2 - $x1) / 4))] $y1]
3280
}
3281
4 {
3282
return [list $x1 [expr ($y1 + (($y2 - $y1) / 4))]]
3283
}
3284
5 {
3285
return [list $x1 [expr ($y1 + ((($y2 - $y1) /4) * 3))]]
3286
}
3287
6 {
3288
return [list [expr ($x1 + (($x2 - $x1) / 4))] $y2]
3289
}
3290
7 {
3291
return [list [expr ($x1 + ((($x2 - $x1) / 4) * 3))]]
3292
}
3293
8 {
3294
return [list $x2 [expr ($y1 + ((($y2 - $y1) / 4) * 3))]]
3295
}
3296
3297
}
3298
3299
}
3300
3301
}
3302
3303
}
3304
3305
3306
;#
3307
;# gui_add_link_to_oct TYPE1 OBJ1 TYPE2 OBJ2 OCT
3308
;#
3309
;# Add a link to OBJ2 to OBJ1's OCT
3310
3311
proc gui_add_link_to_oct {type1 obj1 type2 obj2 oct} {
3312
3313
global gerwin_entity
3314
global gerwin_links
3315
3316
;# Add the new link to gerwin_links
3317
lappend gerwin_links [list $type1 $obj1 $type2 $obj2]
3318
lappend gerwin_links [list $type2 $obj2 $type1 $obj1]
3319
3320
switch $type1 {
3321
3322
3323
Entity {
3324
3325
set temp [lindex $gerwin_entity($obj1,octs) [expr $oct - 1]]
3326
lappend temp [list $type2 $obj2]
3327
set gerwin_entity($obj1,octs) \
3328
[lreplace $gerwin_entity($obj1,octs) [expr $oct - 1] [expr $oct - 1] $temp]
3329
3330
}
3331
3332
3333
}
3334
3335
}
3336
3337
;#
3338
;# gui_redraw_oct TYPE OBJ OCT
3339
;#
3340
;# Redraw all links on the OBJ oct named OCT
3341
3342
proc gui_redraw_oct {type obj oct} {
3343
3344
global gerwin_entity
3345
3346
3347
switch $type {
3348
3349
Entity {
3350
3351
set oct_content [lindex $gerwin_entity($obj,octs) [expr $oct - 1]]
3352
3353
;# Get the internal pad
3354
set nlinks [llength $oct_content]
3355
set ipad
3356
3357
}
3358
}
3359
3360
3361
}
3362
3363
;#
3364
;# gui_link {TYPE1 OBJ1} {TYPE2 OBJ2}
3365
;#
3366
;# Makes and draw a link between OBJ1 and OBJ2
3367
3368
3369
proc gui_link {elem1 elem2} {
3370
3371
global gerwin_entity
3372
global gm_entity
3373
global gcanvas
3374
3375
3376
set type1 [lindex $elem1 0]
3377
set type2 [lindex $elem2 0]
3378
set object1 [lindex $elem1 1]
3379
set object2 [lindex $elem2 1]
3380
3381
;# Get bboxes
3382
set bbox1 [${gcanvas} bbox "taggroup-$type1-$object1"]
3383
set bbox2 [${gcanvas} bbox "taggroup-$type2-$object2"]
3384
3385
;# Obtain the cuads
3386
set refpoint1x [lindex $bbox1 2]
3387
set refpoint1y [lindex $bbox1 3]
3388
set refpoint2x [lindex $bbox2 2]
3389
set refpoint2y [lindex $bbox2 3]
3390
3391
3392
set cuad1 [gui_get_cuad $refpoint1x $refpoint1y \
3393
$refpoint2x $refpoint2y]
3394
3395
switch $cuad1 {
3396
3397
1 { set cuad2 3 }
3398
2 { set cuad2 4 }
3399
3 { set cuad2 1 }
3400
4 { set cuad2 2 }
3401
}
3402
3403
;# Depending of the cuad, we must find an oct link point for both
3404
;# objects.
3405
3406
set oct1 [gui_get_free_oct $object1 $type1 $cuad1]
3407
;# We get oct2 depending of oct1
3408
switch $oct1 {
3409
8 { set oct2 3}
3410
7 { set oct2 4}
3411
6 { set oct2 1}
3412
5 { set oct2 2}
3413
4 { set oct2 7}
3414
3 { set oct2 8}
3415
2 { set oct2 5}
3416
1 { set oct2 6}
3417
}
3418
3419
3420
3421
;# Add the new link to the links of both objects octs
3422
gui_add_link_to_oct $type1 $obj1 $type2 $obj2 $oct1
3423
gui_add_link_to_oct $type2 $obj2 $type1 $obj1 $oct2
3424
3425
;# Redraw the octs links for both objects
3426
;#gui_redraw_oct $type1 $obj1 $oct1
3427
;#gui_redraw_oct $type2 $obj2 $oct2
3428
3429
;# Get the link points
3430
set lpoint1 [gui_get_link_point_from_oct $object1 $type1 $oct1]
3431
set lp1x [lindex $lpoint1 0]
3432
set lp1y [lindex $lpoint1 1]
3433
set lpoint2 [gui_get_link_point_from_oct $object2 $type2 $oct2]
3434
set lp2x [lindex $lpoint2 0]
3435
set lp2y [lindex $lpoint2 1]
3436
3437
;# Get the link's intermediate point
3438
;# It depend of the cuad
3439
3440
switch $cuad1 {
3441
1 {
3442
set intpx $lp2x
3443
set intpy $lp1y
3444
}
3445
2 {
3446
set intpx $lp1x
3447
set intpy $lp2y
3448
}
3449
3 {
3450
set intpx $lp2x
3451
set intpy $lp1y
3452
}
3453
4 {
3454
set intpx $lp2x
3455
set intpy $lp1y
3456
}
3457
}
3458
3459
;# make the link
3460
${gcanvas} create line $lp1x $lp1y \
3461
$intpx $intpy \
3462
$lp2x $lp2y \
3463
-tag $type1-$object1-$type2-$object2
3464
3465
}
3466
3467
3468
;#
3469
;# gui_link_delete type1 object1 type2 object2
3470
;#
3471
;# Deletes the link
3472
3473
3474
proc gui_link_delete {type1 obj1 type2 obj2} {
3475
3476
global gcanvas
3477
3478
${gcanvas} delete $type1-$obj1-$type2-$obj2
3479
3480
3481
3482
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1