1 ;;; sun-cursors.el --- cursor definitions for Sun windows
3 ;; Copyright (C) 1987 Free Software Foundation, Inc.
5 ;; Author: Jeff Peck <peck@sun.com>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;;; Added some more cursors and moved the hot spots
27 ;;; Cursor defined by 16 pairs of 16-bit numbers
29 ;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <peck@sun.com>
33 (defvar sc
::cursors nil
"List of known cursors")
35 (defmacro defcursor
(name x y string
)
36 (if (not (memq name sc
::cursors
))
37 (setq sc
::cursors
(cons name sc
::cursors
)))
38 (list 'defconst name
(list 'vector x y string
)))
40 ;;; push should be defined in common lisp, but if not use this:
42 ; "The ITEM is evaluated and consed onto LIST, a list-valued atom"
43 ; (list 'setq l (list 'cons v l)))
46 ;;; The standard default cursor
48 (defcursor sc
:right-arrow
15 0
49 (concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15
50 0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192)))
52 ;;(sc:set-cursor sc:right-arrow)
54 (defcursor sc
:fat-left-arrow
0 8
55 (concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255
56 255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0)))
59 (concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4
60 8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252)))
62 (defcursor sc
:hourglass
8 8
63 (concat "\177\376\100\002\040\014\032\070"
64 "\017\360\007\340\003\300\001\200"
65 "\001\200\002\100\005\040\010\020"
66 "\021\210\043\304\107\342\177\376"))
68 (defun sc:set-cursor
(icon)
69 "Change the Sun mouse cursor to ICON.
70 If ICON is nil, switch to the system default cursor,
71 Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]"
72 (interactive "XIcon Name: ")
73 (if (symbolp icon
) (setq icon
(symbol-value icon
)))
74 (sun-change-cursor-icon icon
))
76 (make-local-variable '*edit-icon
*)
77 (make-variable-buffer-local 'icon-edit
)
78 (setq-default icon-edit nil
)
79 (or (assq 'icon-edit minor-mode-alist
)
80 (push '(icon-edit " IconEdit") minor-mode-alist
))
82 (defun sc:edit-cursor
(icon)
83 "convert icon to rectangle, edit, and repack"
84 (interactive "XIcon Name: ")
85 (if (not icon
) (setq icon
(sc::menu-choose-cursor
(selected-window) 1 1)))
86 (if (symbolp icon
) (setq icon
(symbol-value icon
)))
87 (if (get-buffer "icon-edit") (kill-buffer "icon-edit"))
88 (switch-to-buffer "icon-edit")
89 (local-set-mouse '(text right
) 'sc
::menu-function
)
90 (local-set-mouse '(text left
) '(sc::pic-ins-at-mouse
32))
91 (local-set-mouse '(text middle
) '(sc::pic-ins-at-mouse
64))
92 (local-set-mouse '(text left middle
) 'sc
::hotspot
)
93 (sc::display-icon icon
)
95 (setq icon-edit t
) ; for mode line display
98 (defun sc::pic-ins-at-mouse
(char)
99 "Picture insert char at mouse location"
100 (mouse-move-point *mouse-window
* (min 15 *mouse-x
*) (min 15 *mouse-y
*))
101 (move-to-column (1+ (min 15 (current-column))) t
)
106 (defun sc::menu-function
(window x y
)
107 (sun-menu-evaluate window
(1+ x
) y sc
::menu
))
111 ("Pack & Use" sc
::pack-buffer-to-cursor
)
112 ("Pack to Icon" sc
::pack-buffer-to-icon
113 (sc::menu-choose-cursor
*menu-window
* *menu-x
* *menu-y
*))
114 ("New Icon" call-interactively
'sc
::make-cursor
)
115 ("Edit Icon" sc
:edit-cursor
116 (sc::menu-choose-cursor
*menu-window
* *menu-x
* *menu-y
*))
117 ("Set Cursor" sc
:set-cursor
118 (sc::menu-choose-cursor
*menu-window
* *menu-x
* *menu-y
*))
119 ("Reset Cursor" sc
:set-cursor nil
)
120 ("Help". sc
::edit-icon-help-menu
)
121 ("Quit" sc
::quit-edit
)
124 (defun sc::quit-edit
()
126 (bury-buffer (current-buffer))
127 (switch-to-buffer (other-buffer) 'no-record
))
129 (defun sc::make-cursor
(symbol)
130 (interactive "SIcon Name: ")
131 (eval (list 'defcursor symbol
0 0 ""))
132 (sc::pack-buffer-to-icon
(symbol-value symbol
)))
134 (defmenu sc
::edit-icon-help-menu
135 ("Simple Icon Editor")
141 (defun sc::edit-icon-help
()
142 (message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU"))
144 (defun sc::pack-buffer-to-cursor
()
145 (sc::pack-buffer-to-icon
*edit-icon
*)
146 (sc:set-cursor
*edit-icon
*))
148 (defun sc::menu-choose-cursor
(window x y
)
149 "Presents a menu of cursor names, and returns one or nil"
150 (let ((curs sc
::cursors
)
153 (push (sc::menu-item-for-cursor
(car curs
)) items
)
154 (setq curs
(cdr curs
)))
155 (push (list "Choose Cursor") items
)
156 (setq menu
(menu-create items
))
157 (sun-menu-evaluate window x y menu
)))
159 (defun sc::menu-item-for-cursor
(cursor)
160 "apply function to selected cursor"
161 (list (symbol-name cursor
) 'quote cursor
))
163 (defun sc::hotspot
(window x y
)
164 (aset *edit-icon
* 0 x
)
165 (aset *edit-icon
* 1 y
)
168 (defun sc::goto-hotspot
()
169 (goto-line (1+ (aref *edit-icon
* 1)))
170 (move-to-column (aref *edit-icon
* 0)))
172 (defun sc::display-icon
(icon)
173 (setq *edit-icon
* (copy-sequence icon
))
174 (let ((string (aref *edit-icon
* 2))
177 (let ((char (aref string index
))
180 (insert (sc::char-at-bit char bit
))
181 (setq bit
(lsh bit -
1))))
182 (if (eq 1 (% index
2)) (newline))
183 (setq index
(1+ index
))))
186 (defun sc::char-at-bit
(char bit
)
187 (if (> (logand char bit
) 0) "@" " "))
189 (defun sc::pack-buffer-to-icon
(icon)
190 "Pack 16 x 16 field into icon string"
191 (goto-char (point-min))
192 (aset icon
0 (aref *edit-icon
* 0))
193 (aset icon
1 (aref *edit-icon
* 1))
194 (aset icon
2 (mapconcat 'sc
::pack-one-line
"1234567890123456" ""))
198 (defun sc::pack-one-line
(dummy)
199 (let* (char chr1 chr2
)
200 (setq char
0 chr1
(mapconcat 'sc
::pack-one-char
"12345678" "") chr1 char
)
201 (setq char
0 chr2
(mapconcat 'sc
::pack-one-char
"12345678" "") chr2 char
)
203 (concat (char-to-string chr1
) (char-to-string chr2
))
206 (defun sc::pack-one-char
(dummy)
207 "pack following char into char, unless eolp"
208 (if (or (eolp) (char-equal (following-char) 32))
209 (setq char
(lsh char
1))
210 (setq char
(1+ (lsh char
1))))
211 (if (not (eolp))(forward-char)))
213 (provide 'sm-cursors
)
215 ;;; sun-cursors.el ends here