source: vmdshow/trunk/vmdserver.tcl @ 5123

Last change on this file since 5123 was 5122, checked in by mmc, 9 years ago

Ported changes over from trunk: Added support for shift-click in
"pick" operation, so that you can click on multiple atoms and measure
bond lengths and angles.

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