;;;; gene-frame.el --- Frame management for the gene editor ;;;; Copyright (C) 1994 Indiana University Foundation ;; ;; This software is copyrighted under the terms of the GNU General ;; Public License (see terms below). The copyright covers this file, ;; specifically, and the program of which it is a part. ;; ;; 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 1, 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. ;;;; Displaying the watch pointer within a certain dynamic scope. (put 'gene-with-pointer-shape 'lisp-indent-function 1) (defmacro gene-with-pointer-shape (shape &rest forms) "Like progn, but displays mouse pointer as SHAPE while evaluating FORMS." (list 'let* '((gene-with-watch-pointer-frame (selected-frame)) (gene-with-watch-pointer-color (list (assq 'mouse-color (frame-parameters gene-with-watch-pointer-frame))))) (list 'unwind-protect (` (let ((x-pointer-shape (, shape))) (modify-frame-parameters gene-with-watch-pointer-frame gene-with-watch-pointer-color) (,@ forms))) '(modify-frame-parameters gene-with-watch-pointer-frame gene-with-watch-pointer-color)))) (put 'gene-with-watch-pointer 'lisp-indent-function 0) (defmacro gene-with-watch-pointer (&rest forms) "Like progn, but displays a wristwatch mouse pointer while evaluating FORMS." (` (gene-with-pointer-shape x-pointer-watch (,@ forms)))) ;;;; Creating frames. (defun gene-frame-get-frame (name) "Return a frame whose name is NAME, or nil if there is none." (car (apply 'append ; compress nulls (mapcar (lambda (frame) (if (string= name (cdr (assq 'name (frame-parameters frame)))) (list frame))) (frame-list))))) (defun gene-frame-show (buffer &optional parameters) "Display BUFFER-OR-NAME in its own frame, using frame parameters PARAMETERS. The frame has the same name as BUFFER-OR-NAME. BUFFER-OR-NAME is a buffer or the name of a buffer. PARAMETERS defaults to nil. If a frame by that name exists already, display BUFFER in it. If that frame is iconified or invisible, make it visible." (let ((name (if (stringp buffer) (buffer-name (get-buffer-create buffer)) (buffer-name buffer)))) (let ((frame (gene-frame-get-frame name))) (if (frame-live-p frame) (make-frame-visible frame) (setq frame (gene-with-watch-pointer (let ((x-pointer-shape gene-seq-default-pointer-shape)) (new-frame (cons (cons 'name name) parameters)))))) (modify-frame-parameters frame parameters) (select-window (frame-selected-window frame)) (delete-other-windows) (switch-to-buffer (get-buffer buffer)) frame))) (defun gene-frame-hide (frame) "Make FRAME invisible. FRAME is a frame, frame name, or buffer. If no such frame, do nothing." (let ((real-frame (cond ((stringp frame) (gene-frame-get-frame frame)) ((bufferp frame) (gene-frame-get-frame (buffer-name frame))) ((frame-live-p frame) frame) (t nil)))) (if real-frame (make-frame-invisible real-frame)))) ;;;; Frame parameters. ;; todo: this will have to be determined on the fly from ;; x-defined-colors or something... or using RGB values! ;; These should use make-var-buf-loc, instead of make-loc-var, because ;; seq buffers should share them until one buffer wants to march to ;; the beat of a different drummer. (defvar gene-background-color "black" "*Default background color.") (defvar gene-foreground-color "white" "*Default foreground color.") (defvar gene-cursor-color "white" "*Default cursor color.") (defconst gene-pointer-arrow 2) (defvar gene-seq-default-pointer-shape gene-pointer-arrow "*Shape of the mouse pointer in normal operation.") (defvar gene-modeline-color "brown" "*Default modeline background color.") (defvar gene-alignment-frame-params nil "*Default parameters for the gene alignment frame.") (defun gene-frame-alignment-frame-params () "Return a parameter alist appropriate for the alignment frame." (let* ((geometry (getenv "ALE_GEOMETRY")) (parsed (if geometry (x-parse-geometry geometry))) (full-height (/ (- (x-display-pixel-height) 50) (/ (frame-pixel-height) (frame-height)))) (full-width (/ (- (x-display-pixel-width) 50) (/ (frame-pixel-width) (frame-width)))) (others (` ((foreground-color . (, gene-foreground-color)) (background-color . (, gene-background-color)) (cursor-color . (, gene-cursor-color)) (mouse-color . (, gene-foreground-color)) (font . "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1") )))) (append gene-alignment-frame-params parsed (list (cons 'height full-height) (cons 'width full-width)) others))) (defun gene-frame-alignment-frame-other-params () "Set other parameters of the alignment frame. This is specifically for things that can't be set in the frame's parameter alist, like the modeline face and the mouse cursor." ;; We have to set the color or else the pointer shape change won't ;; be noticed. Whoopee! (setq x-pointer-shape gene-seq-default-pointer-shape) (set-mouse-color (cdr (assq 'mouse-color (frame-parameters (selected-frame)))))) (defun gene-make-all-faces () "Construct some faces used by the gene editor. Faces are built by copying and modifying the default face. That means that we can call this function to propagate changes made to the frame parameters or default face into all the gene editor's faces. Note that it's incorrect to make faces in top-level expressions, since the construction of a face depends on run-time factors (like the fonts available)." (set-face-background 'modeline (gene-check-color-allowable gene-modeline-color "black")) (set-face-foreground ;; uselessly paranoid 'modeline (gene-check-color-allowable gene-foreground-color "white")) (gene-dialog-make-faces) (gene-id-mode-make-faces) (gene-locking-make-faces) (gene-mode-tools-make-faces) (gene-phylo-make-faces) (gene-search-make-faces) (gene-sgroup-make-faces) (gene-help-make-faces) (gene-selection-make-faces)) ;;;; Font management. ;;; We put the following properties on the symbols naming the sizes: ;;; gene-size-font: the fully-resolved name of the font we've decided ;;; to use for this size. ;;; gene-size-font-patterns: a list of font patterns matching acceptable ;;; fonts for this size; consulted when gene-size-font isn't set. ;;; gene-no-font: set once we have found that none of gene-size-font-patterns ;;; match; disables the menu item. (defvar gene-default-font 'default "The default font, one of gene-font-sizes: \(tiny small medium large huge default\)") (defconst gene-font-sizes '(tiny small medium large huge default)) (put 'tiny 'gene-size-font-patterns '("-*-*-medium-r-*-*-*-70-75-75-c-*-iso8859-1" "-*-*-medium-r-*-*-*-50-100-100-c-*-iso8859-1")) (put 'small 'gene-size-font-patterns '("-*-*-medium-r-*-*-*-120-75-75-c-*-iso8859-1" "-*-*-medium-r-*-*-*-100-100-100-c-*-iso8859-1")) (put 'medium 'gene-size-font-patterns '("-*-*-medium-r-*-*-*-140-75-75-c-*-iso8859-1" "-*-*-medium-r-*-*-*-120-100-100-c-*-iso8859-1")) (put 'large 'gene-size-font-patterns '("-*-lucidatypewriter-medium-r-*-*-*-180-100-100-*-*-iso8859-1")) (put 'huge 'gene-size-font-patterns '("-*-lucidatypewriter-medium-r-*-*-*-240-100-100-*-*-iso8859-1")) (defun gene-frame-generate-font-menu () "Generate the font-list section of the Display menu." (cons "Fonts:" (mapcar (lambda (size) ;; Have we discovered that we have no font for this size? (if (get size 'gene-no-font) ;; If so, make an unselectable menu item. (symbol-name size) (let ((closure (list 'lambda nil (list 'interactive) (list 'gene-frame-set-font-by-size (list 'quote size))))) (cons (concat (if (eq size gene-default-font) "* " " ") (symbol-name size)) closure)))) gene-font-sizes))) (defvar gene-font-affect-all-frames nil "*Non-nil means that font changes will affect all frames, not just the alignment frame.") (defun gene-frame-set-font-by-size (size) "Set up things to use the font size SIZE. SIZE may be any element of (tiny small medium large huge default)." (gene-with-watch-pointer (let ((status-visible-p (get-buffer-window gene-status-buffer t))) (let ((font (gene-frame-lookup-font-by-size size))) (setq gene-default-font size) ;; Niels points out that people usually only want to change ;; the font of the alignment frame: (if gene-font-affect-all-frames ;; Preference for affecting all frames: (mapcar (lambda (frame) (gene-frame-set-font-preserve-size frame font)) (frame-list)) ;; Else we only affect the alignment frame (this is the default): (gene-frame-set-font-preserve-size (window-frame (gene-seq-buffer-window)) font))) ;; Now rebuild the faces with the new font. (gene-make-all-faces) ;; And make sure all the windows are just so. (apply 'gene-arrange-windows (append (if status-visible-p (list gene-status-buffer)) (list gene-id-buffer) (if gene-window-split-p (list gene-seq-buffer gene-seq-buffer) (list gene-seq-buffer)))) (gene-do-window-sync t)))) (defun gene-frame-lookup-font-by-size (size) "Return the name of an appropriate font for SIZE. SIZE may be any element of (tiny small medium large huge default)." (or (memq size gene-font-sizes) (error "gene-frame-lookup-font-by-size: not a valid size")) (let ((font (or (get size 'gene-size-font) (gene-frame-find-first-font (get size 'gene-size-font-patterns)) (progn (put size 'gene-no-font t) (error "can't find an appropriate %s font" size))))) (put size 'gene-size-font font) font)) (defun gene-frame-find-first-font (patterns) "Return a fully-resolved font name matching an element of PATTERNS. Return nil if there are no fonts matching any of the PATTERNS. Try earlier PATTERNS first." (let (font) (while patterns (let ((matches (x-list-fonts (car patterns)))) (if matches (setq font (car matches) patterns nil) (setq patterns (cdr patterns))))) font)) (defun gene-frame-set-font-preserve-size (frame font) "Have FRAME use FONT; resize to keep frame's pixel size mostly the same. This seems not to work very well. Don't bother trying to preserve the size. Maybe, if later versions of Emacs fix this, we can try again." (modify-frame-parameters frame (list (cons 'font font)))) ;; (let ((width (frame-pixel-width)) ;; (height (frame-pixel-height))) ;; (modify-frame-parameters frame (list (cons 'font font))) ;; (let ((font-width (/ (frame-pixel-width) (frame-width))) ;; (font-height (/ (frame-pixel-height) (frame-height)))) ;; (modify-frame-parameters frame ;; (list (cons 'width (/ width font-width)) ;; (cons 'height (/ height font-height))))))) (defun gene-frame-init-fonts () "Initialize the font-choice machinery." (put 'default 'gene-size-font (cdr (assq 'font (frame-parameters (selected-frame)))))) (provide 'gene-frame)