src/c/xsivwin.c

   1 /* xsiviewwin - XLISP interface to IVIEW dynamic graphics package.     */
   2 /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
   3 /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
   4 /* You may give out copies of this software; for conditions see the    */
   5 /* file COPYING included with this distribution.                       */
   6
   7 #include "xlisp.h"
   8 #include "xlstat.h"
   9
  10 #define IVIEW_WINDOW_TITLE  "Graph Window"
  11 #ifdef MACINTOSH
  12 #define IVIEW_WINDOW_LEFT 10
  13 #define IVIEW_WINDOW_TOP 20
  14 #define IVIEW_WINDOW_WIDTH  250
  15 #define IVIEW_WINDOW_HEIGHT 250
  16 #else
  17 #ifdef _Windows
  18 #define IVIEW_WINDOW_LEFT 0
  19 #define IVIEW_WINDOW_TOP 0
  20 #define IVIEW_WINDOW_WIDTH 250
  21 #define IVIEW_WINDOW_HEIGHT 250
  22 #define IVIEW_WINDOW_LEFT 50
  23 #else
  24 #define IVIEW_WINDOW_LEFT 50
  25 #ifdef AMIGA
  26 #define IVIEW_WINDOW_TOP 0
  27 #else
  28 #define IVIEW_WINDOW_TOP 50
  29 #endif /* AMIGA */
  30 #define IVIEW_WINDOW_WIDTH  400
  31 #define IVIEW_WINDOW_HEIGHT 400
  32 #endif /* _Windows */
  33 #endif /* MACINTOSH */
  34
  35 /* external variables */
  36 extern LVAL s_true;
  37 extern LVAL sk_allocate, sk_dispose, sk_resize, sk_redraw, sk_do_idle,
  38   sk_do_click, sk_do_motion, sk_do_key, sk_install, sk_remove, s_title,
  39   s_go_away, s_menu, s_hardware_address, s_black_on_white, s_has_h_scroll,
  40   s_has_v_scroll, s_internals, sk_show, sk_show_window;
  41 extern LVAL s_in_callback;
  42
  43 /**************************************************************************/
  44 /**                                                                      **/
  45 /**                       Window Creation Functions                      **/
  46 /**                                                                      **/
  47 /**************************************************************************/
  48
  49 /* :ISNEW message for IVIEW-WINDOW-CLASS */
  50 LVAL iview_window_isnew(V)
  51 {
  52   LVAL object = xlgaobject();
  53   int show = xsboolkey(sk_show, TRUE);
  54
  55   object_isnew(object);
  56   initialize_graph_window(object);
  57   if (show) send_message(object, sk_allocate);
  58   return(object);
  59 }
  60
  61 /* :ALLOCATE message for IVIEW-WINDOW-CLASS */
  62 LVAL iview_window_allocate(V)
  63 {
  64   LVAL object;
  65   IVIEW_WINDOW w;
  66
  67   object = xlgaobject();
  68
  69   w = IViewWindowNew(object, TRUE);
  70   /* use StShowWindow to show (map) window but NOT send :resize or :redraw */
  71   if (xsboolkey(sk_show, TRUE)) StShowWindow(w);
  72
  73   return(object);
  74 }
  75
  76 VOID StGWGetAllocInfo P7C(LVAL, object, char **, title,
  77                           int *, left, int *, top, int *, width, int *, height, int *, goAway)
  78 {
  79   LVAL window_title;
  80
  81   if (slot_value(object, s_hardware_address) != NIL)
  82         send_message(object, sk_dispose);
  83
  84   window_title = slot_value(object, s_title);
  85   if (!stringp(window_title)) {
  86     window_title = cvstring(IVIEW_WINDOW_TITLE);
  87     set_slot_value(object, s_title, window_title);
  88   }
  89   *title = (char *) getstring(window_title);
  90
  91   *left = IVIEW_WINDOW_LEFT;
  92   *top = IVIEW_WINDOW_TOP;
  93   *width = IVIEW_WINDOW_WIDTH;
  94   *height = IVIEW_WINDOW_HEIGHT;
  95   get_window_bounds(object, left, top, width, height);
  96
  97   *goAway = slot_value(object, s_go_away) != NIL;
  98 }
  99
 100 VOID StGWObDoClobber P1C(LVAL, object)
 101 {
 102   standard_hardware_clobber(object);
 103 }
 104
 105 VOID StGWObResize P1C(LVAL, object)
 106 {
 107   send_callback_message(object, sk_resize);
 108 }
 109
 110 VOID StGWObRedraw P1C(LVAL, object)
 111 {
 112   send_callback_message(object, sk_redraw);
 113 }
 114
 115
 116 /* idle action. incall is used to detect longjmp's on errors and to    */
 117 /* turn off idle calling if the call is generating an error.           */
 118 VOID StGWObDoIdle P1C(LVAL, object)
 119 {
 120   static int incall = FALSE;
 121
 122   if (incall) {
 123     StGWSetIdleOn(StGWObWinInfo(object), FALSE);
 124     incall = FALSE;
 125     return;
 126   }
 127   else {
 128     incall = TRUE;
 129     send_callback_message(object, sk_do_idle);
 130     incall = FALSE;
 131   }
 132 }
 133
 134 VOID StGWObDoMouse P5C(LVAL, object, int, x, int, y, MouseEventType, type, MouseClickModifier, mods)
 135 {
 136   LVAL Lx, Ly, argv[6], olddenv;
 137   int extend, option;
 138
 139   xlstkcheck(2);
 140   xlsave(Lx);
 141   xlsave(Ly);
 142   argv[0] = object;
 143   argv[2] = Lx = cvfixnum((FIXTYPE) x);
 144   argv[3] = Ly = cvfixnum((FIXTYPE) y);
 145
 146   olddenv = xldenv;
 147   xldbind(s_in_callback, s_true);
 148   if (type == MouseClick) {
 149         extend = ((int) mods) % 2;
 150         option = ((int) mods) / 2;
 151     argv[1] = sk_do_click;
 152         argv[4] = (extend) ? s_true : NIL;
 153         argv[5] = (option) ? s_true : NIL;
 154     xscallsubrvec(xmsend, 6, argv);
 155   }
 156   else {
 157     argv[1] = sk_do_motion;
 158     xscallsubrvec(xmsend, 4, argv);
 159   }
 160   xlpopn(2);
 161   xlunbind(olddenv);
 162 }
 163
 164 VOID StGWObDoKey P4C(LVAL, object, int, key, int, shift, int, opt)
 165 {
 166   LVAL argv[5], ch, olddenv;
 167
 168   olddenv = xldenv;
 169   xldbind(s_in_callback, s_true);
 170   xlsave1(ch);
 171   ch = cvchar(key);
 172   argv[0] = object;
 173   argv[1] = sk_do_key;
 174   argv[2] = ch;
 175   argv[3] = shift ? s_true : NIL;
 176   argv[4] = opt ? s_true : NIL;
 177   xscallsubrvec(xmsend, 5, argv);
 178   xlpop();
 179   xlunbind(olddenv);
 180 }
 181
 182 StGWWinInfo *StGWObWinInfo P1C(LVAL, object)
 183 {
 184   LVAL internals = slot_value(object, s_internals);
 185
 186   if (! consp(internals) || ! adatap(car(internals))
 187       || getadaddr(car(internals)) == NULL)
 188     xlfail("bad internal data");
 189   return((StGWWinInfo *) getadaddr(car(internals)));
 190 }
 191
 192 VOID initialize_graph_window P1C(LVAL, object)
 193 {
 194   LVAL internals, value;
 195   int v, width, height, size;
 196   StGWWinInfo *gwinfo;
 197   ColorCode bc,dc; /* added JKL */
 198
 199   internals = newadata(StGWWinInfoSize(), 1, FALSE);
 200   set_slot_value(object, s_internals, consa(internals));
 201   StGWInitWinInfo(object);
 202
 203   gwinfo = StGWObWinInfo(object);
 204   if (gwinfo == NULL) return;
 205
 206   StGWSetObject(gwinfo, object);
 207
 208   if (slot_value(object, s_black_on_white) == NIL) {
 209     bc = StGWBackColor(gwinfo);         /* this seems better for color */
 210     dc = StGWDrawColor(gwinfo);         /* machines - 0 and 1 are not  */
 211     StGWSetDrawColor(gwinfo, bc);       /* the default draw and back   */
 212     StGWSetBackColor(gwinfo, dc);       /* colors on the Amiga   JKL   */
 213   }
 214
 215   StGetScreenSize(&width, &height);
 216   size = (width > height) ? width : height;
 217   if ((value = slot_value(object, s_has_h_scroll)) != NIL) {
 218     v =  (fixp(value)) ? getfixnum(value) : size;
 219     StGWSetHasHscroll(gwinfo, TRUE, v);
 220   }
 221   if ((value = slot_value(object, s_has_v_scroll)) != NIL) {
 222     v =  (fixp(value)) ? getfixnum(value) : size;
 223     StGWSetHasVscroll(gwinfo, TRUE, v);
 224   }
 225 }
 226
 227 LVAL xsiview_window_update(V)
 228 {
 229 #ifdef MACINTOSH
 230   LVAL object;
 231   int resized;
 232
 233   object = xlgaobject();
 234   resized = (xlgetarg() != NIL);
 235   xllastarg();
 236
 237   graph_update_action(StGWObWinInfo(object), resized);
 238 #endif /* MACINTOSH */
 239   return(NIL);
 240 }
 241
 242 LVAL xsiview_window_activate(V)
 243 {
 244 #ifdef MACINTOSH
 245   LVAL object, menu;
 246   int active;
 247
 248   object = xlgaobject();
 249   active = (xlgetarg() != NIL);
 250   xllastarg();
 251
 252   graph_activate_action(StGWObWinInfo(object), active);
 253   menu = slot_value(object, s_menu);
 254   if (menu_p(menu)) {
 255     if (active) send_message(menu, sk_install);
 256     else send_message(menu, sk_remove);
 257   }
 258 #endif /* MACINTOSH */
 259   return(NIL);
 260 }
 261
 262 /**************************************************************************/
 263 /**                                                                      **/
 264 /**                     Idle Installation Functions                      **/
 265 /**                                                                      **/
 266 /**************************************************************************/
 267
 268 LVAL iview_window_idle_on(V)
 269 {
 270   StGWWinInfo *gwinfo;
 271   int on = 0, set = FALSE;
 272
 273   gwinfo = StGWObWinInfo(xlgaobject());
 274   if (gwinfo == NULL) return(NIL);
 275
 276   if (moreargs()) {
 277     set = TRUE;
 278     on = (xlgetarg() != NIL) ? TRUE : FALSE;
 279   }
 280   xllastarg();
 281
 282   if (set) StGWSetIdleOn(gwinfo, on);
 283   return((StGWIdleOn(gwinfo)) ? s_true : NIL);
 284 }
 285
 286 /**************************************************************************/
 287 /**                                                                      **/
 288 /**                 Menu Installation and Access Functions               **/
 289 /**                                                                      **/
 290 /**************************************************************************/
 291
 292 LVAL iview_window_menu(V)
 293 {
 294   LVAL object, menu = NULL;
 295   int set = FALSE;
 296
 297   object = xlgaobject();
 298   if (moreargs()) {
 299     set = TRUE;
 300     menu = xlgetarg();
 301   }
 302   xllastarg();
 303
 304   if (set) {
 305     if (menu_p(menu)) set_slot_value(object, s_menu, menu);
 306     else if (menu == NIL) set_slot_value(object, s_menu, NIL);
 307     else xlerror("not a menu", menu);
 308   }
 309
 310   return(slot_value(object, s_menu));
 311 }