source: vmdshow/branches/0.1/vmdserver.tcl

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

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