[4452] | 1 | # ---------------------------------------------------------------------- |
---|
| 2 | # HUBZERO: server for VMD |
---|
| 3 | # |
---|
| 4 | # This program runs VMD and acts as a server for client applications. |
---|
| 5 | # ---------------------------------------------------------------------- |
---|
| 6 | # Michael McLennan (mmclennan@purdue.edu) |
---|
| 7 | # ====================================================================== |
---|
| 8 | # Copyright (c) 2013 - HUBzero Foundation, LLC |
---|
| 9 | # ====================================================================== |
---|
| 10 | |
---|
| 11 | # The VMD TCL interpreter is by default interactive. Turn this off |
---|
| 12 | # so that unknown commands like "scene" don't get exec-ed. |
---|
| 13 | set ::tcl_interactive 0 |
---|
| 14 | |
---|
| 15 | proc bgerror {mesg} { |
---|
| 16 | puts stderr "SERVER ERROR: $mesg" |
---|
| 17 | } |
---|
| 18 | |
---|
| 19 | # parse command line args |
---|
| 20 | set Paradigm "socket" |
---|
| 21 | while {[llength $argv] > 0} { |
---|
| 22 | set opt [lindex $argv 0] |
---|
| 23 | set argv [lrange $argv 1 end] |
---|
| 24 | |
---|
| 25 | switch -- $opt { |
---|
| 26 | -socket { set Paradigm "socket" } |
---|
| 27 | -stdio { set Paradigm "stdio" } |
---|
| 28 | default { |
---|
| 29 | puts stderr "bad option \"$opt\": should be -socket or -stdio" |
---|
| 30 | } |
---|
| 31 | } |
---|
| 32 | } |
---|
| 33 | |
---|
| 34 | # use this to take snapshots to send to clients |
---|
| 35 | image create photo SnapShot |
---|
| 36 | |
---|
| 37 | # set the screen to a good size |
---|
| 38 | set DisplaySize(w) 300 |
---|
| 39 | set DisplaySize(h) 300 |
---|
| 40 | display resize $DisplaySize(w) $DisplaySize(h) |
---|
| 41 | set DisplaySize(changed) 0 |
---|
| 42 | |
---|
| 43 | # capture initial display settings for later reset |
---|
| 44 | display antialias on |
---|
| 45 | |
---|
| 46 | set DisplayProps(options) "" |
---|
| 47 | foreach key { |
---|
| 48 | ambientocclusion antialias aoambient aodirect |
---|
| 49 | backgroundgradient |
---|
| 50 | culling cuestart cueend cuedensity cuemode |
---|
| 51 | depthcue distance |
---|
| 52 | eyesep |
---|
| 53 | farclip focallength |
---|
| 54 | height |
---|
| 55 | nearclip |
---|
| 56 | projection |
---|
| 57 | shadows stereo |
---|
| 58 | } { |
---|
| 59 | if {$key eq "nearclip" || $key eq "farclip"} { |
---|
| 60 | append DisplayProps(options) [list display $key set [display get $key]] "\n" |
---|
| 61 | } else { |
---|
| 62 | append DisplayProps(options) [list display $key [display get $key]] "\n" |
---|
| 63 | } |
---|
| 64 | } |
---|
| 65 | |
---|
| 66 | # initialize work queue and epoch counter (see server_send_image) |
---|
| 67 | set Epoch 0 |
---|
| 68 | set Work(queue) "" |
---|
| 69 | set Sendqueue "" |
---|
| 70 | set Scenes(@CURRENT) "" |
---|
[6185] | 71 | set tmpDir "" |
---|
[4452] | 72 | |
---|
| 73 | set parser [interp create -safe] |
---|
| 74 | |
---|
| 75 | foreach cmd { |
---|
[6185] | 76 | axes |
---|
| 77 | color |
---|
| 78 | gettimestep |
---|
| 79 | graphics |
---|
| 80 | imd |
---|
| 81 | label |
---|
| 82 | vmd_label |
---|
| 83 | light |
---|
| 84 | material |
---|
| 85 | measure |
---|
| 86 | mobile |
---|
| 87 | mol |
---|
| 88 | molinfo |
---|
| 89 | molecule |
---|
| 90 | mouse |
---|
| 91 | parallel |
---|
| 92 | plugin |
---|
| 93 | rawtimestep |
---|
| 94 | render |
---|
| 95 | rotate |
---|
| 96 | rotmat |
---|
| 97 | scale |
---|
| 98 | vmd_scale |
---|
| 99 | spaceball |
---|
| 100 | stage |
---|
| 101 | tkrender |
---|
| 102 | tool |
---|
| 103 | translate |
---|
| 104 | user |
---|
| 105 | |
---|
| 106 | vecadd |
---|
| 107 | veccross |
---|
| 108 | vecdist |
---|
| 109 | vecdot |
---|
| 110 | vecinvert |
---|
| 111 | veclength |
---|
| 112 | veclength2 |
---|
| 113 | vecmean |
---|
| 114 | vecmul |
---|
| 115 | vecnorm |
---|
| 116 | vecscale |
---|
| 117 | vecscale |
---|
| 118 | vecstddev |
---|
| 119 | vecsub |
---|
| 120 | vecsum |
---|
| 121 | veczero |
---|
| 122 | |
---|
| 123 | vmdcollab |
---|
| 124 | vmdcon |
---|
| 125 | vmdinfo |
---|
| 126 | vmdbench |
---|
| 127 | volmap |
---|
[4452] | 128 | } { |
---|
| 129 | $parser alias $cmd $cmd |
---|
| 130 | } |
---|
| 131 | |
---|
| 132 | # ---------------------------------------------------------------------- |
---|
| 133 | # USAGE: display option ?arg arg...? |
---|
| 134 | # |
---|
| 135 | # Executes the "command arg arg..." string in the server and substitutes |
---|
| 136 | # the result into the template string in place of each "%v" field. |
---|
| 137 | # Sends the result back to the client. |
---|
| 138 | # ---------------------------------------------------------------------- |
---|
| 139 | proc cmd_display {args} { |
---|
| 140 | set option [lindex $args 0] |
---|
| 141 | if {[lsearch {resize reposition rendermode update fps} $option] >= 0} { |
---|
| 142 | # ignore these commands -- they cause trouble |
---|
| 143 | return "" |
---|
| 144 | } |
---|
| 145 | eval display $args |
---|
| 146 | } |
---|
| 147 | $parser alias display cmd_display |
---|
| 148 | |
---|
| 149 | # ---------------------------------------------------------------------- |
---|
| 150 | # USAGE: tellme "command template with %v" command arg arg... |
---|
| 151 | # |
---|
| 152 | # Executes the "command arg arg..." string in the server and substitutes |
---|
| 153 | # the result into the template string in place of each "%v" field. |
---|
| 154 | # Sends the result back to the client. |
---|
| 155 | # ---------------------------------------------------------------------- |
---|
| 156 | proc cmd_tellme {fmt args} { |
---|
| 157 | global parser client |
---|
| 158 | |
---|
| 159 | # evaluate args as a command and subst the result in the fmt string |
---|
| 160 | if {[catch {$parser eval $args} result] == 0} { |
---|
| 161 | server_send_result $client "nv>[string map [list %v $result] $fmt]" |
---|
| 162 | } else { |
---|
| 163 | server_oops $client $result |
---|
| 164 | } |
---|
| 165 | } |
---|
| 166 | $parser alias tellme cmd_tellme |
---|
[6185] | 167 | $parser alias set_temporary_directory server_set_temporary_directory |
---|
[4452] | 168 | |
---|
| 169 | # ---------------------------------------------------------------------- |
---|
[5122] | 170 | # USAGE: queryinfo <x> <y> ?-prev atomid atomid? |
---|
| 171 | # USAGE: queryinfo <x> <y> ?-prev atomid? |
---|
| 172 | # USAGE: queryinfo <x> <y> |
---|
[5050] | 173 | # |
---|
[5122] | 174 | # Picks the atom at screen coordinate <x>,<y> and returns information |
---|
| 175 | # about it. If one previous atom is specified, then this command |
---|
| 176 | # returns the bond length between the previous atom and the current |
---|
| 177 | # one. If two previous atoms are specified, then it returns the |
---|
| 178 | # angle between the three atoms. |
---|
[5050] | 179 | # ---------------------------------------------------------------------- |
---|
| 180 | proc cmd_queryinfo {x y args} { |
---|
| 181 | global DisplayProps MolNames MolInfo |
---|
| 182 | |
---|
[5122] | 183 | # handle command arguments |
---|
| 184 | set prevatoms "" |
---|
| 185 | while {[llength $args] > 0} { |
---|
| 186 | set option [lindex $args 0] |
---|
| 187 | set args [lrange $args 1 end] |
---|
| 188 | if {$option eq "-prev"} { |
---|
| 189 | while {[llength $args] > 0} { |
---|
| 190 | set val [lindex $args 0] |
---|
| 191 | if {[regexp {^[0-9]} $val]} { |
---|
| 192 | lappend prevatoms $val |
---|
| 193 | set args [lrange $args 1 end] |
---|
| 194 | } else { |
---|
| 195 | break |
---|
| 196 | } |
---|
| 197 | } |
---|
| 198 | } else { |
---|
| 199 | error "bad option \"$option\": should be -prev" |
---|
| 200 | } |
---|
| 201 | } |
---|
| 202 | |
---|
[5050] | 203 | # be careful -- VMD uses coordinates from LOWER-left corner of window |
---|
| 204 | set vmdy [expr {$DisplayProps(frameh)-$y}] |
---|
| 205 | |
---|
| 206 | set vals [pick $x $vmdy] |
---|
| 207 | if {$vals ne ""} { |
---|
| 208 | array set data $vals |
---|
| 209 | |
---|
| 210 | # map the molecule ID back to the name used within MD Showcase |
---|
| 211 | foreach molname $MolNames { |
---|
| 212 | if {$MolInfo($molname) == $data(mol)} { |
---|
| 213 | set data(molname) $molname |
---|
| 214 | break |
---|
| 215 | } |
---|
| 216 | } |
---|
| 217 | |
---|
| 218 | # pass back the click coord on screen so we know where this came from |
---|
| 219 | set data(screenx) $x |
---|
| 220 | set data(screeny) $y |
---|
| 221 | |
---|
[5122] | 222 | # if there are -prev atoms, query extra info |
---|
| 223 | set curr [list $data(index) $data(mol)] |
---|
| 224 | set meas $prevatoms |
---|
| 225 | set i [lsearch -exact $meas $curr] |
---|
| 226 | if {$i >= 0} { |
---|
| 227 | set meas [lreplace $meas $i $i] |
---|
| 228 | } |
---|
| 229 | set meas [linsert $meas 0 $curr] |
---|
| 230 | set meas [lrange $meas 0 2] |
---|
| 231 | |
---|
| 232 | switch -- [llength $meas] { |
---|
| 233 | 2 { |
---|
| 234 | set data(bondlength) [measure bond $meas] |
---|
| 235 | } |
---|
| 236 | 3 { |
---|
| 237 | set data(bondlength) [measure bond [lrange $meas 0 1]] |
---|
| 238 | set data(bondlength2) [measure bond [lrange $meas 1 2]] |
---|
| 239 | set data(angle) [measure angle $meas] |
---|
| 240 | } |
---|
| 241 | } |
---|
| 242 | |
---|
| 243 | # convert data back to return value |
---|
[5050] | 244 | set vals [array get data] |
---|
| 245 | } |
---|
| 246 | return $vals |
---|
| 247 | } |
---|
| 248 | $parser alias queryinfo cmd_queryinfo |
---|
| 249 | |
---|
| 250 | # ---------------------------------------------------------------------- |
---|
[4452] | 251 | # USAGE: resize <w> <h> |
---|
| 252 | # |
---|
| 253 | # Resizes the visualization window to the given width <w> and height |
---|
| 254 | # <h>. The next image sent should be this size. |
---|
| 255 | # ---------------------------------------------------------------------- |
---|
| 256 | proc cmd_resize {w h} { |
---|
| 257 | global DisplayProps |
---|
| 258 | |
---|
| 259 | # store the desired size in case we downscale |
---|
| 260 | set DisplayProps(framew) $w |
---|
| 261 | set DisplayProps(frameh) $h |
---|
| 262 | |
---|
| 263 | server_safe_resize $w $h |
---|
| 264 | } |
---|
| 265 | $parser alias resize cmd_resize |
---|
| 266 | |
---|
| 267 | # ---------------------------------------------------------------------- |
---|
| 268 | # USAGE: setview ?-rotate <mtx>? ?-scale <mtx>? ?-center <mtx>? ?-global <mtx>? |
---|
| 269 | # |
---|
| 270 | # Sets the view matrix for one or more components of the view. This |
---|
| 271 | # is a convenient way of getting a view for a particular frame just |
---|
| 272 | # right in one shot. |
---|
| 273 | # ---------------------------------------------------------------------- |
---|
| 274 | proc cmd_setview {args} { |
---|
| 275 | if {[llength $args] == 8} { |
---|
| 276 | # setting all matrices? then start clean |
---|
| 277 | display resetview |
---|
| 278 | } |
---|
| 279 | foreach {key val} $args { |
---|
| 280 | switch -- $key { |
---|
| 281 | -rotate { |
---|
| 282 | molinfo top set rotate_matrix [list $val] |
---|
| 283 | } |
---|
| 284 | -scale { |
---|
| 285 | molinfo top set scale_matrix [list $val] |
---|
| 286 | } |
---|
| 287 | -center { |
---|
| 288 | molinfo top set center_matrix [list $val] |
---|
| 289 | } |
---|
| 290 | -global { |
---|
| 291 | molinfo top set global_matrix [list $val] |
---|
| 292 | } |
---|
| 293 | default { |
---|
| 294 | error "bad option \"$key\": should be -rotate, -scale, -center, or -global" |
---|
| 295 | } |
---|
| 296 | } |
---|
| 297 | } |
---|
| 298 | } |
---|
| 299 | $parser alias setview cmd_setview |
---|
| 300 | |
---|
| 301 | # ---------------------------------------------------------------------- |
---|
| 302 | # USAGE: drag start|end |
---|
| 303 | # |
---|
| 304 | # Resizes the visualization window to the given width <w> and height |
---|
| 305 | # <h>. The next image sent should be this size. |
---|
| 306 | # ---------------------------------------------------------------------- |
---|
| 307 | proc cmd_drag {action} { |
---|
| 308 | global DisplayProps |
---|
| 309 | |
---|
| 310 | switch -- $action { |
---|
| 311 | start { |
---|
| 312 | # simplify rendering so it goes faster during drag operations |
---|
| 313 | set neww [expr {round($DisplayProps(framew)/2.0)}] |
---|
| 314 | set newh [expr {round($DisplayProps(frameh)/2.0)}] |
---|
| 315 | server_safe_resize $neww $newh |
---|
| 316 | display rendermode Normal |
---|
| 317 | display shadows off |
---|
| 318 | |
---|
[6185] | 319 | if 0 { |
---|
[4452] | 320 | foreach nmol [molinfo list] { |
---|
| 321 | set max [molinfo $nmol get numreps] |
---|
| 322 | for {set nrep 0} {$nrep < $max} {incr nrep} { |
---|
| 323 | mol modstyle $nrep $nmol "Lines" |
---|
| 324 | } |
---|
| 325 | } |
---|
[6185] | 326 | } |
---|
[4452] | 327 | } |
---|
| 328 | end { |
---|
| 329 | # put original rendering options back |
---|
| 330 | server_safe_resize $DisplayProps(framew) $DisplayProps(frameh) |
---|
| 331 | display rendermode $DisplayProps(rendermode) |
---|
| 332 | display shadows $DisplayProps(shadows) |
---|
| 333 | |
---|
[6185] | 334 | if 0 { |
---|
[4452] | 335 | # restore rendering methods for all representations |
---|
| 336 | foreach nmol [molinfo list] { |
---|
| 337 | set max [molinfo $nmol get numreps] |
---|
| 338 | for {set nrep 0} {$nrep < $max} {incr nrep} { |
---|
| 339 | mol modstyle $nrep $nmol $DisplayProps(rep-$nmol-$nrep) |
---|
| 340 | } |
---|
| 341 | } |
---|
[6185] | 342 | } |
---|
[4452] | 343 | } |
---|
| 344 | default { |
---|
| 345 | error "bad option \"$action\": should be start or end" |
---|
| 346 | } |
---|
| 347 | } |
---|
| 348 | } |
---|
| 349 | $parser alias drag cmd_drag |
---|
| 350 | |
---|
| 351 | # ---------------------------------------------------------------------- |
---|
[4453] | 352 | # USAGE: setquality normal|high |
---|
| 353 | # |
---|
| 354 | # Sets the rendering quality for the scene--either "high" (GLSL) or |
---|
| 355 | # normal. |
---|
| 356 | # ---------------------------------------------------------------------- |
---|
| 357 | proc cmd_setquality {newval} { |
---|
| 358 | global DisplayProps |
---|
| 359 | |
---|
| 360 | switch -- $newval { |
---|
| 361 | high { |
---|
| 362 | display rendermode GLSL |
---|
| 363 | set DisplayProps(rendermode) "GLSL" |
---|
| 364 | } |
---|
| 365 | normal { |
---|
| 366 | display rendermode Normal |
---|
| 367 | set DisplayProps(rendermode) "Normal" |
---|
| 368 | } |
---|
| 369 | default { |
---|
| 370 | error "bad quality value \"$newval\": should be normal or high" |
---|
| 371 | } |
---|
| 372 | } |
---|
| 373 | } |
---|
| 374 | $parser alias setquality cmd_setquality |
---|
| 375 | |
---|
| 376 | # ---------------------------------------------------------------------- |
---|
[4452] | 377 | # USAGE: smoothreps <value> |
---|
| 378 | # |
---|
| 379 | # Changes the smoothing factor for all representations of the current |
---|
| 380 | # molecule. |
---|
| 381 | # ---------------------------------------------------------------------- |
---|
| 382 | proc cmd_smoothreps {val} { |
---|
| 383 | if {$val < 0} { |
---|
| 384 | error "bad smoothing value \"$val\": should be >= 0" |
---|
| 385 | } |
---|
| 386 | foreach nmol [molinfo list] { |
---|
| 387 | set max [molinfo $nmol get numreps] |
---|
| 388 | for {set nrep 0} {$nrep < $max} {incr nrep} { |
---|
| 389 | mol smoothrep $nmol $nrep $val |
---|
| 390 | } |
---|
| 391 | } |
---|
| 392 | } |
---|
| 393 | $parser alias smoothreps cmd_smoothreps |
---|
| 394 | |
---|
| 395 | # ---------------------------------------------------------------------- |
---|
| 396 | # USAGE: animate <option> <args>... |
---|
| 397 | # USAGE: rock off |
---|
| 398 | # USAGE: rock x|y|z by <step> ?<n>? |
---|
| 399 | # |
---|
| 400 | # The usual VMD "animate" and "rock" commands are problematic for this |
---|
| 401 | # server. If we're going to rock or play the animation, the client |
---|
| 402 | # will do it. Intercept any "animate" and "rock" commands in the scene |
---|
| 403 | # scripts and do nothing. |
---|
| 404 | # ---------------------------------------------------------------------- |
---|
| 405 | proc cmd_animate {args} { |
---|
| 406 | # do nothing |
---|
| 407 | } |
---|
| 408 | $parser alias animate cmd_animate |
---|
| 409 | |
---|
| 410 | proc cmd_rock {args} { |
---|
| 411 | # do nothing |
---|
| 412 | } |
---|
| 413 | $parser alias rock cmd_rock |
---|
| 414 | |
---|
| 415 | # ---------------------------------------------------------------------- |
---|
[4453] | 416 | # These commands just confuse things, so ignore them silently. |
---|
| 417 | # ---------------------------------------------------------------------- |
---|
| 418 | proc cmd_noop {args} { |
---|
| 419 | # do nothing |
---|
| 420 | } |
---|
| 421 | |
---|
| 422 | $parser alias sleep cmd_noop |
---|
| 423 | $parser alias menu cmd_noop |
---|
| 424 | $parser alias vmd_menu cmd_noop |
---|
| 425 | $parser alias play cmd_noop |
---|
| 426 | $parser alias quit cmd_noop |
---|
| 427 | |
---|
| 428 | # ---------------------------------------------------------------------- |
---|
[4452] | 429 | # USAGE: load <file> <file>... |
---|
| 430 | # |
---|
| 431 | # Loads the molecule data from one or more files, which may be PDB, |
---|
| 432 | # DCD, PSF, etc. |
---|
| 433 | # ---------------------------------------------------------------------- |
---|
[6185] | 434 | proc cmd_load { fileList } { |
---|
| 435 | puts stderr "cmd_load fileList=$fileList\n" |
---|
| 436 | global MolInfo MolNames tmpDir |
---|
[4453] | 437 | |
---|
[4452] | 438 | # clear all existing molecules |
---|
| 439 | foreach nmol [molinfo list] { |
---|
| 440 | mol delete $nmol |
---|
| 441 | } |
---|
[4453] | 442 | catch {unset MolInfo} |
---|
[5050] | 443 | set MolNames "" |
---|
[4452] | 444 | |
---|
| 445 | # load new files |
---|
[6185] | 446 | if {![regexp {^@name:} $fileList]} { |
---|
[4453] | 447 | # make sure that there is at least one name in the list |
---|
[6185] | 448 | set fileList [linsert $fileList 0 "@name:0"] |
---|
[4453] | 449 | } |
---|
[6185] | 450 | puts stderr "2. cmd_load fileList=$fileList" |
---|
[4453] | 451 | |
---|
| 452 | set slot 0 |
---|
[6185] | 453 | foreach file $fileList { |
---|
| 454 | puts stderr "file=$file\n" |
---|
[4453] | 455 | if {[regexp {^@name:(.+)} $file match name]} { |
---|
| 456 | set op "new" |
---|
| 457 | continue |
---|
| 458 | } |
---|
[6185] | 459 | if { $tmpDir != "" } { |
---|
| 460 | set tmpFile [file join $tmpDir [file tail $file]] |
---|
| 461 | if { [file exists $tmpFile] } { |
---|
| 462 | set file $tmpFile |
---|
| 463 | } |
---|
| 464 | } |
---|
[4452] | 465 | mol $op $file waitfor all |
---|
[6185] | 466 | if { ![info exists name] } { |
---|
| 467 | puts stderr "can't find name file=$file" |
---|
| 468 | } |
---|
[4453] | 469 | if {$op eq "new"} { |
---|
| 470 | set newnum [lindex [molinfo list] end] |
---|
[5050] | 471 | if {[lsearch -exact MolNames $name] < 0} { |
---|
| 472 | lappend MolNames $name |
---|
| 473 | } |
---|
[4453] | 474 | set MolInfo($name) $newnum |
---|
| 475 | set MolInfo($slot) $newnum |
---|
| 476 | incr slot |
---|
| 477 | set op "addfile" |
---|
| 478 | } |
---|
[4452] | 479 | } |
---|
| 480 | |
---|
| 481 | # BE CAREFUL -- force a "display update" here |
---|
| 482 | # that triggers something in VMD that changes view matrices now, |
---|
| 483 | # so if we change them later, the new values stick |
---|
| 484 | display update |
---|
| 485 | } |
---|
| 486 | $parser alias load cmd_load |
---|
| 487 | |
---|
| 488 | # ---------------------------------------------------------------------- |
---|
[6185] | 489 | # USAGE: scene define id <script> |
---|
| 490 | # USAGE: scene show id ?-before <viewCmd>? ?-after <viewCmd>? |
---|
[4452] | 491 | # USAGE: scene clear |
---|
[6185] | 492 | # USAGE: scene forget ?id id...? |
---|
[4452] | 493 | # |
---|
| 494 | # Used to define and manipulate scenes of the trajectory information |
---|
| 495 | # loaded previously by the "load" command. The "define" operation |
---|
[6185] | 496 | # defines the script that loads a scene called <id>. The "show" |
---|
[4452] | 497 | # operation executes that script to show the scene. The "clear" |
---|
| 498 | # operation clears the current scene (usually in preparation for |
---|
| 499 | # showing another scene). The "forget" operation erases one or more |
---|
[6185] | 500 | # scene definitions; if no ids are specified, then all scenes are |
---|
[4452] | 501 | # forgotten. |
---|
| 502 | # ---------------------------------------------------------------------- |
---|
| 503 | proc cmd_scene {option args} { |
---|
[4453] | 504 | global Scenes Views MolInfo DisplayProps parser |
---|
[4452] | 505 | |
---|
| 506 | switch -- $option { |
---|
| 507 | define { |
---|
| 508 | if {[llength $args] != 2} { |
---|
[6185] | 509 | error "wrong # args: should be \"scene define id script\"" |
---|
[4452] | 510 | } |
---|
[6185] | 511 | set id [lindex $args 0] |
---|
[4452] | 512 | set script [lindex $args 1] |
---|
[6185] | 513 | set Scenes($id) $script |
---|
[4452] | 514 | } |
---|
| 515 | show { |
---|
| 516 | if {[llength $args] < 1 || [llength $args] > 5} { |
---|
[6185] | 517 | error "wrong # args: should be \"scene show id ?-before cmd? ?-after cmd?\"" |
---|
[4452] | 518 | } |
---|
[6185] | 519 | set id [lindex $args 0] |
---|
| 520 | if {![info exists Scenes($id)]} { |
---|
| 521 | error "bad scene id \"$id\": should be one of [join [array names Scenes] {, }]" |
---|
[4452] | 522 | } |
---|
| 523 | |
---|
| 524 | set triggers(before) "" |
---|
| 525 | set triggers(after) "" |
---|
| 526 | foreach {key val} [lrange $args 1 end] { |
---|
| 527 | switch -- $key { |
---|
| 528 | -before { set triggers(before) $val } |
---|
| 529 | -after { set triggers(after) $val } |
---|
| 530 | default { error "bad option \"$key\": should be -before, -after" } |
---|
| 531 | } |
---|
| 532 | } |
---|
| 533 | |
---|
| 534 | # if -before arg was given, send back the view right now |
---|
| 535 | if {$triggers(before) ne "" && $Scenes(@CURRENT) ne ""} { |
---|
| 536 | cmd_tellme $triggers(before) getview |
---|
| 537 | } |
---|
| 538 | |
---|
| 539 | # clear the old scene |
---|
| 540 | cmd_scene clear |
---|
| 541 | display resetview |
---|
| 542 | |
---|
| 543 | # use a safe interp to keep things safe |
---|
| 544 | foreach val [$parser eval {info vars}] { |
---|
| 545 | # clear all variables created by previous scripts |
---|
| 546 | $parser eval [list catch [list unset $val]] |
---|
| 547 | } |
---|
[4453] | 548 | $parser eval [list array set mol [array get MolInfo]] |
---|
| 549 | |
---|
[6185] | 550 | if {[catch {$parser eval $Scenes($id)} result]} { |
---|
| 551 | error "$result\nwhile loading scene \"$id\"" |
---|
[4452] | 552 | } |
---|
| 553 | |
---|
| 554 | # capture display characteristics in case we ever need to reset |
---|
[4453] | 555 | set DisplayProps(rendermode) "Normal" |
---|
[4452] | 556 | set DisplayProps(shadows) [display get shadows] |
---|
| 557 | |
---|
| 558 | foreach nmol [molinfo list] { |
---|
| 559 | set max [molinfo $nmol get numreps] |
---|
| 560 | for {set nrep 0} {$nrep < $max} {incr nrep} { |
---|
| 561 | set style [lindex [molinfo $nmol get "{rep $nrep}"] 0] |
---|
| 562 | set DisplayProps(rep-$nmol-$nrep) $style |
---|
| 563 | } |
---|
| 564 | } |
---|
| 565 | |
---|
[6185] | 566 | # store the scene id for later |
---|
| 567 | set Scenes(@CURRENT) $id |
---|
[4452] | 568 | |
---|
| 569 | # if -after arg was given, send back the view after the script |
---|
| 570 | if {$triggers(after) ne ""} { |
---|
| 571 | cmd_tellme $triggers(after) getview |
---|
| 572 | } |
---|
| 573 | } |
---|
| 574 | clear { |
---|
| 575 | foreach mol [molinfo list] { |
---|
| 576 | set numOfRep [lindex [mol list $mol] 12] |
---|
| 577 | for {set i 1} {$i <= $numOfRep} {incr i} { |
---|
| 578 | mol delrep 0 $mol |
---|
| 579 | } |
---|
| 580 | } |
---|
| 581 | set Scenes(@CURRENT) "" |
---|
| 582 | catch {unset Views} |
---|
| 583 | |
---|
| 584 | # reset the server properties |
---|
| 585 | axes location off |
---|
| 586 | color Display Background black |
---|
| 587 | eval $DisplayProps(options) |
---|
| 588 | } |
---|
| 589 | forget { |
---|
| 590 | if {[llength $args] == 0} { |
---|
| 591 | set args [array names Scenes] |
---|
| 592 | } |
---|
[6185] | 593 | foreach id $args { |
---|
| 594 | if {$id eq "@CURRENT"} continue |
---|
| 595 | catch {unset Scenes($id)} |
---|
| 596 | if {$id eq $Scenes(@CURRENT)} { |
---|
[4452] | 597 | set Scenes(@CURRENT) "" |
---|
| 598 | } |
---|
| 599 | } |
---|
| 600 | } |
---|
| 601 | default { |
---|
| 602 | error "bad option \"$option\": should be define, show, clear, forget" |
---|
| 603 | } |
---|
| 604 | } |
---|
| 605 | } |
---|
| 606 | $parser alias scene cmd_scene |
---|
| 607 | |
---|
| 608 | # ---------------------------------------------------------------------- |
---|
| 609 | # USAGE: frames defview <frame> {matrixNames...} {matrixValues...} |
---|
| 610 | # USAGE: frames time <epochValue> <start> ?<finish>? ?<inc>? ?-defview? |
---|
| 611 | # USAGE: frames rotate <epochValue> <xa> <ya> <za> <number> |
---|
| 612 | # USAGE: frames max |
---|
| 613 | # |
---|
| 614 | # Used to request one or more frames for an animation. A "time" |
---|
| 615 | # animation is a series of frames between two time points. A "rotate" |
---|
| 616 | # animation is a series of frames that rotate the view 360 degrees. |
---|
| 617 | # |
---|
| 618 | # The <epochValue> is passed by the client to indicate the relevance of |
---|
| 619 | # the request. Whenever the client enters a new epoch, it is no longer |
---|
| 620 | # concerned with any earlier epochs, so the server can ignore pending |
---|
| 621 | # images that are out of date. The server sends back the epoch with |
---|
| 622 | # all frames so the client can understand if the frames are relevant. |
---|
| 623 | # |
---|
| 624 | # The "defview" operation sets the default view associated with each |
---|
| 625 | # frame. Animation scripts can change the default view to a series of |
---|
| 626 | # fly-through views. This operation provides a way of storing those |
---|
| 627 | # views. |
---|
| 628 | # |
---|
| 629 | # For a "time" animation, the <start> is a number of a requested frame. |
---|
| 630 | # The <finish> is the last frame in the series. The <inc> is the step |
---|
| 631 | # by which the frames should be generated, which may be larger than 1. |
---|
| 632 | # |
---|
| 633 | # For a "rotate" animation, the <xa>,<ya>,<za> angles indicate the |
---|
| 634 | # direction of the rotation. The <number> is the number of frames |
---|
| 635 | # requested for a full 360 degree rotation. |
---|
| 636 | # |
---|
| 637 | # The "frames max" query returns the maximum number of frames in the |
---|
| 638 | # trajectory. The server uses this to figure out the limits of |
---|
| 639 | # animation. |
---|
| 640 | # ---------------------------------------------------------------------- |
---|
| 641 | proc cmd_frames {what args} { |
---|
| 642 | global client Epoch Work Views |
---|
| 643 | |
---|
| 644 | # check incoming parameters |
---|
| 645 | switch -- $what { |
---|
| 646 | time { |
---|
| 647 | set epochValue [lindex $args 0] |
---|
| 648 | set start [lindex $args 1] |
---|
| 649 | |
---|
| 650 | set i [lsearch $args -defview] |
---|
| 651 | if {$i >= 0} { |
---|
| 652 | set defview 1 |
---|
| 653 | set args [lreplace $args $i $i] |
---|
| 654 | } else { |
---|
| 655 | set defview 0 |
---|
| 656 | } |
---|
| 657 | |
---|
| 658 | set finish [lindex $args 2] |
---|
| 659 | if {$finish eq ""} { set finish $start } |
---|
| 660 | set inc [lindex $args 3] |
---|
| 661 | if {$inc eq ""} { set inc 1 } |
---|
| 662 | |
---|
| 663 | if {![string is integer $finish]} { |
---|
| 664 | server_oops $client "bad animation end \"$finish\" should be integer" |
---|
| 665 | return |
---|
| 666 | } |
---|
| 667 | if {![string is integer $inc] || $inc == 0} { |
---|
| 668 | server_oops $client "bad animation inc \"$inc\" should be non-zero integer" |
---|
| 669 | return |
---|
| 670 | } |
---|
| 671 | if {($finish < $start && $inc > 0) || ($finish > $start && $inc < 0)} { |
---|
| 672 | server_oops $client "bad animation limits: from $start to $finish by $inc" |
---|
| 673 | } |
---|
| 674 | |
---|
| 675 | # new epoch? then clean out work queue |
---|
| 676 | if {$epochValue > $Epoch} { |
---|
| 677 | catch {unset Work} |
---|
| 678 | set Work(queue) "" |
---|
| 679 | set Epoch $epochValue |
---|
| 680 | } |
---|
| 681 | |
---|
| 682 | # add these frames to the queue |
---|
| 683 | if {$inc > 0} { |
---|
| 684 | # generate frames in play>> direction |
---|
| 685 | for {set n $start} {$n <= $finish} {incr n $inc} { |
---|
| 686 | if {![info exists Work($n)]} { |
---|
| 687 | lappend Work(queue) [list epoch $epochValue frame $n num $n defview $defview] |
---|
| 688 | set Work($n) 1 |
---|
| 689 | } |
---|
| 690 | } |
---|
| 691 | } else { |
---|
| 692 | # generate frames in <<play direction |
---|
| 693 | for {set n $start} {$n >= $finish} {incr n $inc} { |
---|
| 694 | if {![info exists Work($n)]} { |
---|
| 695 | lappend Work(queue) [list epoch $epochValue frame $n num $n defview $defview] |
---|
| 696 | set Work($n) 1 |
---|
| 697 | } |
---|
| 698 | } |
---|
| 699 | } |
---|
| 700 | } |
---|
| 701 | rotate { |
---|
| 702 | set epochValue [lindex $args 0] |
---|
| 703 | set mx [lindex $args 1] |
---|
| 704 | if {![string is double -strict $mx]} { |
---|
| 705 | server_oops $client "bad mx rotation value \"$mx\" should be double" |
---|
| 706 | return |
---|
| 707 | } |
---|
| 708 | set my [lindex $args 2] |
---|
| 709 | if {![string is double -strict $my]} { |
---|
| 710 | server_oops $client "bad my rotation value \"$my\" should be double" |
---|
| 711 | return |
---|
| 712 | } |
---|
| 713 | set mz [lindex $args 3] |
---|
| 714 | if {![string is double -strict $mz]} { |
---|
| 715 | server_oops $client "bad mz rotation value \"$mz\" should be double" |
---|
| 716 | return |
---|
| 717 | } |
---|
| 718 | set num [lindex $args 4] |
---|
| 719 | if {![string is integer -strict $num] || $num < 2} { |
---|
| 720 | server_oops $client "bad number of rotation frames \"$num\" should be integer > 1" |
---|
| 721 | return |
---|
| 722 | } |
---|
| 723 | |
---|
| 724 | # |
---|
| 725 | # Compute the rotation matrix for each rotated view. |
---|
| 726 | # Start with the current rotation matrix. Rotate that around |
---|
| 727 | # a vector perpendicular to the plane of rotation for the given |
---|
| 728 | # angles (mx,my,mz). Find vector that by rotating some vector |
---|
| 729 | # such as (1,1,1) by the angles (mx,my,mz). Do a couple of |
---|
| 730 | # times and compute the differences between those vectors. |
---|
| 731 | # Then, compute the cross product of the differences. The |
---|
| 732 | # result is the axis of rotation. |
---|
| 733 | # |
---|
| 734 | set lastrotx [trans axis x $mx deg] |
---|
| 735 | set lastroty [trans axis y $my deg] |
---|
| 736 | set lastrotz [trans axis z $mz deg] |
---|
| 737 | set lastrot [transmult $lastrotx $lastroty $lastrotz] |
---|
| 738 | |
---|
| 739 | set lastvec [list 1 1 1] |
---|
| 740 | foreach v {1 2} { |
---|
| 741 | foreach row $lastrot comp {x y z w} { |
---|
| 742 | # multiply each row by last vector |
---|
| 743 | set vec($comp) 0 |
---|
| 744 | for {set i 0} {$i < 3} {incr i} { |
---|
| 745 | set vec($comp) [expr {$vec($comp) + [lindex $row $i]}] |
---|
| 746 | } |
---|
| 747 | } |
---|
| 748 | set vec${v}(x) [expr {$vec(x)-[lindex $lastvec 0]}] |
---|
| 749 | set vec${v}(y) [expr {$vec(y)-[lindex $lastvec 1]}] |
---|
| 750 | set vec${v}(z) [expr {$vec(z)-[lindex $lastvec 2]}] |
---|
| 751 | |
---|
| 752 | set lastvec [list $vec(x) $vec(y) $vec(z)] |
---|
| 753 | set lastrot [transmult $lastrot $lastrotx $lastroty $lastrotz] |
---|
| 754 | } |
---|
| 755 | |
---|
| 756 | set crx [expr {$vec1(y)*$vec2(z)-$vec1(z)*$vec2(y)}] |
---|
| 757 | set cry [expr {$vec1(z)*$vec2(x)-$vec1(x)*$vec2(z)}] |
---|
| 758 | set crz [expr {$vec1(x)*$vec2(y)-$vec1(y)*$vec2(x)}] |
---|
| 759 | |
---|
| 760 | set angle [expr {360.0/$num}] |
---|
| 761 | set rotby [transabout [list $crx $cry $crz] $angle deg] |
---|
| 762 | set rotm [lindex [molinfo top get rotate_matrix] 0] |
---|
| 763 | |
---|
| 764 | # compute cross product of (1,1,1,0) and rotated vector from above |
---|
| 765 | |
---|
| 766 | for {set n 0} {$n < $num} {incr n} { |
---|
| 767 | lappend Work(queue) [list epoch $epochValue rotate $rotm num $n defview 0] |
---|
| 768 | set rotm [transmult $rotby $rotm] |
---|
| 769 | set Work($n) 1 |
---|
| 770 | } |
---|
| 771 | } |
---|
| 772 | defview { |
---|
| 773 | if {[llength $args] != 3} { error "wrong # args: should be \"defview matrixNameList matrixValueList\"" } |
---|
| 774 | set n [lindex $args 0] |
---|
| 775 | if {![string is int $n]} { error "bad frame value \"$n\"" } |
---|
| 776 | set Views($n) [lrange $args 1 end] |
---|
| 777 | } |
---|
| 778 | max { |
---|
| 779 | set nmol [lindex [molinfo list] 0] |
---|
| 780 | if {$nmol ne ""} { |
---|
| 781 | return [molinfo $nmol get numframes] |
---|
| 782 | } |
---|
| 783 | return 0 |
---|
| 784 | } |
---|
| 785 | default { |
---|
| 786 | error "bad option \"$what\": should be defview, time, rotate, max" |
---|
| 787 | } |
---|
| 788 | } |
---|
| 789 | |
---|
| 790 | # service the queue at some point |
---|
| 791 | server_send_image -eventually |
---|
| 792 | } |
---|
| 793 | $parser alias frames cmd_frames |
---|
| 794 | |
---|
| 795 | # ---------------------------------------------------------------------- |
---|
| 796 | # USAGE: getview |
---|
| 797 | # |
---|
| 798 | # Used to query the scaling and centering of the initial view set |
---|
| 799 | # by VMD after a molecule is loaded. Returns the following: |
---|
| 800 | # <viewName> -rotate <mtx> -global <mtx> -scale <mtx> -center <mtx> |
---|
| 801 | # ---------------------------------------------------------------------- |
---|
| 802 | proc cmd_getview {} { |
---|
| 803 | global Scenes |
---|
| 804 | |
---|
[6185] | 805 | if { [llength [molinfo list]] == 0 } { |
---|
| 806 | return "" |
---|
| 807 | } |
---|
| 808 | if { $Scenes(@CURRENT) eq "" } { |
---|
| 809 | return "" |
---|
| 810 | } |
---|
[4452] | 811 | |
---|
[6185] | 812 | set rval [list $Scenes(@CURRENT)] ;# start with the scene id |
---|
[4452] | 813 | |
---|
| 814 | lappend rval -rotate [lindex [molinfo top get rotate_matrix] 0] \ |
---|
| 815 | -scale [lindex [molinfo top get scale_matrix] 0] \ |
---|
| 816 | -center [lindex [molinfo top get center_matrix] 0] \ |
---|
| 817 | -global [lindex [molinfo top get global_matrix] 0] |
---|
| 818 | |
---|
| 819 | return $rval |
---|
| 820 | } |
---|
| 821 | $parser alias getview cmd_getview |
---|
| 822 | |
---|
[6185] | 823 | proc cmd_atomselect {args} { |
---|
| 824 | global parser |
---|
| 825 | |
---|
| 826 | foreach arg $args { |
---|
| 827 | if { $arg == "writepdb" } { |
---|
| 828 | error "autoselect \"writepdb\" option is disallowed" |
---|
| 829 | } |
---|
| 830 | } |
---|
| 831 | set cmd [eval atomselect $args] |
---|
| 832 | $parser alias $cmd $cmd |
---|
| 833 | return $cmd |
---|
| 834 | } |
---|
| 835 | |
---|
| 836 | $parser alias atomselect cmd_atomselect |
---|
| 837 | |
---|
[4452] | 838 | # |
---|
| 839 | # USAGE: server_safe_resize <width> <height> |
---|
| 840 | # |
---|
| 841 | # Use this version instead of "display resize" whenever possible. |
---|
| 842 | # The VMD "display resize" goes into the event loop, so calling that |
---|
| 843 | # causes things to execute out of order. Use this method instead to |
---|
| 844 | # store the change and actually resize later. |
---|
| 845 | # |
---|
| 846 | proc server_safe_resize {w h} { |
---|
| 847 | global DisplaySize |
---|
| 848 | |
---|
| 849 | if {$w != $DisplaySize(w) || $h != $DisplaySize(h)} { |
---|
| 850 | set DisplaySize(w) $w |
---|
| 851 | set DisplaySize(h) $h |
---|
| 852 | set DisplaySize(changed) yes |
---|
| 853 | } |
---|
| 854 | } |
---|
| 855 | |
---|
| 856 | # ---------------------------------------------------------------------- |
---|
| 857 | # SERVER CORE |
---|
| 858 | # ---------------------------------------------------------------------- |
---|
| 859 | proc server_accept {cid addr port} { |
---|
| 860 | global env |
---|
| 861 | |
---|
| 862 | fileevent $cid readable [list server_handle $cid $cid] |
---|
| 863 | fconfigure $cid -buffering none -blocking 0 |
---|
| 864 | |
---|
| 865 | if {[info exists env(LOCAL)]} { |
---|
| 866 | # identify server type to this client |
---|
| 867 | # VMD on the hub has this built in, but stock versions can |
---|
| 868 | # set the environment variable as a work-around |
---|
| 869 | puts $cid "vmd 0.1" |
---|
| 870 | } |
---|
| 871 | } |
---|
| 872 | |
---|
| 873 | proc server_handle {cin cout} { |
---|
| 874 | global parser buffer client |
---|
| 875 | |
---|
| 876 | if {[gets $cin line] < 0} { |
---|
| 877 | # when client drops connection, we can exit |
---|
| 878 | # nanoscale will spawn a new server next time we need it |
---|
| 879 | if {[eof $cin]} { |
---|
[6185] | 880 | server_exit $cin $cout 0 |
---|
[4452] | 881 | } |
---|
| 882 | } else { |
---|
| 883 | append buffer($cin) $line "\n" |
---|
| 884 | if {[info complete $buffer($cin)]} { |
---|
| 885 | set request $buffer($cin) |
---|
| 886 | set buffer($cin) "" |
---|
| 887 | set client $cout |
---|
| 888 | if {[catch {$parser eval $request} result] == 0} { |
---|
| 889 | server_send_image -eventually |
---|
| 890 | } else { |
---|
| 891 | server_oops $cout $result |
---|
| 892 | if { [string match "invalid command*" $result] } { |
---|
[5050] | 893 | bgerror "server received invalid command: $result" |
---|
[6185] | 894 | server_exit $cin $cout 1 |
---|
[4452] | 895 | } |
---|
| 896 | } |
---|
| 897 | } |
---|
| 898 | } |
---|
| 899 | } |
---|
| 900 | |
---|
| 901 | proc server_send {cout} { |
---|
| 902 | global Epoch Sendqueue |
---|
| 903 | |
---|
| 904 | # grab the next chunk of output and send it along |
---|
| 905 | # discard any chunks from an older epoch |
---|
| 906 | while {[llength $Sendqueue] > 0} { |
---|
| 907 | set chunk [lindex $Sendqueue 0] |
---|
| 908 | set Sendqueue [lrange $Sendqueue 1 end] |
---|
| 909 | |
---|
| 910 | catch {unset data}; array set data $chunk |
---|
| 911 | if {$data(epoch) < 0 || $data(epoch) == $Epoch} { |
---|
| 912 | catch {puts $cout $data(cmd)} |
---|
| 913 | |
---|
| 914 | # if this command has a binary data block, send it specially |
---|
| 915 | if {[string length $data(bytes)] > 0} { |
---|
| 916 | fconfigure $cout -translation binary |
---|
| 917 | catch {puts $cout $data(bytes)} |
---|
| 918 | fconfigure $cout -translation auto |
---|
| 919 | } |
---|
| 920 | break |
---|
| 921 | } |
---|
| 922 | } |
---|
| 923 | |
---|
| 924 | # nothing left? Then stop callbacks until we get more |
---|
| 925 | if {[llength $Sendqueue] == 0} { |
---|
| 926 | fileevent $cout writable "" |
---|
| 927 | server_send_image -eventually |
---|
| 928 | } |
---|
| 929 | } |
---|
| 930 | |
---|
[6185] | 931 | proc server_exit {cin cout code} { |
---|
[4452] | 932 | catch {close $cin} |
---|
[6185] | 933 | catch {exit $code} |
---|
| 934 | |
---|
[4452] | 935 | } |
---|
| 936 | |
---|
| 937 | # ---------------------------------------------------------------------- |
---|
| 938 | # SERVER RESPONSES |
---|
| 939 | # ---------------------------------------------------------------------- |
---|
| 940 | |
---|
| 941 | # turn off constant updates -- only need them during server_send_image |
---|
| 942 | display update off |
---|
| 943 | |
---|
| 944 | proc server_send_image {{when -now}} { |
---|
| 945 | global client Epoch Work Views Sendqueue DisplaySize |
---|
| 946 | |
---|
| 947 | if {$when eq "-eventually"} { |
---|
| 948 | after cancel server_send_image |
---|
| 949 | after 1 server_send_image |
---|
| 950 | return |
---|
| 951 | } elseif {$when ne "-now"} { |
---|
| 952 | error "bad option \"$when\" for server_send_image: should be -now or -eventually" |
---|
| 953 | } |
---|
| 954 | |
---|
| 955 | # is there a display resize pending? then resize and try again later |
---|
| 956 | if {$DisplaySize(changed)} { |
---|
| 957 | set DisplaySize(changed) 0 |
---|
| 958 | after idle [list display resize $DisplaySize(w) $DisplaySize(h)] |
---|
| 959 | after 20 server_send_image |
---|
| 960 | return |
---|
| 961 | } |
---|
| 962 | |
---|
| 963 | # loop through requests in the work queue and skip any from an older epoch |
---|
| 964 | while {1} { |
---|
| 965 | if {[llength $Work(queue)] == 0} { |
---|
| 966 | return |
---|
| 967 | } |
---|
| 968 | |
---|
| 969 | set rec [lindex $Work(queue) 0] |
---|
| 970 | set Work(queue) [lrange $Work(queue) 1 end] |
---|
| 971 | |
---|
| 972 | catch {unset item}; array set item $rec |
---|
| 973 | if {$item(epoch) < $Epoch} { |
---|
| 974 | catch {unset Work($item(num))} |
---|
| 975 | continue |
---|
| 976 | } |
---|
| 977 | |
---|
| 978 | # set the frame characteristics and render this frame |
---|
| 979 | if {[info exists item(frame)]} { |
---|
| 980 | animate goto $item(frame) |
---|
| 981 | } elseif {[info exists item(rotate)]} { |
---|
| 982 | molinfo top set rotate_matrix [list $item(rotate)] |
---|
| 983 | # send rotation matrix back to the client so we can pause later |
---|
| 984 | server_send_latest $client [list nv>rotatemtx $item(num) $item(rotate)] |
---|
| 985 | } else { |
---|
| 986 | puts "ERROR: bad work frame: [array get item]" |
---|
| 987 | } |
---|
| 988 | |
---|
| 989 | # flag to use the stored default view? then set that |
---|
| 990 | if {[info exists item(defview)] && $item(defview)} { |
---|
| 991 | if {[info exists Views($item(frame))]} { |
---|
| 992 | eval molinfo top set $Views($item(frame)) |
---|
| 993 | } |
---|
| 994 | } |
---|
| 995 | catch {unset Work($item(num))} |
---|
| 996 | break |
---|
| 997 | } |
---|
| 998 | |
---|
| 999 | # force VMD to update and grab the screen |
---|
| 1000 | display update |
---|
| 1001 | tkrender SnapShot |
---|
| 1002 | |
---|
| 1003 | set data [SnapShot data -format PPM] |
---|
| 1004 | server_send_latest $client "nv>image epoch $item(epoch) frame $item(num) length [string length $data]" $data |
---|
| 1005 | |
---|
| 1006 | # if there's more work in the queue, try again later |
---|
| 1007 | if {[llength $Work(queue)] > 0} { |
---|
| 1008 | after 1 server_send_image |
---|
| 1009 | } |
---|
| 1010 | } |
---|
| 1011 | |
---|
[6185] | 1012 | proc server_set_temporary_directory { path } { |
---|
| 1013 | global tmpDir |
---|
| 1014 | |
---|
| 1015 | set tmpDir $path |
---|
| 1016 | } |
---|
| 1017 | |
---|
[4452] | 1018 | proc server_send_result {cout cmd {data ""}} { |
---|
| 1019 | global Sendqueue |
---|
| 1020 | |
---|
| 1021 | # add this result to the output queue |
---|
| 1022 | # use the epoch -1 to force the send even if the epoch has changed |
---|
| 1023 | lappend Sendqueue [list epoch -1 cmd $cmd bytes $data] |
---|
| 1024 | fileevent $cout writable [list server_send $cout] |
---|
| 1025 | } |
---|
| 1026 | |
---|
| 1027 | proc server_send_latest {cout cmd {data ""}} { |
---|
| 1028 | global Epoch Sendqueue |
---|
| 1029 | |
---|
| 1030 | # add this result to the output queue |
---|
| 1031 | # wait until the client is ready, then send the output |
---|
| 1032 | lappend Sendqueue [list epoch $Epoch cmd $cmd bytes $data] |
---|
| 1033 | fileevent $cout writable [list server_send $cout] |
---|
| 1034 | } |
---|
| 1035 | |
---|
| 1036 | proc server_oops {cout mesg} { |
---|
| 1037 | # remove newlines -- all lines must start with nv> |
---|
| 1038 | set mesg [string map {\n " "} $mesg] |
---|
| 1039 | server_send_result $cout "nv>oops [list $mesg]" |
---|
| 1040 | } |
---|
| 1041 | |
---|
| 1042 | if {$Paradigm eq "socket"} { |
---|
| 1043 | socket -server server_accept 2018 |
---|
| 1044 | } else { |
---|
| 1045 | set cin $vmd_client(read) |
---|
| 1046 | set cout $vmd_client(write) |
---|
| 1047 | |
---|
| 1048 | fileevent $cin readable [list server_handle $cin $cout] |
---|
| 1049 | fconfigure $cout -buffering none -blocking 0 |
---|
| 1050 | } |
---|
| 1051 | |
---|
| 1052 | # vmd automatically drops into an event loop at this point... |
---|
| 1053 | # |
---|
| 1054 | # The VMD TCL interpreter is by default interactive. Their version |
---|
| 1055 | # of tkconsole always turns this on. Turn this off |
---|
| 1056 | # so that unknown commands like "scene" don't get exec-ed. |
---|
| 1057 | set ::tcl_interactive 0 |
---|