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 / hyperbole / hui-epV4-b.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  8.0 KB  |  215 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hui-epV4-b.el
  4. ;; SUMMARY:      Support color and flashing of hyper-buttons under Epoch V4
  5. ;; USAGE:        Epoch Lisp Library
  6. ;; KEYWORDS:     faces, hypermedia
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:    27-Apr-91 at 05:37:10
  12. ;; LAST-MOD:     14-Apr-95 at 16:10:55 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; It is for use with Epoch, a modified version of GNU Emacs.
  16. ;; Available for use and distribution under the same terms as GNU Emacs.
  17. ;;
  18. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  19. ;; Developed with support from Motorola Inc.
  20. ;;
  21. ;; DESCRIPTION:  
  22. ;;
  23. ;;   Requires Epoch 4.0a or greater.
  24. ;;
  25. ;;   This is truly prototype code.
  26. ;;
  27. ;; DESCRIP-END.
  28.  
  29. (if (and (boundp 'epoch::version) (stringp epoch::version)
  30.      (or noninteractive (not (string-lessp epoch::version "Epoch 4"))))
  31.     nil
  32.   (error "(hui-epV4-b.el): Load only under Epoch V4 or higher."))
  33.  
  34. (load "button")
  35. (require 'hui-ep-but)
  36.  
  37. (defun hproperty:background ()
  38.   "Returns default background color for selected frame."
  39.   (epoch::background))
  40.  
  41. (defun hproperty:foreground ()
  42.   "Returns default foreground color for selected frame."
  43.   (epoch::foreground))
  44.  
  45. ;;; ************************************************************************
  46. ;;; Public variables
  47. ;;; ************************************************************************
  48.  
  49. (defvar hproperty:item-highlight-color (foreground)
  50.   "Color with which to highlight list/menu selections.
  51. Call (hproperty:set-item-highlight <color>) to change value.")
  52.  
  53. ;;; ************************************************************************
  54. ;;; Public functions
  55. ;;; ************************************************************************
  56.  
  57. (defun hproperty:but-create (&optional start-delim end-delim regexp-match)
  58.   "Mark all hyper-buttons in buffer as Epoch buttons, for later highlighting.
  59. Will use optional strings START-DELIM and END-DELIM instead of default values.
  60. If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
  61. expression which matches an entire button string.
  62. If REGEXP-MATCH is non-nil, only buttons matching this argument are
  63. highlighted."
  64.   ;; Clear out Hyperbole button zones.
  65.   (hproperty:but-clear)
  66.   ;; Then recreate them.
  67.   (hproperty:but-create-all start-delim end-delim regexp-match))
  68.  
  69. (defun hproperty:but-clear ()
  70.   "Delete all Hyperbole button zones from current buffer."
  71.   (interactive)
  72.   (mapcar (function (lambda (zone)
  73.               (if (eq (epoch::zone-style zone) hproperty:but)
  74.               (epoch::delete-zone zone))))
  75.       (epoch::zone-list)))
  76.  
  77. (defun hproperty:cycle-but-color (&optional color)
  78.   "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr."
  79.   (interactive "sHyperbole button color: ")
  80.   (if (<= (epoch::number-of-colors) 2)
  81.       nil
  82.     (if color (setq hproperty:color-ptr nil))
  83.     (epoch::set-style-foreground
  84.      hproperty:but
  85.      (or color (car (hproperty:list-cycle
  86.              hproperty:color-ptr hproperty:good-colors))))
  87.     (hproperty:set-flash-color)
  88.     (redraw-display)
  89.     t))
  90.  
  91. (defun hproperty:but-flash ()
  92.   "Flash a Hyperbole button at point to indicate selection, when using Epoch."
  93.   (interactive)
  94.   (let ((ibut) (prev)
  95.     (start (hattr:get 'hbut:current 'lbl-start))
  96.     (end   (hattr:get 'hbut:current 'lbl-end))
  97.     (b) (a))
  98.     (if (and start end (setq prev (epoch::button-at start)
  99.                  ibut t))
  100.     (progn (if (not prev) (hproperty:but-add start end hproperty:but))
  101.            (setq b (and start (epoch::button-at start))))
  102.       (setq b (button-at (point))))
  103.     (if (setq a (and (epoch::buttonp b) (epoch::button-style b)))
  104.     (progn
  105.       (epoch::set-button-style b hproperty:flash-face)
  106.       (epoch::redisplay-screen)
  107.       ;; Delay before redraw button
  108.       (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i))))
  109.       (epoch::set-button-style b a)
  110.       (epoch::redisplay-screen)
  111.       ))
  112.     (if (and ibut (not prev)) (hproperty:but-delete start))
  113.     ))
  114.  
  115. (defun hproperty:set-item-highlight (&optional background foreground)
  116.   "Setup or reset item highlight style using optional BACKGROUND and FOREGROUND."
  117.   (make-local-variable 'hproperty:item-face)
  118.   (if (stringp background) (setq hproperty:item-highlight-color background))
  119.   (if (not hproperty:highlight-face)
  120.       (progn 
  121.     (setq hproperty:highlight-face (make-style))
  122.     (set-style-foreground hproperty:highlight-face (background))
  123.     (set-style-underline hproperty:highlight-face nil)))
  124.  
  125.   (let ((update-rolo-highlight-flag
  126.      (and (boundp 'rolo-highlight-face) (stylep rolo-highlight-face)
  127.           (or (null (style-foreground rolo-highlight-face))
  128.           (equal (style-foreground hproperty:highlight-face)
  129.              (style-foreground rolo-highlight-face))))))
  130.     (if (not (equal (style-background hproperty:highlight-face)
  131.             (get-color hproperty:item-highlight-color)))
  132.     (set-style-background hproperty:highlight-face
  133.                   hproperty:item-highlight-color))
  134.     (and background (not (equal (style-background hproperty:highlight-face)
  135.                 (get-color background)))
  136.      (set-style-background hproperty:highlight-face background))
  137.     (and foreground (not (equal (style-foreground hproperty:highlight-face)
  138.                 (get-color foreground)))
  139.      (set-style-foreground hproperty:highlight-face foreground))
  140.     (setq hproperty:item-face hproperty:highlight-face)
  141.     (if update-rolo-highlight-flag
  142.     (progn
  143.       (set-style-background rolo-highlight-face
  144.                 (style-background hproperty:highlight-face))
  145.       (set-style-foreground rolo-highlight-face
  146.                 (style-foreground hproperty:highlight-face))
  147.       (set-style-font rolo-highlight-face
  148.               (style-font hproperty:highlight-face))
  149.       (set-style-underline rolo-highlight-face
  150.                    (style-underline hproperty:highlight-face))))))
  151.  
  152. (defun hproperty:select-item (&optional pnt)
  153.   "Select item in current buffer at optional position PNT using hproperty:item-face."
  154.   (or hproperty:item-button
  155.       (setq hproperty:item-button (add-button (point) (point) hproperty:item-face)))
  156.   (if pnt (goto-char pnt))
  157.   (skip-chars-forward " \t")
  158.   (skip-chars-backward "^ \t\n")
  159.   (let ((start (point)))
  160.     (save-excursion
  161.       (skip-chars-forward "^ \t\n")
  162.       (move-button hproperty:item-button start (point))
  163.       ))
  164.   (epoch::redisplay-screen)
  165.   )
  166.  
  167. (defun hproperty:select-line (&optional pnt)
  168.   "Select line in current buffer at optional position PNT using hproperty:item-face."
  169.   (or hproperty:item-button
  170.       (setq hproperty:item-button (add-button (point) (point) hproperty:item-face)))
  171.   (if pnt (goto-char pnt))
  172.   (save-excursion
  173.     (beginning-of-line)
  174.     (move-button hproperty:item-button (point) (progn (end-of-line) (point)))
  175.     )
  176.   (epoch::redisplay-screen)
  177.   )
  178.  
  179. ;;; ************************************************************************
  180. ;;; Private functions
  181. ;;; ************************************************************************
  182.  
  183. (defun hproperty:set-flash-color ()
  184.   "Set button flashing colors based upon current color set."
  185.   (if (<= (epoch::number-of-colors) 2)
  186.       nil
  187.     (epoch::set-style-background hproperty:flash-face (hproperty:but-color))
  188.     (epoch::set-style-foreground hproperty:flash-face (hproperty:background))
  189.     ))
  190.  
  191. ;;; ************************************************************************
  192. ;;; Private variables
  193. ;;; ************************************************************************
  194.  
  195. (defvar hproperty:but (epoch::make-style) "Style for hyper-buttons.")
  196. (epoch::set-style-foreground hproperty:but (hproperty:but-color))
  197. (epoch::set-style-background hproperty:but (hproperty:background))
  198.  
  199. (defvar hproperty:flash-face (epoch::make-style)
  200.   "Style for flashing hyper-buttons.")
  201. (hproperty:set-flash-color)
  202.  
  203. (defvar hproperty:item-button nil
  204.   "Button used to highlight an item in a listing buffer.")
  205. (make-variable-buffer-local 'hproperty:item-button)
  206. (defvar hproperty:item-face nil "Style for item marking.")
  207. (defvar hproperty:highlight-face nil
  208.   "Item highlighting face.  Use (hproperty:set-item-highlight) to set.")
  209. (if hproperty:highlight-face
  210.     nil
  211.   ;; Reverse foreground and background colors for default block-style highlighting.
  212.   (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background)))
  213.  
  214. (provide 'hui-epV4-b)
  215.