![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sun-cursors.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to sun-cursors.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 ! root 1: ;; Cursor definitions for Sun windows ! 2: ;; Copyright (C) 1987 Free Software Foundation, Inc. ! 3: ! 4: ;; This file is part of GNU Emacs. ! 5: ! 6: ;; GNU Emacs is free software; you can redistribute it and/or modify ! 7: ;; it under the terms of the GNU General Public License as published by ! 8: ;; the Free Software Foundation; either version 1, or (at your option) ! 9: ;; any later version. ! 10: ! 11: ;; GNU Emacs is distributed in the hope that it will be useful, ! 12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ! 13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! 14: ;; GNU General Public License for more details. ! 15: ! 16: ;; You should have received a copy of the GNU General Public License ! 17: ;; along with GNU Emacs; see the file COPYING. If not, write to ! 18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ! 19: ! 20: ;;; ! 21: ;;; Added some more cursors and moved the hot spots ! 22: ;;; Cursor defined by 16 pairs of 16-bit numbers ! 23: ;;; ! 24: ;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <[email protected]> ! 25: ! 26: (provide 'sm-cursors) ! 27: ! 28: (defvar sc::cursors nil "List of known cursors") ! 29: ! 30: (defmacro defcursor (name x y string) ! 31: (if (not (memq name sc::cursors)) ! 32: (setq sc::cursors (cons name sc::cursors))) ! 33: (list 'defconst name (list 'vector x y string))) ! 34: ! 35: ;;; push should be defined in common lisp, but if not use this: ! 36: ;(defmacro push (v l) ! 37: ; "The ITEM is evaluated and consed onto LIST, a list-valued atom" ! 38: ; (list 'setq l (list 'cons v l))) ! 39: ! 40: ;;; ! 41: ;;; The standard default cursor ! 42: ;;; ! 43: (defcursor sc:right-arrow 15 0 ! 44: (concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15 ! 45: 0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192))) ! 46: ! 47: ;;(sc:set-cursor sc:right-arrow) ! 48: ! 49: (defcursor sc:fat-left-arrow 0 8 ! 50: (concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255 ! 51: 255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0))) ! 52: ! 53: (defcursor sc:box 8 8 ! 54: (concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4 ! 55: 8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252))) ! 56: ! 57: (defcursor sc:hourglass 8 8 ! 58: (concat "\177\376\100\002\040\014\032\070" ! 59: "\017\360\007\340\003\300\001\200" ! 60: "\001\200\002\100\005\040\010\020" ! 61: "\021\210\043\304\107\342\177\376")) ! 62: ! 63: (defun sc:set-cursor (icon) ! 64: "Change the Sun mouse cursor to ICON. ! 65: If ICON is nil, switch to the system default cursor, ! 66: Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]" ! 67: (interactive "XIcon Name: ") ! 68: (if (symbolp icon) (setq icon (symbol-value icon))) ! 69: (sun-change-cursor-icon icon)) ! 70: ! 71: (make-local-variable '*edit-icon*) ! 72: (make-variable-buffer-local 'icon-edit) ! 73: (setq-default icon-edit nil) ! 74: (or (assq 'icon-edit minor-mode-alist) ! 75: (push '(icon-edit " IconEdit") minor-mode-alist)) ! 76: ! 77: (defun sc:edit-cursor (icon) ! 78: "convert icon to rectangle, edit, and repack" ! 79: (interactive "XIcon Name: ") ! 80: (if (not icon) (setq icon (sc::menu-choose-cursor (selected-window) 1 1))) ! 81: (if (symbolp icon) (setq icon (symbol-value icon))) ! 82: (if (get-buffer "icon-edit") (kill-buffer "icon-edit")) ! 83: (switch-to-buffer "icon-edit") ! 84: (local-set-mouse '(text right) 'sc::menu-function) ! 85: (local-set-mouse '(text left) '(sc::pic-ins-at-mouse 32)) ! 86: (local-set-mouse '(text middle) '(sc::pic-ins-at-mouse 64)) ! 87: (local-set-mouse '(text left middle) 'sc::hotspot) ! 88: (sc::display-icon icon) ! 89: (picture-mode) ! 90: (setq icon-edit t) ; for mode line display ! 91: ) ! 92: ! 93: (defun sc::pic-ins-at-mouse (char) ! 94: "Picture insert char at mouse location" ! 95: (mouse-move-point *mouse-window* (min 15 *mouse-x*) (min 15 *mouse-y*)) ! 96: (move-to-column-force (1+ (min 15 (current-column)))) ! 97: (delete-char -1) ! 98: (insert char) ! 99: (sc::goto-hotspot)) ! 100: ! 101: (defun sc::menu-function (window x y) ! 102: (sun-menu-evaluate window (1+ x) y sc::menu)) ! 103: ! 104: (defmenu sc::menu ! 105: ("Cursor Menu") ! 106: ("Pack & Use" sc::pack-buffer-to-cursor) ! 107: ("Pack to Icon" sc::pack-buffer-to-icon ! 108: (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) ! 109: ("New Icon" call-interactively 'sc::make-cursor) ! 110: ("Edit Icon" sc:edit-cursor ! 111: (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) ! 112: ("Set Cursor" sc:set-cursor ! 113: (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) ! 114: ("Reset Cursor" sc:set-cursor nil) ! 115: ("Help". sc::edit-icon-help-menu) ! 116: ("Quit" sc::quit-edit) ! 117: ) ! 118: ! 119: (defun sc::quit-edit () ! 120: (interactive) ! 121: (bury-buffer (current-buffer)) ! 122: (switch-to-buffer (other-buffer) 'no-record)) ! 123: ! 124: (defun sc::make-cursor (symbol) ! 125: (interactive "SIcon Name: ") ! 126: (eval (list 'defcursor symbol 0 0 "")) ! 127: (sc::pack-buffer-to-icon (symbol-value symbol))) ! 128: ! 129: (defmenu sc::edit-icon-help-menu ! 130: ("Simple Icon Editor") ! 131: ("Left => CLEAR") ! 132: ("Middle => SET") ! 133: ("L & M => HOTSPOT") ! 134: ("Right => MENU")) ! 135: ! 136: (defun sc::edit-icon-help () ! 137: (message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU")) ! 138: ! 139: (defun sc::pack-buffer-to-cursor () ! 140: (sc::pack-buffer-to-icon *edit-icon*) ! 141: (sc:set-cursor *edit-icon*)) ! 142: ! 143: (defun sc::menu-choose-cursor (window x y) ! 144: "Presents a menu of cursor names, and returns one or nil" ! 145: (let ((curs sc::cursors) ! 146: (items)) ! 147: (while curs ! 148: (push (sc::menu-item-for-cursor (car curs)) items) ! 149: (setq curs (cdr curs))) ! 150: (push (list "Choose Cursor") items) ! 151: (setq menu (menu-create items)) ! 152: (sun-menu-evaluate window x y menu))) ! 153: ! 154: (defun sc::menu-item-for-cursor (cursor) ! 155: "apply function to selected cursor" ! 156: (list (symbol-name cursor) 'quote cursor)) ! 157: ! 158: (defun sc::hotspot (window x y) ! 159: (aset *edit-icon* 0 x) ! 160: (aset *edit-icon* 1 y) ! 161: (sc::goto-hotspot)) ! 162: ! 163: (defun sc::goto-hotspot () ! 164: (goto-line (1+ (aref *edit-icon* 1))) ! 165: (move-to-column (aref *edit-icon* 0))) ! 166: ! 167: (defun sc::display-icon (icon) ! 168: (setq *edit-icon* (copy-sequence icon)) ! 169: (let ((string (aref *edit-icon* 2)) ! 170: (index 0)) ! 171: (while (< index 32) ! 172: (let ((char (aref string index)) ! 173: (bit 128)) ! 174: (while (> bit 0) ! 175: (insert (sc::char-at-bit char bit)) ! 176: (setq bit (lsh bit -1)))) ! 177: (if (eq 1 (mod index 2)) (newline)) ! 178: (setq index (1+ index)))) ! 179: (sc::goto-hotspot)) ! 180: ! 181: (defun sc::char-at-bit (char bit) ! 182: (if (> (logand char bit) 0) "@" " ")) ! 183: ! 184: (defun sc::pack-buffer-to-icon (icon) ! 185: "Pack 16 x 16 field into icon string" ! 186: (goto-char (point-min)) ! 187: (aset icon 0 (aref *edit-icon* 0)) ! 188: (aset icon 1 (aref *edit-icon* 1)) ! 189: (aset icon 2 (mapconcat 'sc::pack-one-line "1234567890123456" "")) ! 190: (sc::goto-hotspot) ! 191: ) ! 192: ! 193: (defun sc::pack-one-line (dummy) ! 194: (let* (char chr1 chr2) ! 195: (setq char 0 chr1 (mapconcat 'sc::pack-one-char "12345678" "") chr1 char) ! 196: (setq char 0 chr2 (mapconcat 'sc::pack-one-char "12345678" "") chr2 char) ! 197: (forward-line 1) ! 198: (concat (char-to-string chr1) (char-to-string chr2)) ! 199: )) ! 200: ! 201: (defun sc::pack-one-char (dummy) ! 202: "pack following char into char, unless eolp" ! 203: (if (or (eolp) (char-equal (following-char) 32)) ! 204: (setq char (lsh char 1)) ! 205: (setq char (1+ (lsh char 1)))) ! 206: (if (not (eolp))(forward-char))) ! 207:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.