;;; Copyright (C) 1990  Alan M. Carroll
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 3.2 or later.
;;;
;;; This code is distributed in the hope that it will be useful,
;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License, except the original author nor his
;;; agents are bound by the License in their use of this code.
;;; (These special rights for the author in no way restrict the rights of
;;;  others given in the License or this prologue)
;;; A copy of this license is supposed to have been given to you along
;;; with Epoch so you can know your rights and responsibilities. 
;;; It should be in a file named COPYING.  Among other things, the
;;; copyright notice and this notice must be preserved on all copies. 
;;;
;;;
;;; Chris Love wrote the original version of this, but there's nothing left of
;;; it now.
;;;
(require 'mini-cl)
(provide 'button)

(defun epoch::add-button (start end attribute &optional data buffer)
  "Adds a button to from START to END having ATTRIBUTE and DATA in an optional BUFFER. START and END should be markers or integers. ATTRIBUTE must be a number in the range 0..255. DATA can be any lisp object. Returns the button if successful."
  (let
    (
      (button (epoch::move-button (epoch::make-button) start end buffer))
    )
    (when button
      (epoch::set-button-data button data)
      (epoch::set-button-attribute button attribute)
    )
    button
  )
)
(fset 'add-button (symbol-function 'epoch::add-button))
;;; --------------------------------------------------------------------------
;;; some BC functions (for non-style stuff)
(defun set-attribute-global (attr fore back &optional cfore cback)
  (let ((style (attribute-style attr)))
    (when (not style)
      (setq style (make-style))
      (set-attribute-style attr style)
    )
    (and fore (set-style-foreground style fore))
    (and back (set-style-background style back))
    (and cfore (set-style-cursor-foreground style cfore))
    (and cback (set-style-cursor-background style cback))
  )
)

(defun set-attribute-local (attr fore back &optional cfore cback)
  (let ((style (or (attribute-style attr) (make-style))))
    ;; always force the style local
    (set-attribute-style attr style (current-screen))
    (and fore (set-style-foreground style fore))
    (and back (set-style-background style back))
    (and cfore (set-style-cursor-foreground style cfore))
    (and cback (set-style-cursor-background style cback))
  )
)
;;; --------------------------------------------------------------------------
;;; some utility functions
;;;
(defun add-read-only-button (start end attribute &optional data buffer)
  (set-button-read-only
    (add-button start end attribute data buffer)
    t
  )
)
;;;
(defun button-text (&optional button)
"Returns the text contained inside the BUTTON as a string."
  (and button (not (buttonp button))
    (signal 'wrong-type-argument (list 'buttonp button))
  )
  (setq button (or button (button-at)))
  (let
    (
      (buff (and button (button-buffer button)))
    )
    (if (bufferp buff)
      (save-excursion
	(set-buffer buff)
	(buffer-substring (button-start button) (button-end button))
      )
      ""
    )
  )
)
;;; --------------------------------------------------------------------------
;;; Attribute number allocation
;;;
(defvar *free-attribute-list* t "List of all available free attributes")
(if (eq t *free-attribute-list*)
  (progn
    (setq *free-attribute-list* nil)
    (let ( (i 255) )
      (while (> i 0)
	(push i *free-attribute-list*)
	(decf i)
      )
    )
  )
)
;;;
(defun reserve-attributes (count &optional noerror)
"Return a list of unreserved attributes, and remove them from the free list.
Optional COUNT indicates to return that many. If the NOERROR flag is set,
reserve-attribute will silently return too few attributes if no more are
available, otherwise an error will be signaled."
  (if (null count) (setq count 1))
  (let
    (
      (result nil)
    )
    (while (and (> count 0) *free-attribute-list*)
      (push (pop *free-attribute-list*) result)
      (decf count)
    )
    (when (and (not noerror) (> count 0))
      (release-attributes result)	;put them back
      (error "All attributes allocated") ;error
    )
    result
  )
)
;;;
(defun reserve-attribute ()
"Reserves an attribute index, and returns the number of the attribute"
  (car (reserve-attributes 1))
)
;;;
(defun release-attributes (attrs)
"Mark each attribute in LIST as being unreserved"
  (if
    (or
      (not (list attrs))
      (notevery 'numberp attrs)
    )
    (error "Badly formed attribute list")
  )
  (setq *free-attribute-list* (append *free-attribute-list* attrs))
)

(defun release-attribute (attr)
"Mark ATTRIBUTE as being unreserved"
  (if (not (numberp attr))
    (signal 'wrong-type-argument (list 'numberp attr))
  )
  (release-attributes (list attr))
)
