ncad023a
|
Makefile,
RCS,
README,
cl-nogui.lsp,
compile.lsp,
config.lsp,
contrib,
diamondoid,
feedback-317,
forces.scm,
gambit.scm,
gui-1.scm,
gui-2.lsp,
gui-2.mrd,
gui-2.tcl,
hackv.scm,
helper,
lisp.lsp,
lispd.lsp,
make-tgz,
make-zip,
methane,
mred.scm,
mz-nogui.scm,
ncad023.scm,
propane,
run-clisp.lsp,
run-mred.scm,
scheme.scm,
test.scm,
trial,
|
|
|
;; gui-2.lsp - Implementation-dependent GUI code, CLISP and Tcl
;; Copyright (C) 1996,1997 Will Ware
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version 2
;; of the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; I can be reached via email at .
(define (atom-color name)
(cond ((equal? name "C") (tellwish "{set_color black}"))
((equal? name "H") (tellwish "{set_color white}"))
((equal? name "O") (tellwish "{set_color red}"))
(else (tellwish "{set_color blue}"))))
(defun re-center () '())
(defun select-pen (c)
(case c
(normal
(tellwish "{set_pen black 1}"))
(double-bond
(tellwish "{set_pen black 3}"))
(triple-bond
(tellwish "{set_pen black 5}"))
(force-vector
(tellwish "{set_pen red 1}"))
(else
(format t "??: (select-pen ~c)~%" c))))
(define (set-bondorder b)
(case b
(single (setf current-bond-order 1))
(double (setf current-bond-order 2))
(triple (setf current-bond-order 3))))
(define (set-element e)
(case e
(c (setf current-element "C"))
(n (setf current-element "N"))
(o (setf current-element "O"))
(h (setf current-element "H"))))
(define (set-eminspeed s)
(case s
(coarse (setf emin-factor coarse-emin-factor))
(fine (setf emin-factor fine-emin-factor))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Routines for handling Lisp-to-Wish communication
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package 'user)
;; Variable to hold stream used to communicate with Wish
(defvar *lisp-to-wish-stream*)
(defun start-wish-process ()
(setq *lisp-to-wish-stream* (run-shell-command
"wish -f gui-2.tcl"
:input :stream
:output :stream)))
;; Send "format"-type string to Wish
(defmacro tellwish (&rest args)
`(progn
(format *lisp-to-wish-stream* ,(car args) ,@(cdr args))
(terpri *lisp-to-wish-stream*)
(force-output *lisp-to-wish-stream*)))
;; Send end-of-transmission symbol, giving control back to Wish
(defmacro finish-lisp-broadcast ()
'(tellwish "@"))
;; Close the stream to Wish
(defun close-wish-stream ()
(finish-lisp-broadcast) ;; When we're done shutting down
(close *lisp-to-wish-stream*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Handle interaction between program and Wish
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun delete-all ()
(tellwish "delete_erasable"))
(defun draw-line (x1 y1 x2 y2)
(tellwish "{create_line ~a ~a ~a ~a}" x1 y1 x2 y2))
(defun draw-ellipse (x1 y1 d)
(tellwish "{create_ellipse ~a ~a ~a ~a}" x1 y1 (+ x1 d) (+ y1 d)))
(defun get-file-name ()
(format t "~%Please type the file name in double-quotes: ")
(read *standard-input*))
(defun show-gui ()
(start-wish-process)
(do ((wish-read (read-line *lisp-to-wish-stream*)
(read-line *lisp-to-wish-stream*)))
;; Let user exit without closing connection
((equal wish-read "exit") (close-wish-stream))
(let ((from-tcl (read-from-string wish-read)))
(case (car from-tcl)
(startup (update-display true))
(clear (clear-structure)
(update-display false))
(emin (emin-step)
(update-display true))
(options
(setf draw-force-vectors (= 1 (nth 1 from-tcl)))
(setf use-torsion-forces (= 2 (nth 1 from-tcl)))
(setf use-vdw-forces (= 3 (nth 1 from-tcl)))
(update-display true))
(controls
(set-action (nth 1 from-tcl))
(set-bondorder (nth 2 from-tcl))
(set-element (nth 3 from-tcl))
(set-zoomfactor (nth 4 from-tcl))
(set-eminspeed (nth 5 from-tcl)))
(load
(load-structure (get-file-name)))
(save
(save-structure (get-file-name)))
(savexyz
(save-structure-xyz (get-file-name)))
(press-1
(funcall press-function (nth 1 from-tcl) (nth 2 from-tcl)))
(move-1
(funcall drag-function (nth 1 from-tcl) (nth 2 from-tcl)))
(release-1
(funcall release-function (nth 1 from-tcl) (nth 2 from-tcl)))))
(finish-lisp-broadcast)))
|