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