;; gene-seq-mode.el (part of ale). ;; Copyright (C) 1993, 1994 Karl Fogel ;; ;; 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. ;; ;; Search for instances of "todo:" to find notes about future plans. ;;; Code: (require 'cl) (require 'cl-19) (require 'gene-data-input) (require 'gene-mode-tools) (require 'gene-locking) (require 'gene-display) ;;; Variables (defvar gene-use-bell nil "*Non-nil means certain functions will sometimes beep.") ;;; keybindings (defvar gene-seq-mode-map (make-sparse-keymap)) (defvar gene-ctl-x-map (make-sparse-keymap)) (define-prefix-command 'gene-ctl-x-map 'gene-ctl-x-map) (defun gene-seq-make-keybinding-reference (file) "Build a keybinding quick-ref file from gene-seq-mode.el." (interactive "FQuick-ref file: ") (save-excursion (let ((ref-buf (find-file-noselect file)) (source-buf (find-file-noselect "~kfogel/genes/lisp/gene-seq-mode.el"))) (set-buffer ref-buf) (delete-region (point-min) (point-max)) (insert "Gene Mode Keybindings (TM).\n") (insert "---------------------------\n\n") (set-buffer source-buf) (goto-char (point-min)) (search-forward "###keybinding begin cookie") ;; The end cookie is never really used, I guess. (forward-line 1) (while (re-search-forward "^(define-key gene-seq-mode-map " nil t) (forward-sexp) (backward-sexp) (forward-char 1) (let ((key-str (buffer-substring-no-properties (point) (1- (re-search-forward "]\\|\"")))) (binding-str ;; We don't need to include the multi-line ;; lambda bindings that belong to the mouse... (if (search-forward "'" (gene-eol-point) t) (buffer-substring-no-properties (progn ;; Don't include the "gene-seq-" prefix: (forward-word 2) (forward-char 1) (point)) (1- (search-forward ")"))) ;; ... so make binding-str be nil if we've ;; got one of those: nil))) (set-buffer ref-buf) (if binding-str (insert (make-string (- 26 (length key-str)) ? ) key-str " = " binding-str "\n")) (set-buffer source-buf))) (set-buffer ref-buf) (save-buffer) (kill-buffer nil)))) ;; Do not delete the following comment, please: ;; ###keybinding begin cookie ;; cursor motion (define-key gene-seq-mode-map [right] 'gene-seq-forward-position) (define-key gene-seq-mode-map [left] 'gene-seq-backward-position) (define-key gene-seq-mode-map "\C-f" 'gene-seq-forward-position) (define-key gene-seq-mode-map "\C-b" 'gene-seq-backward-position) (define-key gene-seq-mode-map [C-right] 'gene-seq-forward-base) (define-key gene-seq-mode-map [C-left] 'gene-seq-backward-base) (define-key gene-seq-mode-map "\M-?" 'gene-seq-where-am-I) (define-key gene-seq-mode-map "\M-p" 'gene-seq-goto-base) (define-key gene-seq-mode-map "\M-C" 'gene-sel-cancel-all-selections) (define-key gene-seq-mode-map "\M-c" 'gene-goto-column-interactive) (define-key gene-seq-mode-map "\M-o" 'gene-seq-goto-organism) ;; todo: these two were C-S- before. (define-key gene-seq-mode-map [M-right] 'gene-seq-next-base-group) (define-key gene-seq-mode-map [M-left] 'gene-seq-previous-base-group) (define-key gene-seq-mode-map "\M-v" 'gene-seq-scroll-buffer-down) (define-key gene-seq-mode-map "\C-v" 'gene-seq-scroll-buffer-up) (define-key gene-seq-mode-map [C-M-up] 'gene-seq-scroll-buffer-down) (define-key gene-seq-mode-map [C-M-down] 'gene-seq-scroll-buffer-up) (define-key gene-seq-mode-map [C-M-right] 'gene-seq-scroll-buffer-left) (define-key gene-seq-mode-map [C-M-left] 'gene-seq-scroll-buffer-right) (define-key gene-seq-mode-map "\C-n" 'gene-seq-next-line) (define-key gene-seq-mode-map "\C-p" 'gene-seq-previous-line) (define-key gene-seq-mode-map [down] 'gene-seq-next-line) (define-key gene-seq-mode-map [up] 'gene-seq-previous-line) (define-key gene-seq-mode-map [C-down] 'gene-seq-down-base) (define-key gene-seq-mode-map [C-up] 'gene-seq-up-base) (define-key gene-seq-mode-map [M-down] 'gene-seq-down-to-different-base) (define-key gene-seq-mode-map [M-up] 'gene-seq-up-to-different-base) (define-key gene-seq-mode-map "\C-e" 'gene-seq-last-col) (define-key gene-seq-mode-map "\C-a" 'gene-seq-first-col) (define-key gene-seq-mode-map "\M-<" 'gene-seq-beginning-of-alignment) (define-key gene-seq-mode-map "\M->" 'gene-seq-end-of-alignment) (define-key gene-seq-mode-map [S-M-right] 'gene-seq-last-col) (define-key gene-seq-mode-map [S-M-left] 'gene-seq-first-col) (define-key gene-seq-mode-map [S-M-up] 'gene-seq-first-sequence) (define-key gene-seq-mode-map [S-M-down] 'gene-seq-last-sequence) ;; *** BEGIN KLUGE *** ;; These are site-specific bindings, necessary because of a bug in ;; Emacs. When Jim is here, I'll ask him what's up with ;; double-modified arrow-keys. Why is it C-right, but C-S-f32??? Why ;; is C-r okay, but C-R appears to be S-C-r??? ;; Hey, why can't control and shift be combined at all??? (define-key gene-seq-mode-map [S-M-f32] 'gene-seq-last-col) (define-key gene-seq-mode-map [S-M-f30] 'gene-seq-first-col) (define-key gene-seq-mode-map [S-M-f28] 'gene-seq-first-sequence) (define-key gene-seq-mode-map [S-M-f34] 'gene-seq-last-sequence) ;; *** END KLUGE *** ;;; Put things on C-x: (define-key gene-seq-mode-map "\C-x" 'gene-ctl-x-map) (define-key gene-ctl-x-map "\C-s" 'gene-save-sequences) (define-key gene-ctl-x-map "\C-w" 'gene-save-sequences-as) (define-key gene-ctl-x-map "\C-f" 'gene-open-sequence-file) (define-key gene-ctl-x-map "i" 'gene-insert-sequence-file) (define-key gene-ctl-x-map "\C-c" 'gene-quit-maybe-offer-save) (define-key gene-ctl-x-map "\C-s" 'gene-save-sequences) (define-key gene-ctl-x-map "3" 'gene-split-unsplit-window-horizontally) ;;; Make raw menu-bar and mode-line clicks scroll up or down: ;; Down-mouse clicks and releases cannot be distinguished on the ;; menu-bar. What you think is a single click (i.e.: event) turns out ;; to register as two -- unless you happen to drag the mouse off the ;; menu-bar before releasing the button! Call that a ;; "click-and-scram", since I'll need to talk about it below too. ;; The first fix that comes to mind involves a firing squad. However, ;; a short-term solution is still necessary. ;; We'll use a parity flag, which will be either t or nil. Each raw ;; menu-bar click calls a function only if the flag is t, and then ;; sets it to the opposite of itself. This means that every *other* ;; "click-and-scram" will do nothing, while the ones in between will ;; act just like a regular click-and-release at one location on the ;; menu-bar. Click-and-scram is probably pretty rare; I don't think ;; anyone will get confused, and anyway, it's better than checking ;; timestamps (which roll around the complete Lisp integers every 5 ;; hours or so, making it possible that two clicks which are really ;; about 5 hours apart will appear to have been within a few ;; milliseconds of each other). ;; (defvar gene-seq-menu-bar-flag t ; toggles between nil and t ;; "Lexical scoping would be worth its weight in gold. Enough said.") ;; (define-key gene-seq-mode-map [menu-bar nil] ;; (lambda (event) ;; (interactive "e") ;; ;; Air-sickness bags may be found in the seat pocket in front of you: ;; (if gene-seq-menu-bar-flag (gene-seq-scroll-buffer-down)) ;; ;; Flip the flag, so that the release click can just flip it back. ;; (setq gene-seq-menu-bar-flag (not gene-seq-menu-bar-flag)))) ;; (define-key gene-seq-mode-map [mode-line] ;; (lambda (event) ;; (interactive "e") ;; ;; We only want to do it on the down-click; the release should ;; ;; have no effect. How nice that the modeline, at least, knows ;; ;; what event was clicked on it. The menu-bar thinks you pressed ;; ;; the `nil' button on the mouse. My mouse doesn't even have a ;; ;; nil button -- maybe it's emulating some weird brand, ahem? ;; (if (memq (car event) ;; (list 'down-mouse-1 'down-mouse-2 'down-mouse-3)) ;; (gene-seq-scroll-buffer-up)))) ;; moving text (non-selections) around (define-key gene-seq-mode-map "\M-r" 'gene-seq-fetch-right) (define-key gene-seq-mode-map "\M-l" 'gene-seq-fetch-left) (define-key gene-seq-mode-map "\C-r" 'gene-seq-slide-right) (define-key gene-seq-mode-map "\C-l" 'gene-seq-slide-left) (define-key gene-seq-mode-map "\C-\M-r" 'gene-seq-throw-right) (define-key gene-seq-mode-map "\C-\M-l" 'gene-seq-throw-left) (define-key gene-seq-mode-map "\M-\C-d" 'gene-seq-delete-superfluous-gap-column) ;; Undoing (define-key gene-seq-mode-map "\M-u" 'gene-undo) ;; Deleting text (define-key gene-seq-mode-map "\C-d" 'gene-seq-delete-char) (define-key gene-seq-mode-map [delete] 'gene-seq-delete-backward-char) (define-key gene-seq-mode-map [backspace] 'gene-seq-delete-backward-char) ;; creating selections (define-key gene-seq-mode-map [down-mouse-1] 'gene-sel-drag-select) (define-key gene-seq-mode-map [S-mouse-1] 'gene-absorb-mouse-event) ;; (define-key gene-seq-mode-map [S-mouse-1] 'gene-sel-start-click-select) (define-key gene-seq-mode-map [S-down-mouse-1] (lambda (evt) (interactive "e") (gene-sel-drag-select evt nil t))) (define-key gene-seq-mode-map [M-down-mouse-1] (lambda (evt) (interactive "e") (gene-sel-drag-select evt 'hard))) (define-key gene-seq-mode-map [S-M-down-mouse-1] (lambda (evt) (interactive "e") (gene-sel-drag-select evt 'hard t))) (define-key gene-seq-mode-map [double-mouse-1] 'gene-absorb-mouse-event) (define-key gene-seq-mode-map [double-down-mouse-1] 'gene-seq-position-and-recenter) ;; manipulating selections: (define-key gene-seq-mode-map [C-mouse-1] 'gene-sel-unselect-chunk) (define-key gene-seq-mode-map [C-down-mouse-1] 'gene-absorb-mouse-event) (define-key gene-seq-mode-map [C-double-down-mouse-1] 'gene-absorb-mouse-event) (define-key gene-seq-mode-map [C-triple-down-mouse-1] 'gene-absorb-mouse-event) ;; Bind mouse-1 to nothing explicitly, to avoid unbound messages: (define-key gene-seq-mode-map [mouse-1] (lambda () (interactive))) ;; These dummy functions shouldn't be necessary. Find out exactly how ;; the relationship between down-mouse-X and mouse-X works, and what ;; one has to do to make the down-mouse-X bindings go away. (define-key gene-seq-mode-map [drag-mouse-1] 'gene-mouse-dummy-function) (define-key gene-seq-mode-map [M-drag-mouse-1] 'gene-mouse-dummy-function) (define-key gene-seq-mode-map [M-mouse-1] (lambda (evt) (interactive "e") (gene-sel-finish-click-select evt 'hard))) (define-key gene-seq-mode-map [S-M-mouse-1] (lambda (evt) (interactive "e") (gene-sel-two-sided-select evt 'hard))) ;; moving selections (define-key gene-seq-mode-map [mouse-2] 'gene-absorb-mouse-event) (define-key gene-seq-mode-map [down-mouse-2] (lambda (evt) (interactive "e") (gene-sel-drag-selection-or-base-group evt 'hard))) (define-key gene-seq-mode-map [M-down-mouse-2] (lambda (evt) (interactive "e") (gene-sel-drag-selection-or-base-group evt 'fluid))) ;; Bind control-hyphen to `gene-seq-insert-context-gap'. ;; (define-key gene-seq-mode-map "\t" 'gene-seq-insert-context-gap) (define-key gene-seq-mode-map [tab] 'gene-seq-insert-context-gap) (define-key gene-seq-mode-map [M-tab] 'gene-seq-insert-gap-column-elsewhere) ;; Bind all the printing characters for insertion (let ((ch 32)) (while (<= ch 126) (define-key gene-seq-mode-map (char-to-string ch) 'gene-seq-self-insert-char) (setq ch (1+ ch)))) ;; misc commands (define-key gene-seq-mode-map "\C-o" 'gene-seq-recenter) ;; Redo this later, after testing it in a scratch buffer: ;; I wonder if this is working. Hmm. Well, at least it doesn't seem ;; to be hurting anything. ;; Don't let outside Emacs bindings show through: ;; (nconc ;; gene-seq-mode-map ;; (list ;; (cons t ;; (lambda () ;; (interactive) ;; (gene-error ;; "%s has been unbound here. Please check the number and dial again." ;; (this-command-keys) ;; ))))) (defun gene-unbound-alert () "Notify the user that the key which invoked this is unbound." (interactive) (message "%S is not bound." (this-command-keys))) ;; Bind everything else to nothing. ;; (nconc gene-seq-mode-map (list (cons t 'gene-unbound-alert))) ;; ###keybinding end cookie ;; Do not delete the preceding comment, please. (defun gene-mouse-dummy-function (event) "Just returns nil." (interactive "e") nil) ;; How should this work? Right now we pass it leading-pt and ;; direction, and it just returns the greatest safe dist to move. We ;; could give it a bigger job, by passing it pt, direction, and ;; desired-dist, and have it actually move the chunk "beginning" at ;; point (and ending at chunk-end, which this func would determine) ;; the lesser of desired-dist and safe-dist. But we also still need ;; something for just computing safe-dist, without side-effecting ;; anything, so what was just described would be a further wrapper ;; around what's below. As long as they stay defsubsts, it shouldn't ;; matter too much. (defun gene-seq-compute-safe-dist (leading-pt direction) "Returns gappy distance after LEADING-PT in the given DIRECTION. LEADING-PT is a number, DIRECTION is `left' or `right'. The distance is negative or positive, depending on whether you want to move left or right. This function takes care of the odd off-by-one-error if you're moving leftward, ahem." (save-excursion (if (eq direction 'left) (let ((bol (prog2 (goto-char leading-pt) (gene-bol-point)))) (skip-chars-backward gene-skip-gaps-regexp bol)) (let ((eol (prog2 (goto-char (1+ leading-pt)) (gene-eol-point)))) (if (bolp) ; did we just cross a newline? 0 (1+ (skip-chars-forward gene-skip-gaps-regexp eol))))))) (defvar gene-default-gap ?- "*The default (most common) gap character in this mode.") (defvar gene-beg-end-gap ?~ "*Gap character to use at the beginnings and ends of lines, when a guess must be made.") (defvar gene-default-filler ? "*Default non-residue non-gap character. It's frequently used to fill in column information for sequences that are too short; that's why it's called \"filler\".") (defun gene-seq-gap-before (&optional pos) "Which gap would you insert before POS, if you had to insert one? POS defaults to point." (save-excursion (if pos (goto-char pos)) ; else already at (point), right? (cond ((bolp) ;; can't back up one, so look here and guess (if (looking-at gene-base-regexp) gene-beg-end-gap (char-after (point)))) ((looking-at gene-gap-regexp) (char-after (point))) (t ; else back up one and examine (forward-char -1) (if (looking-at gene-base-regexp) gene-default-gap (char-after (point))))))) (defun gene-seq-gap-after (&optional pos) "Which gap would you insert after POS, if you had to insert one? POS defaults to point." (save-excursion (if pos (goto-char pos) (setq pos (point))) (if (eolp) ;; Easy answer gene-beg-end-gap ;; Else not at end of line, so deduce the right gap (if (looking-at gene-base-regexp) ;; We're on a base, so what should come after it? (progn (forward-char 1) (if (eolp) ; could be there now gene-beg-end-gap (if (looking-at gene-base-regexp) gene-default-gap ;; otherwise just be like the gap after pos (char-after (point))))) ;; Else not called on a base at all, so we should just match ;; the gap we were called on. Now, we might be in between two ;; different gaps, odd as that seems, but in that case there ;; is no right answer, so we just arbitrarily prefer the one ;; to the left. (char-after pos))))) (defun gene-seq-build-sequence-string (&optional sym) "Return a string representing sequence SYM (defaults to current sequence)." (or sym (setq sym (gene-get-here-sym))) (let* ((posn (get sym 'gene-seq-posn)) (start (car posn)) (end (car (cdr posn)))) (buffer-substring-no-properties start end))) ;;; Recentering and handling vertical motion. (defun gene-handle-vertical-motion (&optional force no-recenter) "Handle vertical point motion in the alignment buffer. This includes updating the ID highlight bar and possibly syncing the ID and alignment buffers after a vertical scroll (this will be done unconditionally if optional first argument FORCE is non-nil). Second optional argument NO-RECENTER is just passed directly to `gene-do-window-sync'; see the documentation for that function to learn more. If window-syncing is not performed, then this arg will of course have no effect at all. This function does not do annotation updating; that is handled in `post-command-hook,' because it can happen even in horizontal motion." ;; Various cleanups are necessary after the cursor has moved ;; vertically. If the current ID is being highlighted, that will ;; have to be updated. Furthermore, if the screen scrolled, then ;; the ID and alignment buffers will have to be resynchronized. ;; ;; The `force' argument means force scrolling resynchronization. ;; `force' non-nil means don't try to find out if the redisplay is ;; really necessary, just do it. This is necessary because the ;; method of finding out, (pos-visible-in-window-p), is fooled by ;; some scrolling commands. (if gene-id-highlight-current-id (gene-seq-update-current-id-highlight)) (if force (gene-do-window-sync no-recenter) (or (pos-visible-in-window-p nil (gene-seq-buffer-window t)) (gene-do-window-sync no-recenter)))) (defun gene-seq-update-current-id-highlight () "Update the highlight bar in the ID window." (let* ((cell (gene-get-here-property 'gene-id-posn))) (if cell (apply 'move-overlay gene-id-current-id-overlay cell)))) (defun gene-do-window-sync (&optional no-recenter) "Synchronize the ID and alignment windows. If optional arg NO-RECENTER is non-nil, then query window-start instead of setting it blindly. This depends on window-start being up-to-date in the alignment window, so the the function will sit for an instant to force the necessary redisplay recalculation of window-start to happen. This doesn't always work, sad to say, so don't pass NO-RECENTER unless you absolutely must." (let ((seq-win (gene-seq-buffer-window t))) ;; Only synchronize if the windows are visible. (if seq-win (save-excursion (if (not (eq (selected-frame) (window-frame (gene-seq-buffer-window t)))) (select-frame (window-frame (gene-seq-buffer-window t)))) (let* ((o-win (selected-window)) this-win (line (save-excursion (if no-recenter ;; Keep current line where it has been put ;; relative to the window. Pray that the ;; sit-for forced recalculation of window-start ;; to happen. (progn (sit-for 0) (goto-char (window-start)) (gene-current-line)) ;; Else just manually place current line in the ;; center of the window: (beginning-of-line) (vertical-motion (- (/ (frame-height) 2))) (set-window-start o-win (point)) (gene-current-line))))) (while (not (eq (setq this-win (next-window this-win)) o-win)) (set-buffer (window-buffer this-win)) (gene-goto-line line) (set-window-start this-win (point)))))))) (defun gene-seq-recenter-vertically () "Recenter point horizontally in the sequence buffer." (interactive) (gene-handle-vertical-motion t)) (defun gene-seq-recenter-horizontally () "Recenter point horizontally in the sequence buffer." (interactive) (let ((w (gene-seq-buffer-window))) (if w (progn (select-window w) (set-buffer gene-seq-buffer) ;; Scroll so that point is in the middle. (let* ((apparent-column (- (current-column) (window-hscroll))) (half-width (/ (window-width) 2))) (if (< apparent-column half-width) (scroll-right (- half-width apparent-column)) (if (> apparent-column half-width) (scroll-left (- apparent-column half-width))))))))) (defun gene-seq-recenter () "Redraw sequence window so point is centered horizontally and vertically." (interactive) (gene-handle-vertical-motion t) (gene-seq-recenter-horizontally)) (defun gene-seq-position-and-recenter (event) "Position point where clicked and recenter the screen around it." (interactive "e") (mouse-set-point event) (gene-seq-recenter)) (defun gene-display-all (&optional id-width) "Redisplay the canonical gene windows in the right way. Optional arg ID-WIDTH is a minimum width for the ID window." (interactive) (delete-other-windows) (switch-to-buffer gene-seq-buffer) ;; We don't use arrange-windows the first time because the ID ;; window's width would end up being 1 or something -- it wouldn't ;; have any IDs in it. However, this isn't written in stone; it ;; would be nice to do this cleanly with gene-arrange-windows ;; someday. (split-window-horizontally (gene-id-calculate-window-width nil id-width)) (switch-to-buffer gene-id-buffer) (other-window 1)) ;; Vertical scrollbar support: ;; Check out /usr/local/lib/emacs/19.28/lisp/mouse.el for some ;; scrollbar bindings toward the end. ;; See also: scroll-bar.el: scroll-bar-drag[-1]. (define-key gene-seq-mode-map [vertical-scroll-bar down-mouse-1] 'gene-seq-drag-vertical-scroll-bar) (define-key gene-seq-mode-map [vertical-scroll-bar down-mouse-2] 'gene-seq-drag-vertical-scroll-bar) (define-key gene-seq-mode-map [vertical-scroll-bar down-mouse-3] 'gene-seq-drag-vertical-scroll-bar) ;; It would be nice not to move point until they release the mouse. (defun gene-seq-move-vertical-scroll-bar-and-sync-windows (event edge-col cur-col) "Called by gene-seq-drag-vertical-scroll-bar to place thumb at pointer." (interactive "e") (let* ((start-position (event-start event)) ;; (window (nth 0 start-position)) ; orig (window (gene-seq-buffer-window)) (portion-whole (nth 2 start-position))) (save-excursion ;; (set-buffer (window-buffer window)) ; orig (set-buffer gene-seq-buffer) ;; Calculate position relative to the accessible part of the buffer. (goto-char (+ (point-min) (scroll-bar-scale portion-whole (buffer-size)))) (gene-goto-column edge-col) (set-window-start window (point)) (gene-goto-column cur-col) (gene-do-window-sync) ))) (defun gene-seq-drag-vertical-scroll-bar (event) "Drag the vertical scroll-bar with the mouse, keeping windows in sync." (interactive "e") (let ((running t) ;; Or the column of window start? (edge-col (save-excursion (goto-char (window-start)) (gene-current-column))) (cur-col (gene-current-column))) (setq opoint (gene-seq-move-vertical-scroll-bar-and-sync-windows event edge-col cur-col)) (track-mouse (while running (setq event (read-event)) (if (eq (car-safe event) 'mouse-movement) (setq event (read-event))) (cond ((eq (car-safe event) 'scroll-bar-movement) (setq opoint (gene-seq-move-vertical-scroll-bar-and-sync-windows event edge-col cur-col))) (t ;; Exit when we get the drag event; ignore that event. (setq running nil))))) ;; Restore current column and sync everyone. (gene-goto-column cur-col) (gene-handle-vertical-motion t t))) ;;; COLUMN op support (defsubst gene-seq-col-legal-from-here-p (col) "Return t iff current sequence has at least COL chars after point." (< (+ (point) col) (gene-eol-point))) (defsubst gene-seq-col-legal-p (col) "Return t iff current sequence is at least COL chars long." (save-excursion (beginning-of-line) (< (+ (point) col) (gene-eol-point)))) (defun gene-seq-do-column-op (op &optional col seqs direction) "Call OP at column COL in each of SEQS (see below). This function tries to generalize column operations by \"mapping\" a function at COLumn across specified SEQuences, is that all RIGHT with YOU? OP is a function. Point will be in the correct column when OP is called (sequences that are too short get skipped, even if they're specifically requested). OP always gets a single argument: the current line number. COL is the column in which the operation should be performed. It defaults to the current column. SEQS can be a line number, a dotted pair, or a list. It defaults to the current line if omitted. If SEQS is a line number then start at that line, and move in DIRECTION until reaching the last or first line. DIRECTION defaults to `down'. If SEQS is a dotted-pair, the car and cdr are taken to be the limits of a range. The direction in that case depends on whether the car is greater than the cdr or not, and the value of DIRECTION is ignored. If SEQS is a list of sequences (i.e.: line numbers), OP just gets called at COL in each of the specified sequences." ;; now: is it necessary to maintain cur-line and pass the `line' ;; param in here anymore? Now that props are set indicating current ;; line, maybe not. However, there's no real reason to make the ;; change either, so save it for spring-cleaning. (or col (setq col (gene-current-column))) (or seqs (setq seqs (gene-current-line))) (save-excursion (let (buffer-read-only) (cond ;; go from specified line in a direction ((integerp seqs) (let ((cur-line seqs)) (gene-goto-line cur-line) (or (not (gene-seq-col-legal-from-here-p col)) (forward-char col) (funcall op cur-line)) (if (eq direction 'up) (while (= 0 (forward-line -1)) ; occur: forward-line (setq cur-line (1- cur-line)) (or (not (gene-seq-col-legal-from-here-p col)) (forward-char col) (funcall op cur-line))) (while (= 0 (forward-line 1)) ; occur: forward-line (setq cur-line (1+ cur-line)) (or (not (gene-seq-col-legal-from-here-p col)) (forward-char col) (funcall op cur-line)))))) ;; a range of sequences has been specified (start . end) ((integerp (cdr seqs)) (let ((start (car seqs)) ; from jim patch... (end (cdr seqs))) (gene-goto-line start) (while (< start end) (if (gene-seq-col-legal-from-here-p col) (progn (forward-char col) (funcall op start))) (setq start (1+ start)) (forward-line 1)) ; occur: forward-line (while (>= start end) (if (gene-seq-col-legal-from-here-p col) (progn (forward-char col) (funcall op start))) (setq start (1- start)) (forward-line 1)))) ; occur: forward-line ;; a list of specific sequences (linenumX linenumY linenumZ ...) (t (goto-char (point-min)) (let ((cur-line 1)) (while seqs ; don't say it out loud (forward-line (- (car seqs) cur-line)) ; occur: forward-line (setq cur-line (car seqs)) (or (not (gene-seq-col-legal-from-here-p col)) (forward-char col) (funcall op cur-line)) (setq seqs (cdr seqs))))))))) ;;; gap column stuff. ;; Rather than build a list of all lines except current one, its ;; easier to just include a check that we're not on the original line ;; in the predicate function passed to gene-seq-insert-gap-column, and ;; pass a nil second argument to gene-seq-do-column-op. (defun gene-seq-delete-superfluous-gap-column (&optional col) "If the COL is all gaps, then remove it from the alignment. COL defaults to the current column, of course. If col is a symbol, then it's just as though it were nil. This is so that calling this function from the Edit Menu works correctly." (interactive) ;; COL could be nil, or a symbol (if called from a menu). (or (numberp col) (setq col (gene-current-column))) (let (danger-flag) (gene-seq-do-column-op (lambda (line) (gene-locking-sequence-state-p nil gene-locking-gapinout-state t) (or (gene-gap-p (char-after (point))) (setq danger-flag t))) col 1) (if danger-flag (gene-message "Operation not legal in all sequences.") (let (buffer-read-only) (gene-seq-do-column-op (lambda (line) (delete-char 1)) col 1))))) (defun gene-seq-insert-gap-column-elsewhere (width) "Insert a gap character at this column in all other sequences. A numeric argument means insert that many gap characters." (interactive "p") (let (buffer-read-only (sel-group (gene-sgroup-selected-here)) (this-line (gene-current-line))) (gene-seq-do-column-op ;; Use a different predicate depending on sel-group nil or not... (if sel-group ;; If selected group here, then insert in all sequences not ;; in the selected group. (lambda (line) (or (gene-sgroup-selected-here) (insert-char (gene-seq-gap-before) width gene-sel-stretch-selections))) ;; Else just do it in all sequences but this one. (lambda (line) (or (= line this-line) (insert-char (gene-seq-gap-before) width gene-sel-stretch-selections)))) (gene-current-column) 1))) (defun gene-seq-this-col-first-seq (&optional col) "Return the point value of the current column in the first sequence long enough to contain this column. If optional arg COLUMN (a number) is given, then use that instead of the current column. If there is no sequence long enough to have that COLUMN, then error." (or col (setq col (gene-current-column))) (save-excursion (beginning-of-buffer) (while (not (gene-goto-column col)) (forward-line 1) (if (eobp) (error "No such column in alignment: %d" col))) (point))) (defun gene-seq-this-col-last-seq (&optional col) "Return the point value of the current column in the last sequence long enough to contain this column. If optional arg COLUMN (a number) is given, then use that instead of the current column. If there is no sequence long enough to have that COLUMN, then error." (or col (setq col (gene-current-column))) (save-excursion (or (= (point-max) 1) (goto-char (1- (point-max)))) (beginning-of-line) (while (not (gene-goto-column col)) (forward-line -1) (if (bobp) (error "No such column in alignment: %d" col))) (point))) (defun gene-seq-first-sequence () "Go to current column in the first sequence long enough to have it." (interactive) (goto-char (gene-seq-this-col-first-seq)) (setq this-command 'gene-seq-line-motion) (gene-handle-vertical-motion)) (defun gene-seq-last-sequence () "Go to current column in the last sequence long enough to have it." (interactive) (goto-char (gene-seq-this-col-last-seq)) (setq this-command 'gene-seq-line-motion) (gene-handle-vertical-motion)) ;; column-wise motion, stats, searching, and other stuff (defun gene-seq-build-column-string (&optional col filler) "Returns column COL as a string from first sequence to last. COL defaults to the current column. Sequences too short are represented by FILLER. Care should be taken to insure that FILLER is not a legitimate gap or residue character. FILLER defaults to `SPC'; it's probably best to use the default." (let* ((len (save-excursion (goto-char (point-max)) (if (gene-get-here-sym) (gene-current-line) (1- (gene-current-line))))) (str (make-string len (or filler gene-default-filler)))) (gene-seq-do-column-op (lambda (line) (aset str (1- line) (char-after (point)))) col 1 'down) str)) (defun gene-seq-column-char-stats (&optional col case-sensitive) "Return information about the character distribution of column COL. COL defaults to the current column. The value returned is a list of this form: \(\(RESIDUE NUMBER_OCCURRENCES\) \(RESIDUE NUMBER_OCCURRENCES\) ...\) Each \"RESIDUE\" is a character, and \"NUMBER_OCCURRENCES\" is the number of times that residue occurs in COL. The stats are presented in alphabetical order. Optional second arg CASE-SENSITIVE means be case-sensitive in distinguishing chars; it defaults to nil." (save-excursion (set-buffer gene-seq-buffer) (let* ((str (gene-seq-build-column-string col)) (len (length str)) stats ; filled in and returned later. (idx 0)) (while (< idx len) (let ((ch (if case-sensitive (aref str idx) (upcase (aref str idx))))) (if (= ch gene-default-filler) nil ; do nothing, this seq doesn't extend to COL ;; Else there is a useful character here (let ((cell (assoc ch stats))) (if cell (setcar (cdr cell) (1+ (car (cdr cell)))) ;; Else it's not been seen yet in this column (setq stats (cons (list ch 1) stats)))))) (setq idx (1+ idx))) ;; It's nice to present them sorted, starting from the highest. (sort stats (lambda (a b) (> (nth 1 a) (nth 1 b)))) ))) (defun gene-seq-display-column-stats (&rest cols) "Display information about the character distribution of columns. Pass as many columns as necessary. If there are multiple columns, a frame is brought up for displaying. Otherwise, the minibuffer is used." (interactive (list (save-excursion (set-buffer gene-seq-buffer) (gene-current-column)))) (or cols (setq cols (list (save-excursion (set-buffer gene-seq-buffer) (gene-current-column))))) (message "Calculating column statistics...") (let ((info-list (mapcar (lambda (col) (cons col (gene-seq-column-char-stats col))) cols))) (gene-seq-display-column-stats-internal (length cols) info-list)) (message "Calculating column statistics... done.")) (defvar gene-column-stat-buffer (get-buffer-create "*Column Stats*") "The buffer for displaying column statistics.") (defun gene-seq-display-column-stats-internal (num info) "Internal function used in presenting column stat information. NUM is the number if columns being considered. If NUM is 1, then INFO is a list of the form \(COL COL-INFO\) where COL-INFO is a list of the form returned by `gene-seq-column-char-stats'. If NUM is > 1, then info is a list like this: \(\(COL COL-INFO\) \(COL COL-INFO\) ...\)." (save-excursion (set-buffer gene-column-stat-buffer) (let (buffer-read-only chars) (erase-buffer) (gene-menu-bar-make-hide-button) (setq truncate-lines t) ;; Okay, buffer preps are done. Now to the good stuff. (insert " ") ; three spaces of left margin (mapcar (lambda (zimbabwe) (insert (format "Col %-5d " (car zimbabwe)))) info) (insert "\n") (insert " ") ; three spaces of left margin here too (insert (apply 'concat (make-list num "--------- "))) (insert "\n\n") ;; Find out which chars we'll be dealing with: (mapcar (lambda (bolivia) (let ((col-info (cdr bolivia))) (while col-info (let ((ch (car (car col-info)))) (if (member ch chars) nil (setq chars (cons ch chars)))) (setq col-info (cdr col-info))))) info) (setq chars (nreverse chars)) ;; Make rows for them (mapcar (lambda (ch) (insert ch " :\n\n")) chars) ;; Insert the information: (let ((screen-col 0)) (mapcar (lambda (col-total-info) ; includes col number (let ((col-info (cdr col-total-info))) (mapcar (lambda (cell) (let ((ch (car cell)) (count (car (cdr cell)))) (goto-char (point-min)) (search-forward (format "\n%c :" ch)) (end-of-line) (move-to-column (+ (* screen-col 11) 6) t) (insert (format "%-5d" count)))) col-info) (setq screen-col (1+ screen-col)))) info)) ;; tabs are annoying when trying to preserve columns, as we ;; must when filling in the zeros later, so... (untabify (point-min) (point-max)) ;; Now fill in zeros: (let ((screen-col 0)) (while (< screen-col num) (goto-char (point-min)) (while (re-search-forward "^.+:" nil t) (move-to-column (+ (* screen-col 11) 6) t) (if (looking-at "\\s-") (progn (insert "0") (or (looking-at "\n") (delete-char 1))))) (setq screen-col (1+ screen-col)))) (gene-frame-show (current-buffer) (` ((name . "*Column Stats*") (vertical-scroll-bars . t) (horizontal-scroll-bars . t) (foreground-color . (, gene-foreground-color)) (background-color . (, gene-background-color)) (cursor-color . (, gene-cursor-color)) (mouse-color . (, gene-cursor-color)) (unsplittable . t) (minibuffer . nil) (menu-bar-lines . 1)))) ) ;; Make the buffer read-only, again perhaps (toggle-read-only 1) (goto-char (point-min)))) (defun gene-seq-column-search (re direction) "Search for next/previous match for RE in the current column. If DIRECTION is `up', searches backward, if `down', searches forward. Returns point of match, or nil if none." (catch 'match (gene-seq-do-column-op (lambda (line) (if (string-match re (buffer-substring-no-properties (point) (1+ (point)))) (throw 'match (point)))) (gene-current-column) (gene-current-line) direction))) ;; todo: these two functions do some allocation. Should we find a way ;; around this? (defun gene-seq-down-to-different-base (parg) "Go to next residue different from the current one in this column. Takes a numeric argument." (interactive "p") (if (<= parg 0) nil (let* ((max-lisp-eval-depth gene-really-high-number) (char-here (buffer-substring-no-properties (point) (1+ (point)))) (base-here (if (string-match gene-base-regexp char-here) char-here)) (re (concat "[^" gene-skip-gaps-regexp base-here "]")) (there (gene-seq-column-search re 'down))) ; nil if none (if there (progn (goto-char there) (setq this-command 'gene-seq-line-motion) (if (<= (setq parg (1- parg)) 0) (gene-handle-vertical-motion) (gene-seq-down-to-different-base parg))) (ding) (gene-message "No different residues below this point."))))) (defun gene-seq-up-to-different-base (parg) "Go to previous residue different from the current one in this column. Takes a numeric argument." (interactive "p") (if (<= parg 0) nil (let* ((char-here (buffer-substring-no-properties (point) (1+ (point)))) (base-here (if (string-match gene-base-regexp char-here) char-here)) (re (concat "[^" gene-skip-gaps-regexp base-here "]")) (there (gene-seq-column-search re 'up))) ; nil if none (if there (progn (goto-char there) (setq this-command 'gene-seq-line-motion) (if (<= (setq parg (1- parg)) 0) (gene-handle-vertical-motion) (gene-seq-up-to-different-base parg))) (ding) (gene-message "No different residues above this point."))))) ;; todo: rewrite these using column-search and better organization. ;; Only call the goto-char if there's somewhere to go, and then do a ;; (setq this-command 'gene-seq-line-motion) after it's done, because ;; this is line motion. (defun gene-seq-down-base (parg) "Moves cursor vertically down to next residue." (interactive "p") (if (<= parg 0) nil (let ((max-lisp-eval-depth gene-really-high-number) (opoint (point)) (oline (gene-current-line)) (ocol (gene-current-column))) (goto-char (or (catch 'hit (gene-seq-do-column-op (lambda (line) (if (gene-seq-base-after-p) (throw 'hit (point)))) ocol (1+ oline) 'down)) (progn (ding) (gene-message "No more residues below this point.") (point))))) (if (> (setq parg (1- parg)) 0) (gene-seq-down-base parg) (setq this-command 'gene-seq-line-motion) (gene-handle-vertical-motion)))) (defun gene-seq-up-base (parg) "Moves vertically cursor up to previous residue." (interactive "p") (if (<= parg 0) nil (let ((max-lisp-eval-depth gene-really-high-number) (opoint (point)) (oline (gene-current-line)) (ocol (gene-current-column))) (if (= oline 1) (gene-message "No more residues above this point.") (goto-char (or (catch 'hit (gene-seq-do-column-op (lambda (line) (if (gene-seq-base-after-p) (throw 'hit (point)))) ocol (1- oline) 'up)) (progn (ding) (gene-message "No more residues above this point.") (point)))))) (if (> (setq parg (1- parg)) 0) (gene-seq-up-base parg) (setq this-command 'gene-seq-line-motion) (gene-handle-vertical-motion)))) ;; todo: define gene-seq-up/down-to-base, takes a base and goes up or ;; down to next occurence of that base, flashing a message if none. (defvar gene-seq-preserved-column 0 "Preserves column across repeated line-motion calls. Users should not need to set this variable.") ;; These next four functions are the line-motion functions (defun gene-seq-next-line (parg) "Move to the same column in the next line. If the next line is too short, then this goes to its end. With a numeric argument, moves that many lines, or as far as possible. If interactive, error if unable to go as far as requested, or return 0. Otherwise, returns the distance left to move (usually 0)." (interactive "p") (let ((curcol (if (eq last-command 'gene-seq-line-motion) gene-seq-preserved-column (setq gene-seq-preserved-column (gene-current-column)))) (id-sync-needed (gene-seq-last-displayed-line-p)) (remaining (forward-line parg))) (or ;; last pos in buffer is junky (gene-get-here-sym) (progn (forward-line -1) ;; `remaining' non-zero will flag an error at the end (setq remaining 1))) (gene-goto-column curcol) ; min of line length and goal column (gene-handle-vertical-motion id-sync-needed) (setq this-command 'gene-seq-line-motion) (and (interactive-p) (not (zerop remaining)) (gene-error "Cannot move down any farther.")) remaining)) (defun gene-seq-previous-line (parg) "Move to the same column in the previous line. If the previous line is too short, then this goes to its end. With a numeric argument, moves that many lines, or as far as possible. If interactive, error if unable to go as far as requested, or return 0. Otherwise, returns the distance left to move (usually 0)." (interactive "p") (let ((curcol (if (eq last-command 'gene-seq-line-motion) gene-seq-preserved-column (setq gene-seq-preserved-column (gene-current-column)))) (id-sync-needed (gene-seq-first-displayed-line-p)) (remaining (forward-line (- parg)))) ; occur: forward-line (gene-goto-column curcol) ; min of line length and goal column (gene-handle-vertical-motion id-sync-needed) (setq this-command 'gene-seq-line-motion) (and (interactive-p) (not (zerop remaining)) (gene-error "Cannot move up any farther.")) remaining)) (defun gene-seq-scroll-buffer-up (&optional parg) "Scroll down one screen. This can move point. Optional arg LINES means scroll that many lines. If there's no LINES arg, you're scrolling nearly \"screenful\" of lines. Call this function from the sequence buffer." (interactive "P") (gene-seq-scroll-buffer-internal 'scroll-up (if parg (prefix-numeric-value parg)))) (defun gene-seq-scroll-buffer-down (&optional parg) "Scroll up one screen. This can move point. Optional arg LINES means scroll that many lines. If there's no LINES arg, you're scrolling nearly \"screenful\" of lines. Call this function from the sequence buffer." (interactive "P") (gene-seq-scroll-buffer-internal 'scroll-down (if parg (prefix-numeric-value parg)))) (defun gene-seq-scroll-buffer-internal (func &rest args) "Apply vertical scrolling function FUNC to the optional arguments ARGS. Handle ID highlight and window syncing afterwards. Obviously, the ARGS must be appropriate, in number and type, for FUNC. This function is most generally called by gene-seq-scroll-buffer-up and gene-seq-scroll-buffer-down. However, it is also called with `mouse-scroll-subr' as the FUNC argument in at least one place. In short, this is the wrapper you want to use to do scrolling in gene mode, because it keeps the ID highlight up-to-date, and windows synchronized." (let ((col (if (eq last-command 'gene-seq-line-motion) gene-seq-preserved-column (setq gene-seq-preserved-column (gene-current-column))))) (apply func args) ; sure hope it was a scroller func! (gene-goto-column col) (gene-handle-vertical-motion t t)) (setq this-command 'gene-seq-line-motion)) (defun gene-seq-scroll-buffer-right (&optional parg) "Scroll the buffer right, so that the window of visibility moves left. Point will move backward as well, so that it stays centered in the screen." (interactive "P") (let* ((bol (gene-bol-point)) (w-width (window-width (gene-seq-buffer-window))) (arg (if parg (prefix-numeric-value parg) (* 3 (/ w-width 4))))) ; 75% scroll (forward-char (- arg)) ;; Don't let us move past start of line. If the left edge of the ;; buffer is visible, then just put point in the middle of the ;; screen. (if (< (point) bol) (goto-char (+ bol (/ w-width 2)))) (scroll-right arg))) (defun gene-seq-scroll-buffer-left (&optional parg) "Scroll the buffer left, so that the window of visibility moves right. If there is not enough remaining of the current sequence to make point follow, then point will move to another nearby sequence that is long enough." (interactive "P") (let* ((eol (gene-eol-point)) (w-width (window-width (gene-seq-buffer-window))) (arg (if parg (prefix-numeric-value parg) (* 3 (/ w-width 4))))) (if (gene-seq-col-legal-from-here-p arg) (progn (scroll-left arg) (forward-char arg)) ;; Else not long enough, so go to eol and let user decide what ;; to do. (goto-char (gene-eol-point)) ;; Be on, not after, the last char, and watch out for 0-length ;; sequences! (or (bolp) (forward-char -1))))) ;; Case changing a sequence: (defun gene-seq-upcase-sequence (sym) "Convert all residues in SEQUENCE (an orgsym) to upper case. Called interactively, operates on the sequence at point." (interactive (list (gene-get-here-sym))) (gene-save-excursion-in gene-seq-buffer (let* (buffer-read-only (posns (get sym 'gene-seq-posn)) (start (car posns)) (end (car (cdr posns)))) (gene-undo-record-region-case start end) (let ((buffer-undo-list t)) (upcase-region start end))))) (defun gene-seq-downcase-sequence (sym) "Convert all residues in SEQUENCE (an orgsym) to lower case. Called interactively, operates on the sequence at point." (interactive (list (gene-get-here-sym))) (gene-save-excursion-in gene-seq-buffer (let* (buffer-read-only (posns (get sym 'gene-seq-posn)) (start (car posns)) (end (car (cdr posns)))) (gene-undo-record-region-case start end) (let ((buffer-undo-list t)) (downcase-region start end))))) (defun gene-seq-flipcase-sequence (sym) "Toggle the case of all residues in SEQUENCE (an orgsym). Called interactively, operates on the sequence at point." (interactive (list (gene-get-here-sym))) (gene-save-excursion-in gene-seq-buffer (let* (buffer-read-only (posns (get sym 'gene-seq-posn)) (start (car posns)) (end (car (cdr posns)))) (gene-undo-record-region-case start end) (let ((buffer-undo-list t)) (gene-flipcase-region start end))))) ;; Interesting to note that we can't undo this by reversing TOCHAR and ;; FROMCHAR. What if someone substituted "*" for "A" in this string: ;; ;; "AAAAAA*******AAAAAA" ? ;; ;; A proper undo would restore the original string above; but the ;; naive undo would result in the string "AAAAAAAAAAAAAAAAAAA"! (defun gene-seq-subst-char-in-sequence (sym &optional fromchar tochar no-messages) "In sequence SYM, substitute all occurences of FROMCHAR with TOCHAR. If FROMCHAR and/or TOCHAR is nil or omitted, then the user will be prompted interactively for them. If optional fourth arg NO-MESSAGES is non-nil, then this function will not message the user while replacing." (interactive (list (gene-get-here-sym))) ;; We decided not to check locking for this. ? ;; (gene-locking-sequence-state-p sym gene-locking-unlocked-state t) (or fromchar (setq fromchar (gene-read-char "Char to replace: " t))) (or tochar (setq tochar (gene-read-char (format "Replace \"%c\" with: " fromchar) t))) ;; Check for non-printables (if (or (< tochar ?!) (> tochar ?~)) (gene-error "\"%c\" is not a regular printing char!" tochar)) (or no-messages (message "Replacing \"%c\" with \"%c\"..." fromchar tochar)) (gene-save-excursion-in gene-seq-buffer (let* (buffer-read-only (posn (gene-organism-seq-posn sym)) (start (nth 0 posn)) (end (nth 1 posn))) (subst-char-in-region start end fromchar tochar)) (or no-messages (message "Replacing \"%c\" with \"%c\"... done." fromchar tochar)))) ;;; Couldn't figure out where to put these functions. Here is as good ;;; as anywhere. (defun gene-seq-delete-sequence (sym &optional noundo) "Remove sequence SYM from the alignment and all related buffers. Optional second arg NOUNDO means what you think it does." (interactive (list (gene-get-here-sym))) (let* ((seq-posn (gene-organism-seq-posn sym)) (seq-start (car seq-posn)) (seq-end (1+ (car (cdr seq-posn)))) ; grab the newline too. (id-posn (gene-organism-id-posn sym)) (id-start (car id-posn)) (id-end (1+ (car (cdr id-posn)))) ; grab the newline too. (line-number (save-excursion (set-buffer gene-seq-buffer) (goto-char seq-start) (gene-current-line)))) (unless noundo (gene-undo-record-sequence-delete sym line-number)) ;; First of all, if point is in the sequence being deleted, then ;; move it to the same column in some other sequence. (if (eq (gene-get-here-sym) sym) (gene-this-col-nearby-seq)) ;; Make sure it's not one of the reference sequences for position ;; monitoring. This call does nothing if the sequence is not ;; being monitored. (gene-posmon-remove-sequence sym t) ;; Now that point is safely out of harm's way, do the deletion. (save-excursion ;; Delete sequence from the sequence buffer. (set-buffer gene-seq-buffer) (let (buffer-read-only (buffer-undo-list t)) (delete-region seq-start seq-end)) ;; Delete the ID from the ID buffer. (set-buffer gene-id-buffer) (let (buffer-read-only (buffer-undo-list t)) (delete-region id-start id-end)) ;; Delete status from the status buffer, for now. ;; Later, we may not keep the status buffer maintained except ;; when it's actually being displayed; when that happens, some ;; cleanup will probably be warranted here. (set-buffer gene-status-buffer) (goto-char ; can't trust the line numbers on sym, you see: (text-property-any (point-min) (point-max) 'gene-ident sym)) (let (buffer-read-only (buffer-undo-list t)) (delete-region (gene-bol-point) (1+ (gene-eol-point)))) ;; Delete this sequence from any groups it's a member of. ;; However, *don't* delete the group properties from the ;; sequence itself; we might need those to put it back in the ;; right groups if it's ever pasted back into the sequence ;; buffer. (let ((groups (gene-sgroup-groups-containing-seq sym))) (mapcar (lambda (sgroup) ;; Don't forget to pass the LEAVE-PROPS arg to ;; `gene-sgroup-delete-seq-from-group': (gene-sgroup-delete-seq-from-group sgroup sym t)) groups)) (set-buffer gene-seq-buffer) ; just in case. ))) (defun gene-seq-empty-alignment () "Remove all sequences from the alignment; do not record for undo." (interactive) (if (interactive-p) (unless (gene-y-or-n-p "Empty alignment?") (gene-error "Emptying not confirmed."))) ;; Clear out all organism symbols. (setq gene-obarray (gene-make-obarray)) ;; Clear out all sequence groups (mapcar (lambda (grp) (gene-sgroup-delete-group grp)) gene-sgroup-list) ;; Stop all position monitoring (mapcar (lambda (orgsym) (gene-posmon-remove-sequence orgsym)) gene-posmon-ref-sequences) ;; Clear out the clipboards ;; todo: it's not really right to clear out the sequence and sgroup ;; clipboards. We want their contents to be preserved between ;; emptyings of the alignment. The only reason we don't do that now ;; is that gene-obarray has been re-initialized. Once we're ;; uninterning, or using `active' props, we can do this right. (gene-cb-remove-object nil nil gene-undo-sequence-clipboard) (gene-cb-remove-object nil nil gene-cb-sequence-clipboard) (gene-cb-remove-object nil nil gene-cb-sgroup-clipboard) ;; Finally, clear out the buffers themselves (save-excursion (mapcar (lambda (buf) (set-buffer buf) (let (buffer-read-only) (widen) ; just in case (delete-region (point-min) (point-max)))) (list gene-id-buffer gene-ann-buffer gene-seq-buffer gene-status-buffer)))) ;;; fetch/slide/throw operations (defun gene-seq-fetch-left (parg) "Fetch one residue from the left, then move leftward one space." (interactive "p") ;; todo: parg handling doesn't happen when just moving forward -- ;; that is, when there's a base at point. ;; If on a base, just move over (if (gene-seq-base-after-p) (gene-seq-backward-position 1) ;; Else do the fetch (gene-locking-sequence-state-p nil gene-locking-gapshift-state t) (let (buffer-read-only (to-fetch (save-excursion (re-search-backward gene-base-regexp (gene-bol-point) t)))) (if to-fetch (progn (gene-shift-region-leave-properties to-fetch (1+ to-fetch) (- (point) to-fetch) (gene-seq-gap-before to-fetch)) (gene-seq-backward-position 1))))) ;; Handle the prefix-arg with a recursive call. Actually, wait for ;; Jim to scream... ;; (sit-for 1) ;; Okay, NOW handle the prefix-arg with a recursive call. (if (> parg 1) (gene-seq-fetch-left (1- parg)))) (defun gene-seq-fetch-right (parg) "Fetch one residue from the right, then move rightward one space." (interactive "p") ;; todo: parg handling doesn't happen when just moving forward -- ;; that is, when there's a base at point. (if (gene-seq-base-after-p) (gene-seq-forward-position 1) (gene-locking-sequence-state-p nil gene-locking-gapshift-state t) (let (buffer-read-only (to-fetch (save-excursion (re-search-forward gene-base-regexp (gene-eol-point) t)))) (if to-fetch (progn (gene-shift-region-leave-properties (1- to-fetch) to-fetch (1+ (- (point) to-fetch)) ; o-b-o-e!!! (gene-seq-gap-after to-fetch)) (gene-seq-forward-position 1))))) (if (> parg 1) (gene-seq-fetch-right (1- parg)))) ;; throwing: (defun gene-seq-throw-right () "Throw the residue group starting at point right as far as possible. Then move backward one position. If not on a residue group, then just move backward one position." (interactive) (if (looking-at gene-base-regexp) (let* (buffer-read-only ;; check usage of these three (eol (gene-eol-point)) (chunk-beg (point)) (chunk-end (+ chunk-beg (skip-chars-forward gene-skip-bases-regexp eol))) (dest (min eol (+ chunk-end (skip-chars-forward gene-skip-gaps-regexp eol))))) (gene-locking-sequence-state-p nil gene-locking-gapshift-state t) (gene-shift-region-leave-properties chunk-beg chunk-end (- dest chunk-end) (gene-seq-gap-before chunk-beg)) (goto-char chunk-beg) (gene-seq-backward-position 1)) (gene-seq-backward-position 1))) (defun gene-seq-throw-left () "Throw the residue group starting at point left as far as possible. Then move forward one position. If not on a residue group, then just move forward one position." (interactive) (if (looking-at gene-base-regexp) (let* (buffer-read-only ;; check usage of these three (bol (gene-bol-point)) (chunk-beg (point)) (chunk-end (+ chunk-beg (skip-chars-backward gene-skip-bases-regexp bol))) (dest (max bol (+ chunk-end (skip-chars-backward gene-skip-gaps-regexp bol))))) (gene-locking-sequence-state-p nil gene-locking-gapshift-state t) (gene-shift-region-leave-properties chunk-end (1+ chunk-beg) (- dest chunk-end) (gene-seq-gap-after chunk-beg)) (goto-char chunk-beg) (gene-seq-forward-position 1)) (gene-seq-forward-position 1))) ;; sliding: (defun gene-seq-slide-right (count) "Slide the residue group at point right, else just move point right. A prefix arg slides or moves that far. From Lisp, COUNT is how far to slide." (interactive "p") (if (gene-seq-base-after-p) (let* (buffer-read-only (pt (point)) (eol (gene-eol-point)) (chunk-end (save-excursion (+ pt (skip-chars-forward gene-skip-bases-regexp eol)))) (gap-char (gene-seq-gap-before pt)) (safedist (min count (gene-seq-compute-safe-dist chunk-end 'right)))) (gene-locking-sequence-state-p nil gene-locking-gapshift-state t) (gene-shift-region-leave-properties pt chunk-end safedist gap-char) (forward-char safedist)) (gene-seq-forward-position 1))) (defun gene-seq-slide-left (count) "Slide the residue group at point left, else just move point left. A prefix arg slides or moves left that far. From Lisp, COUNT is how far to slide." (interactive "p") (if (gene-seq-base-after-p) (let* (buffer-read-only (pt (1+ (point))) ; ? (bol (gene-bol-point)) (chunk-end (save-excursion ;; inexplicable o-b-o-e... (1- (+ pt (skip-chars-backward gene-skip-bases-regexp bol))))) (gap-char (gene-seq-gap-after pt)) (safedist ;; must negify `count' here: (max (- count) (gene-seq-compute-safe-dist chunk-end 'left)))) (gene-locking-sequence-state-p nil gene-locking-gapshift-state t) (gene-shift-region-leave-properties pt chunk-end safedist gap-char) (forward-char safedist)) (gene-seq-backward-position 1))) ;;; Base insertion and overwrition. (defun gene-seq-overwrite-with-char (ch) "Overwrite the character at point with new CHAR." (interactive "cOverwrite with char: ") (let (buffer-read-only) (subst-char-in-region (point) (1+ (point)) (char-after (point)) ch))) ;; Char insertion: ;; This determines if the char is a base or a gap, determines if it is ;; are to act on a group or just a single sequence, checks locking ;; states based on that, and then does the insertion if it can. ;; Set up overstrike mode, off by default. (defvar gene-seq-overstrike-mode nil "Non-nil means we're in overstrike mode.") (defun gene-seq-toggle-overstrike-mode (&optional force) "Toggle overstrike mode on or off. Optional argument FORCE positive means turn it on, otherwise non-nil means turn it off." (interactive) (if force (if (and (numberp force) (> force 0)) (setq gene-seq-overstrike-mode t) (setq gene-seq-overstrike-mode nil)) ;; Else just toggle it. (setq gene-seq-overstrike-mode (not gene-seq-overstrike-mode))) ;; The mode-line updates according to the variable. (force-mode-line-update)) (defun gene-seq-insert-context-gap (parg) "Insert the appropriate (context-dependent) gap character. If there is a selected group at point, then operate on the whole group. A prefix arg can be used as a repeat count. Check locking state before doing anything, however. This function is just a wrapper around gene-seq-insert-char." (interactive "p") (gene-seq-insert-char nil parg)) (defun gene-seq-self-insert-char (parg) "Insert the char just typed. In practice, just call `gene-seq-insert-char' with arguments `last-command-char', PARG, and optional arg CONTEXT-GAP. See that function for more details." (interactive "p") (or (gene-seq-maybe-handle-data-input-command last-command-char) ;; Else not in special data-entering mode. (gene-seq-insert-char last-command-char parg))) (defun gene-seq-insert-char (ch count) "Insert char CH at point, overwriting if in overstrike mode. If there is a selected group at point, then operate on the whole group. A prefix arg can be used as a repeat COUNT. If CH is nil, then insert the right gap character for the context. Check locking state before doing anything, however." (let ((col (gene-current-column)) (group (gene-sgroup-selected-here))) (and ch ; if it's nil, we're using a context-gap, so it's not a space. (= ch gene-default-filler) ;; convert space to the default gap character. (setq ch nil)) (if group ;; we are in the selected group (if gene-seq-overstrike-mode ;; Overstrike mode require great care, sigh. (let (pos-list) (save-excursion ;; Check lock state and build a list of where to do the ;; overstriking. This checking code is ripped off from ;; gene-seq-delete-char; someday, it might be nice to ;; factor it all into one place, to avoid the current ;; duplication. (mapcar (lambda (sym) (if (gene-seq-goto-organism sym col t) (progn (cond ((gene-locking-sequence-state-p nil gene-locking-unlocked-state) ;; Unlocked, so we can overstrike anything we ;; want, but must still be careful not to go ;; beyond sequence ends. (setq count (if (> count 0) (min count (- (gene-eol-point) (point))) (max count (- (gene-bol-point) (point))))) ;; Record where we are, so we can just map ;; overstrikes over the pos-list later. (setq pos-list (cons (point) pos-list))) ((gene-locking-sequence-state-p nil gene-locking-gapinout-state) ;; Well, we can overstrike as long as we ;; don't touch any bases. (setq count (if (> count 0) (min count (save-excursion (skip-chars-forward gene-skip-gaps-regexp (gene-eol-point)))) (max count (save-excursion (skip-chars-backward gene-skip-gaps-regexp (gene-bol-point)))))) (setq pos-list (cons (point) pos-list))) (t ;; else the locking does not permit this, so ;; on this sequence we won't overstrike ;; anything. (setq pos-list (cons nil pos-list))))))) (gene-sgroup-sequences group)) ;; Do the overstrikes: (save-excursion (let (buffer-read-only) (mapcar (lambda (spot) (if spot (progn (gene-translate-region-to-char spot (+ spot count) (or ch (gene-seq-gap-before spot))) (forward-char count)) (message "Locking prevented some overstrikes."))) pos-list))) )) ;; Else not in overstrike-mode, thank goodness! ;; Check lock state: ;; todo: check for eolp first? (if (and ch (gene-base-p ch)) ;; Can we insert bases in this group? (gene-locking-sgroup-check-state group gene-locking-unlocked-state col) ;; Else only a gap, so just check gapinout-ness: (gene-locking-sgroup-check-state group gene-locking-gapinout-state col)) ;; Do the insertions: (save-excursion (let (buffer-read-only) (mapcar (lambda (sym) (if (gene-seq-goto-organism sym col t) ;; If the org has this column, then do the ;; operation: (insert-char (or ch (gene-seq-gap-before)) count gene-sel-stretch-selections)) (if (eolp) (put (gene-get-here-sym) 'gene-seq-posn (list (copy-marker (gene-bol-point)) (copy-marker (gene-eol-point)))))) (gene-sgroup-sequences group)))) ;; Now that column isn't important anymore, move forward: (forward-char count) (gene-handle-vertical-motion) ) ;; Else this is not a group, it's only a single sequence: ;; Check lock state: ;; The thing to remember is that in insert mode, locking ;; status cares only about the character about to be inserted, ;; whereas in overstrike mode it ALSO cares about the ;; character(s) over which the user is typing, as well as what's ;; being inserted. (if (gene-locking-sequence-state-p nil gene-locking-unlocked-state) nil ; home free, anything goes! ;; Else not completely unlocked, so we must consider CH too: (if (and ch (gene-base-p ch)) ;; If the char is a base, then we have to be unlocked ;; whether in overstrike mode or not. (gene-error "Locking error; please check locks.") ;; Otherwise, the char is a gap, and we merely need to make ;; sure that it won't overwrite any bases. (if gene-seq-overstrike-mode (setq count (save-excursion (funcall (if (minusp count) 'skip-chars-backward 'skip-chars-forward) gene-skip-gaps-regexp (+ (point) count)))) ;; Else not in overstrike mode. (gene-locking-sequence-state-p nil gene-locking-gapinout-state t)))) ;; Do the insertion: (let (buffer-read-only) (if gene-seq-overstrike-mode (progn (gene-translate-region-to-char (point) (+ (point) count) (or ch (gene-seq-gap-before))) (forward-char count)) (insert-char (or ch (gene-seq-gap-before)) count gene-sel-stretch-selections) (if (eolp) (put (gene-get-here-sym) 'gene-seq-posn (list (copy-marker (gene-bol-point)) (copy-marker (gene-eol-point))))) ))) count)) ;; Deletion is really tricky, especially when you allow prefix args. ;; In order to make sure that the locking is enforced no matter what, ;; you have to check not only if there's an undeletable char at point, ;; but if there's one downstream that will get deleted because of the ;; prefix arg. ;; ;; This all gets hairy^2 when you bring groups into the picture, ;; because the maximum legal deletion range from current column on ;; each line may be different from line to line -- but it's important ;; to preserve alignment, so you can't just treat each line ;; individually! This implies that we have to check the locking on ;; each line, given that we know the operation and the current-column, ;; and that's exactly what we do. Sigh. ;; ;; Below, we try to cope with these restrictions. But it's too damn ;; slow! (defun gene-seq-delete-backward-char (parg) "Delete the char behind point, moving backwards. If there is a selected group at point, then operate on the whole group. A prefix arg can be used as a repeat count; if negative, it means delete forward. Check locking state before doing anything, however." (interactive "p") (or (gene-seq-maybe-handle-data-input-command last-command-char) (gene-seq-delete-char (- parg)))) (defun gene-seq-delete-char (parg) "Delete char at point. If point is in a selected group, then operate on the whole group. A prefix arg can be used as a repeat count; if negative, it means delete backwards. Check locking state before doing anything, however." (interactive "p") (if gene-seq-overstrike-mode (let ((dist (gene-seq-insert-char nil parg))) (forward-char dist)) (let ((group (gene-sgroup-selected-here)) (col (gene-current-column)) pos-list) ; a list of markers (if group ; we are in the selected group (progn ;; Check lock state and build a list of where to do the ;; deletions: (save-excursion (mapcar (lambda (sym) (if (gene-seq-goto-organism sym col t) (progn ;; Record where we are, so we can just map ;; deletions over the pos-list later. (setq pos-list (cons (point-marker) pos-list)) (cond ((gene-locking-sequence-state-p nil gene-locking-unlocked-state) ;; Unlocked, so we can delete anything we want, ;; but must still be careful not to go beyond ;; sequence ends. (setq parg (if (> parg 0) (min parg (- (gene-eol-point) (point))) (max parg (- (gene-bol-point) (point)))))) ((gene-locking-sequence-state-p nil gene-locking-gapinout-state) ;; Well, we can delete as long as we don't ;; touch any bases. (setq parg (if (> parg 0) (min parg (save-excursion (skip-chars-forward gene-skip-gaps-regexp (gene-eol-point)))) (max parg (save-excursion (skip-chars-backward gene-skip-gaps-regexp (gene-bol-point))))))) (t ;; else the locking does not permit this, and to ;; preserve alignments, we won't delete from some ;; sequences and not others. (gene-error "Locking error; check sequence locks.")))))) (gene-sgroup-sequences group))) ;; Do the deletions: (save-excursion (let (buffer-read-only) (mapcar (lambda (marker) (goto-char marker) (delete-char parg)) pos-list))) (gene-handle-vertical-motion)) ;; Else this is not a group, it's only a single sequence: ;; Check lock state, using `parg' as the guard (cond ((gene-locking-sequence-state-p nil gene-locking-unlocked-state) (setq parg (if (> parg 0) (min parg (- (gene-eol-point) (point))) (max parg (- (gene-bol-point) (point)))))) ((gene-locking-sequence-state-p nil gene-locking-gapinout-state) (setq parg (if (> parg 0) (min parg (save-excursion (skip-chars-forward gene-skip-gaps-regexp (gene-eol-point)))) (max parg (save-excursion (skip-chars-backward gene-skip-gaps-regexp (gene-bol-point))))))) (t (gene-error "Locking error; check lock states."))) (if (= 0 parg) ;; Parg got set to zero, probably by a locking situation. ;; We should error, instead of practicing silent betrayal by ;; saying nothing and deleting 0 characters: (gene-error "Sorry, can't do that. Check locking.") ;; Do the deletion: (let (buffer-read-only) (delete-char parg))))))) (defun gene-seq-base-number () "Return the sequence number of the current residue, ignoring gaps. Another term for it might be \"sequence index\"." (save-excursion (let ((base 0) (end (if (eolp) (point) (1+ (point))))) (beginning-of-line) (while (< (point) end) (skip-chars-forward gene-skip-gaps-regexp end) (setq base (+ base (skip-chars-forward gene-skip-bases-regexp end)))) base))) ;;; sequence identification -- communicating with the ID buffer (defun gene-seq-which-organism () "Show current organism name in the minibuffer." (interactive) (gene-message (gene-organism-name))) (defun gene-seq-where-am-I () "Show the current character/residue positions." (interactive) (let ((name (gene-organism-name)) (col (gene-current-column)) (pos (gene-seq-base-number))) (gene-message "Column %d, residue %d (in %s)." (1+ col) pos name))) (defun kf-toggle-pos-monitoring (parg) (interactive "P") (if parg (add-hook 'post-command-hook 'gene-seq-where-am-I) (remove-hook 'post-command-hook 'gene-seq-where-am-I))) (defun gene-seq-forward-position (parg) "Move forward one character, but do not go past end of sequence. Optional prefix arg PARG means move that many characters." (interactive "p") (if (eolp) (gene-error "Cannot move beyond end") (if (> parg 1) (let ((oparg parg)) (setq parg (min parg (- (gene-eol-point) (point)))) (if (= oparg parg) nil (ding) (gene-message "Cannot move beyond end.")))) (forward-char parg))) (defun gene-seq-backward-position (parg) "Move backward one character, but do not go past end of sequence. Optional prefix arg PARG means move that many characters." (interactive "p") (if (bolp) (gene-error "Cannot move beyond beginning.") (if (> parg 1) (let ((oparg parg)) (setq parg (min parg (- (point) (gene-bol-point)))) (if (= oparg parg) nil (ding) (gene-message "Cannot move beyond beginning.")))) (forward-char (- parg)))) (defun gene-seq-forward-base (parg) "Moves cursor forward to next residue." (interactive "p") (let ((max-lisp-eval-depth gene-really-high-number) (eol (gene-eol-point))) (or (eolp) (forward-char 1)) (while (and (> parg 0) (re-search-forward gene-base-regexp eol t)) (setq parg (1- parg))) (forward-char -1) (if (> parg 0) (gene-error "Cannot move past end.")))) (defun gene-seq-backward-base (parg) "Moves cursor backward to previous residue." (interactive "p") (let ((max-lisp-eval-depth gene-really-high-number) (bol (gene-bol-point))) (while (and (> parg 0) (re-search-backward gene-base-regexp bol t)) (setq parg (1- parg))) (if (> parg 0) (gene-error "Cannot move past beginning.")))) (defun gene-seq-next-base-group (parg) "Move to beginning of next group of (consecutive) residue(s). If encounter end of line, just stay there. Optional arg PARG means move forward that many residue groups." (interactive "p") (let ((eol (gene-eol-point))) (while (> parg 0) (skip-chars-forward gene-skip-bases-regexp eol) (skip-chars-forward gene-skip-gaps-regexp eol) (setq parg (1- parg)))) (if (eolp) (progn (forward-char -1) (ding) (message "No more residue groups.")))) (defun gene-seq-previous-base-group (parg) "Move to end of previous group of (consecutive) residue(s). Optional arg PARG means move backward that many residue groups." (interactive "p") (let ((bol (gene-bol-point))) (while (> parg 0) (skip-chars-backward gene-skip-bases-regexp bol) (skip-chars-backward gene-skip-gaps-regexp bol) (setq parg (1- parg))) (if (bolp) (progn (ding) (message "No more residue groups.")) (forward-char -1))) (if (> parg 0) (gene-message "Cannot move past beginning."))) (defun gene-goto-column-interactive (col) "Go to column COL in the current sequence, or end of line if too short. Columns start numbering from 1, for the purposes of this function only." (interactive "nGo to column number: ") (gene-goto-column (max 0 (1- col)))) ;; todo: should bases start numbering from 0 instead? (defun gene-seq-goto-base (num) "Go to residue number NUM in the current sequence. Goes to the last residue if current sequence has fewer than NUM residues." (interactive "nGo to residue number: ") (beginning-of-line) (let ((eol (gene-eol-point))) (re-search-forward gene-base-regexp eol t num)) (forward-char -1)) (defun gene-read-organism-symbol (prompt) "Read an organism name in the minibuffer, return the organism symbol. This function exists to perform completion." (let ((table (gene-id-generate-id-completion-table))) (cdr ;; todo: default to reference organism or something? (assoc (completing-read prompt table nil t) table)))) (defun gene-seq-goto-organism (sym &optional col non-interactive) "Go to the same column in organism SYM's sequence. Return non-nil iff that column exists in that sequence; otherwise if sequence is too short for that, just go to its end and return nil. If no such sequence SYM, an error is signalled. Called from Lisp, this takes an org-symbol. Interactively, it completingly prompts for a string, which it converts. Optional second arg COL is the column to go to. Optional third arg NON-INTERACTIVE means don't do vertical motion handling, because a program is just using this function for positioning point, probably in a loop." (interactive (list (gene-read-organism-symbol "Go to organism (enter a short ID): "))) (if (eq (gene-get-here-sym) sym) ;; Do nothing if already there. ;; Well, just make sure we're in the right column. (if col (gene-goto-column col)) (let* ((column (or col (gene-current-column))) is-a-line (spot (or (text-property-any (point-min) (point-max) 'gene-ident sym) (save-excursion (set-buffer gene-id-buffer) (let ((id-spot (text-property-any (point-min) (point-max) 'gene-ident sym))) (if id-spot (progn (goto-char id-spot) (setq is-a-line t) (gene-current-line)))))))) (if spot (prog2 (if is-a-line (gene-goto-line spot) (goto-char spot)) (gene-goto-column column) (if non-interactive nil (set-window-point (gene-seq-buffer-window t) (point)) (gene-handle-vertical-motion))) ;; Else this organism isn't in the editor. (gene-error "No such organism in editor: %s" sym))))) (defun gene-seq-last-col () "Move to the last residue in the sequence." ;; todo: Now that we no longer call hscroll-point-visible, this ;; wrapper around end-of-line may no longer be necessary. But I'm ;; leaving it in for now, because suspect that just calling ;; end-of-line doesn't actually fulfill the promise made in the doc ;; string (there could be a spacer at the end of this particular ;; line), so we may need to do more here. (interactive) (end-of-line)) (defun gene-seq-first-col () "Move to the first residue in the sequence." ;; todo: Now that we no longer call hscroll-point-visible, this ;; wrapper around beginning-of-line may no longer be necessary. But ;; I'm leaving it in for now, because suspect that just calling ;; beginning-of-line doesn't actually fulfill the promise made in ;; the doc string (there could be a spacer at the start of this ;; particular line), so we may need to do more here. (interactive) (beginning-of-line)) (defun gene-seq-beginning-of-alignment () "Move point to the first column of the first sequence in the buffer." (interactive) (beginning-of-buffer) (setq this-command 'gene-seq-line-motion) (gene-handle-vertical-motion t)) (defun gene-seq-end-of-alignment () "Move point to the last column of the last sequence in the buffer." (interactive) (end-of-buffer) ;; In case we're right after a newline... (forward-char -2) (gene-seq-last-col) (setq this-command 'gene-seq-line-motion) (gene-handle-vertical-motion t)) ;;; Saving individual sequences. (defun gene-seq-save-sequence-as (sym &optional file) "Save SEQUENCE to a new file. If second arg FILE is not provided, the user will be prompted." (interactive (list (gene-get-here-sym) (read-file-name "Save sequence to file: "))) (let* ((name (gene-organism-name sym)) (prompt-str (format "Save %s to file: " name))) (or file (setq file (expand-file-name (read-file-name prompt-str)))) (gene-save-sequences-as file (list sym)))) ;; These will probably go in something like gene-defs.el or something, ;; later on. For now, I think they're useful enough concepts to ;; define right here so they can be used. They'll have to be set from ;; menus or something later on. (defvar gene-default-organism "Mc.jannasc" "*What eats you when you die.") (defvar gene-reference-organism "Mc.jannasc" "*What we compare to.") ;;; Scroll bars (defvar gene-seq-vertical-scroll-bars t "Non-nil means vertical scroll bars are on. Don't set this directly; use gene-seq-toggle-vertical-scroll-bars") (defun gene-seq-toggle-vertical-scroll-bars (&optional flag) "Toggle vertical scroll bars on or off. Optional arg flag non-nil and positive means turn them on; non-nil and non-positive or non-numeric means turn them off." (interactive) (if flag (if (numberp flag) (if (> flag 0) (gene-seq-vertical-scroll-bars-on) (gene-seq-vertical-scroll-bars-off)) (gene-seq-vertical-scroll-bars-off)) ;; Else no flag passed. (if gene-seq-vertical-scroll-bars (gene-seq-vertical-scroll-bars-off) (gene-seq-vertical-scroll-bars-on)))) (defun gene-seq-vertical-scroll-bars-on () "Turn on vertical scroll-bars on the main frame." (toggle-scroll-bar 1) (setq gene-seq-vertical-scroll-bars t)) (defun gene-seq-vertical-scroll-bars-off () "Turn off vertical scroll-bars on the main frame." (toggle-scroll-bar -1) (setq gene-seq-vertical-scroll-bars nil)) (defvar gene-seq-mode-hook nil "*Hook run when gene-sequence mode is called.") (defun gene-seq-mode () "Major mode for aligning and analyzing gene-sequences. \\{gene-seq-mode-map}" (kill-all-local-variables) (use-local-map gene-seq-mode-map) (setq truncate-lines t) (setq cache-long-line-scans t) (setq mark-active nil) (transient-mark-mode -1) (setq undo-limit (* 5 undo-limit) undo-strong-limit (* 5 undo-strong-limit)) ;; This is done for the mode-line update, actually, since ;; overstrike-mode starts out off by default anyway. (gene-seq-toggle-overstrike-mode -1) (gene-use-color-set "Uncolored") (setq mode-line-format (list "Alignment" " " ;; %l doesn't seem to be working right now... ;;"(Line %l)" ;;" " "(%p)" " " '(gene-seq-overstrike-mode "(Overstrike Mode)" "(Insert Mode)") " " '(gene-modified-p " *Changed* " "(No Change)") " " '(gene-data-input-mode ;; modeline-string's value is right in ;; either case. gene-data-input-mode-modeline-string gene-data-input-mode-modeline-string) )) (toggle-read-only 1) (setq major-mode 'gene-seq-mode) (setq mode-name "Gene Sequence Alignment") ;; These are too dangerous to run at the top level. (make-local-variable 'first-change-hook) (add-hook 'first-change-hook 'gene-mark-modified) (add-hook 'gene-save-hook 'gene-mark-save) (run-hooks 'gene-seq-mode-hook 'gene-seq-mode-hooks)) (provide 'gene-seq-mode)