/* support code to drive buttons in epoch */

/*
   Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990
                 Free Software Foundation, Inc.

This file is part of Epoch, a modified version of GNU Emacs.

Epoch is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY.  No author or distributor
accepts responsibility to anyone for the consequences of using it
or for whether it serves any particular purpose or works at all,
unless he says so in writing.  Refer to the GNU Emacs General Public
License for full details.

Everyone is granted permission to copy, modify and redistribute
Epoch, but only under the conditions described in the
GNU Emacs General Public License.   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.  */

#ifdef BUTTON

#include <signal.h>		/* get BLOCK_INPUT() right */

#include "config.h"

#include "lisp.h"

#include "x11term.h"

#include "dispextern.h"

#include "buffer.h"

#include "screen.h"     /* [amc] */
#include "screenW.h"    /* [amc] */
#include "screenX.h"    /* [amc] */

#include "button.h"               /* [cjl] use buttons as distinct type */
#include "xresource.h"		/* need access to X resource objects */

#define min(a,b) ((a)<(b) ? (a) : (b))
#define max(a,b) ((a)>(b) ? (a) : (b))
        
extern Display *XD_display;     /* default display */
extern int XD_plane;		/* display plane */
extern int windows_or_buffers_changed;

Lisp_Object Vbuttons_modify_buffer;
Lisp_Object GlobalStyleTable;

/* this signals a read-only error if buttons-modify-buffer is set, and the
 * buffer is read-only. b is a buffer pointer, and buf should be the
 * Lisp_Object buffer corresponding to b
 */
#define CHECK_READ_ONLY(b,buf)  { if (!NULL(Vbuttons_modify_buffer)\
                                  && !((b == bf_cur) ? NULL(bf_cur->read_only) : NULL(b->read_only)))\
                                  Fsignal(Qbuffer_read_only, (Fcons(buf,Qnil))); }
#define MODIFY_BUFFER(b)    { if (!EQ(Vbuttons_modify_buffer,Qnil))\
                                  if (b == bf_cur) bf_modified += 1;\
                                  else b->text.modified += 1;\
                              windows_or_buffers_changed++; }

/* useful macros */
#define CHARX(a,x)      ((a)*(x)->font_width+(x)->in_border)
#define CHARY(a,x)      ((a)*(x)->font_height+(x)->in_border)

/* ------------------------------------------------------------------------- */
DEFUN ("epoch::make-button",Fmake_button,Smake_button,0,0,0,
       "(epoch::make-button) makes a button pointing nowhere".)
     ()
{
  Lisp_Object val;
  register struct Lisp_Button *p;

  val = Fmake_vector (make_number((sizeof (struct Lisp_Button) -
                                   sizeof (struct Lisp_Vector) +
                                   sizeof (Lisp_Object))
                                  / sizeof (Lisp_Object)), Qnil);
  XSETTYPE (val, Lisp_Button);
  p = XBUTTON(val);
  p->start = Fmake_marker();
  p->end   = Fmake_marker();
  p->attribute = make_number(0);
  /* don't need to set other fields to Qnil, done by Fmake_vector */
  return val;
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::buttons-at",Fbuttons_at,Sbuttons_at,0,2,0,
       "Returns a list of all buttons in buffer intersecting given point.")
     (pos, buffer) Lisp_Object pos, buffer;
{
  register struct buffer *bf1;
  register struct Lisp_Button *button;
  register Lisp_Object buttons,b_list;
  register int ipos;

  /* Check for valid buffer, or get current */
  buffer = NULL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer);
  CHECK_BUFFER(buffer,0);
  bf1 = XBUFFER(buffer);

  ipos = XFASTINT(pos);

  /* Generate the list of buttons */
  for (buttons = bf1->buttons, b_list = Qnil;
       !NULL(buttons);
       buttons = XBUTTON(buttons)->next)
    {
      register int first, last;
      
      button = XBUTTON(buttons);
      first = marker_position (button->start);        /* button start */
      last  = marker_position (button->end);          /* button end   */
      if ((first <= ipos) && (ipos < last))
	b_list = Fcons (buttons, b_list);
    }
  return Fnreverse(b_list);
}
   
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-list",Fbutton_list,Sbutton_list,0,1,0,
       "(epoch::button-list [buffer]) returns a list of all buttons in the\n\
current (or specified) buffer.")
     (buffer) Lisp_Object buffer;
{
  register struct buffer *bf1;
  register struct Lisp_Button *button;
  register Lisp_Object buttons,b_list;
  
  /* Check for a valid buffer, or if null, use the current buffer */
  buffer = NULL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer) ;
  CHECK_BUFFER(buffer,0);
  bf1 = XBUFFER(buffer);

  /* Generate the list of buttons */
  for ( buttons = bf1->buttons, b_list = Qnil ;
       !NULL(buttons) ;
       buttons = XBUTTON(buttons)->next
       )
    b_list = Fcons(buttons, b_list);

  return Fnreverse(b_list);
}

/* ------------------------------------------------------------------------- */
DEFUN ("epoch::buttonp",Fbuttonp,Sbuttonp,1,1,0,
       "(epoch::buttonp OBJECT) returns non nil iff OBJECT is a button")
     (button) Lisp_Object button;
{
  return (XTYPE (button) == Lisp_Button) ? Qt : Qnil;
}

/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-buffer",Fbutton_buffer,Sbutton_buffer,1,1,0,
       "Returns the buffer BUTTON is in")
     (button) Lisp_Object button;
{
  struct buffer *b;
  CHECK_BUTTON (button,0);
  b = XMARKER(XBUTTON(button)->start)->buffer;
  if (!b) return Qnil;
  XSET(button,Lisp_Buffer,b);
  return button;
}

/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-read-only-p",Fbutton_read_only_p,Sbutton_read_only_p,
       1,1,0,
       "Returns t if button is read-only; else nil.")
     (button) Lisp_Object button;
{
  CHECK_BUTTON (button,0);
  return NULL(XBUTTON(button)->read_only) ? Qnil : Qt;
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::set-button-read-only",
       Fset_button_read_only,Sset_button_read_only,2,2,0,
       "Set BUTTON to have a read-only status of FLAG")
     (button,flag) Lisp_Object button, flag;
{
  CHECK_BUTTON (button,0);
  XBUTTON(button)->read_only = NULL(flag) ? Qnil : Qt;
  return button;
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-attribute",Fbutton_attribute,Sbutton_attribute,1,1,0,
       "Returns the button's attribute number.")
     (button) Lisp_Object button;
{
  CHECK_BUTTON (button,0);
  return (XBUTTON(button)->attribute);
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::set-button-attribute",
       Fset_button_attribute,Sset_button_attribute,2,2,0,
       "Sets BUTTON to have ATTRIBUTE for display. ATTRIBUTE must be in the range 0..255")
     (button,attr) Lisp_Object button, attr;
{
  CHECK_BUTTON (button,0);
  CHECK_NUMBER (attr  ,0);
  if (XINT(attr) < 0 || XINT(attr) > 255)
    Fsignal(Qerror,
	    Fcons(build_string("attribute out of range"),Fcons(attr,Qnil)));
  XBUTTON(button)->attribute = attr;
  return button;
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-start",Fbutton_start,Sbutton_start,1,1,0,
       "Return position of start of button, or nil if\n button not inserted.")
     (button) Lisp_Object button;
{
  CHECK_BUTTON (button,0);
  return Fmarker_position(XBUTTON(button)->start);
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-end",Fbutton_end,Sbutton_end,1,1,0,
       "Return position of end of button, or nil if button\n not inserted.")
     (button) Lisp_Object button;
{
  CHECK_BUTTON(button,0);
  return Fmarker_position(XBUTTON(button)->end);
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::button-data",Fbutton_data,Sbutton_data,1,1,0,
       "Return value of BUTTON's data field")
     (button) Lisp_Object button;
{
  CHECK_BUTTON (button,0);
  return (XBUTTON(button)->data);
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::set-button-data",Fset_button_data,Sset_button_data,2,2,0,
       "Set value of button's data field. returns\n data.")
     (button,data) Lisp_Object button,data;
{
  CHECK_BUTTON (button,0);
  XBUTTON(button)->data = data;
  return data;
}
/* ------------------------------------------------------------------------- */
/* [cjl]
 * read-only-region-p
 *      Follow the display rule for selecting buttons, and given a region
 * (start and end), return either nil if no read-only buttons overlap the
 * region, or return the right-most read-only button overlapping the region.
 */
/* Change to collision detection. We asssume that the regious are open, so
 * that if they overlap at only the endpoints, then there is no collision.
 * There's no overlap iff X ends before Y starts, or Y ends before X starts.
 * This assumes that x1 <= x2 && y1 <= y2.
*/
#define NO_REGION_OVERLAP(x1,x2,y1,y2) ( (x2) <= (y1) || (y2) <= (x1) )

DEFUN ("epoch::read-only-region-p",
       Fread_only_region_p,Sread_only_region_p,2,3,0,
       "Given the START and END of a region in BUFFER (current buffer if omitted), check that region for read-only buttons.  START and END do not have to be in right order.  If found, return the button; else return nil.")
     (mark1,mark2,buffer) Lisp_Object mark1,mark2,buffer;
{
  struct buffer *bf1;
  register Lisp_Object buttons;
  register struct Lisp_Button *button;
  register int start,end;

  buffer = NULL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer);
  CHECK_BUFFER(buffer,2);
  bf1 = XBUFFER(buffer);

  CHECK_NUMBER_COERCE_MARKER(mark1,0);
  CHECK_NUMBER_COERCE_MARKER(mark2,1);
  start = XFASTINT(mark1);
  end = XFASTINT(mark2);
  if (start > end)                            /* insure that start <= end */
    { int tmp = end; end = start; start = tmp; }
  
  for (buttons = bf1->buttons; !NULL(buttons) ; buttons = button->next)
    {
      button = XBUTTON(buttons);
      if (!NULL(button->read_only))
      {
        register int first, last;
 
        first = marker_position (button->start);        /* button start */
        last  = marker_position (button->end);          /* button end   */

        if (! NO_REGION_OVERLAP(start,end,first,last))
          {
            register Lisp_Object buttons2;
            register struct Lisp_Button *button2;
            register int first2,last2;

            /* now check remaining buttons for better candidate(s) */
            for (buttons2 = button->next; !NULL(buttons2); buttons2 = button2->next)
              {
                button2 = XBUTTON(buttons2);
                if (!NULL(button2->read_only))
                {
                  first2 = marker_position (button2->start);
                  last2 = marker_position (button2->end);

                  /* if next button doesn't overlap */
		  if (NO_REGION_OVERLAP(start,end,first2,last2))
                    return (buttons); /* no better candidates */
                  /* otherwise, this button also overlaps the region, so   */
                  else if (first2 > first)      /* test if it is a better  */
                    {                           /* solution than the first */
                      button = button2;         /* one we found.  If so,   */
                      first = first2;           /* change the outer loop   */
                      last = last2;             /* and test for a better   */
                      buttons = buttons2;       /* (still) solution.  If   */
                    }                           /* not, then continue this */
                }                               /* inner loop of testing.  */
              }
            return (buttons);
          }
      }
    }
  return Qnil;                  /* no read-only buttons in this region */
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* given a buffer and a location, figure out the attribute value
 * and the start/end of the next button. Buttons are assumed to be disjoint
 * and ordered by position.
 */

int get_button(b,loc,b_start,b_end,b_return)
     struct buffer *b;
     register int loc;
     int *b_start, *b_end;
     Lisp_Object *b_return;
{
  register struct Lisp_Button *button;
  register Lisp_Object buttons;
  register int first,last;

  if (b_start)  *b_start  = -1;
  if (b_end)    *b_end    = -1;
  if (b_return) *b_return = Qnil;

  for (buttons = b->buttons; !NULL(buttons); buttons = button->next)
    {
      button = XBUTTON (buttons);
      first  = marker_position(button->start);
      last   = marker_position(button->end);
      if (loc < last)
        {
          register Lisp_Object buttons2;
          register struct Lisp_Button *button2;
          register int first2,last2;
          
          if (b_start)  *b_start  = first;
          if (b_end)    *b_end    = last;
          if (b_return) *b_return = buttons;

          for (buttons2 = button->next; !NULL(buttons2); buttons2 = button2->next)
            {
              button2 = XBUTTON (buttons2);

	      /* AMC hack - never take a 0 attribute button over a non-0 */
	      if (button->attribute && ! button2->attribute) continue;

              first2  = marker_position(button2->start);
              last2   = marker_position(button2->end);

              if (first2 >= last)
                return XFASTINT (button->attribute);
              else if (first2 > loc)
                {
                  if (b_end) *b_end = first2;
                  return XFASTINT (button->attribute);
                }
              else if (loc < last2)
                {
                  button  = button2;
                  first   = first2;
                  last    = last2;
                  buttons = buttons2;
                  
                  if (b_start)  *b_start  = first;
                  if (b_end)    *b_end    = last;
                  if (b_return) *b_return = buttons;
                }
            }
          return XFASTINT (button->attribute);
        }
    }
  return 0;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::clear-buttons",Fclear_buttons,Sclear_buttons,0,1,"",
      "(epoch::clear-buttons [BUFFER]) Remove all buttons in buffer.")
        (buffer)
        Lisp_Object buffer;
{
  if (EQ(buffer,Qnil)) XSET(buffer,Lisp_Buffer,bf_cur);
  else buffer = Fget_buffer(buffer);

  if (EQ(buffer,Qnil)) return Qnil;
  else
    {
      /* make buttons' markers point nowhere */
      register Lisp_Object buttons = XBUFFER(buffer)->buttons;
      if (!NULL (buttons))
	{
	  XBUFFER(buffer)->force_redisplay = Qt;
	  windows_or_buffers_changed++;
	}
      while (!NULL (buttons))
	{
	  register struct Lisp_Button *button = XBUTTON(buttons);
	  /* avoid overhead of calling Fset_marker */
	  unchain_marker(button->start);
	  unchain_marker(button->end);
	  button->prev = Qnil;
	  buttons = button->next;
	  button->next = Qnil;
	}
      XBUFFER(buffer)->buttons = Qnil;
      return Qt;
    }
}
/* ------------------------------------------------------------------------ */
VOID RemoveButtonFromBuffer(b,bf,unchain)
     struct Lisp_Button *b;
     struct buffer *bf;
     int unchain;		/* unchain markers? */
{
  /* verify that we can remove the button */
  register Lisp_Object buffer;
  XSET(buffer,Lisp_Buffer,bf);
  CHECK_READ_ONLY(bf,buffer);

  if (!NULL (b->next)) XBUTTON(b->next)->prev = b->prev;

  if (NULL (b->prev)) bf->buttons = b->next;
  else XBUTTON(b->prev)->next = b->next;

  b->next = b->prev = Qnil;
  if (unchain)
    {
      unchain_marker(b->start);
      unchain_marker(b->end);
    }

  bf->force_redisplay = Qt;
  windows_or_buffers_changed++;
  MODIFY_BUFFER(bf);
}
/* ------------------------------------------------------------------------- */
DEFUN ("epoch::move-button",Fmove_button,Smove_button,1,4,0,
"Moves the BUTTON to cover the desired region from START to END in BUFFER.\n\
START and END do not have to be in the right order.\n\
If START or END is nil, the current location is used.\n\
If BUFFER is nil, the button buffer is used, or if that is not set, the\n\
current buffer. The button is removed from its current buffer and\n\
inserted into the new buffer.")
    (button,pos1,pos2,buffer) Lisp_Object button,pos1,pos2,buffer;
{
  register struct Lisp_Button *b,*prevb,*nextb;
  register struct buffer *sbuff,*dbuff;	/* destination and source buffers */
  int first=0,last=0;
  Lisp_Object blist;

  CHECK_BUTTON (button,0);
  b = XBUTTON(button);

  /* extract the locations from the markers */
  if (!NULL(pos1))
    {
      CHECK_NUMBER_COERCE_MARKER(pos1,1);
      first = XFASTINT(pos1);
    }
  else if (XMARKER(b->start)->buffer) /* it's already pointing somewhere */
    first = marker_position(b->start);

  if (!NULL(pos2))
    {
      CHECK_NUMBER_COERCE_MARKER(pos2,2);
      last = XFASTINT(pos2);
    }
  else if (XMARKER(b->end)->buffer) /* end marker points somewhere */
    last = marker_position(b->end);

  /* keep ordering intact */
  if (first > last)
    {
      int tmp;
      tmp = first; first = last; last = tmp;
    }

  /* deal with the buffer. The rules are:
   * 1. If buffer is set, that's the buffer the button goes in
   * 2. If buffer is nil, then keep the button in the same buffer
   * 3. If the buffer and button buffer are nil, use the current buffer
   */

  sbuff = XMARKER(b->start)->buffer; /* source buffer */

  if (NULL(buffer))
    if (sbuff)		/* is there a buffer to stay in? */
      {
	dbuff = sbuff;		/* should be in the if, but it's confusing */
	XSET(buffer,Lisp_Buffer,dbuff);
      }
    else			/* no, have to switch */
      {
	buffer = Fcurrent_buffer();
	dbuff = XBUFFER(buffer);
      }
  else				/* buffer was set to something */
    {
      buffer = Fget_buffer(buffer); /* convert possible string, check arg */
      if (NULL(buffer)) error("Invalid buffer for button move");
      dbuff = XBUFFER(buffer);
    }

  /* make sure the destination is alive */
  if (NULL (dbuff->name)) return Qnil;    /* bad destination - return nil */

  /* check the case that the button isn't going anywhere */
  if ( sbuff == dbuff
      && marker_position(b->start) == first
      && marker_position(b->end) == last
      )
    return button;		/* just return it */

  /* make sure we can put the button in the new buffer */
  CHECK_READ_ONLY(dbuff,buffer);

  /* remove button from old buffer */
  if (sbuff) RemoveButtonFromBuffer(b,sbuff,0); /* don't unchain */

  /* set the button to have to right marker locations
   * Fset_marker takes care of unchaining from old buffer, etc.
   */
  Fset_marker(b->start,first,buffer);
  Fset_marker(b->end,last,buffer);

  /* search the list for a place to insert. A valid place is either where the
   * next button starts _after_ this one, or the end of the list.
   */
  prevb = 0;			/* no previous to start with */
  for ( blist = dbuff->buttons ; !NULL(blist) ; blist = XBUTTON(blist)->next )
    {
      nextb = XBUTTON(blist);
      if (marker_position(nextb->start) > first)
	{
	  /* insert before this button */
	  b->next = blist;
	  b->prev = nextb->prev;
	  nextb->prev = button;
	  if (prevb)		/* there's a previous button */
	    prevb->next = button;
	  else
	    dbuff->buttons = button;
	  break;		/* get out of for loop */
	}

      prevb = nextb;
    }

  if (NULL(blist))		/* didn't find an insertion point */
    {
      if (!prevb)		/* no buttons in buffer */
	dbuff->buttons = button; /* that's it */
      else			/* put at end of list */
	{
	  prevb->next = button;
	  XSET(b->prev,Lisp_Button,prevb);
	}
    }

  /* mark buffer as needing redisplay */
  dbuff->force_redisplay = Qt;
  windows_or_buffers_changed++;

  return button;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::button-at",Fbutton_at,Sbutton_at,0,2,0,
      "(epoch::button-at POS [BUFFER]) Return the button, if any, containing POS.")
        (pos,buffer)
        Lisp_Object pos,buffer;
    {
    int first,last,type,ipos;
    Lisp_Object button;

    if (EQ(buffer,Qnil)) XSET(buffer,Lisp_Buffer,bf_cur);
    else buffer = Fget_buffer(buffer);
    if (EQ(buffer,Qnil)) return Qnil;

    if (EQ(pos,Qnil)) pos = Fpoint(); /* default to point */
    CHECK_NUMBER_COERCE_MARKER(pos,1);
    ipos = XFASTINT(pos);

    type = get_button(XBUFFER(buffer),ipos,&first,&last,&button);
    return (ipos >= first && ipos < last) ? button : Qnil;
    }

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::delete-button",Fdelete_button,Sdelete_button,1,1,0,
       "(epoch::delete-button BUTTON) remove BUTTON from the buffer it is in (if any).\n\
if argument is nil, do nothing.")
    (button) Lisp_Object button;
{
  register struct buffer *bf;
  register struct Lisp_Button *b;

  if (NULL(button)) return Qnil;
  CHECK_BUTTON (button,0);
  b = XBUTTON(button);

  bf = XMARKER(b->start)->buffer;
  if (!bf) return button;

  RemoveButtonFromBuffer(b,bf,1); /* remove and unchain markers */
  return button;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::delete-button-at",Fdelete_button_at,Sdelete_button_at,0,2,0,
       "(epoch::delete-button-at [POS] [BUFFER]) Delete the button, if any, containing\n\
the location specified.")
        (pos,buffer)
        Lisp_Object pos,buffer;
{
  return Fdelete_button(Fbutton_at(pos,buffer));
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::get-color",Fepoch_get_color,Sepoch_get_color,1,1,0,
      "Convert the name of a color into a X-cardinal resource (a pixel value)")
      (name) Lisp_Object name;
{
  Lisp_Object zreturn = Qnil;
  int ok = 1;			/* valid input flag */
  XColor c;
  Colormap cmap;
  BLOCK_INPUT_DECLARE();

  cmap = DefaultColormap(XD_display,DefaultScreen(XD_display));

  switch XTYPE(name)
    {
    case Lisp_Vector :
      if (XVECTOR(name)->size >= 3)
	{
	  c.red = XVECTOR(name)->contents[0];
	  c.green = XVECTOR(name)->contents[1];
	  c.blue = XVECTOR(name)->contents[2];
	}
      else ok = 0;
      break;
    case Lisp_String :
      HOLD_INPUT(ok = XParseColor(XD_display,cmap,XSTRING(name)->data,&c))
	break;
    case Lisp_Xresource :
      if (XXRESOURCE(name)->type == XA_CARDINAL) return name;
      /* else fall through */
    default :
      error("Color must be string, vector, or X-cardinal");
      break;
    }

  if (ok)
    {
      BLOCK_INPUT();
      c.flags = DoRed + DoGreen + DoBlue;
      if (XAllocColor(XD_display,cmap,&c))
	zreturn = make_Xresource(XD_display,XD_plane,c.pixel,XA_CARDINAL);
      UNBLOCK_INPUT();
    }

  return zreturn;
}

DEFUN ("epoch::free-color", Fepoch_free_color, Sepoch_free_color, 1, 1, 0,
       "Release COLOR in the X server for reuse.")
     (color) Lisp_Object color;
{
  if (XRESOURCEP(color) && XXRESOURCE(color)->type == XA_CARDINAL)
    XFreeColors(XD_display,
		DefaultColormap(XD_display,XD_plane),
		&(XXRESOURCE(color)->id),
		1, 0);
  else
    error("Color freed must be an X-cardinal");
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
DEFUN ("epoch::number-of-colors",Fx_number_of_colors,Sx_number_of_colors,0,0,0,
      "Returns the number of colors available (display cells). Monochrome returns 2, grey scale and color return larger numbers.")
        ()
    {
    return make_number(DisplayCells(cur_Xscreen->display,cur_Xscreen->plane));
    }

/* ------------------------------------------------------------------------- */
DEFUN ("epoch::make-style",Fepoch_make_style,Sepoch_make_style,0,0,0,
       "Creates a style object, without no values set.\n\
A style is used to describe how to plot characters. Current fields are\n\
foreground : foreground color for text\n\
background : background color for text\n\
cursor-foreground : foreground for plotting the cursor\n\
cursor-background : background for plotting the cursor\n\
font : font to use for characters\n\
underline : color to draw underline in\n\
stipple : stipple for normal text\n\
background-stipple : stipple for character backgrounds\n\
cursor-stipple : stipple for the cursor background")
     ()
{
  Lisp_Object val;

  val = Fmake_vector (make_number((sizeof (struct Lisp_Style) -
                                   sizeof (struct Lisp_Vector) +
                                   sizeof (Lisp_Object))
                                  / sizeof (Lisp_Object)), Qnil);
  XSETTYPE (val, Lisp_Style);
  return val;
}

/* ---------- */
DEFUN ("epoch::set-attribute-style",
       Fepoch_set_attribute_style, Sepoch_set_attribute_style,
       2,3,0,
       "Set ATTRIBUTE to display in STYLE. If the optional SCREEN argument is present, then the ATTRIBUTE is set local to that SCREEN.")
     (attrib,style,screen) Lisp_Object attrib,style,screen;
{
  int index;
  Lisp_Object table;

  CHECK_NUMBER(attrib,0);
  CHECK_STYLE(style,1);

  index = XFASTINT(attrib);
  if (index < 1 || index > MAX_ATTR)
    error("Attribute value out of range (1..%d)",MAX_ATTR);

  if (NULL(screen))
    XVECTOR(GlobalStyleTable)->contents[index] = style;
  else
    {
      screen = find_block(screen);
      if (NULL(screen)) error("Invalid screen");
      table = XROOT(screen)->styles;
      if (!VECTORP(table) || XVECTOR(table)->size != MAX_ATTR)
	table = XROOT(screen)->styles = Fmake_vector(MAX_ATTR,Qnil);
      XVECTOR(table)->contents[index] = style;
    }
  return style;
}
/* ---------- */
DEFUN ("epoch::attribute-style", 
       Fepoch_attribute_style, Sepoch_attribute_style, 1, 2,0,
       "Return the style for ATTRIBUTE. If optional SCREEN is present, the local style for that screen is returned, otherwise the global style is returned.")
     (attrib,screen) Lisp_Object attrib,screen;
{
  int index;
  Lisp_Object result = Qnil,table;

  CHECK_NUMBER(attrib,0);

  index = XFASTINT(attrib);
  if (index < 1 || index > MAX_ATTR)
    error("Attribute value out of range (1..%d)",MAX_ATTR);

  if (NULL(screen)) result = XVECTOR(GlobalStyleTable)->contents[index];
  else
    {
      screen = find_block(screen);
      if (NULL(screen)) error("Invalid screen");
      table = XROOT(screen)->styles;
      if (VECTORP(table) && XVECTOR(table)->size > index)
	result = XVECTOR(table)->contents[index];
    }
  return result;
}
/* ------------------------------------------------------------------------- */
Lisp_Object QXcardinalp,QXfontp,QXbitmapp;

#define STYLE_SET_FUNCTION(field,conversion) \
     (style,value) Lisp_Object style,value;\
{\
  CHECK_STYLE(style,0);\
  XSTYLE(style)->field = EQ(Qnil,value) ? value : conversion(value);\
  return style;\
}
#define STYLE_GET_FUNCTION(field) \
     (style) Lisp_Object style;\
{ CHECK_STYLE(style,0); return XSTYLE(style)->field; }
   
/* ---------- */
DEFUN ("epoch::set-style-foreground", Fepoch_set_style_foreground, Sepoch_set_style_foreground, 2,2,0, "Set the STYLE foreground to COLOR")
     STYLE_SET_FUNCTION(foreground,Fepoch_get_color);
DEFUN ("epoch::style-foreground", Fepoch_style_foreground, Sepoch_style_foreground, 1,1,0, "Return the STYLE's current foreground color")
     STYLE_GET_FUNCTION(foreground)
/* ---------- */
DEFUN ("epoch::set-style-background", Fepoch_set_style_background, Sepoch_set_style_background, 2,2,0, "Set the STYLE background to COLOR")
     STYLE_SET_FUNCTION(background,Fepoch_get_color)
DEFUN ("epoch::style-background", Fepoch_style_background, Sepoch_style_background, 1,1,0, "Return the STYLE's current background color")
     STYLE_GET_FUNCTION(background)
/* ---------- */
DEFUN ("epoch::set-style-cursor-foreground", Fepoch_set_style_cursor_foreground, Sepoch_set_style_cursor_foreground, 2,2,0, "Set the STYLE cursor foreground to COLOR")
     STYLE_SET_FUNCTION(cursor_foreground,Fepoch_get_color)
DEFUN ("epoch::style-cursor-foreground", Fepoch_style_cursor_foreground, Sepoch_style_cursor_foreground, 1,1,0, "Return the STYLE's current cursor foreground color")
     STYLE_GET_FUNCTION(cursor_foreground)
/* ---------- */
DEFUN ("epoch::set-style-cursor-background", Fepoch_set_style_cursor_background, Sepoch_set_style_cursor_background, 2,2,0, "Set the STYLE cursor background to COLOR")
     STYLE_SET_FUNCTION(cursor_background,Fepoch_get_color)
DEFUN ("epoch::style-cursor-background", Fepoch_style_cursor_background, Sepoch_style_cursor_background, 1,1,0, "Return the STYLE's current cursor background color")
     STYLE_GET_FUNCTION(cursor_background)
/* ---------- */
DEFUN ("epoch::set-style-underline", Fepoch_set_style_underline, Sepoch_set_style_underline, 2,2,0, "Set the STYLE underline to COLOR")
     STYLE_SET_FUNCTION(underline,Fepoch_get_color)
DEFUN ("epoch::style-underline", Fepoch_style_underline, Sepoch_style_underline, 1, 1, 0, "Return the STYLE's current underline color")
     STYLE_GET_FUNCTION(underline);
/* ---------- */
DEFUN ("epoch::set-style-font", Fepoch_set_style_font, Sepoch_set_style_font, 2, 2, 0, "Set the STYLE to FONT")
     STYLE_SET_FUNCTION(font,Fepoch_get_font);
DEFUN ("epoch::style-font", Fepoch_style_font, Sepoch_style_font, 1, 1, 0, "Return the current font for STYLE")
     STYLE_GET_FUNCTION(font);
/* ---------- */
/* Yow. Stipples are different - no conversion function available */
#undef STYLE_SET_FUNCTION
#define STYLE_SET_FUNCTION(field,rtype,predicate) \
     (style,value) Lisp_Object style,value;\
{									\
  if (!									\
      ( EQ(value,Qnil)							\
       || (XRESOURCEP(value) && XXRESOURCE(value)->type == rtype)))	\
    wrong_type_argument(predicate,value);				\
  XSTYLE(style)->field = value;						\
  return style;								\
}
/* ---------- */
DEFUN ("epoch::set-style-stipple", Fepoch_set_style_stipple, Sepoch_set_style_stipple, 2, 2, 0, "Set the STYLE to have STIPPLE")
     STYLE_SET_FUNCTION(stipple,XA_BITMAP,QXbitmapp)
DEFUN ("epoch::style-stipple", Fepoch_style_stipple, Sepoch_style_stipple, 1, 1, 0, "Return the current stipple bitmap for STYLE")
     STYLE_GET_FUNCTION(stipple)
/* ---------- */
DEFUN ("epoch::set-style-cursor-stipple", Fepoch_set_style_cursor_stipple, Sepoch_set_style_cursor_stipple, 2, 2, 0, "Set the STYLE to have a cursor STIPPLE")
     STYLE_SET_FUNCTION(cursor_stipple,XA_BITMAP,QXbitmapp)
DEFUN ("epoch::style-cursor-stipple", Fepoch_style_cursor_stipple, Sepoch_style_cursor_stipple, 1, 1, 0, "Return the current cursor stipple bitmap for STYLE")
     STYLE_GET_FUNCTION(cursor_stipple)
/* ---------- */
DEFUN ("epoch::set-style-background-stipple", Fepoch_set_style_background_stipple, Sepoch_set_style_background_stipple, 2, 2, 0, "Set the STYLE to have a background STIPPLE")
     STYLE_SET_FUNCTION(background_stipple,XA_BITMAP,QXbitmapp)
DEFUN ("epoch::style-background-stipple", Fepoch_style_background_stipple, Sepoch_style_background_stipple, 1, 1, 0, "Return the current background stipple bitmap for STYLE")
     STYLE_GET_FUNCTION(background_stipple)
/* ---------- */
#undef STYLE_SET_FUNCTION
#undef STYLE_GET_FUNCTION
/* ------------------------------------------------------------------------- */
/* Some ugliness here, in order to do stippling.
 * In order to stipple, we need two GC's. We can't use XDrawImageString since
 * it ignores stipples. Instead, we have to XFillRectangle with the background
 * color first, and then XDrawString. The problem is that XFillRectangle uses
 * the foreground color, so the GC we use for that must be the inverse of the
 * one for the text. So, we'll set the gc_style GC up, and then exchange
 * foreground/background and the mask bits, and change gc_inverse to be
 * correct. Sadly, this means that GCofStyle is in effect passing results back
 * in global variables (gc_inverse), but that's life. Note that if the
 * attribute is 0, then none of this goes on, since default text can't be
 * stippled.
 */
GC GCofStyle(attrib,type,style,rb)
     int attrib;		/* attrubute # */
     int type;			/* type - text, cursor, etc. */
     Lisp_Object *style;	/* return slot for the style object */
     struct Root_Block *rb;	/* screen */
{
  struct Lisp_Style *s = 0;
  Lisp_Object scratch;
  XGCValues gcv;
  unsigned long gcmask = 0, tmp;
  XS_DEF;

  if (style == 0) style = &scratch; /* avoid pointer problems */
  *style = Qnil;

  if (attrib == 0)
    {
      switch (type)
	{
        default :
	case 0 : return xs->gc_norm;
	case 1 : return xs->gc_curs;
	case 2 : return xs->gc_rev;
	}
    }

  /* find the style, if any, that is referenced */
  if ((VECTORP(rb->styles)
       && (XVECTOR(rb->styles)->size > attrib)
       && (!NULL(*style = (XVECTOR(rb->styles)->contents[attrib]))))
      ||
      (VECTORP(GlobalStyleTable)
       && (XVECTOR(GlobalStyleTable)->size > attrib)
       && (!NULL(*style = (XVECTOR(GlobalStyleTable)->contents[attrib]))))
      )
    s = XSTYLE(*style);

  /* Now, set up the text GC */
  gcmask = GCForeground + GCBackground + GCFillStyle + GCFont;
  gcv.foreground = xs->background;
  gcv.background = (type == 1 ? xs->cursor_color : xs->foreground);
  gcv.font = xs->font_id;
  gcv.fill_style = FillSolid;

  if (s)
    {
      switch (type)
	{
	default :		/* do something */
	case 0 :		/* text */
	  if (XRESOURCEP(s->foreground))
	    gcv.foreground = XXRESOURCE(s->foreground)->id;
	  if (XRESOURCEP(s->background))
	    gcv.background = XXRESOURCE(s->background)->id;
	  break;
	
	case 1 :		/* cursor */
	  /* cursor foreground */
	  if (XRESOURCEP(s->cursor_foreground))
	    gcv.foreground = XXRESOURCE(s->cursor_foreground)->id;
	  else if (XRESOURCEP(s->background))
	    gcv.foreground = XXRESOURCE(s->background)->id;
	
	  /* cursor background */
	  if (XRESOURCEP(s->cursor_background))
	    gcv.background = XXRESOURCE(s->cursor_background)->id;
	  else if (XRESOURCEP(s->foreground))
	    gcv.background = XXRESOURCE(s->foreground)->id;
	  break;
	}

      if (XRESOURCEP(s->font))
	gcmask |= GCFont, gcv.font = XXRESOURCE(s->font)->id;

      if (XRESOURCEP(s->stipple))
	gcmask |= GCStipple + GCFillStyle,
	gcv.stipple = XXRESOURCE(s->stipple)->id,
	gcv.fill_style = FillStippled;
    }

  XChangeGC(xs->display,xs->gc_style,gcmask,&gcv);

  /* set up the background character box, if there's a style */
  if (s)
    {
      /* Have to play games to get the stippling right. Most of these options
       * are set for stippling, but get changed if there is no stipple
       */
      gcmask = GCForeground + GCBackground + GCFillStyle + GCStipple;
      gcv.fill_style = FillOpaqueStippled;
      gcv.foreground = xs->background;

      /* if there's a cursor stipple, and we're doing a cursor, use that
       * else if not a cursor and a background stipple, use that
       * else use a solid pattern, no stipple
       */
      if (type == 1 && XRESOURCEP(s->cursor_stipple))
	gcv.stipple = XXRESOURCE(s->cursor_stipple)->id;
      else if (type != 1 && XRESOURCEP(s->background_stipple))
	gcv.stipple = XXRESOURCE(s->background_stipple)->id;
      else
	{
	  gcv.fill_style = FillSolid;
	  gcmask &= ~(GCStipple + GCBackground);
	  gcv.foreground = gcv.background;
	}

      XChangeGC(xs->display, xs->gc_inverse, gcmask, &gcv);
    }

  return xs->gc_style;

}
/* ------------------------------------------------------------------------- */
void
ShipOutTextBlock(str,count,col,row,cursor,attrib,rb)
     char *str;			/* the characters */
     int count;			/* # of chars */
     int row,col;		/* character location */
     int cursor;		/* cursor flag */
     int attrib;		/* style value */
     struct Root_Block *rb;	/* screen info */
{
  XS_DEF;
  GC theGC;
  Lisp_Object style;
  struct Lisp_Style *s;
  XGCValues gcv;
  unsigned long gcmask;
  int y = CHARY(row,xs) + xs->font_base;
  int x = CHARX(col,xs);

  if (count < 1) return;	/* allow calling with 0 counts */

  theGC = GCofStyle(attrib,cursor,&style,rb);

  if (STYLEP(style))
    {
      s = XSTYLE(style);

      XFillRectangle(xs->display,xs->xid,xs->gc_inverse,
		     x,y - xs->font_base,
		     count*xs->font_width,xs->font_height);
      XDrawString(xs->display,xs->xid,theGC,x,y,str,count);

      if (XRESOURCEP(s->underline))
	{
	  int uy = (y - xs->font_base) + xs->font_height - 1;

	  gcv.foreground = XXRESOURCE(s->underline)->id;
	  gcv.line_style = LineSolid; gcv.line_width = 0;
	  gcv.fill_style = FillSolid;
	  gcmask = GCForeground + GCLineStyle + GCLineWidth + GCFillStyle;
	  XChangeGC(xs->display,theGC,gcmask,&gcv);
	  XDrawLine(xs->display,xs->xid,theGC,
		    x,uy,x + count*xs->font_width,uy);
	}
    }
  else				/* no style, just do it */
    XDrawImageString(xs->display,xs->xid,theGC,x,y,str,count);
}
/* ------------------------------------------------------------------------- */
void
PlotTextLine(line,vpos,hpos,count,rb)
     struct display_line *line; /* what to plot */
     int hpos;               /* offset into the line to start */
     int vpos;               /* vertical location */
     int count;              /* # of chars to print */
     struct Root_Block *rb;    /* screen descriptor */
{
  XS_DEF;
  int index;			/* index into the line */
  int limit = hpos+count;	/* max index to plot */
  int n = 0;			/* char count for current region */
  char *start;			/* pointer to start of region */
  int gctype = -1;		/* current GC type */
  int cursor;			/* flag for ShipOutTextBlock */
  unsigned char *pattr = line->attrib+hpos; /* current attribute byte */
  int spot = hpos;		/* place to put current block */

  cursor = line->highlighted ? 2 : 0;

  for ( index = hpos ; index <  limit ; ++index, ++pattr, ++n )
    {
      if (*pattr != gctype)
	{
	  /* time to ship the region out */
	  ShipOutTextBlock(start,n,spot,vpos,cursor,gctype,rb);
	  spot = index;
	  start = line->body + index;
	  n = 0;
	  gctype = *pattr;	/* get the next attrib char */
	}
    }
    
  /* finish any dangling stuff */
  ShipOutTextBlock(start,n,spot,vpos,cursor,gctype,rb);
}
     
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* assumes cursor is on the line to be updated */
UpdateTextLine(line,row,col,rb)
        struct display_line *line;
        int col,row;
        struct Root_Block *rb;
    {
    int length;
    XS_DEF; WS_DEF;
    BLOCK_INPUT_DECLARE ();
    
    BLOCK_INPUT ();

    length = line->length - col;
    if (length > 0)
        {
        PlotTextLine(line,row,col,length,rb);
        CXTtopos (row, length, rb);
        if (line->length < ws->width)
            Cx_clear_end_of_line (line->length,rb);
        }
    else
        {
        Cx_clear_end_of_line (line->length,rb);
        }
    UNBLOCK_INPUT ();
    }
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Lisp_Object Qbuttonp,Qstylep;

void
init_button()
{
  int i;

  GlobalStyleTable = Fmake_vector(MAX_ATTR,Qnil);
  staticpro(&GlobalStyleTable);

}

/* - - - - - - - */
void
syms_of_button()
{
  init_button();

  Qbuttonp = intern ("buttonp"); staticpro(&Qbuttonp);
  Qstylep = intern ("stylep"); staticpro(&Qstylep);
  QXcardinalp = intern ( "Xcardinalp" ); staticpro(&QXcardinalp);
  QXfontp = intern ( "Xfontp" ); staticpro(&QXfontp);
  QXbitmapp = intern ( "Xbitmapp" ); staticpro(&QXbitmapp);

  defsubr(&Smake_button);
  defsubr(&Sbuttonp);
  defsubr(&Smove_button);
  defsubr(&Sdelete_button);
  defsubr(&Sbuttons_at);
  defsubr(&Sbutton_list);
  defsubr(&Sread_only_region_p);
  defsubr(&Sbutton_buffer);
  defsubr(&Sbutton_attribute);
  defsubr(&Sset_button_attribute);
  defsubr(&Sbutton_start);
  defsubr(&Sbutton_end);
  defsubr(&Sbutton_data);
  defsubr(&Sset_button_data);
  defsubr(&Sbutton_read_only_p);
  defsubr(&Sset_button_read_only);
  defsubr(&Sclear_buttons);
  defsubr(&Sbutton_at);
  defsubr(&Sdelete_button_at);
  defsubr(&Sepoch_get_color);
  defsubr(&Sepoch_free_color);
  defsubr(&Sx_number_of_colors);

  defsubr(&Sepoch_make_style);
  defsubr(&Sepoch_attribute_style);
  defsubr(&Sepoch_set_attribute_style);
  defsubr(&Sepoch_set_style_foreground);
  defsubr(&Sepoch_style_foreground);
  defsubr(&Sepoch_set_style_background);
  defsubr(&Sepoch_style_background);
  defsubr(&Sepoch_style_cursor_foreground);
  defsubr(&Sepoch_set_style_cursor_foreground);
  defsubr(&Sepoch_set_style_cursor_background);
  defsubr(&Sepoch_style_cursor_background);
  defsubr(&Sepoch_set_style_underline);
  defsubr(&Sepoch_style_underline);
  defsubr(&Sepoch_set_style_font);
  defsubr(&Sepoch_style_font);
  defsubr(&Sepoch_set_style_stipple);
  defsubr(&Sepoch_style_stipple);
  defsubr(&Sepoch_set_style_cursor_stipple);
  defsubr(&Sepoch_style_cursor_stipple);
  defsubr(&Sepoch_set_style_background_stipple);
  defsubr(&Sepoch_style_background_stipple);

  DEFVAR_LISP("epoch::buttons-modify-buffer",&Vbuttons_modify_buffer,
	      "Flag on whether buttons should mark a buffer as modified.");
  Vbuttons_modify_buffer = Qt;
}
#endif /* BUTTON */
