-
Notifications
You must be signed in to change notification settings - Fork 4
/
classify.tcl
executable file
·1353 lines (1130 loc) · 43.3 KB
/
classify.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
################################################################################
##
## FILE: classify.tcl
##
## DESCRIPTION: Contains methods to carry out the classification process
## (selection of text, bucket selection etc.)
##
## CVS: $Header: /p/learning/cvs/projects/jtag/classify.tcl,v 1.20 2006-01-04 21:53:32 scottl Exp $
##
## REVISION HISTORY:
## $Log: classify.tcl,v $
## Revision 1.20 2006-01-04 21:53:32 scottl
## Removed start_of_page and end_of_page buckets, fixed snap bug causing
## other selection to move after manual resize
##
## Revision 1.19 2003/09/15 19:06:35 scottl
## Small bugfix to ensure we only activate the one matching bucket.
##
## Revision 1.18 2003/09/11 18:26:21 scottl
## Activate button corresponding to classified selection when mouse enters
## that selection.
##
## Revision 1.17 2003/08/29 18:53:27 scottl
## Updated status bar to display data array info when mousing over a
## classified selection.
##
## Revision 1.16 2003/08/25 17:43:39 scottl
## Added a status bar to display status messages during certain actions.
##
## Revision 1.15 2003/07/31 19:18:17 scottl
## Added resize_attempts information to the data array.
##
## Revision 1.14 2003/07/29 21:02:44 scottl
## bugfix to prevent destroying sel. and class time data on writeout.
##
## Revision 1.13 2003/07/28 19:55:19 scottl
## - Cleaned up timers.
## - Implemented jlog functionality.
## - Added snapped parameter to data structure.
##
## Revision 1.12 2003/07/23 20:12:07 scottl
## rounded co-ords to remove sligt decimal numbers that sometimes occured.
##
## Revision 1.11 2003/07/21 21:35:18 scottl
## Moved snapping to inital rectangle creation only, also moved snap threshold to
## be read from the config file instead of hard-coded within this file.
##
## Revision 1.10 2003/07/21 15:21:36 scottl
## Implemented automatic snapping of selections to bound text based on percentage
## of non-background ink found.
##
## Revision 1.9 2003/07/18 17:58:48 scottl
## - Fixed bug whereby already classified resizes where not being updated in the
## data array.
## - Also split AddToBucket into a helper so that the helper can be used
## elsewhere.
##
## Revision 1.8 2003/07/16 20:51:20 scottl
## Bugfix to allow proper resizing when scrolled away from top-left corner.
##
## Revision 1.7 2003/07/16 20:28:05 scottl
## Renamed classifiers to classes to avoid confusion with the name.
##
## Revision 1.6 2003/07/16 19:08:37 scottl
## Increased default size of rectangles.
##
## Revision 1.5 2003/07/15 16:44:27 scottl
## - Renamed CheckReclassify method to get_selection and exported it for
## availability to other namespaces
## - Implemented unbind_selection method to control bindings when opening
## multiple images
## - Implemented remove method to cleanup data array and intelligently remove
## elements
##
## Revision 1.4 2003/07/14 19:06:58 scottl
## Implemented "simple" mode, made resizing more robust.
##
## Revision 1.3 2003/07/14 15:09:17 scottl
## Created add procedure to update the contents of the data array and optionally
## create rectangles if neccessary.
##
## Revision 1.2 2003/07/10 19:25:12 scottl
## Get classifications from data array instead of cnfg.
## Removed temporary debugging puts outputs.
## Normailzed selection co-ordinates when stored in the data array.
##
## Revision 1.1 2003/07/08 14:57:39 scottl
## Initial revision.
##
##
################################################################################
# PACKAGE DEPENDENCIES #
########################
package require Tk 8.3
package require BLT 2.4
# NAMESPACE DECLARATION #
#########################
namespace eval ::Jtag::Classify {
# make all public procedures declared in this namespace available
namespace export {[a-z]*}
# Import all the data from ::Jtag::Config into this namespace
namespace import ::Jtag::Config::*
# NAMESPACE VARIABLES #
#######################
# Lists of bucket button paths, one for the left and one for the right.
variable lBuckets
variable rBuckets
# options to apply to both the left and right frame created
variable f_attribs {-relief groove -borderwidth 3}
# options to apply to all buttons created
variable b_attribs {-relief groove -overrelief raised -borderwidth 3}
# the current selection rectangle
variable sel
set sel(parent) {}
set sel(tkn_label) {}
set sel(id) {}
set sel(modifying) 0
set sel(pos) {}
set sel(x1) {}
set sel(y1) {}
set sel(x2) {}
set sel(y2) {}
set sel(snapped) 0
set sel(start_timer) 0.
set sel(sl_time) 0.
set sel(cl_time) 0.
# the proximity to an exact pixel you must be
variable pad 3
}
# PUBLIC PROCEDURES #
#####################
# ::Jtag::Classify::create_buckets --
#
# Using information taken from the config file, sets up two frame widgets
# and evenly places buttons representing buckets inside them. Also sets up
# each bucket as a drag&drop target. Note that if either of the two
# specially named buckets: "start_of_page" or "end_of_page" is included in
# the list of buckets, these two are ignored since it doesn't make sense to
# tag an item as either of these.
#
# Arguments:
# wl The left parent window path. The left frame will be a child of
# this, and its buttons a child of the frame.
#
# wr The right parent window path. The right frame will be a child of
# this, and its buttons a child of the frame.
# Results:
# Returns a list containing paths to the left and right frames created upon
# success. Otherwise an error is returned.
proc ::Jtag::Classify::create_buckets {wl wr} {
# link any namespace variables needed
variable ::Jtag::Config::data
variable lBuckets {}
variable rBuckets {}
variable f_attribs
variable b_attribs
# declare any local variables needed
variable I
variable Item
variable Count
variable Match
variable Name
variable IgnoreSP "start_of_page"
variable IgnoreEP "end_of_page"
# the paths to the left, right frames
variable LF
variable RF
set Item(path) {}
set Item(colour) {}
debug {entering ::Jtag::Classify::create_buckets}
# create the left and right frames
catch {destroy $wl.left}
catch {destroy $wl.right}
set LF [eval frame $wl.left $f_attribs]
set RF [eval frame $wr.right $f_attribs]
# go through each of the configured classes, creating a button
# and packing it to its frame. Also add a drag&drop receiver for each
# button
set Count 1
foreach I [lsort -dictionary [array names data -regexp {(.*)(,)(colour)}]] {
# skip if we match any of the Ignore strings
if {[regexp $IgnoreSP $I] || [regexp $IgnoreEP $I]} {
continue
}
set Item(colour) $data($I)
regexp (.*)(,)(colour) $I Match Name
if {$Count % 2} {
# create a button for the left frame
set Item(path) $LF.$Name
if { [catch {lappend lBuckets [eval button $Item(path) \
-activebackground $Item(colour) -foreground $Item(colour) \
-text $Name $b_attribs ]} lBuckets] } {
error "Bad colour specified in config file"
}
} else {
# create a button for the right frame
set Item(path) $RF.$Name
if { [catch {lappend rBuckets [eval button $Item(path) \
-activebackground $Item(colour) -foreground $Item(colour) \
-text $Name $b_attribs ]} rBuckets] } {
error "Bad colour specified in config file"
}
}
# register the button as a drag&drop receiver
::blt::drag&drop target $Item(path) handler sel \
{::Jtag::Classify::AddToBucket %v %W}
set Count [expr $Count + 1]
}
if {[info exists lBuckets]} {
eval pack $lBuckets -side top -fill both -expand 1
}
if {[info exists rBuckets]} {
eval pack $rBuckets -side top -fill both -expand 1
}
::Jtag::UI::status_text "Creating class buttons"
# return a list containing the left and right frame
return [list $LF $RF]
}
# ::Jtag::Classify::bind_selection --
#
# This procedure binds the selection mechanisms to the widget passed.
#
# Arguments:
# w The widget to bind selection to. Usually this will be a canvas or
# some other widget that the user can draw on.
#
# Results:
# Associates appropriate left mouse button actions with helper methods
# to draw selections.
proc ::Jtag::Classify::bind_selection {w} {
# link any namespace variables needed
variable sel
# declare any local variables needed
variable Token
debug {entering ::Jtag::Classify::bind_selection}
# bind left mouse button selections on the widget passed to the helper
# methods defined below
set sel(parent) $w
bind $sel(parent) <ButtonPress-1> {::Jtag::Classify::PressDecide %W %x %y}
bind $sel(parent) <B1-Motion> {::Jtag::Classify::B1MotionDecide %W %x %y}
bind $sel(parent) <Motion> {::Jtag::Classify::MotionDecide %W %x %y}
bind $sel(parent) <ButtonRelease-1> {::Jtag::Classify::RelDecide %W %x %y}
# register the window passed as a drag & drop source (but don't bind any
# buttons to it yet -- hence the 0)
::blt::drag&drop source $w -button 0 -packagecmd \
{::Jtag::Classify::PackageSel %W %t}
::blt::drag&drop source $w handler sel
# create the token and its label, which will appear when we drag things
set Token [::blt::drag&drop token $w]
set sel(tkn_label) [label $Token.label]
pack $sel(tkn_label)
}
# ::Jtag::Classify::unbind_selection --
#
# This procedure removes any and all selection bindings from the widget
# stored in $sel(parent) (the canvas widget)
#
# Arguments:
#
# Results:
# Removes all click and drag event bindings from the canvas, unregisters the
# drag&drop sources and token.
proc ::Jtag::Classify::unbind_selection {} {
# link any namespace variables needed
variable sel
# declare any local variables needed
debug {entering ::Jtag::Classify::unbind_selection}
if {$sel(parent) == ""} {
# no selection have been bound yet
debug {nothing to un-bind}
return
}
bind $sel(parent) <ButtonPress-1> {}
bind $sel(parent) <B1-Motion> {}
bind $sel(parent) <Motion> {}
bind $sel(parent) <ButtonRelease-1> {}
destroy $sel(tkn_label)
}
# ::Jtag::Classify::add --
#
# This procedure adds the data passed to create a new entry in the data
# array, creating and displaying a new selection on the canvas if necessary.
#
# Arguments:
# c The canvas upon which to add the selection.
# class The name of the class to which the selection is being added
# x1 The actual image resolution normalized left edge selection pixel
# y1 The actual image resolution normalized top edge selection pixel
# x2 The actual image resolution normalized right edge selection pixel
# y2 The actual image resolution normalized bottom edge selection pixel
# mode The selection mode used (crop or simple)
# snapped 1 if the image rectangle was created by snapping, 0 otherwise
# id (optional) The full path to the selection rectangle if one has
# already been created. Specify "" to create a new one
# sl_time (optional) The total time in seconds to create the rectangle
# cl_time (optional) The total time in seconds to drag the selection to a
# classification bucket
# cl_att (optional) The number of times the selection has been
# classified/reclassified
# re_att (optional) The number of time the selection has been manually
# resized
#
# Results:
# Adds the data passed to the 'data' array, creating a new rectangle
# selection if neccessary.
proc ::Jtag::Classify::add {c class x1 y1 x2 y2 mode snapped {id ""} \
{sl_time ""} {cl_time ""} {cl_att ""} {re_att ""}} {
# link any namespace variables needed
variable ::Jtag::Config::data
variable ::Jtag::Image::img
# declare any local variables needed
debug {entering ::Jtag::Classify::add}
# create rectangle if neccessary
if {$id == ""} {
# since co-ords are in actual image size, we must multiply them by
# the current zoom factor to create correct sized rectangle
set id [$c create rectangle [expr $img(zoom) * $x1] \
[expr $img(zoom) * $y1] [expr $img(zoom) * $x2] \
[expr $img(zoom) * $y2]]
# hack to create transparent rectangles
::blt::bitmap define null1 { { 1 1 } { 0x0 } }
$c itemconfigure $id -width 2 -activewidth 4 -fill black \
-stipple null1 -outline $data($class,colour)
}
if {$sl_time == ""} {
set sl_time 0.
}
if {$cl_time == ""} {
set cl_time 0.
}
if {$cl_att == ""} {
set cl_att 1
}
if {$re_att == ""} {
set re_att 0
}
# update the data array
set data($class,$data($class,num_sels)) [list $id [expr round($x1)] \
[expr round($y1)] [expr round($x2)] [expr round($y2)] \
$mode $snapped $sl_time $cl_time $cl_att $re_att]
incr data($class,num_sels)
}
# ::Jtag::Classify::remove --
#
# This procedure removes the entry passed from the 'data' array, shifting
# up any other items, and decrementing the number of selections.
#
# Arguments:
# sel_ref The 'data' item to be removed. Note that it must be a string of
# the form: "<class>,<num>" where <class> is the name of a valid
# class and <num> is a valid numerical number corresponding
# to the selection number. This is the same format as is returned
# by ::Jtag::Classify::get_selection.
#
# Results:
# Updates the 'data' array appropriately to remove the element reference
# passed. Note that it is the caller's responsibility to destroy the
# associated rectange from the canvas.
proc ::Jtag::Classify::remove {sel_ref} {
# link any namespace variables needed
variable ::Jtag::Config::data
# declare any local variables needed
variable CommaPos
variable SelBase
variable SelNum
debug {entering ::Jtag::Classify::remove}
if {[array names data -exact $sel_ref] == ""} {
debug "trying to remove: $sel_ref a non-existent data item"
return
}
# remove the entry from 'data' and decrement the number of selection
# for the associated class. Note that the original may not be
# the last element, so check this and swap the last element for the
# now empty space.
set CommaPos [string last "," $sel_ref]
set SelBase [string range $sel_ref 0 $CommaPos]
set SelNum [string range $sel_ref [expr $CommaPos + 1] \
[string length $sel_ref]]
set LastNum [expr $data(${SelBase}num_sels) - 1]
debug "Removing $sel_ref entry: $data($sel_ref)"
if {$SelNum != $LastNum} {
# pop the last element contents to fill the hole in the array
array set data [list $sel_ref $data(${SelBase}${LastNum})]
array unset data ${SelBase}${LastNum}
} else {
array unset data $sel_ref
}
incr data(${SelBase}num_sels) -1
}
# ::Jtag::Classify::get_selection --
#
# Searches through all selection data in the 'data' array to see if there
# is a match for the rectangle id passed.
#
# Arguments:
# id the unique id returned during the creation of a rectangle that
# exists on the canvas.
#
# Results:
# If a match was found for id in the data array, a string is returned
# giving the element containing its data. Otherwise, the empty string is
# returned. Note that the string returned is a bit of a hack in that
# Tcl/Tk has no real support for multi-dimensional arrays. Since our data
# array is of this form, the string returned is of the form "<class>,<num>"
# where <class> is replaced with a valid class name, and <num> is
# replaced with the appropriate selection number matching the rectangle
# given by the id passed. You can use the string returned to get to the
# data as follows: data([get_selection $id]) for example.
proc ::Jtag::Classify::get_selection id {
# link any namespace variables
variable ::Jtag::Config::data
# declare any local variables needed
variable I
# debug "entering ::Jtag::Classify::get_selection"
# iterate through each of the selections in the data array one-by-one
foreach I [array names data -regexp {(.*)(,)([0-9])+}] {
if {$id == [lindex $data($I) 0]} {
# match found
return $I
}
}
return ""
}
# ::Jtag::Classify::snap_selection --
#
# Given a selection id, this procedure tightens the bounding rectangle
# represented by this id using ink thresholds as appropriate
#
# Arguments:
# id The unique id returned during the creation of a rectangle that
# exists on the canvas
#
# Results:
# The image is shrunk down on all 4 sides (if mode is crop) or top and
# bottom side (if mode is simple) until each side of the bounding box
# contains a certain threshold of non-background pixels
proc ::Jtag::Classify::snap_selection id {
# link any namespace variables
variable ::Jtag::Config::cnfg
variable ::Jtag::Image::can
variable ::Jtag::Image::img
variable ::Jtag::Config::data
# declare any local variables needed
variable Threshold
variable Background {#ffffff} ;# background colour (RGB format)
variable Simple {simple}
variable Data
variable NumPixels
variable InkCount
variable I
variable J
# current rectangle bounds
variable X1
variable Y1
variable X2
variable Y2
# set to 1 when we've met the bound for that side
variable X1Done 0
variable Y1Done 0
variable X2Done 0
variable Y2Done 0
debug {entering ::Jtag::Classify::snap_selection}
# ensure that an image exists to snap to
if {! [::Jtag::Image::exists]} {
debug "no image to snap selection to"
return
}
# ensure that the id refers to a created rectangle
set Y2 [$can(path) coords $id]
if {[llength $Y2] != 4} {
debug "no rectangle belonging to id $id passed"
return
}
# ensure the threshold exists and is a valid percent
if {$cnfg(snap_threshold) < 0 || $cnfg(snap_threshold) > 100} {
debug "snap_threshold set to invalid percentage"
return
}
# change the cursor since this may take a bit of time (depending on sel
# size and error), and prevent other operations
::blt::busy hold .
set X1 [expr round([lindex $Y2 0] / $img(zoom))]
set Y1 [expr round([lindex $Y2 1] / $img(zoom))]
set X2 [expr round([lindex $Y2 2] / $img(zoom))]
set Y2 [expr round([lindex $Y2 3] / $img(zoom))]
::Jtag::UI::status_text "Snapping selection at ($X1, $Y1) ($X2, $Y2)"
# if we are in simple mode, explicitly set X1 and X2 to be the width of
# the image (rounding may make it larger than the image, causing problems
# below)
if {$cnfg(mode) == $Simple} {
set X1 0
set X2 [lindex [::Jtag::Image::get_actual_dimensions] 0]
}
# loop over all sides, moving them in one pixel at a time until done
while {! ($X1Done && $Y1Done && $X2Done && $Y2Done)} {
if {$X1 >= $X2 || $Y1 >= $Y2} {
debug "no ink found in selection"
# now allow people to interact and handle events again
::blt::busy release .
return
}
if {! $X1Done} {
set Data [$img(orig_img) data -grayscale \
-from $X1 $Y1 [expr $X1+1] $Y2]
set NumPixels [llength $Data]
set InkCount 0
foreach I $Data {
if {$I != $Background} {
incr InkCount
}
}
if {$InkCount >= [expr $NumPixels * $cnfg(snap_threshold) / 100.]} {
set X1Done 1
} else {
incr X1
}
} ;# end X1 checks
if {! $Y1Done} {
set Data [$img(orig_img) data -grayscale \
-from $X1 $Y1 $X2 [expr $Y1+1]]
set NumPixels [llength [lindex $Data 0]]
set InkCount 0
foreach I [lindex $Data 0] {
if {$I != $Background} {
incr InkCount
}
}
if {$InkCount >= [expr $NumPixels * $cnfg(snap_threshold) / 100.]} {
set Y1Done 1
} else {
incr Y1
}
} ;# end Y1 checks
if {! $X2Done} {
set Data [$img(orig_img) data -grayscale \
-from [expr $X2 -1] $Y1 $X2 $Y2]
set NumPixels [llength $Data]
set InkCount 0
foreach I $Data {
if {[lindex $I 0] != $Background} {
incr InkCount
}
}
if {$InkCount >= [expr $NumPixels * $cnfg(snap_threshold) / 100.]} {
set X2Done 1
} else {
incr X2 -1
}
} ;# end X2 checks
if {! $Y2Done} {
set Data [$img(orig_img) data -grayscale \
-from $X1 [expr $Y2 -1] $X2 $Y2]
set NumPixels [llength [lindex $Data 0]]
set InkCount 0
foreach I [lindex $Data 0] {
if {$I != $Background} {
incr InkCount
}
}
if {$InkCount >= [expr $NumPixels * $cnfg(snap_threshold) / 100.]} {
set Y2Done 1
} else {
incr Y2 -1
}
} ;# end Y2 checks
} ;# end while
if {$cnfg(mode) == $Simple} {
# explicitly set the X widths back to the image width
set X1 0
set X2 [lindex [::Jtag::Image::get_actual_dimensions] 0]
}
# now set the rectangle co-ords to the new value
$can(path) coords $id [expr $X1 * $img(zoom)] [expr $Y1 * $img(zoom)] \
[expr $X2 * $img(zoom)] [expr $Y2 * $img(zoom)]
# now allow people to interact and handle events again
::blt::busy release .
}
# PRIVATE PROCEDURES #
######################
# ::Jtag::Classify::PressDecide --
#
# Determines course of action to take when the user presses the left mouse
# button inside the canvas
#
# Arguments:
# c The canvas upon which we have clicked
# x The current x co-ord of the mouse (relative to visible window)
# y The current y co-ord of the mouse (relative to visible window)
#
# Results:
# Appropriate helper is called depending on the mode, and where we clicked
proc ::Jtag::Classify::PressDecide {c x y} {
# link any namespace variables needed
variable ::Jtag::Config::cnfg
variable sel
# declare any local variables needed
variable R
variable Coords
# check to see if we are clicking on/inside a rectangle
set R [$c find withtag current]
set Coords [$c coords $R]
if {[llength $Coords] != 4} {
# outside a rectangle, start a selection in the appropriate mode,
# first converting x,y into canvas co-ords
::Jtag::Classify::SelStart $c [$c canvasx $x] [$c canvasy $y] \
$cnfg(mode)
} else {
# check if we clicked on the border (and thus allow resizing to start)
set Pos [eval ::Jtag::Classify::DeterminePos [join $Coords] \
[$c canvasx $x] [$c canvasy $y]]
if {$Pos != ""} {
::Jtag::Classify::ResizeStart $c $R $Pos
} else {
# allow the canvas to perform drag & drop operation
::blt::drag&drop source $c -button 1
# start the classification timer
set sel(cl_time) 0.
set sel(start_timer) [clock clicks -milliseconds]
}
}
}
# ::Jtag::Classify::B1MotionDecide --
#
# Determines course of action to take when the user has the left mouse
# button depressed and drags the mouse over the canvas
#
# Arguments:
# c The canvas upon which we have clicked
# x The current x co-ord of the mouse (relative to visible window)
# y The current y co-ord of the mouse (relative to visible window)
#
# Results:
# Appropriate helper is called depending on the mode, and if we are in the
# middle of a drag & drop
proc ::Jtag::Classify::B1MotionDecide {c x y} {
# link any namespace variables needed
variable ::Jtag::Config::cnfg
# declare any local variables needed
variable R
variable Coords
# short circuit the call if we are in the middle of a drag & drop op
# or happen to nudge the mouse while presseing or releasing the button
# inside a rectangle (ex after snapping or merging a selection)
set R [$c find withtag current]
set Coords [$c coords $R]
if {[::blt::drag&drop active] || [llength $Coords] == 4} {
return
}
::Jtag::Classify::SelExpand $c [$c canvasx $x] [$c canvasy $y] $cnfg(mode)
}
# ::Jtag::Classify::MotionDecide --
#
# Determines the course of action to take when the user moves the mouse
# over the canvas.
#
# Arguments:
# c The canvas upon which we have clicked
# x The current x co-ord of the mouse (relative to visible window)
# y The current y co-ord of the mouse (relative to visible window)
#
# Results:
# If we are over the edge of a selection window the appropriate cursor
# image is displayed, to ease with resizing
proc ::Jtag::Classify::MotionDecide {c x y} {
# link any namespace variables needed
variable pad
variable ::Jtag::Image::img
variable lBuckets
variable rBuckets
# declare any local variables needed
variable R
variable Coords
variable X1
variable Y1
variable X2
variable Y2
set R [$c find withtag current]
set Coords [$c coords $R]
::Jtag::UI::status_text "POS: [expr [$c canvasx $x] / $img(zoom)], \
[expr [$c canvasy $y] / $img(zoom)]"
set Buckets [concat $lBuckets $rBuckets]
foreach I $Buckets {
$I configure -state normal
}
if {[llength $Coords] == 4} {
#inside a rectangle
set X1 [lindex $Coords 0]
set Y1 [lindex $Coords 1]
set X2 [lindex $Coords 2]
set Y2 [lindex $Coords 3]
$c configure -cursor [::Jtag::Classify::DeterminePos $X1 $Y1 $X2 $Y2 \
[$c canvasx $x] [$c canvasy $y]]
set SelRef [::Jtag::Classify::get_selection $R]
if {$SelRef != ""} {
# display the original 'data' elements
set Class [string range $SelRef 0 [expr \
[string last "," $SelRef] - 1]]
set X1 [lindex $::Jtag::Config::data($SelRef) 1]
set Y1 [lindex $::Jtag::Config::data($SelRef) 2]
set X2 [lindex $::Jtag::Config::data($SelRef) 3]
set Y2 [lindex $::Jtag::Config::data($SelRef) 4]
set Mode [lindex $::Jtag::Config::data($SelRef) 5]
set Snapped [lindex $::Jtag::Config::data($SelRef) 6]
set SelTime [lindex $::Jtag::Config::data($SelRef) 7]
set ClsTime [lindex $::Jtag::Config::data($SelRef) 8]
set ClsAttmpt [lindex $::Jtag::Config::data($SelRef) 9]
set ResAttmpt [lindex $::Jtag::Config::data($SelRef) 10]
# flash the button associated with this selection
foreach I $Buckets {
if {[regexp \\.$Class$ $I]} {
$I configure -state active
}
}
::Jtag::UI::status_text "SEL: ($X1, $Y1, $X2, $Y2) \
Class=$Class Mode=$Mode Snapped=$Snapped SelTime=$SelTime \
ClsTime=$ClsTime ClassAttmpts=$ClsAttmpt \
ResizeAttmpts=$ResAttmpt"
}
} else {
$c configure -cursor left_ptr
}
}
# ::Jtag::Classify::RelDecide --
#
# Determines course of action to take when the user releases the left mouse
# button inside the canvas
#
# Arguments:
# c The canvas upon which we have clicked
# x The current x co-ord of the mouse (relative to visible window)
# y The current y co-ord of the mouse (relative to visible window)
#
# Results:
# Appropriate helper is called depending on the mode, and where we released
proc ::Jtag::Classify::RelDecide {c x y} {
# link any namespace variables needed
variable sel
variable ::Jtag::Config::cnfg
# declare any local variables needed
if {$sel(modifying)} {
::Jtag::Classify::SelEnd $c [$c canvasx $x] [$c canvasy $y] $cnfg(mode)
return
}
# since we have released a drag&drop, ensure that we unbind it
::blt::drag&drop source $c -button 0
}
# ::Jtag::Classify::SelStart --
#
# This procedure starts creation of a selection rectangle in the mode
# passed.
#
# Arguments:
# c The canvas upon which we are making the selection
# x The x co-ord of the mouse at the start of the selection
# y The y co-ord of the mouse at the start of the selection
# m The mode (must be a string containing either "crop" or "simple"
#
# Results:
# Begins the creation of the rectangle that will expand as the user drags
# the mouse.
proc ::Jtag::Classify::SelStart {c x y m} {
# link any namespace variables needed
variable sel
# declare any local variables needed
# create a rectangle at the origin:
set sel(y1) $y
set sel(y2) $y
if {$m == "crop"} {
set sel(x1) $x
set sel(x2) $x
} elseif {$m == "simple"} {
set sel(x1) 0.
set sel(x2) [lindex [::Jtag::Image::get_current_dimensions] 0]
} else {
debug "Unknown selection mode passed. Ignoring creation of rectangle"
return
}
set sel(id) [$c create rectangle $sel(x1) $sel(y1) $sel(x2) $sel(y2)]
# set flag to declare that we are modifying our selection rectangle
set sel(modifying) 1
set sel(snapped) 0
set sel(pos) ""
# record current time (in seconds) to determine selection time
set sel(start_timer) [clock clicks -milliseconds]
set sel(sl_time) 0.
}
# ::Jtag::Classify::ResizeStart --
#
# This procedure starts to resize a selection rectangle.
#
# Arguments:
# c The canvas upon which we are making the resize
# r The rectangle we are resizing
# pos The corner/side to resize (anchor all other co-ords)
#
# Results:
# Begins the modification of the rectangle that will expand/contract anchored
# about (x1,y1) as the user drags the mouse.
proc ::Jtag::Classify::ResizeStart {c r pos} {
# link any namespace variables needed
variable sel
# declare any local variables needed
variable Coords [$c coords $r]
# create a rectangle at the origin:
set sel(id) $r
# remember origin:
set sel(x1) [lindex $Coords 0]
set sel(y1) [lindex $Coords 1]
set sel(x2) [lindex $Coords 2]
set sel(y2) [lindex $Coords 3]
set sel(pos) $pos
set sel(snapped) 0
# set flag to declare that we are modifying our selection rectangle
set sel(modifying) 1
# record current time (in seconds) to determine selection time
set sel(start_timer) [clock clicks -milliseconds]
set sel(sl_time) 0.
}
# ::Jtag::Classify::SelExpand --
#
# Expands an existing selection rectangle appropriately depending on the
# mode passed.
#
# Arguments:
# c The canvas upon which we are making the selection
# x The x co-ord of the mouse currently
# y The y co-ord of the mouse currently
# m The mode (must be a string containing either "crop" or "simple"
#
# Results:
# The rectangle size is increased to that of the current mouse position in
# height (and in width if mode is "crop")
proc ::Jtag::Classify::SelExpand {c x y m} {
# link any namespace variables needed
variable sel