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