home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / annotations.el < prev    next >
Encoding:
Text File  |  1995-05-17  |  15.9 KB  |  424 lines
  1. ;;; annotations.el --- interface to marginal annotations
  2.  
  3. ;; Copyright (C) 1992-1994 Free Software Foundation, Inc.
  4. ;;
  5. ;; Created: 10-Oct-93, Chuck Thompson <cthomp@cs.uiuc.edu>
  6. ;; Keywords: extensions, hypermedia, outlining
  7. ;; Enhanced by Andy Piper <ajp@eng.cam.ac.uk>: 6-may-94
  8. ;;
  9. ;; Last modified:  12-May-95 by Chuck Thompson.
  10.  
  11. ;; This file is part of XEmacs.
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify it
  14. ;; under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;;
  28. ;; The annotations are implemented on top of extents.  The extent data
  29. ;; field of an extent being used as an annotation is vector of size 5.
  30. ;;    ('annotation [<data> <action> <menu> <glyph> <down-glyph>])
  31. ;;
  32.  
  33. (defvar make-annotation-hook nil
  34.   "*Function or functions to run immediately after creating an annotation.")
  35.  
  36. (defvar before-delete-annotation-hook nil
  37.   "*Function or functions to run immediately before deleting an annotation.")
  38.  
  39. (defvar after-delete-annotation-hook nil
  40.   "*Function or functions to run immediately after deleting an annotation.")
  41.  
  42. (defvar annotation-local-map-default
  43.   (let ((map (make-sparse-keymap)))
  44.     (set-keymap-name map 'annotation-local-map)
  45.     (define-key map 'button1 'annotation-activate-function-default)
  46.     (define-key map 'button3 'annotation-popup-menu)
  47.     map)
  48.   "Keymap used to activate annotations with only annotation data passed.")
  49.  
  50. (defvar annotation-local-map-with-event
  51.   (let ((map (make-sparse-keymap)))
  52.     (set-keymap-name map 'annotation-local-map)
  53.     (define-key map 'button1 'annotation-activate-function-with-event)
  54.     (define-key map 'button3 'annotation-popup-menu)
  55.     map)
  56.   "Keymap used to activate annotations with annotation data and event passed.")
  57.  
  58. ;;
  59. ;; When the mouse is pressed and released over an annotation glyph
  60. ;; this will run the annotation action passing a single arg, the value
  61. ;; of the annotation data field.
  62. ;;
  63. (defun annotation-activate-function-default (event)
  64.   (interactive "e")
  65.   (let ((extent (event-glyph-extent event))
  66.     (mouse-down t)
  67.     (up-glyph nil))
  68.     ;; make the glyph look pressed
  69.     (cond ((annotation-down-glyph extent)
  70.        (setq up-glyph (annotation-glyph extent))
  71.        (set-annotation-glyph extent (annotation-down-glyph extent))))
  72.     (while mouse-down
  73.       (setq event (next-event event))
  74.       (if (button-release-event-p event)
  75.       (setq mouse-down nil)))
  76.     ;; make the glyph look released
  77.     (cond ((annotation-down-glyph extent)
  78.        (set-annotation-glyph extent up-glyph)))
  79.     (if (eq extent (event-glyph-extent event))
  80.     (if (annotation-action extent)
  81.         (funcall (annotation-action extent) (annotation-data extent))))))
  82.  
  83. ;;
  84. ;; When the mouse is pressed and released over an annotation glyph
  85. ;; this will run the annotation action passing two args, the value
  86. ;; of the annotation data field and the event which triggered the
  87. ;; annotation.
  88. ;;
  89. (defun annotation-activate-function-with-event (event)
  90.   (interactive "e")
  91.   (let ((extent (event-glyph-extent event))
  92.     (mouse-down t)
  93.     (up-glyph nil))
  94.     ;; make the glyph look pressed
  95.     (cond ((annotation-down-glyph extent)
  96.        (setq up-glyph (annotation-glyph extent))
  97.        (set-annotation-glyph extent (annotation-down-glyph extent))))
  98.     (while mouse-down
  99.       (setq event (next-event event))
  100.       (if (button-release-event-p event)
  101.       (setq mouse-down nil)))
  102.     ;; make the glyph look released
  103.     (cond ((annotation-down-glyph extent)
  104.        (set-annotation-glyph extent up-glyph)))
  105.     (if (eq extent (event-glyph-extent event))
  106.     (if (annotation-action extent)
  107.         (funcall (annotation-action extent) (annotation-data extent)
  108.              event)))))
  109.  
  110. ;; #### Glyphs should be glyphs should be glyphs
  111. (defun make-annotation (glyph &optional pos layout buffer with-event d-glyph rightp)
  112.   "Create a marginal annotation with symbol GLYPH at position POS.
  113. GLYPH may be either a pixmap object or a string.  Use layout policy
  114. LAYOUT and place the annotation in buffer BUFFER.  If POS is nil, point is
  115. used.  If LAYOUT is nil, `whitespace' is used.  If BUFFER is nil, the
  116. current buffer is used.  If WITH-EVENT is non-nil, then when an annotation
  117. is activated, the triggering event is passed as the second arg to the
  118. annotation function.  If D-GLYPH is non-nil then it is used as the glyph 
  119. that will be displayed when button1 is down.  If RIGHTP is non-nil then
  120. the glyph will be displayed on the right side of the buffer"
  121.   (let ((new-annotation))
  122.     ;; get the buffer to add the annotation at
  123.     (if (not buffer)
  124.     (setq buffer (current-buffer))
  125.       (setq buffer (get-buffer buffer)))
  126.     ;; get the position to put it at
  127.     (if (not pos)
  128.     (save-excursion
  129.       (set-buffer buffer)
  130.       (setq pos (point))))
  131.     ;; make sure it gets some layout policy
  132.     (if (not layout)
  133.     (setq layout 'whitespace))
  134.  
  135.     ;; make sure the glyph arguments are actually glyphs
  136.     (if (and glyph (not (glyphp glyph)))
  137.     (setq glyph (make-glyph glyph)))
  138.     (if (and d-glyph (not (glyphp d-glyph)))
  139.     (setq d-glyph (make-glyph d-glyph)))
  140.  
  141.     ;; create the actual annotation
  142.     (setq new-annotation (make-extent pos pos buffer))
  143.     (detach-extent new-annotation)
  144.     (set-extent-endpoints new-annotation pos pos)
  145.     (if rightp
  146.     (set-extent-end-glyph new-annotation glyph layout)
  147.       (set-extent-begin-glyph new-annotation glyph layout))
  148.     (set-extent-property new-annotation 'annotation 
  149.              (vector nil nil nil glyph d-glyph rightp))
  150.     (set-extent-property new-annotation 'end-closed t)
  151.     (set-extent-property new-annotation 'start-open t)
  152.     (set-extent-property new-annotation 'duplicable t)
  153.     (if with-event
  154.     (set-extent-property new-annotation 'keymap
  155.                  annotation-local-map-with-event)
  156.       (set-extent-property new-annotation 'keymap
  157.                annotation-local-map-default))
  158.     (run-hook-with-args 'make-annotation-hook new-annotation)
  159.     new-annotation))
  160.  
  161. (fset 'make-graphic-annotation 'make-annotation)
  162. (make-obsolete 'make-graphic-annotation 'make-annotation)
  163.  
  164. (defun delete-annotation (annotation)
  165.   "Remove ANNOTATION from its buffer.  This does not modify the buffer text."
  166.   (if (not (annotationp annotation))
  167.       (error "%s is not an annotation" annotation)
  168.     (progn
  169.       (run-hook-with-args 'before-delete-annotation-hook annotation)
  170.       (delete-extent annotation)
  171.       (run-hooks 'after-delete-annotation-hook))))
  172.  
  173. (defun annotationp (annotation)
  174.   "T if OBJECT is an annotation"
  175.   (and (extent-live-p annotation)
  176.        (not (null (extent-property annotation 'annotation)))))
  177.  
  178. (defun annotation-visible (annotation)
  179.   "T if there is enough available space to display ANNOTATION."
  180.   (if (not (annotationp annotation))
  181.       (error "%s is not an annotation" annotation)
  182.     (not (extent-property annotation 'glyph-invisible))))
  183.  
  184. (defun annotation-at (&optional pos buffer)
  185.   "Find annotation at POS in BUFFER.  BUFFER defaults to the current buffer.
  186. POS defaults to point in BUFFER"
  187.   (car (annotations-at pos buffer)))
  188.  
  189. (defun annotation-layout (annotation)
  190.   "Return the layout policy of annotation ANNOTATION.  The layout policy
  191. is set using `set-annotation-layout'."
  192.   (if (not (annotationp annotation))
  193.       (error "%s is not an annotation" annotation)
  194.     (extent-layout annotation)))
  195.  
  196. (defun annotation-side (annotation)
  197.   "Return the side of the buffer the annotation is displayed on.
  198. Return value is either 'left or 'right"
  199.   (if (aref (extent-property annotation 'annotation) 5)
  200.       'right
  201.     'left))
  202.  
  203. (defun set-annotation-layout (annotation layout)
  204.   "Set the layout policy of ANNOTATION to LAYOUT.  The function
  205. `annotation-layout' returns the current layout policy."
  206.   (if (not (annotationp annotation))
  207.       (error "%s is not an annotation" annotation)
  208.     (set-extent-layout annotation layout)))
  209.  
  210. ;; Now that annotatios use glyphs this function has little value and
  211. ;; will actually not work as is.
  212. ;(defun annotation-type (annotation)
  213. ;  "Return the display type of the annotation ANNOTATION.  The type will
  214. ;be one of the following symbols:
  215. ;
  216. ;    pixmap
  217. ;    bitmap
  218. ;    string
  219. ;    nil    (the object is not an annotation)"
  220. ;  (if (not (annotationp annotation))
  221. ;      nil
  222. ;    (let ((glyph (annotation-glyph annotation)))
  223. ;      (if (stringp glyph)
  224. ;      'stringp
  225. ;    (if (not (pixmapp glyph))
  226. ;        (error "%s is a corrupt annotation" annotation)
  227. ;      (if (> (pixmap-depth glyph) 0)
  228. ;          'pixmap
  229. ;        'bitmap))))))
  230. (make-obsolete 'annotation-type "This function no longer has any meaning.")
  231.  
  232. (defun annotation-width (annotation)
  233.   "Return the width of the annotation ANNOTATION in pixels."  
  234.   (if (not (annotationp annotation))
  235.       (error "%s is not an annotation" annotation)
  236.     (glyph-width (annotation-glyph annotation))))
  237.  
  238. (defun annotation-glyph (annotation)
  239.   "If ANNOTATION is of type `string' return the string.  Otherwise, return
  240. the bitmap or pixmap object of the glyph representing ANNOTATION.
  241. The glyph is set using `set-annotation-glyph'."
  242.   (if (not (annotationp annotation))
  243.       (error "%s is not an annotation" annotation)
  244.     (aref (extent-property annotation 'annotation) 3)))
  245.  
  246. (defun set-annotation-glyph (annotation glyph &optional layout rightp)
  247.   "Set the representation of ANNOTATION to GLYPH.  GLYPH may be either
  248. a string or a bitmap/pixmap object.  If LAYOUT is non-nil set the layout
  249. policy of the annotation to LAYOUT.  If RIGHTP is equal to 'left or 'right
  250. change the side of the annotation to that value.
  251. The function `annotation-glyph' returns the current glyph."
  252.   (if (not (annotationp annotation))
  253.       (error "%s is not an annotation" annotation)
  254.     (progn
  255.       (if (not layout)
  256.       (setq layout (extent-layout annotation)))
  257.       (if (or (eq rightp 'right)
  258.           (and (not (eq rightp 'left))
  259.            (eq (annotation-side annotation) 'right)))
  260.       (set-extent-end-glyph annotation glyph layout)
  261.     (set-extent-begin-glyph annotation glyph layout))
  262.       (aset (extent-property annotation 'annotation) 3 glyph)
  263.       (aset (extent-property annotation 'annotation) 5 rightp)
  264.       (annotation-glyph annotation))))
  265.  
  266. (defun annotation-down-glyph (annotation)
  267.   "If ANNOTATION is of type `string' return the down string.  Otherwise,
  268. return the bitmap or pixmap object of the down-glyph representing ANNOTATION.
  269. The down-glyph is set using `set-annotation-down-glyph'."
  270.   (if (not (annotationp annotation))
  271.       (error "%s is not an annotation" annotation)
  272.     (aref (extent-property annotation 'annotation) 4)))
  273.  
  274. (defun set-annotation-down-glyph (annotation glyph)
  275.   "Set the depressed representation of ANNOTATION to GLYPH.  
  276. GLYPH may be either a string or a bitmap/pixmap object. 
  277. The function `annotation-down-glyph' returns the current down-glyph."
  278.   (if (not (annotationp annotation))
  279.       (error "%s is not an annotation" annotation)
  280.     (aset (extent-property annotation 'annotation) 4 glyph)))
  281.  
  282. (fset 'annotation-graphic 'annotation-glyph)
  283. (fset 'set-annotation-graphic 'set-annotation-glyph)
  284. (make-obsolete 'annotation-graphic 'annotation-glyph)
  285. (make-obsolete 'set-annotation-graphic 'set-annotation-glyph)
  286.   
  287. (defun annotation-data (annotation)
  288.   "Return the data associated with annotation ANNOTATION.  The data is
  289. set using `set-annotation-data'."
  290.   (if (not (annotationp annotation))
  291.       (error "%s is not an annotation" annotation)
  292.     (aref (extent-property annotation 'annotation) 0)))
  293.  
  294. (defun set-annotation-data (annotation data)
  295.   "Set the data field of ANNOTATION to DATA.
  296. The function `annotation-data' returns the current data."
  297.   (if (not (annotationp annotation))
  298.       (error "%s is not an annotation" annotation)
  299.     (aset (extent-property annotation 'annotation) 0 data)))
  300.  
  301. (defun annotation-action (annotation)
  302.   "Return the action associated with annotation ANNOTATION.  The action
  303. is set using `set-annotation-action'."
  304.   (if (not (annotationp annotation))
  305.       (error "%s is not an annotation" annotation)
  306.     (aref (extent-property annotation 'annotation) 1)))
  307.  
  308. (defun set-annotation-action (annotation action)
  309.   "Set the action field of ANNOTATION to ACTION.  The function
  310. `annotation-action' returns the current action."
  311.   (if (not (annotationp annotation))
  312.       (error "%s is not an annotation" annotation)
  313.     (aset (extent-property annotation 'annotation) 1 action)))
  314.  
  315. (defun annotation-face (annotation)
  316.   "Return the face associated with annotation ANNOTATION.  The face is
  317. set using `set-annotation-face'."
  318.   (if (not (annotationp annotation))
  319.       (error "%s is not an annotation" annotation)
  320.     (extent-face annotation)))
  321.  
  322. (defun set-annotation-face (annotation face)
  323.   "Set the face associated with annotation ANNOTATION to FACE.  The function
  324. `annotation-face' returns the current face."
  325.   (if (not (annotationp annotation))
  326.       (error "%s is not an annotation" annotation)
  327.     (set-extent-face annotation face)))
  328.  
  329. (defun annotation-hide (annotation)
  330.   "Remove ANNOTATION's glyph so that it is invisible."
  331.   (if (eq (annotation-side annotation) 'left)
  332.       (set-extent-begin-glyph annotation nil)
  333.     (set-extent-end-glyph annotation nil)))
  334.  
  335. (defun annotation-reveal (annotation)
  336.   "Add ANNOTATION's glyph so that it is visible."
  337.   (if (eq (annotation-side annotation) 'left)
  338.       (set-extent-begin-glyph annotation (annotation-glyph annotation))
  339.     (set-extent-end-glyph annotation (annotation-glyph annotation))))
  340.  
  341. (defun annotations-in-region (start end buffer)
  342.   "Return all annotations in BUFFER which are between START and END
  343. inclusively."
  344.   (save-excursion
  345.     (set-buffer buffer)
  346.  
  347.     (if (< start (point-min))
  348.       (error "<start> not in range of buffer"))
  349.     (if (> end (point-max))
  350.       (error "<end> not in range of buffer"))
  351.  
  352.     (let (note-list)
  353.       (map-extents
  354.        (function (lambda (extent dummy)
  355.            (progn
  356.              (if (annotationp extent)
  357.              (setq note-list (cons extent note-list)))
  358.              nil)))
  359.        buffer start end nil t)
  360.       note-list)))
  361.  
  362. (defun annotations-at (&optional pos buffer)
  363.   "Return a list of all annotations at POS in BUFFER.  If BUFFER is nil,
  364. the current buffer is used.  If POS is nil, point is used."
  365.   (if (not buffer)
  366.       (setq buffer (current-buffer)))
  367.   (if (not pos)
  368.       (save-excursion
  369.     (set-buffer buffer)
  370.     (setq pos (point))))
  371.  
  372.   (annotations-in-region pos pos buffer)
  373. )
  374.  
  375. (defun annotation-list (&optional buffer)
  376.   "Return a list of all annotations in BUFFER.  If BUFFER is nil, the
  377. current buffer is used."
  378.   (if (not buffer)
  379.     (setq buffer (current-buffer)))
  380.  
  381.   (save-excursion
  382.     (set-buffer buffer)
  383.     (annotations-in-region (point-min) (point-max) buffer)))
  384.  
  385. (defun all-annotations ()
  386.   "Return a list of all annotations in existence."
  387.   (let ((b (buffer-list))
  388.     result)
  389.     (while b
  390.       (setq result (nconc result (annotation-list (car b))))
  391.       (setq b (cdr b)))
  392.     result))
  393.  
  394. ;;; #### really this menus junk should append to the prevailing menu
  395. ;;;      in the same way `popup-mode-menu' does.  --jwz
  396.  
  397. ;; annotations menu stuff
  398. (defun annotation-popup-menu (event)
  399.   "Pop up a menu of annotations commands.
  400. Point is temporarily moved to the click position."
  401.   (interactive "e")
  402.   (let ((extent (event-glyph-extent event)))
  403.     (save-excursion
  404.       (goto-char (extent-end-position extent))
  405.       (if (annotation-menu extent)
  406.       (popup-menu (annotation-menu extent))
  407.     (popup-mode-menu)))))
  408.  
  409. (defun set-annotation-menu (annotation menu)
  410.   "Set the menu field of ANNOTATION to MENU.  The function
  411. `annotation-menu' returns the current menu."
  412.   (if (not (annotationp annotation))
  413.       (error "%s is not an annotation" annotation)
  414.     (aset (extent-property annotation 'annotation) 2 menu)))
  415.  
  416. (defun annotation-menu (annotation)
  417.   "Return the menu associated with annotation ANNOTATION.  The menu
  418. is set using `set-annotation-menu'."
  419.   (if (not (annotationp annotation))
  420.       (error "%s is not an annotation" annotation)
  421.     (aref (extent-property annotation 'annotation) 2)))
  422.  
  423. (provide 'annotations)
  424.