Context Navigation

source: branches/uq/gui/scripts/videoscreen.tcl @ 5679

Last change on this file since 5679 was 5679, checked in by ldelgass, 9 years ago
Full merge 1.3 branch to uq branch to sync. Fixed partial subdirectory merge by removing mergeinfo from lang/python/Rappture directory.
File size: 41.6 KB

Line
1	# -- mode: tcl; indent-tabs-mode: nil --
2	# ----------------------------------------------------------------------
3	# COMPONENT: video - viewing movies
4	#
5	# ======================================================================
6	# AUTHOR: Michael McLennan, Purdue University
7	# Copyright (c) 2004-2012 HUBzero Foundation, LLC
8	#
9	# See the file "license.terms" for information on usage and redistribution of
10	# this file, and for a DISCLAIMER OF ALL WARRANTIES.
11	# ======================================================================
12
13	package require Itk
14	package require BLT
15	package require Img
16	package require Rappture
17	package require RapptureGUI
18
19	option add *Video.width -1 widgetDefault
20	option add *Video.height -1 widgetDefault
21	option add *Video.foreground black widgetDefault
22	option add *Video.controlBackground gray widgetDefault
23	option add *Video.font \
24	--helvetica-medium-r-normal--12-* widgetDefault
25
26	itcl::class Rappture::VideoScreen {
27	inherit itk::Widget
28
29	itk_option define -width width Width -1
30	itk_option define -height height Height -1
31	itk_option define -fileopen fileopen Fileopen ""
32
33	constructor { args } {
34	# defined below
35	}
36	destructor {
37	# defined below
38	}
39
40	public method load {type data}
41	public method loadcb {args}
42	public method video {args}
43	public method query {type}
44
45	protected method Play {}
46	protected method Seek {n}
47	protected method fixSize {}
48	protected method Upload {args}
49	protected method eventually {args}
50
51	private method togglePtrCtrl {pbvar}
52	private method whatPtrCtrl {}
53	private method togglePtrBind {pbvar}
54
55	# drawing tools
56	private method Rubberband {status win x y}
57	private method updateMeasurements {}
58	private method Measure {status win x y}
59	private method Particle {status win x y}
60	private method Trajectory {args}
61	private method calculateTrajectory {args}
62	private method writeText {x y text color tags width}
63	private method clearDrawings {}
64
65	# video dial tools
66	private method toggleloop {}
67
68	private common _settings
69	private common _pendings
70	private common _pbvars
71	private common _counters
72
73	private variable _width -1 ;# width of the movie
74	private variable _height -1 ;# height of the movie
75	private variable _movie "" ;# movie we grab images from
76	private variable _lastFrame 0 ;# last frame in the movie
77	private variable _imh "" ;# current image being displayed
78	private variable _id "" ;# id of the next play command from after
79	private variable _framerate 30 ;# video frame rate
80	private variable _mspf 7 ;# milliseconds per frame wait time
81	private variable _ofrd 19 ;# observed frame retrieval delay of
82	;# underlying c lib in milliseconds
83	private variable _delay 0 ;# milliseconds between play calls
84	private variable _nextframe 0 ;#
85
86	private variable _px2dist 0 ;# conversion for pixels to user specified distance
87	private variable _particles "" ;# list of particles
88	private variable _measurements "" ;# list of all measurement lines
89	private variable _obj "" ;# temp var holding the last created object
90	}
91
92
93	itk::usual VideoScreen {
94	keep -background -foreground -cursor -font
95	keep -plotbackground -plotforeground
96	}
97
98	# ----------------------------------------------------------------------
99	# CONSTRUCTOR
100	# ----------------------------------------------------------------------
101	itcl::body Rappture::VideoScreen::constructor {args} {
102
103	array set _settings [subst {
104	framenum 0
105	loop 0
106	play 0
107	speed 1
108	}]
109
110	array set _pendings {
111	seek 0
112	play 0
113	}
114
115	array set _counters {
116	particle 0
117	measure 0
118	}
119
120	# Create flow controls...
121
122	itk_component add main {
123	canvas $itk_interior.main
124	} {
125	usual
126	rename -background -controlbackground controlBackground Background
127	}
128	bind $itk_component(main) <Configure> [itcl::code $this fixSize]
129
130	# setup the image display
131	# hold the video frames in an image on the canvas
132	set _imh [image create photo]
133
134	$itk_component(main) create image 0 0 \
135	-anchor center \
136	-image ${_imh} \
137	-tags videoframe
138
139	# setup movie controls
140	itk_component add moviecontrols {
141	frame $itk_interior.moviecontrols
142	} {
143	usual
144	rename -background -controlbackground controlBackground Background
145	}
146
147	# setup frame number frame
148	itk_component add frnumfr {
149	frame $itk_component(moviecontrols).frnumfr
150	} {
151	usual
152	rename -background -controlbackground controlBackground Background
153	}
154
155	set imagesDir [file join $RapptureGUI::library scripts images]
156
157	# ==== fileopen ====
158	itk_component add fileopen {
159	button $itk_component(moviecontrols).fileopen \
160	-borderwidth 1 -padx 1 -pady 1 \
161	-image [Rappture::icon upload] \
162	-command [itcl::code $this loadcb]
163	} {
164	usual
165	}
166	Rappture::Tooltip::for $itk_component(fileopen) \
167	"Open file"
168
169	# ==== measuring tool ====
170	set measImg [image create photo -file [file join $imagesDir "line_darrow_green.png"]]
171	itk_component add measure {
172	Rappture::PushButton $itk_component(moviecontrols).measurepb \
173	-onimage $measImg \
174	-offimage $measImg \
175	-disabledimage $measImg \
176	-command [itcl::code $this togglePtrCtrl "measure"] \
177	-variable [itcl::scope _pbvars(measure)]
178	} {
179	usual
180	}
181	$itk_component(measure) disable
182	Rappture::Tooltip::for $itk_component(measure) \
183	"Measure the distance of a structure"
184
185	# ==== particle mark tool ====
186	set particleImg [image create photo -file [file join $imagesDir "volume-on.gif"]]
187	itk_component add particle {
188	Rappture::PushButton $itk_component(moviecontrols).particlepb \
189	-onimage $particleImg \
190	-offimage $particleImg \
191	-disabledimage $particleImg \
192	-command [itcl::code $this togglePtrCtrl "particle"] \
193	-variable [itcl::scope _pbvars(particle)]
194	} {
195	usual
196	}
197	$itk_component(particle) disable
198	Rappture::Tooltip::for $itk_component(particle) \
199	"Mark the location of a particle to follow"
200
201
202	# Rewind
203	itk_component add rewind {
204	button $itk_component(moviecontrols).rewind \
205	-borderwidth 1 -padx 1 -pady 1 \
206	-image [Rappture::icon video-rewind] \
207	-command [itcl::code $this video seek 0]
208	} {
209	usual
210	ignore -borderwidth
211	rename -highlightbackground -controlbackground controlBackground \
212	Background
213	}
214	$itk_component(rewind) configure -state disabled
215	Rappture::Tooltip::for $itk_component(rewind) \
216	"Rewind movie"
217
218	# Seek back
219	itk_component add seekback {
220	button $itk_component(moviecontrols).seekback \
221	-borderwidth 1 -padx 1 -pady 1 \
222	-image [Rappture::icon flow-rewind] \
223	-command [itcl::code $this video seek -1]
224	} {
225	usual
226	ignore -borderwidth
227	rename -highlightbackground -controlbackground controlBackground \
228	Background
229	}
230	$itk_component(seekback) configure -state disabled
231	Rappture::Tooltip::for $itk_component(rewind) \
232	"Seek backwards 1 frame"
233
234	# Play
235	itk_component add play {
236	Rappture::PushButton $itk_component(moviecontrols).play \
237	-onimage [Rappture::icon flow-pause] \
238	-offimage [Rappture::icon flow-play] \
239	-disabledimage [Rappture::icon flow-play] \
240	-variable [itcl::scope _settings(play)] \
241	-command [itcl::code $this video play]
242	}
243	$itk_component(play) disable
244	Rappture::Tooltip::for $itk_component(play) \
245	"Play/Pause movie"
246
247	# Seek forward
248	itk_component add seekforward {
249	button $itk_component(moviecontrols).seekforward \
250	-borderwidth 1 -padx 1 -pady 1 \
251	-image [Rappture::icon flow-forward] \
252	-command [itcl::code $this video seek +1]
253	} {
254	usual
255	ignore -borderwidth
256	rename -highlightbackground -controlbackground controlBackground \
257	Background
258	}
259	$itk_component(seekforward) configure -state disabled
260	Rappture::Tooltip::for $itk_component(seekforward) \
261	"Seek forward 1 frame"
262
263	# Loop
264	itk_component add loop {
265	Rappture::PushButton $itk_component(moviecontrols).loop \
266	-onimage [Rappture::icon flow-loop] \
267	-offimage [Rappture::icon flow-loop] \
268	-disabledimage [Rappture::icon flow-loop] \
269	-variable [itcl::scope _settings(loop)] \
270	-command [itcl::code $this toggleloop]
271	}
272	$itk_component(loop) disable
273	Rappture::Tooltip::for $itk_component(loop) \
274	"Play continuously between marked sections"
275
276	itk_component add dial {
277	frame $itk_interior.dial
278	} {
279	usual
280	rename -background -controlbackground controlBackground Background
281	}
282
283	# Video Dial Major
284	itk_component add dialmajor {
285	Rappture::Videodial1 $itk_component(dial).dialmajor \
286	-length 10 -valuewidth 0 -valuepadding 0 -padding 6 \
287	-linecolor "" -activelinecolor "" \
288	-min 0 -max 1 \
289	-variable [itcl::scope _settings(framenum)] \
290	-dialoutlinecolor black \
291	-knobimage [Rappture::icon knob2] -knobposition center@middle
292	} {
293	usual
294	ignore -dialprogresscolor
295	rename -background -controlbackground controlBackground Background
296	}
297	$itk_component(dialmajor) current 0
298	bind $itk_component(dialmajor) <<Value>> [itcl::code $this video update]
299
300	# Video Dial Minor
301	itk_component add dialminor {
302	Rappture::Videodial2 $itk_component(dial).dialminor \
303	-padding 0 \
304	-min 0 -max 1 \
305	-minortick 1 -majortick 5 \
306	-variable [itcl::scope _settings(framenum)] \
307	-dialoutlinecolor black
308	} {
309	usual
310	rename -background -controlbackground controlBackground Background
311	}
312	$itk_component(dialminor) current 0
313	bind $itk_component(dialminor) <<Value>> [itcl::code $this video update]
314
315	set fg [option get $itk_component(hull) font Font]
316
317	itk_component add framenumlabel {
318	label $itk_component(frnumfr).framenuml -text "Frame:" -font "arial 9" \
319	-highlightthickness 0
320	} {
321	usual
322	ignore -highlightthickness
323	rename -background -controlbackground controlBackground Background
324	}
325
326	# Current Frame Number
327	itk_component add framenum {
328	label $itk_component(frnumfr).framenum \
329	-background white -font "arial 9" \
330	-textvariable [itcl::scope _settings(framenum)]
331	} {
332	usual
333	ignore -highlightthickness
334	rename -background -controlbackground controlBackground Background
335	}
336	Rappture::Tooltip::for $itk_component(framenum) \
337	"Current frame number"
338
339
340	pack $itk_component(framenumlabel) -side left
341	pack $itk_component(framenum) -side right
342
343
344	itk_component add speedlabel {
345	label $itk_component(moviecontrols).speedl -text "Speed:" -font $fg \
346	-highlightthickness 0
347	} {
348	usual
349	ignore -highlightthickness
350	rename -background -controlbackground controlBackground Background
351	}
352
353	# Speed
354	itk_component add speed {
355	Rappture::Videospeed $itk_component(moviecontrols).speed \
356	-min 0 -max 1 -width 4 -font "arial 9" -factor 2
357	} {
358	usual
359	ignore -highlightthickness
360	rename -background -controlbackground controlBackground Background
361	}
362	Rappture::Tooltip::for $itk_component(speed) \
363	"Change speed of movie"
364
365	$itk_component(speed) value 0.25
366	bind $itk_component(speed) <<Value>> [itcl::code $this video speed]
367
368
369	blt::table $itk_component(dial) \
370	0,0 $itk_component(dialmajor) -fill x \
371	1,0 $itk_component(dialminor) -fill x
372
373	blt::table $itk_component(moviecontrols) \
374	0,0 $itk_component(fileopen) -padx {2 0} \
375	0,1 $itk_component(measure) -padx {4 0} \
376	0,2 $itk_component(particle) -padx {4 0} \
377	0,5 $itk_component(dial) -fill x -padx {2 4} -rowspan 3 \
378	1,0 $itk_component(rewind) -padx {2 0} \
379	1,1 $itk_component(seekback) -padx {4 0} \
380	1,2 $itk_component(play) -padx {4 0} \
381	1,3 $itk_component(seekforward) -padx {4 0} \
382	1,4 $itk_component(loop) -padx {4 0} \
383	2,0 $itk_component(frnumfr) -padx {0 0} -cspan 3 \
384	2,3 $itk_component(speed) -padx {2 0} -cspan 2
385
386	blt::table configure $itk_component(moviecontrols) c* -resize none
387	blt::table configure $itk_component(moviecontrols) c5 -resize both
388	blt::table configure $itk_component(moviecontrols) r0 -pady 1
389
390
391	blt::table $itk_interior \
392	0,0 $itk_component(main) -fill both \
393	1,0 $itk_component(moviecontrols) -fill x
394	blt::table configure $itk_interior c* -resize both
395	blt::table configure $itk_interior r0 -resize both
396	blt::table configure $itk_interior r1 -resize none
397
398	eval itk_initialize $args
399
400	$itk_component(main) configure -background black
401	}
402
403	# ----------------------------------------------------------------------
404	# DESTRUCTOR
405	# ----------------------------------------------------------------------
406	itcl::body Rappture::VideoScreen::destructor {} {
407	array unset _settings *
408	array unset _pendings *
409	array unset _pbvars *
410	array unset _counters *
411
412
413	if {[info exists _imh] && ("" != ${_imh})} {
414	image delete ${_imh}
415	set _imh ""
416	}
417
418	if {[info exists measImg]} {
419	image delete $measImg
420	set measImg ""
421	}
422
423	if {[info exists particleImg]} {
424	image delete $particleImg
425	set particleImg ""
426	}
427
428	if {("" != [info commands ${_movie}])} {
429	# clear the movie if it is still open
430	${_movie} release
431	set _movie ""
432	}
433
434	clearDrawings
435	}
436
437	# ----------------------------------------------------------------------
438	# clearDrawings - delete all particle and measurement objects
439	# ----------------------------------------------------------------------
440	itcl::body Rappture::VideoScreen::clearDrawings {} {
441
442	# delete all previously placed particles
443	set obj [lindex ${_particles} end]
444	while {"" != [info commands $obj]} {
445	itcl::delete object $obj
446	set _particles [lreplace ${_particles} end end]
447	if {[llength ${_particles}] == 0} {
448	break
449	}
450	set obj [lindex ${_particles} end]
451	}
452
453	# delete all previously placed measurements
454	set obj [lindex ${_measurements} end]
455	while {"" != [info commands $obj]} {
456	itcl::delete object $obj
457	set _measurements [lreplace ${_measurements} end end]
458	if {[llength ${_measurements}] == 0} {
459	break
460	}
461	set obj [lindex ${_measurements} end]
462	}
463	}
464
465	# ----------------------------------------------------------------------
466	# load - load a video file
467	# type - type of data, "data" or "file"
468	# data - what to load.
469	# if type == "data", data is treated like binary data
470	# if type == "file", data is treated like the name of a file
471	# and is opened and then loaded.
472	# ----------------------------------------------------------------------
473	itcl::body Rappture::VideoScreen::load {type data} {
474
475	video stop
476
477	# open the file
478	set fname ""
479	switch $type {
480	"data" {
481	if {"" == $data} {
482	error "bad value \"$data\": data should be a movie"
483	}
484
485	set fname "/tmp/tmpVV[pid].video"
486	set fid [open $fname "w"]
487	fconfigure $fid -translation binary -encoding binary
488	puts $fid $data
489	close $fid
490	set type "file"
491	set data $fname
492	}
493	"file" {
494	if {"" == $data} {
495	error "bad value \"$data\": data should be a movie file path"
496	}
497	# do nothing
498	}
499	default {
500	error "bad value: \"$type\": should be \"load \[data\|file\] <data>\""
501	}
502	}
503
504	if {"file" == $type} {
505	if {("" != [info commands ${_movie}])} {
506	# compare the new file name to the name of the file
507	# we already have open in our _movie object.
508	# if they are the same, do not reopen the video.
509	# if they are different, close the old movie
510	# and clear out all old drawings from the canvas.
511	set err [catch {${_movie} filename} filename]
512	if {($err == 0)&& ($data == $filename)} {
513	# video file already open, don't reopen it.
514	return
515	} else {
516	# clear the old movie
517	${_movie} release
518	set _width -1
519	set _height -1
520
521	# delete drawings objects from canvas
522	clearDrawings
523	}
524	}
525	}
526
527	set _movie [Rappture::Video $type $data]
528	if {"" != $fname} {
529	file delete $fname
530	}
531	set _framerate [${_movie} framerate]
532	video speed
533	puts stderr "framerate: ${_framerate}"
534
535	set _lastFrame [${_movie} get position end]
536
537	# update the dial with video information
538	$itk_component(dialmajor) configure -min 0 -max ${_lastFrame}
539	$itk_component(dialminor) configure -min 0 -max ${_lastFrame}
540
541	# turn on the buttons and dials
542	$itk_component(measure) enable
543	$itk_component(particle) enable
544	$itk_component(rewind) configure -state normal
545	$itk_component(seekback) configure -state normal
546	$itk_component(play) enable
547	$itk_component(seekforward) configure -state normal
548	$itk_component(loop) enable
549
550	# make sure looping is off
551	set _settings(loop) 0
552	$itk_component(dialminor) loop disable
553
554	fixSize
555
556	# goto the first frame
557	# update the dial and framenum widgets
558	video seek 0
559	set _settings(framenum) 0
560	}
561
562	# ----------------------------------------------------------------------
563	# loadcb - load callback
564	# ----------------------------------------------------------------------
565	itcl::body Rappture::VideoScreen::loadcb {args} {
566	video stop
567	Rappture::filexfer::upload {piv tool} {id label desc} [itcl::code $this Upload]
568	}
569
570	# ----------------------------------------------------------------------
571	# Upload -
572	# ----------------------------------------------------------------------
573	itcl::body Rappture::VideoScreen::Upload {args} {
574	array set data $args
575	video stop
576
577	if {[info exists data(error)]} {
578	Rappture::Tooltip::cue $itk::component(main) $data(error)
579	puts stderr $data(error)
580	}
581
582	if {[info exists data(path)] && [info exists data(data)]} {
583	Rappture::Tooltip::cue hide ;# take down note about the popup window
584
585	# load data
586	load "data" $data(data)
587	}
588
589	}
590
591
592	# ----------------------------------------------------------------------
593	# fixSize
594	# ----------------------------------------------------------------------
595	itcl::body Rappture::VideoScreen::fixSize {} {
596
597	if {[string compare "" ${_movie}] == 0} {
598	return
599	}
600
601	if {![winfo ismapped $itk_component(hull)]} {
602	return
603	}
604
605	# get dimensions for the new image
606	# adjust the aspect ratio, if necessary
607
608	puts stderr "aspect ratio: [query aspectratio]"
609
610	foreach {w h} [query dimensions] break
611	foreach {num den} [query aspectratio] break
612
613	if {[expr 1.0$w/$h] != [expr 1.0$num/$den]} {
614	# we need to adjust the frame height and width
615	# to keep the correct aspect ratio
616	# hold the height constant,
617	# adjust the width as close as we can
618	# to the correct aspect ratio
619	set w [expr int(1.0$num/$den$h)]
620	}
621
622	if {-1 == ${_width}} {
623	set _width $w
624	}
625	if {-1 == ${_height}} {
626	set _height $h
627	}
628
629	# get an image with the new size
630	${_imh} blank
631	${_imh} configure -width 1 -height 1
632	${_imh} configure -width 0 -height 0
633	${_imh} put [${_movie} get image ${_width} ${_height}]
634
635	# place the image in the center of the canvas
636	set ccw [winfo width $itk_component(main)]
637	set cch [winfo height $itk_component(main)]
638	$itk_component(main) coords videoframe [expr $ccw/2.0] [expr $cch/2.0]
639
640	puts stderr "----------------------------"
641	puts stderr "adjusted = $w $h"
642	puts stderr "data = ${_width} ${_height}"
643	puts stderr "image = [image width ${_imh}] [image height ${_imh}]"
644	foreach {x0 y0 x1 y1} [$itk_component(main) bbox videoframe] break
645	puts stderr "bbox = $x0 $y0 $x1 $y1"
646	puts stderr "ccw cch = [expr $ccw/2.0] [expr $cch/2.0]"
647	puts stderr "main = [winfo width $itk_component(main)] [winfo height $itk_component(main)]"
648	puts stderr "hull = [winfo width $itk_component(hull)] [winfo height $itk_component(hull)]"
649	}
650
651	# ----------------------------------------------------------------------
652	# video - play, stop, rewind, fastforward the video
653	# ----------------------------------------------------------------------
654	itcl::body Rappture::VideoScreen::video { args } {
655	set option [lindex $args 0]
656	switch -- $option {
657	"play" {
658	if {$_settings(play) == 1} {
659	eventually play
660	} else {
661	# pause/stop
662	after cancel $_id
663	set _pendings(play) 0
664	set _settings(play) 0
665	}
666	}
667	"seek" {
668	Seek [lreplace $args 0 0]
669	}
670	"stop" {
671	after cancel $_id
672	set _settings(play) 0
673	}
674	"speed" {
675	set speed [$itk_component(speed) value]
676	set _mspf [expr round(((1.0/${_framerate})*1000)/$speed)]
677	set _delay [expr {${_mspf} - ${_ofrd}}]
678	puts stderr "_mspf = ${_mspf} \| $speed \| ${_ofrd} \| ${_delay}"
679	}
680	"update" {
681	eventually seek [expr round($_settings(framenum))]
682	# Seek [expr round($_settings(framenum))]
683	}
684	default {
685	error "bad option \"$option\": should be play, stop, toggle, position, or reset."
686	}
687	}
688	}
689
690	# ----------------------------------------------------------------------
691	# query - query things about the video
692	#
693	# dimensions - returns width and height as a list
694	# frames - number of frames in video (last frame + 1)
695	# framenum - current position
696	# ----------------------------------------------------------------------
697	itcl::body Rappture::VideoScreen::query { type } {
698	set ret ""
699	switch -- $type {
700	"aspectratio" {
701	set ret [${_movie} aspect display]
702	}
703	"dimensions" {
704	set ret [${_movie} size]
705	}
706	"frames" {
707	set ret [expr [${_movie} get position end] + 1]
708	}
709	"framenum" {
710	set ret [${_movie} get position cur]
711	}
712	default {
713	error "bad type \"$type\": should be dimensions, frames, framenum."
714	}
715	}
716	return $ret
717	}
718
719	# ----------------------------------------------------------------------
720	# Play - get the next video frame
721	# ----------------------------------------------------------------------
722	itcl::body Rappture::VideoScreen::Play {} {
723
724	set cur ${_nextframe}
725
726	# time how long it takes to retrieve the next frame
727	set _ofrd [time {
728	# use seek instead of next fxn incase the ${_nextframe} is
729	# not the current frame+1. this happens when we skip frames
730	# because the underlying c lib is too slow at reading.
731	${_movie} seek $cur
732	${_imh} put [${_movie} get image ${_width} ${_height}]
733	} 1]
734	regexp {(\d+\.?\d*) microseconds per iteration} ${_ofrd} match _ofrd
735	set _ofrd [expr {round(${_ofrd}/1000)}]
736
737	# calculate the delay we shoud see
738	# between frames being placed on screen
739	# taking into account the cost of retrieving the frame
740	set _delay [expr {${_mspf}-${_ofrd}}]
741	if {0 > ${_delay}} {
742	set _delay 0
743	}
744
745	set cur [${_movie} get position cur]
746
747	# update the dial and framenum widgets
748	set _settings(framenum) $cur
749
750
751	# no play cmds pending
752	set _pendings(play) 0
753
754	# if looping is turned on and markers setup,
755	# then loop back to loopstart when cur hits loopend
756	if {$_settings(loop)} {
757	if {$cur == [$itk_component(dialminor) mark position loopend]} {
758	Seek [$itk_component(dialminor) mark position loopstart]
759	}
760	}
761
762	# schedule the next frame to be displayed
763	if {$cur < ${_lastFrame}} {
764	set _id [after ${_delay} [itcl::code $this eventually play]]
765	} else {
766	video stop
767	}
768
769	event generate $itk_component(hull) <<Frame>>
770	}
771
772
773	# ----------------------------------------------------------------------
774	# Seek - go to a frame in the video
775	# Seek +5
776	# Seek -5
777	# Seek 35
778	# ----------------------------------------------------------------------
779	itcl::body Rappture::VideoScreen::Seek {args} {
780	set val [lindex $args 0]
781	if {"" == $val} {
782	error "bad value: \"$val\": should be \"seek value\""
783	}
784	set cur [${_movie} get position cur]
785	if {[string compare $cur $val] == 0} {
786	# already at the frame to seek to
787	set _pendings(seek) 0
788	return
789	}
790	${_movie} seek $val
791	${_imh} put [${_movie} get image ${_width} ${_height}]
792
793	# update the dial and framenum widgets
794	set _settings(framenum) [${_movie} get position cur]
795	event generate $itk_component(main) <<Frame>>
796
797	# removing pending
798	set _pendings(seek) 0
799	}
800
801
802	# ----------------------------------------------------------------------
803	# eventually -
804	# seek
805	# play
806	# ----------------------------------------------------------------------
807	itcl::body Rappture::VideoScreen::eventually {args} {
808	set option [lindex $args 0]
809	switch -- $option {
810	"seek" {
811	if {0 == $_pendings(seek)} {
812	# no seek pending, schedule one
813	set _pendings(seek) 1
814	after idle [itcl::code $this Seek [lindex $args 1]]
815	} else {
816	# there is a seek pending, update its seek value
817	}
818	}
819	"play" {
820	if {0 == $_pendings(play)} {
821	# no play pending schedule one
822	set _pendings(play) 1
823	set _nextframe [expr {[${_movie} get position cur] + 1}]
824	after idle [itcl::code $this Play]
825	} else {
826	# there is a play pending, update its frame value
827	incr _nextframe
828	}
829	}
830	default {
831	}
832	}
833	}
834
835
836	# ----------------------------------------------------------------------
837	# togglePtrCtrl - choose pointer mode:
838	# rectangle, measure, particlemark
839	# ----------------------------------------------------------------------
840	itcl::body Rappture::VideoScreen::togglePtrCtrl {tool} {
841
842	if {[info exists _pbvars($tool)] == 0} {
843	return
844	}
845
846	if {$_pbvars($tool) == 1} {
847	# unpush previously pushed buttons
848	foreach pbv [array names _pbvars] {
849	if {[string compare $tool $pbv] != 0} {
850	set _pbvars($pbv) 0
851	}
852	}
853	}
854	togglePtrBind $tool
855	}
856
857
858	# ----------------------------------------------------------------------
859	# whatPtrCtrl - figure out the current pointer mode:
860	# rectangle, measure, particlemark
861	# ----------------------------------------------------------------------
862	itcl::body Rappture::VideoScreen::whatPtrCtrl {} {
863	foreach pbv [array names _pbvars] {
864	if {$_pbvars($pbv) != 0} {
865	return $pbv
866	}
867	}
868	}
869
870
871	# ----------------------------------------------------------------------
872	# togglePtrBind - update the bindings based on pointer controls
873	# ----------------------------------------------------------------------
874	itcl::body Rappture::VideoScreen::togglePtrBind {pbvar} {
875
876	if {[string compare $pbvar current] == 0} {
877	set pbvar [whatPtrCtrl]
878	}
879
880	if {[string compare $pbvar rectangle] == 0} {
881
882	# Bindings for selecting rectangle
883	$itk_component(main) configure -cursor ""
884
885	bind $itk_component(main) <ButtonPress-1> \
886	[itcl::code $this Rubberband new %W %x %y]
887	bind $itk_component(main) <B1-Motion> \
888	[itcl::code $this Rubberband drag %W %x %y]
889	bind $itk_component(main) <ButtonRelease-1> \
890	[itcl::code $this Rubberband release %W %x %y]
891
892	} elseif {[string compare $pbvar measure] == 0} {
893
894	# Bindings for measuring distance
895	$itk_component(main) configure -cursor ""
896
897	bind $itk_component(main) <ButtonPress-1> \
898	[itcl::code $this Measure new %W %x %y]
899	bind $itk_component(main) <B1-Motion> \
900	[itcl::code $this Measure drag %W %x %y]
901	bind $itk_component(main) <ButtonRelease-1> \
902	[itcl::code $this Measure release %W %x %y]
903
904	} elseif {[string compare $pbvar particle] == 0} {
905
906	# Bindings for marking particle locations
907	$itk_component(main) configure -cursor ""
908
909	bind $itk_component(main) <ButtonPress-1> \
910	[itcl::code $this Particle new %W %x %y]
911	bind $itk_component(main) <B1-Motion> ""
912	bind $itk_component(main) <ButtonRelease-1> ""
913
914
915	} elseif {[string compare $pbvar object] == 0} {
916
917	# Bindings for interacting with objects
918	$itk_component(main) configure -cursor hand2
919
920	bind $itk_component(main) <ButtonPress-1> { }
921	bind $itk_component(main) <B1-Motion> { }
922	bind $itk_component(main) <ButtonRelease-1> { }
923
924	} else {
925
926	# invalid pointer mode
927
928	}
929	}
930
931
932
933
934
935	###### DRAWING TOOLS #####
936
937
938
939
940
941	# ----------------------------------------------------------------------
942	# Rubberband - draw a rubberband around something in the canvas
943	# ----------------------------------------------------------------------
944	itcl::body Rappture::VideoScreen::Rubberband {status win x y} {
945	switch -- $status {
946	"new" {
947	$win delete "rubbershape"
948	set _x0 $x
949	set _y0 $y
950	$win create rectangle \
951	$x $y $x $y -outline white -width 2 \
952	-tags "rubbershape" -dash {4 4}
953	}
954	"drag" {
955	foreach { x0 y0 x1 y1 } [$win coords "rubbershape"] break
956
957	if {$_x0 > $x} {
958	# backward direction
959	set x0 $x
960	set x1 $_x0
961	} else {
962	set x1 $x
963	}
964
965	if {$_y0 >= $y} {
966	# backward direction
967	set y0 $y
968	set y1 $_y0
969	} else {
970	set y1 $y
971	}
972
973	eval $win coords "rubbershape" [list $x0 $y0 $x1 $y1]
974	}
975	"release" {
976	Rubberband drag $win $x $y
977	}
978	default {
979	error "bad status \"$status\": should be new, drag, or release"
980	}
981	}
982	}
983
984	# ----------------------------------------------------------------------
985	# Measure - draw a line to measure something on the canvas,
986	# when user releases the line, user is given the
987	# calculated measurement.
988	# ----------------------------------------------------------------------
989	itcl::body Rappture::VideoScreen::Measure {status win x y} {
990	switch -- $status {
991	"new" {
992	set name "measure[incr _counters(measure)]"
993
994	set _obj [Rappture::VideoDistance $itk_component(main).$name $name $win \
995	-fncallback [itcl::code $this query framenum] \
996	-bindentercb [itcl::code $this togglePtrBind object] \
997	-bindleavecb [itcl::code $this togglePtrBind current] \
998	-writetextcb [itcl::code $this writeText] \
999	-ondelete [itcl::code $itk_component(dialminor) mark remove $name] \
1000	-onframe [itcl::code $itk_component(dialminor) mark add $name] \
1001	-px2dist [itcl::scope _px2dist] \
1002	-units "m" \
1003	-color green \
1004	-bindings disable]
1005	${_obj} Coords $x $y $x $y
1006	${_obj} Show object
1007	lappend _measurements ${_obj}
1008	}
1009	"drag" {
1010	# FIXME: something wrong with the bindings, if the objects menu is
1011	# open, and you click on the canvas off the menu, a "drag"
1012	# or "release" call is made. need to figure out how to
1013	# disable bindings while obj's menu is open. for now
1014	# we set _obj to "" when we are finished creating it and
1015	# check to see if it's valid when we do a drag or release
1016
1017	if {"" == ${_obj}} {
1018	return
1019	}
1020
1021	${_obj} Coords [lreplace [${_obj} Coords] 2 3 $x $y]
1022	}
1023	"release" {
1024	# if we enable ${_obj}'s bindings when we create it,
1025	# probably never entered because the object's <Enter>
1026	# bindings kick in before the window's release bindings do
1027
1028	if {"" == ${_obj}} {
1029	return
1030	}
1031
1032	Measure drag $win $x $y
1033
1034	if {${_px2dist} == 0} {
1035	${_obj} Menu activate $x $y
1036	}
1037	${_obj} configure -bindings enable
1038
1039	set _obj ""
1040	}
1041	default {
1042	error "bad status \"$status\": should be new, drag, or release"
1043	}
1044	}
1045	}
1046
1047	# ----------------------------------------------------------------------
1048	# Particle - mark a particle in the video, a new particle object is
1049	# created from information like the name, which video
1050	# frames it lives in, it's coords in the canvas in each
1051	# frame, it's color...
1052	# ----------------------------------------------------------------------
1053	itcl::body Rappture::VideoScreen::Particle {status win x y} {
1054	switch -- $status {
1055	"new" {
1056	set name "particle[incr _counters(particle)]"
1057	set _obj [Rappture::VideoParticle $itk_component(main).$name $name $win \
1058	-fncallback [itcl::code $this query framenum] \
1059	-bindentercb [itcl::code $this togglePtrBind object] \
1060	-bindleavecb [itcl::code $this togglePtrBind current] \
1061	-trajcallback [itcl::code $this Trajectory] \
1062	-ondelete [itcl::code $itk_component(dialminor) mark remove $name] \
1063	-onframe [itcl::code $itk_component(dialminor) mark add $name] \
1064	-framerange "0 ${_lastFrame}" \
1065	-halo 5 \
1066	-color green \
1067	-px2dist [itcl::scope _px2dist] \
1068	-units "m/s"]
1069	${_obj} Coords $x $y
1070	${_obj} Show object
1071	#$itk_component(dialminor) mark add $name current
1072	# bind $itk_component(hull) <<Frame>> [itcl::code $itk_component(main).$name UpdateFrame]
1073
1074	# link the new particle to the last particle added, if it exists
1075	set lastp [lindex ${_particles} end]
1076	while {"" == [info commands $lastp]} {
1077	set _particles [lreplace ${_particles} end end]
1078	if {[llength ${_particles}] == 0} {
1079	break
1080	}
1081	set lastp [lindex ${_particles} end]
1082	}
1083	if {"" != [info commands $lastp]} {
1084	$lastp Link ${_obj}
1085	}
1086
1087	# add the particle to the list
1088	lappend _particles ${_obj}
1089	}
1090	default {
1091	error "bad status \"$status\": should be new"
1092	}
1093	}
1094	}
1095
1096	# ----------------------------------------------------------------------
1097	# Trajectory - draw a trajectory between two particles
1098	#
1099	# Trajectory $p0 $p1
1100	# ----------------------------------------------------------------------
1101	itcl::body Rappture::VideoScreen::Trajectory {args} {
1102
1103	set nargs [llength $args]
1104	if {($nargs != 1) && ($nargs != 2)} {
1105	error "wrong # args: should be \"Trajectory p0 p1\""
1106	}
1107
1108	set p0 ""
1109	set p1 ""
1110	foreach {p0 p1} $args break
1111
1112	if {[string compare "" $p0] == 0} {
1113	# p0 does not exist
1114	return
1115	}
1116
1117	# remove any old trajectory links from p0
1118	set p0name [$p0 name]
1119	set oldlink "vec-$p0name"
1120	$itk_component(main) delete $oldlink
1121
1122	# check to see if p1 exists anymore
1123	if {[string compare "" $p1] == 0} {
1124	# p1 does not exist
1125	return
1126	}
1127
1128	foreach {x0 y0} [$p0 Coords] break
1129	foreach {x1 y1} [$p1 Coords] break
1130	set p1name [$p1 name]
1131	set link "vec-$p0name-$p1name"
1132	$itk_component(main) create line $x0 $y0 $x1 $y1 \
1133	-fill green \
1134	-width 2 \
1135	-tags "vector $link vec-$p0name" \
1136	-dash {4 4} \
1137	-arrow last
1138	$itk_component(main) lower $link $p0name
1139
1140	# calculate trajectory, truncate it after 4 sigdigs
1141	set t [calculateTrajectory [$p0 Frame] $x0 $y0 [$p1 Frame] $x1 $y1]
1142	set tt [string range $t 0 [expr [string first . $t] + 4]]
1143
1144
1145	# calculate coords for text
1146	foreach { x0 y0 x1 y1 } [$itk_component(main) bbox $link] break
1147	set x [expr "$x0 + (abs($x1-$x0)/2)"]
1148	set y [expr "$y0 + (abs($y1-$y0)/2)"]
1149
1150	set tt "$tt m/s"
1151	set tags "vectext $link vec-$p0name"
1152	set width [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1153
1154	writeText $x $y $tt green $tags $width
1155	return $link
1156	}
1157
1158
1159	# ----------------------------------------------------------------------
1160	# writeText - write text to the canvas
1161	# writes text to the canvas in the color <color> at <x>,<y>
1162	# writes text twice more offset up-left and down right,
1163	# to add a shadowing effect so colors can be seen
1164	#
1165	# FIXME: Not sure how the text wrapped due to -width collides with the
1166	# offset text.
1167	# ----------------------------------------------------------------------
1168	itcl::body Rappture::VideoScreen::writeText {x y text color tags width} {
1169	$itk_component(main) create text [expr $x-1] [expr $y] \
1170	-tags $tags \
1171	-justify center \
1172	-text $text \
1173	-fill black \
1174	-width $width
1175
1176	$itk_component(main) create text [expr $x+1] [expr $y] \
1177	-tags $tags \
1178	-justify center \
1179	-text $text \
1180	-fill black \
1181	-width $width
1182
1183	$itk_component(main) create text [expr $x] [expr $y-1] \
1184	-tags $tags \
1185	-justify center \
1186	-text $text \
1187	-fill black \
1188	-width $width
1189
1190	$itk_component(main) create text [expr $x] [expr $y+1] \
1191	-tags $tags \
1192	-justify center \
1193	-text $text \
1194	-fill black \
1195	-width $width
1196
1197	# # write text up-left
1198	# $itk_component(main) create text [expr $x-1] [expr $y-1] \
1199	# -tags $tags \
1200	# -justify center \
1201	# -text $text \
1202	# -fill black \
1203	# -width $width
1204	#
1205	# # write text down-right
1206	# $itk_component(main) create text [expr $x+1] [expr $y+1] \
1207	# -tags $tags \
1208	# -justify center \
1209	# -text $text \
1210	# -fill black \
1211	# -width $width
1212
1213	# write text at x,y
1214	$itk_component(main) create text $x $y \
1215	-tags $tags \
1216	-justify center \
1217	-text $text \
1218	-fill $color \
1219	-width $width
1220
1221	}
1222
1223	# ----------------------------------------------------------------------
1224	# calculateTrajectory - calculate the value of the trajectory
1225	# ----------------------------------------------------------------------
1226	itcl::body Rappture::VideoScreen::calculateTrajectory {args} {
1227	# set framerate 29.97 ;# frames per second
1228	# set px2dist 8.00 ;# px per meter
1229
1230	foreach {f0 x0 y0 f1 x1 y1} $args break
1231	set px [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1232	set frames [expr $f1 - $f0]
1233
1234	if {($frames != 0) && (${_px2dist} != 0)} {
1235	set t [expr 1.0$px/$frames${_px2dist}*${_framerate}]
1236	} else {
1237	set t 0.0
1238	}
1239
1240	return $t
1241	}
1242
1243	# ----------------------------------------------------------------------
1244	# toggleloop - add/remove a start/end loop mark to video dial.
1245	# ----------------------------------------------------------------------
1246	itcl::body Rappture::VideoScreen::toggleloop {} {
1247	if {$_settings(loop) == 0} {
1248	$itk_component(dialminor) loop disable
1249	} else {
1250	set cur [${_movie} get position cur]
1251	set end [${_movie} get position end]
1252
1253	set startframe [expr $cur-10]
1254	if {$startframe < 0} {
1255	set startframe 0
1256	}
1257
1258	set endframe [expr $cur+10]
1259	if {$endframe > $end} {
1260	set endframe $end
1261	}
1262
1263	$itk_component(dialminor) loop between $startframe $endframe
1264	}
1265
1266	}
1267
1268	# ----------------------------------------------------------------------
1269	# OPTION: -width - width of the video
1270	# ----------------------------------------------------------------------
1271	itcl::configbody Rappture::VideoScreen::width {
1272	# $_dispatcher event -idle !fixsize
1273	if {[string is integer $itk_option(-width)] == 0} {
1274	error "bad value: \"$itk_option(-width)\": width should be an integer"
1275	}
1276	set _width $itk_option(-width)
1277	after idle [itcl::code $this fixSize]
1278	}
1279
1280	# ----------------------------------------------------------------------
1281	# OPTION: -height - height of the video
1282	# ----------------------------------------------------------------------
1283	itcl::configbody Rappture::VideoScreen::height {
1284	# $_dispatcher event -idle !fixsize
1285	if {[string is integer $itk_option(-height)] == 0} {
1286	error "bad value: \"$itk_option(-height)\": height should be an integer"
1287	}
1288	set _height $itk_option(-height)
1289	after idle [itcl::code $this fixSize]
1290	}
1291
1292	# ----------------------------------------------------------------------
1293	# OPTION: -fileopen
1294	# ----------------------------------------------------------------------
1295	itcl::configbody Rappture::VideoScreen::fileopen {
1296	$itk_component(fileopen) configure -command $itk_option(-fileopen)
1297	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: