;;!emacs
;;
;; FILE:         hui-xe-but.el
;; SUMMARY:      XEmacs button highlighting and flashing support.
;; USAGE:        XEmacs Lisp Library
;; KEYWORDS:     faces, hypermedia
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    21-Aug-92
;; LAST-MOD:     16-May-95 at 17:12:26 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; It is for use with XEmacs, a modified version of GNU Emacs V19.
;; Available for use and distribution under the same terms as GNU Emacs.
;;
;; Copyright (C) 1992-1995, Free Software Foundation, Inc.
;; Developed with support from Motorola Inc.
;;
;; DESCRIPTION:  
;;
;;   This is truly prototype code.
;;
;;   Can't use read-only buttons here because then outline-mode
;;   becomes unusable.
;;
;; DESCRIP-END.

(or hyperb:lemacs-p
    (error "(hui-xe-but.el):  Load only when running XEmacs."))

;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************

(require 'hbut)

;;; XEmacs 19.12 renamed x-color-display-p to x-display-color-p.
(if (and (fboundp 'x-color-display-p)
	 (not (fboundp 'x-display-color-p)))
    (fset 'x-display-color-p 'x-color-display-p))

(defun hproperty:background ()
  "Returns default background color for selected frame."
  (face-background (get-face 'default)))

(defun hproperty:foreground ()
  "Returns default foreground color for selected frame."
  (face-foreground (get-face 'default)))

;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

(defvar hproperty:but-emphasize-p nil
  "*Non-nil means visually emphasize that button under mouse cursor is selectable.")

(defvar hproperty:but-flash-time 1000
  "*Machine specific value for empty loop counter, XEmacs button flash delay.")

(defvar hproperty:item-highlight-color (hproperty:foreground)
  "Color with which to highlight list/menu selections.
Call (hproperty:set-item-highlight <color>) to change value.")

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun hproperty:but-add (start end face)
  "Add between START and END a button using FACE in current buffer."
  (let ((but (make-extent start end)))
    (set-extent-face but face)
    (set-extent-property but 'highlight hproperty:but-emphasize-p)))

(defun hproperty:but-color ()
  "Return current color of buffer's buttons."
  (if hproperty:color-ptr
      (car hproperty:color-ptr)
    (hproperty:foreground)))

(defun hproperty:but-create (&optional start-delim end-delim regexp-match)
  "Mark all hyper-buttons in buffer as XEmacs extents.
Will use optional strings START-DELIM and END-DELIM instead of default values.
If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
expression which matches an entire button string.
If REGEXP-MATCH is non-nil, only buttons matching this argument are
highlighted."
  (interactive)
  (hproperty:but-clear)
  (hproperty:but-create-all start-delim end-delim regexp-match))

(defun hproperty:but-clear ()
  "Delete all Hyperbole buttons from current buffer."
  (interactive)
  (map-extents (function (lambda (extent unused-arg)
			   (if (eq (extent-face extent) 'hbut)
			       (delete-extent extent))))))

(defun hproperty:but-create-all (&optional start-delim end-delim regexp-match)
  "Mark all hyper-buttons in buffer as XEmacs buttons, for later highlighting.
Will use optional strings START-DELIM and END-DELIM instead of default values.
If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular
expression which matches an entire button string.
If REGEXP-MATCH is non-nil, only buttons matching this argument are
highlighted."
  (ebut:map (function (lambda (lbl start end)
			(hproperty:but-add start end hproperty:but-face)))
	    start-delim end-delim regexp-match 'include-delims))
	       
(defun hproperty:but-delete (&optional pos)
  (let ((extent (extent-at (or pos (point)))))
    (if extent (delete-extent extent))))

;;; ************************************************************************
;;; Private functions
;;; ************************************************************************

(defmacro hproperty:list-cycle (list-ptr list)
  "Move LIST-PTR to next element in LIST or when at end to first element."
  (` (or (and (, list-ptr)
	      (setq (, list-ptr) (cdr (, list-ptr))))
	 (setq (, list-ptr) (, list)))))

;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(defconst hproperty:color-list '( "red" "blue" "paleturquoise4" "mediumpurple2"
"lightskyblue3" "springgreen2" "salmon" "yellowgreen" "darkorchid2"
"aquamarine4" "slateblue4" "slateblue1" "olivedrab1" "goldenrod4"
"goldenrod3" "cadetblue2" "burlywood1" "slategrey" "mistyrose"
"limegreen" "lightcyan" "goldenrod" "gainsboro" "skyblue1" "honeydew"
"yellow2" "tomato3" "skyblue" "purple4" "orange3" "bisque3" "bisque2"
"grey34" "gray99" "gray63" "gray44" "gray37" "gray33" "gray26" "azure1"
"snow4" "peru" "red" "lightgoldenrod4" "mediumseagreen" "blush"
"mediumorchid2" "lightskyblue1" "darkslateblue" "midnightblue"
"lightsalmon1" "lemonchiffon" "yellow" "lightsalmon" "coral"
"dodgerblue3" "darkorange4" "blue" "royalblue4" "red" "green" "cyan"
"darkviolet" "darksalmon" "darkorange" "blue" "pink" "magenta2"
"sienna4" "khaki2" "grey75" "grey74" "grey73" "grey69" "grey68" "grey35"
"grey13" "gray90" "gray81" "gray55" "gray51" "gray31" "snow2" "pink3"
"grey7" "gray1" "red4" "red3" "tan" "red" "yellow" "mediumvioletred"
"lightslategrey" "lavenderblush4" "turquoise" "darkturquoise"
"darkslategrey" "lightskyblue" "lightsalmon4" "lightsalmon3"
"forestgreen" "dodgerblue4" "orchid" "rosybrown4" "brown" "peachpuff3"
"palegreen3" "orangered2" "rose" "lightcyan4" "indianred4" "indianred3"
"seagreen2" "indianred" "deeppink1" "navyblue" "lavender" "grey"
"deeppink" "salmon4" "salmon3" "oldlace" "grey78" "grey77" "grey54"
"grey45" "grey21" "gray97" "gray96" "gray95" "gray88" "gray87" "gray86"
"gray70" "gray57" "gray38" "gray12" "gray11" "plum3" "linen" "gray9"
"gray8" "blue4" "beige" "turquoise" "blue" "lemonchiffon4"
"darkseagreen1" "antiquewhite3" "mediumorchid" "springgreen"
"turquoise4" "steelblue3" "mistyrose2" "lightcyan2" "red" "firebrick2"
"royalblue" "cadetblue" "skyblue3" "yellow3" "salmon1" "orange4"
"hotpink" "grey90" "gray56" "gray39" "gray18" "gray14" "plum4" "grey6"
"gray6" "gold3" "gold1" "blue2" "tan2" "cyan" "mediumspringgreen"
"darkolivegreen2" "goldenrod" "lightsteelblue" "brown" "whip"
"chartreuse3" "violetred4" "royalblue2" "royalblue1" "papayawhip"
"mistyrose3" "lightcyan1" "aquamarine" "skyblue4" "hotpink4" "hotpink3"
"hotpink2" "dimgray" "tomato" "grey66" "grey65" "grey64" "grey33"
"grey27" "gray76" "gray69" "gray68" "grey0" "azure" "green"
"darkgoldenrod4" "darkgoldenrod3" "darkgoldenrod2" "darkgoldenrod"
"brown" "lightsalmon2" "deepskyblue4" "deepskyblue3" "deepskyblue2"
"deepskyblue" "darkorange1" "violetred3" "violetred2" "violetred1"
"slateblue3" "slateblue2" "drab" "indianred1" "firebrick1" "cadetblue4"
"violetred" "rosybrown" "blue" "firebrick" "grey100" "wheat4" "grey79"
"grey76" "grey61" "gray93" "gray84" "gray65" "gray36" "gray32" "gray13"
"gray10" "azure3" "snow1" "tan1" "gray" "darkolivegreen1" "blue"
"almond" "lavenderblush3" "lavenderblush2" "lavenderblush1"
"darkolivegreen" "lavenderblush" "aquamarine2" "red" "olivedrab2"
"mistyrose4" "mistyrose1" "lightcyan3" "lightcoral" "chartreuse"
"peachpuff" "palegreen" "mintcream" "skyblue2" "moccasin" "tomato1"
"orchid3" "maroon3" "salmon" "grey81" "grey62" "grey39" "grey38"
"grey37" "gray92" "gray83" "gray66" "gray54" "gray50" "gray30" "gray19"
"gray15" "azure4" "grey3" "tan3" "pink" "gray" "blue" "lightsteelblue2"
"lightsteelblue1" "green" "lightslategray" "lemonchiffon2"
"springgreen1" "greenyellow" "chartreuse2" "grey" "royalblue3"
"powderblue" "peachpuff2" "palegreen2" "cream" "slateblue" "seashell2"
"deeppink2" "darkkhaki" "maroon4" "sienna" "grey71" "grey67" "grey18"
"gray59" "gray43" "gray25" "bisque" "red1" "mediumslateblue"
"lightgoldenrod1" "goldenrod" "paleturquoise3" "lightskyblue4" "green"
"yellow" "smoke" "blue" "white" "steelblue4" "rosybrown3" "peachpuff1"
"palegreen1" "blueviolet" "seashell4" "sienna3" "grey40" "gray91"
"gray82" "gray5" "cyan2" "cyan1" "blue1" "snow" "lightgoldenrod2"
"lightslateblue" "mediumorchid3" "darkseagreen4" "springgreen3" "green"
"slategray4" "slategray3" "slategray2" "blue" "peachpuff4" "palegreen4"
"green" "orangered3" "goldenrod1" "ghostwhite" "firebrick4" "firebrick3"
"cadetblue3" "slategray" "seashell3" "honeydew3" "cornsilk4" "cornsilk2"
"purple1" "dimgrey" "khaki1" "ivory3" "grey70" "grey60" "grey32"
"grey22" "grey12" "gray98" "gray89" "gray71" "gray64" "gray60" "gray49"
"azure2" "gray3" "paleturquoise1" "mediumpurple1" "purple"
"lemonchiffon1" "blue" "navajowhite3" "darkorchid1" "orange"
"goldenrod2" "khaki" "chocolate2" "burlywood2" "honeydew1" "darkgreen"
"thistle3" "thistle2" "thistle1" "thistle" "maroon2" "maroon1" "grey53"
"grey44" "grey25" "gray74" "gray45" "gray41" "gray35" "gray27" "gray23"
"gray16" "brown4" "wheat" "coral" "tan4" "lightgoldenrodyellow" "blue"
"green" "gray" "palevioletred3" "mediumpurple4" "mediumpurple3"
"saddlebrown" "blue" "darkorchid4" "darkorchid3" "puff" "olivedrab4"
"lightblue4" "lightpink" "lightgray" "honeydew2" "cornsilk1" "lace"
"sienna1" "bisque4" "orchid" "khaki3" "grey84" "grey83" "grey82"
"grey72" "grey52" "grey43" "grey26" "grey14" "grey10" "gray75" "gray53"
"gray21" "gray20" "brown3" "grey8" "red2" "navy" "grey" "gold"
"mediumaquamarine" "lightgoldenrod" "darkslategray4" "darkseagreen3"
"darkseagreen2" "antiquewhite4" "white" "springgreen4" "lightyellow4"
"white" "aquamarine1" "turquoise3" "steelblue2" "rosybrown2" "pink"
"gray" "indianred2" "dodgerblue" "green" "seagreen1" "deeppink4"
"aliceblue" "magenta1" "pink" "sienna2" "orchid1" "gray100" "grey97"
"grey94" "grey87" "grey86" "grey51" "grey42" "grey19" "gray94" "gray85"
"gray61" "brown2" "khaki" "grey1" "gold4" "blue" "green" "grey"
"turquoise" "paleturquoise" "mediumorchid4" "antiquewhite2"
"lightyellow2" "violet" "salmon" "chartreuse1" "turquoise1" "sandybrown"
"orangered1" "lightpink1" "lightblue2" "lightblue1" "grey" "seagreen4"
"seagreen3" "lightblue" "deeppink3" "burlywood" "seashell" "hotpink1"
"gray" "yellow4" "yellow" "purple" "orange" "ivory4" "grey99" "grey89"
"grey63" "grey58" "grey49" "grey31" "grey24" "grey20" "green4" "green1"
"gray73" "gray67" "coral3" "coral2" "plum2" "pink4" "ivory" "gray4"
"gray2" "gold2" "aquamarine" "grey" "lightgoldenrod3" "darkolivegreen3"
"darkgoldenrod1" "goldenrod" "orchid" "chiffon" "navajowhite4"
"deepskyblue1" "lightyellow" "floralwhite" "blue" "mediumblue"
"chocolate4" "chocolate3" "burlywood4" "turquoise" "steelblue" "green"
"lawngreen" "honeydew4" "seagreen" "orchid4" "wheat1" "violet" "ivory1"
"grey88" "grey85" "grey57" "grey56" "grey55" "grey48" "grey47" "grey46"
"grey30" "grey17" "gray47" "gray29" "pink2" "grey5" "grey4" "green"
"gray0" "brown" "lightsteelblue4" "darkolivegreen4" "palevioletred4"
"blue" "darkslategray3" "darkslategray2" "darkslategray1"
"blanchedalmond" "palegoldenrod" "blue" "lightseagreen" "lemonchiffon3"
"darkslategray" "green" "darkseagreen" "antiquewhite" "darkorange2"
"chartreuse4" "blue" "rosybrown1" "olivedrab3" "lightpink2" "orangered"
"thistle4" "blue" "cornsilk" "salmon2" "orchid2" "ivory2" "grey93"
"grey92" "grey91" "grey36" "grey29" "grey28" "grey16" "gray79" "gray78"
"gray77" "gray48" "gray17" "coral4" "coral1" "plum1" "pink1" "grey9"
"grey2" "gray7" "cyan4" "blue3" "plum" "cornflowerblue" "lightskyblue2"
"antiquewhite1" "navajowhite2" "navajowhite1" "lightyellow3"
"navajowhite" "darkorange3" "whitesmoke" "turquoise2" "steelblue1"
"lightpink4" "lightblue3" "green" "chocolate1" "blue" "olivedrab"
"lightgrey" "chocolate" "magenta4" "magenta3" "yellow1" "purple3"
"purple2" "orange2" "orange1" "magenta" "bisque1" "wheat2" "maroon"
"khaki4" "grey96" "grey95" "grey80" "grey50" "grey41" "grey15" "grey11"
"gray80" "gray58" "gray40" "gray34" "gray22" "brown1" "snow3"
"mediumturquoise" "lightsteelblue3" "palevioletred2" "palevioletred1"
"paleturquoise2" "green" "palevioletred" "mediumorchid1" "white"
"mediumpurple" "lightyellow1" "dodgerblue2" "dodgerblue1" "violet"
"aquamarine3" "slategray1" "gray" "orangered4" "lightpink3" "blue"
"darkorchid" "cadetblue1" "burlywood3" "seashell1" "cornsilk3" "tomato4"
"tomato2" "wheat3" "grey98" "grey59" "grey23" "green3" "green2" "gray72"
"gray62" "gray52" "gray46" "gray42" "gray28" "gray24" "white" "cyan3"
"black" ))

(defvar hproperty:color-ptr nil
  "Pointer to current color name table to use for Hyperbole buttons in XEmacs.")

(defconst hproperty:good-colors
  '(
    "medium violet red" "indianred4" "firebrick1" "DarkGoldenrod" "NavyBlue"
    "darkorchid" "tomato3" "mediumseagreen" "deeppink" "forestgreen"
    "mistyrose4" "slategrey" "purple4" "dodgerblue3" "mediumvioletred"
    "lightsalmon3" "orangered2" "turquoise4" "Gray55"
    )
  "Good colors for contrast against wheat background and black foreground.")


;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun hproperty:cycle-but-color (&optional color)
  "Switches button color to optional COLOR name or next item referenced by hproperty:color-ptr."
  (interactive "sHyperbole button color: ")
  (if (not (x-display-color-p))
      nil
    (if color (setq hproperty:color-ptr nil))
    (set-face-foreground
     hproperty:but-face
     (or color (car (hproperty:list-cycle
		     hproperty:color-ptr hproperty:good-colors))))
    (hproperty:set-flash-color)
    (sit-for 0)  ;; Force display update
    t))

(defun hproperty:set-flash-color ()
  "Set button flashing colors based upon current color set."
  (if (not (x-display-color-p))
      nil
    (set-face-background hproperty:flash-face (hproperty:but-color))
    (set-face-foreground hproperty:flash-face (hproperty:background))))

(defun hproperty:but-flash ()
  "Flash a XEmacs Hyperbole button at or near point to indicate selection."
  (interactive)
  (let ((ibut) (prev)
	(start (hattr:get 'hbut:current 'lbl-start))
	(end   (hattr:get 'hbut:current 'lbl-end))
	(b) (a))
    (if (and start end (setq prev (extent-at start)
			     ibut t))
	(progn (if (not prev) (hproperty:but-add start end hproperty:but-face))
	       (setq b (and start (extent-at start))))
      (setq b (extent-at (point))))
    (if (setq a (and (extentp b) (extent-face b)))
	(progn
	  (set-extent-face b hproperty:flash-face)
	  (sit-for 0);; Force display update
	  ;; Delay before redraw button
	  (let ((i 0)) (while (< i hproperty:but-flash-time) (setq i (1+ i))))
	  (set-extent-face b a)
	  (sit-for 0);; Force display update
	  ))
    (if (and ibut (not prev)) (hproperty:but-delete start))
    ))

(defun hproperty:set-item-highlight (&optional background foreground)
  "Setup or reset item highlight face using optional BACKGROUND and FOREGROUND."
  (make-local-variable 'hproperty:item-face)
  (if background (setq hproperty:item-highlight-color background))
  (if (not hproperty:highlight-face)
      (progn 
	(setq hproperty:highlight-face
	      (or (find-face 'hproperty:highlight-face)
		  (face-name (make-face 'hproperty:highlight-face))))
	(set-face-foreground hproperty:highlight-face
			     (or foreground (hproperty:background)))
	(set-face-underline-p hproperty:highlight-face nil)))

  (let* ((tty (and (fboundp 'device-type)
		   (eq 'tty (device-type (selected-device)))))
	 (specifiers-function
	  (if (fboundp 'specifier-specs) 'specifier-specs 'identity))
	 (color-function
	  (if (fboundp 'color-name) 'color-name 'identity))
	 (update-rolo-highlight-flag
	  (and (boundp 'rolo-highlight-face) (find-face rolo-highlight-face)
	       (or (null 
		    (funcall specifiers-function
			     (face-foreground rolo-highlight-face)))
		   (equal
		    (funcall color-function
			     (face-foreground rolo-highlight-face))
		    (funcall color-function (face-foreground 'default)))
		   (face-equal hproperty:highlight-face rolo-highlight-face)))))
    (if tty
	(copy-face 'italic 'hproperty:highlight-face)
      (if (and (funcall specifiers-function
			(face-background hproperty:highlight-face))
	       (equal (funcall color-function
			       (face-background hproperty:highlight-face))
		      hproperty:item-highlight-color))
	  nil
	(set-face-background hproperty:highlight-face
			     hproperty:item-highlight-color))
      (and background (not (equal (face-background
				   hproperty:highlight-face) background))
	   (set-face-background hproperty:highlight-face background))
      (and foreground (not (equal (face-foreground
				   hproperty:highlight-face) foreground))
	   (set-face-foreground hproperty:highlight-face foreground)))
    (setq hproperty:item-face hproperty:highlight-face)
    (if update-rolo-highlight-flag
	(if tty
	    (copy-face 'italic 'rolo-highlight-face)
	  (copy-face hproperty:highlight-face rolo-highlight-face)))))

(defun hproperty:select-item (&optional pnt)
  "Select item in current buffer at optional position PNT using hproperty:item-face."
  (if hproperty:item-button
      nil
    (set-extent-face (setq hproperty:item-button (make-extent (point) (point)))
		     hproperty:item-face))
  (if pnt (goto-char pnt))
  (skip-chars-forward " \t")
  (skip-chars-backward "^ \t\n")
  (let ((start (point)))
    (save-excursion
      (skip-chars-forward "^ \t\n")
      (set-extent-endpoints hproperty:item-button start (point))
      ))
  (sit-for 0)  ;; Force display update
  )

(defun hproperty:select-line (&optional pnt)
  "Select line in current buffer at optional position PNT using hproperty:item-face."
  (if hproperty:item-button
      nil
    (set-extent-face (setq hproperty:item-button (make-extent (point) (point)))
		     hproperty:item-face))
  (if pnt (goto-char pnt))
  (save-excursion
    (beginning-of-line)
    (set-extent-endpoints hproperty:item-button (point) (progn (end-of-line) (point)))
    )
  (sit-for 0)  ;; Force display update
  )

;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(defvar hproperty:but-face (face-name (make-face 'hproperty:but-face))
  "Face for hyper-buttons.")
(setq hproperty:but hproperty:but-face)
(if (and (fboundp 'device-type)
	 (eq 'tty (device-type (selected-device))))
    (copy-face 'italic 'hproperty:but-face)
  (set-face-foreground hproperty:but-face (hproperty:but-color))
  (set-face-background hproperty:but-face (hproperty:background)))

(defvar hproperty:flash-face (face-name (make-face 'hproperty:flash-face))
  "Face for flashing hyper-buttons.")
(hproperty:set-flash-color)

(defvar hproperty:item-button nil
  "Button used to highlight an item in a listing buffer.")
(make-variable-buffer-local 'hproperty:item-button)
(defvar hproperty:item-face nil "Item marking face.")
(defvar hproperty:highlight-face nil
  "Item highlighting face.  Use (hproperty:set-item-highlight) to set.")
(if hproperty:highlight-face
    nil
  ;; Reverse foreground and background colors for default block-style highlighting.
  (hproperty:set-item-highlight (hproperty:foreground) (hproperty:background)))

(provide 'hui-xe-but)
