cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hui-epV4-b.el

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