source: vmdshow/trunk/vmdserver.tcl @ 6429

Last change on this file since 6429 was 6429, checked in by ldelgass, 8 years ago

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