1# seq grabber
2package require QuickTimeTcl
3wm title . {Fast Motion}
4
5set bgCol #dedede
6. configure -bg $bgCol
7wm resizable . 0 0
8option add *Frame.Background $bgCol
9option add *Label.Background $bgCol
10
11set wgrabber .sfr.sg
12frame .sfr -relief sunken -bd 1 -bg $bgCol
13seqgrabber $wgrabber
14pack .sfr -padx 8 -pady 8 -side top
15pack $wgrabber -padx 8 -pady 8
16
17frame .fr
18set wbt [frame .fr.fbt]
19set wfr [frame .fr.f]
20set wfr2 [frame .fr.f2]
21set wbtstart $wbt.start
22pack .fr
23pack $wbt -pady 4
24pack $wfr -pady 4
25pack $wfr2 -pady 4
26
27set wmovie .mfr.m
28frame .mfr -relief sunken -bd 1 -bg $bgCol
29pack .mfr -padx 8 -pady 8 -side top
30
31pack [button $wbtstart -text Start -width 8 -command Start] -side left -padx 10 -pady 4
32pack [button $wbt.btmm -text "Make Movie" -command MakeMovie] -side left -padx 10 -pady 4
33label $wfr.sla -text "Shot interval: " -font System
34spinbox $wfr.min -from 0 -to 60 -increment 1 -width 2 -textvariable shotinterval(min) -font System
35label $wfr.slamin -text "Minutes" -font System
36spinbox $wfr.secs -from 0 -to 59 -increment 1 -width 2 -textvariable shotinterval(secs) -font System
37label $wfr.slasec -text "Seconds" -font System
38grid $wfr.sla $wfr.min $wfr.slamin $wfr.secs $wfr.slasec -padx 2 -pady 2 -anchor w
39
40label $wfr2.lpho -text "Number of Photos:"
41label $wfr2.npho -textvariable uid
42grid $wfr2.lpho $wfr2.npho -padx 2 -pady 2 -anchor w
43
44set shotinterval(min) 0
45set shotinterval(secs) 5
46set uid 0
47
48set cachePath [file join [file dirname [info script]] cache]
49if {![file isdirectory $cachePath]} {
50    file mkdir $cachePath
51}
52
53proc Start { } {
54    global wbtstart wgrabber uid shotinterval afterid width height cachePath
55
56    foreach f [glob -nocomplain -directory $cachePath *.png] {
57	file delete $f
58    }
59    set width [winfo width $wgrabber]
60    set height [winfo height $wgrabber]
61    set nphotos 0
62
63    $wbtstart configure -text Stop -command Stop
64    set uid 0
65    Picture
66}
67
68proc Stop { } {
69    global wbtstart afterid
70
71    after cancel $afterid
72    $wbtstart configure -text Start -command Start
73}
74
75proc Picture { } {
76    global wgrabber cachePath uid afterid shotinterval
77
78    set imName [image create photo]
79    $wgrabber picture $imName
80    set filename [file join $cachePath "image[incr uid].png"]
81    $imName write $filename -format quicktimepng
82    image delete $imName
83    set ms [expr 1000 * ($shotinterval(min) * 60 + $shotinterval(secs))]
84    set afterid [after $ms Picture]
85}
86
87proc MakeMovie { } {
88    global cachePath width height wmovie
89
90    catch {destroy $wmovie}
91    movie $wmovie
92    $wmovie new [file join $cachePath themovie.mov]
93    set res [$wmovie tracks new video $width $height]
94    set trackID [lindex $res 1]
95
96    set allFiles [lsort -dictionary [glob -nocomplain -directory $cachePath *.png]]
97
98    # Batch to be economical.
99    set len [llength $allFiles]
100    set nbatch 12
101    set i 0
102    set fileBatchList {}
103    while {$i < $len} {
104	lappend fileBatchList [lrange $allFiles $i [expr $i + $nbatch - 1]]
105	incr i $nbatch
106    }
107    set fps 10
108    set duration [expr 600/$fps]
109    set starttime 0
110
111    foreach fileBatch $fileBatchList {
112	set imageList {}
113	foreach f $fileBatch {
114	    lappend imageList [image create photo -file $f]
115	}
116	$wmovie tracks add picture $trackID $starttime $duration $imageList
117	  #-compressor mp4v -spatialquality high -temporalquality high
118	eval {image delete} $imageList
119	incr starttime [expr $nbatch * $duration]
120    }
121    pack $wmovie -padx 8 -pady 8
122    $wmovie save
123}
124
125
126