home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / x11graph.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  38KB  |  1,154 lines
  1. /* -*-C-*-
  2.  
  3. $Id: x11graph.c,v 1.41 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Simple graphics for X11 */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "x11.h"
  27. #include "float.h"
  28. #include <math.h>
  29.  
  30. #define RESOURCE_NAME "schemeGraphics"
  31. #define RESOURCE_CLASS "SchemeGraphics"
  32. #define DEFAULT_GEOMETRY "512x384+0+0"
  33.  
  34. struct gw_extra
  35. {
  36.   float x_left;
  37.   float x_right;
  38.   float y_bottom;
  39.   float y_top;
  40.   float x_slope;
  41.   float y_slope;
  42.   int x_cursor;
  43.   int y_cursor;
  44. };
  45.  
  46. #define XW_EXTRA(xw) ((struct gw_extra *) ((xw) -> extra))
  47.  
  48. #define XW_X_LEFT(xw) ((XW_EXTRA (xw)) -> x_left)
  49. #define XW_X_RIGHT(xw) ((XW_EXTRA (xw)) -> x_right)
  50. #define XW_Y_BOTTOM(xw) ((XW_EXTRA (xw)) -> y_bottom)
  51. #define XW_Y_TOP(xw) ((XW_EXTRA (xw)) -> y_top)
  52. #define XW_X_SLOPE(xw) ((XW_EXTRA (xw)) -> x_slope)
  53. #define XW_Y_SLOPE(xw) ((XW_EXTRA (xw)) -> y_slope)
  54. #define XW_X_CURSOR(xw) ((XW_EXTRA (xw)) -> x_cursor)
  55. #define XW_Y_CURSOR(xw) ((XW_EXTRA (xw)) -> y_cursor)
  56.  
  57. #define ROUND_FLOAT(flonum)                        \
  58.   ((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5)))
  59.  
  60. #define X_COORDINATE(virtual_device_x, xw, direction)            \
  61.   (((XW_X_SLOPE (xw)) == FLT_MAX)                    \
  62.    ? ((direction <= 0) ? 0 : ((int) ((XW_X_SIZE (xw)) - 1)))        \
  63.    : (ROUND_FLOAT                            \
  64.       (((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw)))))))
  65.  
  66. #define Y_COORDINATE(virtual_device_y, xw, direction)            \
  67.   (((XW_Y_SLOPE (xw)) == FLT_MAX)                    \
  68.    ? ((direction <= 0) ? ((int) ((XW_Y_SIZE (xw)) - 1)) : 0)        \
  69.    : (((int) ((XW_Y_SIZE (xw)) - 1))                    \
  70.       + (ROUND_FLOAT                            \
  71.      ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw)))))))
  72.  
  73. #define X_LENGTH(virtual_length, xw)                    \
  74.   (((XW_X_SLOPE (xw)) == 0.0)                        \
  75.    ? 0                                    \
  76.    : ((XW_X_SLOPE (xw)) == FLT_MAX)                    \
  77.    ? ((int) ((XW_X_SIZE (xw)) - 1))                    \
  78.    : (ROUND_FLOAT ((fabs (XW_X_SLOPE (xw))) * (virtual_length))))
  79.  
  80. #define Y_LENGTH(virtual_length, xw)                    \
  81.   (((XW_Y_SLOPE (xw)) == 0.0)                        \
  82.    ? 0                                    \
  83.    : ((XW_Y_SLOPE (xw)) == FLT_MAX)                    \
  84.    ? ((int) ((XW_Y_SIZE (xw)) - 1))                    \
  85.    : (ROUND_FLOAT ((fabs (XW_Y_SLOPE (xw))) * (virtual_length))))
  86.  
  87. static int
  88. DEFUN (arg_x_coordinate, (arg, xw, direction),
  89.        unsigned int arg AND
  90.        struct xwindow * xw AND
  91.        int direction)
  92. {
  93.   return (X_COORDINATE (((float) (arg_real_number (arg))), xw, direction));
  94. }
  95.  
  96. static int
  97. DEFUN (arg_y_coordinate, (arg, xw, direction),
  98.        unsigned int arg AND
  99.        struct xwindow * xw AND
  100.        int direction)
  101. {
  102.   return (Y_COORDINATE (((float) (arg_real_number (arg))), xw, direction));
  103. }
  104.  
  105. static SCHEME_OBJECT
  106. DEFUN (x_coordinate_map, (xw, x), struct xwindow * xw AND unsigned int x)
  107. {
  108.   return
  109.     (FLOAT_TO_FLONUM
  110.      ((((XW_X_SLOPE (xw)) == 0.0) || ((XW_X_SLOPE (xw)) == FLT_MAX))
  111.       ? (XW_X_LEFT (xw))
  112.       : ((((float) x) / (XW_X_SLOPE (xw))) + (XW_X_LEFT (xw)))));
  113. }
  114.  
  115. static SCHEME_OBJECT
  116. DEFUN (y_coordinate_map, (xw, y), struct xwindow * xw AND unsigned int y)
  117. {
  118.   return
  119.     (FLOAT_TO_FLONUM
  120.      ((((XW_Y_SLOPE (xw)) == 0.0) || ((XW_Y_SLOPE (xw)) == FLT_MAX))
  121.       ? (XW_Y_BOTTOM (xw))
  122.       : (((((float) y) - ((XW_Y_SIZE (xw)) - 1)) / (XW_Y_SLOPE (xw)))
  123.      + (XW_Y_BOTTOM (xw)))));
  124. }
  125.  
  126. static void
  127. DEFUN (set_clip_rectangle, (xw, x_left, y_bottom, x_right, y_top),
  128.        struct xwindow * xw AND
  129.        int x_left AND
  130.        int y_bottom AND
  131.        int x_right AND
  132.        int y_top)
  133. {
  134.   XRectangle rectangles [1];
  135.   Display * display = (XW_DISPLAY (xw));
  136.   unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  137.   if (x_left > x_right)
  138.     {
  139.       unsigned int x = x_left;
  140.       x_left = x_right;
  141.       x_right = x;
  142.     }
  143.   if (y_top > y_bottom)
  144.     {
  145.       unsigned int y = y_top;
  146.       y_top = y_bottom;
  147.       y_bottom = y;
  148.     }
  149.   {
  150.     unsigned int width = ((x_right + 1) - x_left);
  151.     unsigned int height = ((y_bottom + 1) - y_top);
  152.     (XW_CLIP_X (xw)) = x_left;
  153.     (XW_CLIP_Y (xw)) = y_top;
  154.     (XW_CLIP_WIDTH (xw)) = width;
  155.     (XW_CLIP_HEIGHT (xw)) = height;
  156.     ((rectangles[0]) . x) = x_left;
  157.     ((rectangles[0]) . y) = y_top;
  158.     ((rectangles[0]) . width) = width;
  159.     ((rectangles[0]) . height) = height;
  160.   }
  161.   XSetClipRectangles
  162.     (display,
  163.      (XW_NORMAL_GC (xw)),
  164.      internal_border_width,
  165.      internal_border_width,
  166.      rectangles, 1, Unsorted);
  167.   XSetClipRectangles
  168.     (display,
  169.      (XW_REVERSE_GC (xw)),
  170.      internal_border_width,
  171.      internal_border_width,
  172.      rectangles, 1, Unsorted);
  173. }
  174.  
  175. static void
  176. DEFUN (reset_clip_rectangle, (xw), struct xwindow * xw)
  177. {
  178.   set_clip_rectangle
  179.     (xw, 0, ((XW_Y_SIZE (xw)) - 1), ((XW_X_SIZE (xw)) - 1), 0);
  180. }
  181.  
  182. static void
  183. DEFUN (reset_virtual_device_coordinates, (xw), struct xwindow * xw)
  184. {
  185.   /* Note that the expression ((XW_c_SIZE (xw)) - 1) guarantees that
  186.      both limits of the device coordinates will be inside the window. */
  187.   (XW_X_SLOPE (xw))
  188.     = (((XW_X_RIGHT (xw)) == (XW_X_LEFT (xw)))
  189.        ? FLT_MAX
  190.        : ((XW_X_SIZE (xw)) <= 1)
  191.        ? 0.0
  192.        : (((float) ((XW_X_SIZE (xw)) - 1))
  193.       / ((XW_X_RIGHT (xw)) - (XW_X_LEFT (xw)))));
  194.   (XW_Y_SLOPE (xw))
  195.     = (((XW_Y_BOTTOM (xw)) == (XW_Y_TOP (xw)))
  196.        ? FLT_MAX
  197.        : ((XW_Y_SIZE (xw)) <= 1)
  198.        ? 0.0
  199.        : (((float) ((XW_Y_SIZE (xw)) - 1))
  200.       / ((XW_Y_BOTTOM (xw)) - (XW_Y_TOP (xw)))));
  201.   reset_clip_rectangle (xw);
  202. }
  203.  
  204. DEFINE_PRIMITIVE ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5,
  205.   "(X-GRAPHICS-SET-VDC-EXTENT WINDOW X-MIN Y-MIN X-MAX Y-MAX)\n\
  206. Set the virtual device coordinates to the given values.")
  207. {
  208.   PRIMITIVE_HEADER (5);
  209.   {
  210.     struct xwindow * xw = (x_window_arg (1));
  211.     float x_left = (arg_real_number (2));
  212.     float y_bottom = (arg_real_number (3));
  213.     float x_right = (arg_real_number (4));
  214.     float y_top = (arg_real_number (5));
  215.     (XW_X_LEFT (xw)) = x_left;
  216.     (XW_Y_BOTTOM (xw)) = y_bottom;
  217.     (XW_X_RIGHT (xw)) = x_right;
  218.     (XW_Y_TOP (xw)) = y_top;
  219.     reset_virtual_device_coordinates (xw);
  220.   }
  221.   PRIMITIVE_RETURN (UNSPECIFIC);
  222. }
  223.  
  224. DEFINE_PRIMITIVE ("X-GRAPHICS-VDC-EXTENT", Prim_x_graphics_vdc_extent, 1, 1, 0)
  225. {
  226.   PRIMITIVE_HEADER (5);
  227.   {
  228.     struct xwindow * xw = (x_window_arg (1));
  229.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
  230.     VECTOR_SET (result, 0, (double_to_flonum ((double) (XW_X_LEFT (xw)))));
  231.     VECTOR_SET (result, 1, (double_to_flonum ((double) (XW_Y_BOTTOM (xw)))));
  232.     VECTOR_SET (result, 2, (double_to_flonum ((double) (XW_X_RIGHT (xw)))));
  233.     VECTOR_SET (result, 3, (double_to_flonum ((double) (XW_Y_TOP (xw)))));
  234.     PRIMITIVE_RETURN (result);
  235.   }
  236. }
  237.  
  238. DEFINE_PRIMITIVE ("X-GRAPHICS-RESET-CLIP-RECTANGLE", Prim_x_graphics_reset_clip_rectangle, 1, 1, 0)
  239. {
  240.   PRIMITIVE_HEADER (1);
  241.   reset_clip_rectangle (x_window_arg (1));
  242.   PRIMITIVE_RETURN (UNSPECIFIC);
  243. }
  244.  
  245. DEFINE_PRIMITIVE ("X-GRAPHICS-SET-CLIP-RECTANGLE", Prim_x_graphics_set_clip_rectangle, 5, 5,
  246.   "(X-GRAPHICS-SET-CLIP-RECTANGLE WINDOW X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\
  247. Set the clip rectangle to the given coordinates.")
  248. {
  249.   PRIMITIVE_HEADER (5);
  250.   {
  251.     struct xwindow * xw = (x_window_arg (1));
  252.     set_clip_rectangle
  253.       (xw,
  254.        (arg_x_coordinate (2, xw, -1)),
  255.        (arg_y_coordinate (3, xw, -1)),
  256.        (arg_x_coordinate (4, xw, 1)),
  257.        (arg_y_coordinate (5, xw, 1)));
  258.   }
  259.   PRIMITIVE_RETURN (UNSPECIFIC);
  260. }
  261.  
  262. static void
  263. DEFUN (process_event, (xw, event),
  264.        struct xwindow * xw AND
  265.        XEvent * event)
  266. {
  267. }
  268.  
  269. static void
  270. DEFUN (reconfigure, (xw, width, height),
  271.        struct xwindow * xw AND
  272.        unsigned int width AND
  273.        unsigned int height)
  274. {
  275.   unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
  276.   unsigned int x_size = ((width < extra) ? 0 : (width - extra));
  277.   unsigned int y_size = ((height < extra) ? 0 : (height - extra));
  278.   if ((x_size != (XW_X_SIZE (xw))) || (y_size != (XW_Y_SIZE (xw))))
  279.     {
  280.       (XW_X_SIZE (xw)) = x_size;
  281.       (XW_Y_SIZE (xw)) = y_size;
  282.       reset_virtual_device_coordinates (xw);
  283.       XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  284.     }
  285. }
  286.  
  287. DEFINE_PRIMITIVE ("X-GRAPHICS-RECONFIGURE", Prim_x_graphics_reconfigure, 3, 3, 0)
  288. {
  289.   PRIMITIVE_HEADER (3);
  290.   reconfigure ((x_window_arg (1)),
  291.            (arg_ulong_integer (2)),
  292.            (arg_ulong_integer (3)));
  293.   PRIMITIVE_RETURN (UNSPECIFIC);
  294. }
  295.  
  296. static void
  297. DEFUN (wm_set_size_hint, (xw, geometry_mask, x, y),
  298.        struct xwindow * xw AND
  299.        int geometry_mask AND
  300.        int x AND
  301.        int y)
  302. {
  303.   unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
  304.   XSizeHints * size_hints = (XAllocSizeHints ());
  305.   if (size_hints == 0)
  306.     error_external_return ();
  307.   (size_hints -> flags) =
  308.     (PResizeInc | PMinSize | PBaseSize
  309.      | (((geometry_mask & XValue) && (geometry_mask & YValue))
  310.     ? USPosition : PPosition)
  311.      | (((geometry_mask & WidthValue) && (geometry_mask & HeightValue))
  312.     ? USSize : PSize));
  313.   (size_hints -> x) = x;
  314.   (size_hints -> y) = y;
  315.   (size_hints -> width) = ((XW_X_SIZE (xw)) + extra);
  316.   (size_hints -> height) = ((XW_Y_SIZE (xw)) + extra);
  317.   (size_hints -> width_inc) = 1;
  318.   (size_hints -> height_inc) = 1;
  319.   (size_hints -> min_width) = extra;
  320.   (size_hints -> min_height) = extra;
  321.   (size_hints -> base_width) = extra;
  322.   (size_hints -> base_height) = extra;
  323.   XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints);
  324.   XFree ((caddr_t) size_hints);
  325. }
  326.  
  327. DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 3, 3,
  328.   "(X-GRAPHICS-OPEN-WINDOW DISPLAY GEOMETRY SUPPRESS-MAP?)\n\
  329. Open a window on DISPLAY using GEOMETRY.\n\
  330. If GEOMETRY is false map window interactively.\n\
  331. If third argument SUPPRESS-MAP? is true, do not map the window immediately.")
  332. {
  333.   PRIMITIVE_HEADER (3);
  334.   {
  335.     struct xdisplay * xd = (x_display_arg (1));
  336.     Display * display = (XD_DISPLAY (xd));
  337.     struct drawing_attributes attributes;
  338.     struct xwindow_methods methods;
  339.     XSetWindowAttributes wattributes;
  340.     CONST char * resource_name = RESOURCE_NAME;
  341.     CONST char * resource_class = RESOURCE_CLASS;
  342.     int map_p;
  343.  
  344.     x_decode_window_map_arg
  345.       ((ARG_REF (3)), (&resource_name), (&resource_class), (&map_p));
  346.     x_default_attributes
  347.       (display, resource_name, resource_class, (&attributes));
  348.     (wattributes . background_pixel) = (attributes . background_pixel);
  349.     (wattributes . border_pixel) = (attributes . border_pixel);
  350.     (wattributes . backing_store) = Always;
  351.     (methods . deallocator) = 0;
  352.     (methods . event_processor) = process_event;
  353.     (methods . x_coordinate_map) = x_coordinate_map;
  354.     (methods . y_coordinate_map) = y_coordinate_map;
  355.     (methods . update_normal_hints) = 0;
  356.     {
  357.       unsigned int extra = (2 * (attributes . internal_border_width));
  358.       int x_pos = (-1);
  359.       int y_pos = (-1);
  360.       int x_size = 512;
  361.       int y_size = 384;
  362.       int geometry_mask =
  363.     (XGeometry (display, (DefaultScreen (display)),
  364.             (((ARG_REF (2)) == SHARP_F)
  365.              ? (x_get_default
  366.             (display, resource_name, resource_class,
  367.              "geometry", "Geometry", 0))
  368.              : (STRING_ARG (2))),
  369.             DEFAULT_GEOMETRY, (attributes . border_width),
  370.             1, 1, extra, extra,
  371.             (&x_pos), (&y_pos), (&x_size), (&y_size)));
  372.       Window window =
  373.     (XCreateWindow
  374.      (display,
  375.       (RootWindow (display, (DefaultScreen (display)))),
  376.       x_pos, y_pos, (x_size + extra), (y_size + extra),
  377.       (attributes . border_width),
  378.       CopyFromParent, CopyFromParent, CopyFromParent,
  379.       (CWBackPixel | CWBorderPixel | CWBackingStore),
  380.       (&wattributes)));
  381.       if (window == 0)
  382.     error_external_return ();
  383.       {
  384.     struct xwindow * xw =
  385.       (x_make_window
  386.        (xd, window, x_size, y_size, (&attributes), (&methods),
  387.         (sizeof (struct gw_extra))));
  388.     (XW_X_LEFT (xw)) = ((float) (-1));
  389.     (XW_X_RIGHT (xw)) = ((float) 1);
  390.     (XW_Y_BOTTOM (xw)) = ((float) (-1));
  391.     (XW_Y_TOP (xw)) = ((float) 1);
  392.     reset_virtual_device_coordinates (xw);
  393.     (XW_X_CURSOR (xw)) = 0;
  394.     (XW_Y_CURSOR (xw)) = 0;
  395.     wm_set_size_hint (xw, geometry_mask, x_pos, y_pos);
  396.     xw_set_wm_input_hint (xw, 0);
  397.     xw_set_wm_name (xw, "scheme-graphics");
  398.     xw_set_wm_icon_name (xw, "scheme-graphics");
  399.     XSelectInput (display, window, StructureNotifyMask);
  400.     xw_make_window_map (xw, resource_name, resource_class, map_p);
  401.     PRIMITIVE_RETURN (XW_TO_OBJECT (xw));
  402.       }
  403.     }
  404.   }
  405. }
  406.  
  407. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINE", Prim_x_graphics_draw_line, 5, 5,
  408.   "(X-GRAPHICS-DRAW-LINE WINDOW X-START Y-START X-END Y-END)\n\
  409. Draw a line from the start coordinates to the end coordinates.\n\
  410. Subsequently move the graphics cursor to the end coordinates.")
  411. {
  412.   PRIMITIVE_HEADER (5);
  413.   {
  414.     struct xwindow * xw = (x_window_arg (1));
  415.     unsigned int new_x_cursor = (arg_x_coordinate (4, xw, 0));
  416.     unsigned int new_y_cursor = (arg_y_coordinate (5, xw, 0));
  417.     unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  418.     XDrawLine
  419.       ((XW_DISPLAY (xw)),
  420.        (XW_WINDOW (xw)),
  421.        (XW_NORMAL_GC (xw)),
  422.        (internal_border_width + (arg_x_coordinate (2, xw, 0))),
  423.        (internal_border_width + (arg_y_coordinate (3, xw, 0))),
  424.        (internal_border_width + new_x_cursor),
  425.        (internal_border_width + new_y_cursor));
  426.     (XW_X_CURSOR (xw)) = new_x_cursor;
  427.     (XW_Y_CURSOR (xw)) = new_y_cursor;
  428.   }
  429.   PRIMITIVE_RETURN (UNSPECIFIC);
  430. }
  431.  
  432. DEFINE_PRIMITIVE ("X-GRAPHICS-MOVE-CURSOR", Prim_x_graphics_move_cursor, 3, 3,
  433.   "(X-GRAPHICS-MOVE-CURSOR WINDOW X Y)\n\
  434. Move the graphics cursor to the given coordinates.")
  435. {
  436.   PRIMITIVE_HEADER (3);
  437.   {
  438.     struct xwindow * xw = (x_window_arg (1));
  439.     (XW_X_CURSOR (xw)) = (arg_x_coordinate (2, xw, 0));
  440.     (XW_Y_CURSOR (xw)) = (arg_y_coordinate (3, xw, 0));
  441.   }
  442.   PRIMITIVE_RETURN (UNSPECIFIC);
  443. }
  444.  
  445. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAG-CURSOR", Prim_x_graphics_drag_cursor, 3, 3,
  446.   "(X-GRAPHICS-DRAG-CURSOR WINDOW X Y)\n\
  447. Draw a line from the graphics cursor to the given coordinates.\n\
  448. Subsequently move the graphics cursor to those coordinates.")
  449. {
  450.   PRIMITIVE_HEADER (3);
  451.   {
  452.     struct xwindow * xw = (x_window_arg (1));
  453.     unsigned int new_x_cursor = (arg_x_coordinate (2, xw, 0));
  454.     unsigned int new_y_cursor = (arg_y_coordinate (3, xw, 0));
  455.     unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  456.     XDrawLine
  457.       ((XW_DISPLAY (xw)),
  458.        (XW_WINDOW (xw)),
  459.        (XW_NORMAL_GC (xw)),
  460.        (internal_border_width + (XW_X_CURSOR (xw))),
  461.        (internal_border_width + (XW_Y_CURSOR (xw))),
  462.        (internal_border_width + new_x_cursor),
  463.        (internal_border_width + new_y_cursor));
  464.     (XW_X_CURSOR (xw)) = new_x_cursor;
  465.     (XW_Y_CURSOR (xw)) = new_y_cursor;
  466.   }
  467.   PRIMITIVE_RETURN (UNSPECIFIC);
  468. }
  469.  
  470. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINT", Prim_x_graphics_draw_point, 3, 3,
  471.   "(X-GRAPHICS-DRAW-POINT WINDOW X Y)\n\
  472. Draw one point at the given coordinates.\n\
  473. Subsequently move the graphics cursor to those coordinates.")
  474. {
  475.   PRIMITIVE_HEADER (3);
  476.   {
  477.     struct xwindow * xw = (x_window_arg (1));
  478.     unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  479.     XDrawPoint
  480.       ((XW_DISPLAY (xw)),
  481.        (XW_WINDOW (xw)),
  482.        (XW_NORMAL_GC (xw)),
  483.        (internal_border_width + (arg_x_coordinate (2, xw, 0))),
  484.        (internal_border_width + (arg_y_coordinate (3, xw, 0))));
  485.   }
  486.   PRIMITIVE_RETURN (UNSPECIFIC);
  487. }
  488.  
  489. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-ARC", Prim_x_graphics_draw_arc, 8, 8,
  490.   "(X-GRAPHICS-DRAW-ARC WINDOW X Y RADIUS-X RADIUS-Y START-ANGLE SWEEP-ANGLE FILL?)\n\
  491. Draw an arc at the given coordinates, with given X and Y radii.\n\
  492. START-ANGLE and SWEEP-ANGLE are in degrees, anti-clocwise.\n\
  493. START-ANGLE is from 3 o'clock, and SWEEP-ANGLE is relative to the START-ANGLE\n\
  494. If FILL? is true, the arc is filled.")
  495. {
  496.   PRIMITIVE_HEADER (3);
  497.   {
  498.     struct xwindow * xw = (x_window_arg (1));
  499.     unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  500.     float  virtual_device_x = arg_real_number (2);
  501.     float  virtual_device_y = arg_real_number (3);
  502.     float  radius_x = arg_real_number (4);
  503.     float  radius_y = arg_real_number (5);
  504.     float  angle_start = arg_real_number (6);
  505.     float  angle_sweep = arg_real_number (7);
  506.  
  507.     /* we assume a virtual coordinate system with X increasing left to
  508.      * right and Y increasing top to bottom.  If we are wrong then we
  509.      * have to flip the axes and adjust the angles */
  510.  
  511.     int x1 = (X_COORDINATE (virtual_device_x - radius_x,  xw, 0));
  512.     int x2 = (X_COORDINATE (virtual_device_x + radius_x,  xw, 0));
  513.     int y1 = (Y_COORDINATE (virtual_device_y + radius_y,  xw, 0));
  514.     int y2 = (Y_COORDINATE (virtual_device_y - radius_y,  xw, 0));
  515.     int width, height;
  516.     int angle1 = ((int)(angle_start * 64)) % (64*360);
  517.     int angle2 = ((int)(angle_sweep * 64));
  518.     if (angle1 < 0)
  519.       angle1 = (64*360) + angle1;
  520.     /* angle1 is now 0..359 */
  521.     if (x2<x1) { /* x-axis flip */
  522.       int t=x1; x1=x2; x2=t;
  523.       if (angle1 < 64*180)
  524.     angle1 = 64*180 - angle1;
  525.       else
  526.     angle1 = 64*540 - angle1;
  527.       angle2 = -angle2;
  528.     }
  529.     if (y2<y1) { /* y-axis flip */
  530.       int t=y1; y1=y2; y2=t;
  531.       angle1 = 64*360 - angle1;
  532.       angle2 = -angle2;
  533.     }
  534.     width  = x2 - x1;
  535.     height = y2 - y1;
  536.     if (ARG_REF(8) == SHARP_F)
  537.       XDrawArc
  538.     ((XW_DISPLAY (xw)),
  539.      (XW_WINDOW (xw)),
  540.      (XW_NORMAL_GC (xw)),
  541.      (internal_border_width + x1),
  542.      (internal_border_width + y1),
  543.      width, height,  angle1, angle2);
  544.     else
  545.       XFillArc
  546.     ((XW_DISPLAY (xw)),
  547.      (XW_WINDOW (xw)),
  548.      (XW_NORMAL_GC (xw)),
  549.      (internal_border_width + x1),
  550.      (internal_border_width + y1),
  551.      width, height,  angle1, angle2);
  552.   }
  553.   PRIMITIVE_RETURN (UNSPECIFIC);
  554. }
  555.  
  556. /**************   TEST PROGRAM FOR X-GRAPHICS-DRAW-ARC  *****************
  557. (define g (make-graphics-device))
  558.  
  559. (define (test dx dy a1 a2)
  560.   (let ((x .3)
  561.     (y .4)
  562.     (r .2))
  563.     (define (fx a) (+ x (* r (cos (* a (asin 1) 1/90)))))
  564.     (define (fy a) (+ y (* r (sin (* a (asin 1) 1/90)))))
  565.     (graphics-set-coordinate-limits g (- dx) (- dy) dx dy)
  566.     (graphics-operation g 'set-foreground-color "black")
  567.     (graphics-clear g)
  568.  
  569.     (graphics-draw-text g   0   0 ".")
  570.  
  571.     (graphics-draw-line g  -1   0 1 0)
  572.     (graphics-draw-line g   0  -1 0 1)
  573.     (graphics-draw-line g   0   0 1 1)
  574.     (graphics-draw-text g  .5   0 "+X")
  575.     (graphics-draw-text g -.5   0 "-X")
  576.     (graphics-draw-text g   0  .5 "+Y")
  577.     (graphics-draw-text g   0 -.5 "-Y")
  578.  
  579.     ;; The grey wedge is that that 10 degrees of the arc.
  580.     (graphics-operation g 'set-foreground-color "grey")
  581.     (graphics-operation g 'draw-arc x y r r a1 a2 #T)
  582.     (graphics-operation g 'set-foreground-color "black")
  583.     (graphics-operation g 'draw-arc x y r r a1 (+ a2 (if (< a2 0) 10 -10)) #T)
  584.   
  585.     (graphics-operation g 'set-foreground-color "red")
  586.     (graphics-draw-text g x y ".O")
  587.   
  588.     (let ((b1 (min a1 (+ a1 a2)))
  589.       (b2 (max a1 (+ a1 a2))))
  590.       (do ((a b1 (+ a 5)))
  591.       ((> a b2))
  592.     (graphics-draw-text g (fx a) (fy a) ".")))
  593.  
  594.     (graphics-draw-text g (fx a1) (fy a1) ".Start")
  595.     (graphics-draw-text g (fx (+ a1 a2)) (fy (+ a1 a2)) ".End")))
  596.  
  597. ;; Test axes
  598. (test  1  1  30 90)
  599. (test -1  1  30 90)
  600. (test  1 -1  30 90)
  601. (test -1 -1  30 90)
  602.  
  603. ;; Test angles
  604. (test  1  1  30 90)
  605. (test  1  1  30 -90)
  606. (test  1  1  -30 90)
  607. (test  1  1  -30 -90)
  608.  ***********************************************************************/
  609.  
  610. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-STRING", Prim_x_graphics_draw_string, 4, 4,
  611.   "(X-GRAPHICS-DRAW-STRING WINDOW X Y STRING)\n\
  612. Draw characters in the current font at the given coordinates, with\n\
  613. transparent background.")
  614. {
  615.   PRIMITIVE_HEADER (4);
  616.   {
  617.     struct xwindow * xw = (x_window_arg (1));
  618.     unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  619.     char * s = (STRING_ARG (4));
  620.     XDrawString
  621.       ((XW_DISPLAY (xw)),
  622.        (XW_WINDOW (xw)),
  623.        (XW_NORMAL_GC (xw)),
  624.        (internal_border_width + (arg_x_coordinate (2, xw, 0))),
  625.        (internal_border_width + (arg_y_coordinate (3, xw, 0))),
  626.        s,
  627.        (STRING_LENGTH (ARG_REF (4))));
  628.   }
  629.   PRIMITIVE_RETURN (UNSPECIFIC);
  630. }
  631.  
  632. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-IMAGE-STRING",
  633.           Prim_x_graphics_draw_image_string, 4, 4,
  634.   "(X-GRAPHICS-DRAW-IMAGE-STRING WINDOW X Y STRING)\n\
  635. Draw characters in the current font at the given coordinates, with\n\
  636. solid background.")
  637. {
  638.   PRIMITIVE_HEADER (4);
  639.   {
  640.     struct xwindow * xw = (x_window_arg (1));
  641.     unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
  642.     char * s = (STRING_ARG (4));
  643.     XDrawImageString
  644.       ((XW_DISPLAY (xw)),
  645.        (XW_WINDOW (xw)),
  646.        (XW_NORMAL_GC (xw)),
  647.        (internal_border_width + (arg_x_coordinate (2, xw, 0))),
  648.        (internal_border_width + (arg_y_coordinate (3, xw, 0))),
  649.        s,
  650.        (STRING_LENGTH (ARG_REF (4))));
  651.   }
  652.   PRIMITIVE_RETURN (UNSPECIFIC);
  653. }
  654.  
  655. DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0)
  656. {
  657.   PRIMITIVE_HEADER (2);
  658.   {
  659.     struct xwindow * xw = (x_window_arg (1));
  660.     Display * display = (XW_DISPLAY (xw));
  661.     unsigned int function = (arg_ulong_index_integer (2, 16));
  662.     XSetFunction (display, (XW_NORMAL_GC (xw)), function);
  663.     XSetFunction (display, (XW_REVERSE_GC (xw)), function);
  664.   }
  665.   PRIMITIVE_RETURN (UNSPECIFIC);
  666. }
  667.  
  668. static XPoint *
  669. DEFUN (floating_vector_point_args, (xw, x_index, y_index, return_n_points),
  670.        struct xwindow * xw AND
  671.        unsigned int x_index AND
  672.        unsigned int y_index AND
  673.        unsigned int * return_n_points)
  674. {
  675.   SCHEME_OBJECT x_vector = (ARG_REF (x_index));
  676.   SCHEME_OBJECT y_vector = (ARG_REF (y_index));
  677.   unsigned int n_points;
  678.  
  679.   if (!FLONUM_P (x_vector))
  680.     error_wrong_type_arg (x_index);
  681.   if (!FLONUM_P (y_vector))
  682.     error_wrong_type_arg (y_index);
  683.   n_points = (FLOATING_VECTOR_LENGTH (x_vector));
  684.   if (n_points != (FLOATING_VECTOR_LENGTH (y_vector)))
  685.     error_bad_range_arg (x_index);
  686.   {
  687.     XPoint * points = (dstack_alloc (n_points * (sizeof (XPoint))));
  688.     double * scan_x = (FLOATING_VECTOR_LOC (x_vector, 0));
  689.     double * end_x = (FLOATING_VECTOR_LOC (x_vector, n_points));
  690.     double * scan_y = (FLOATING_VECTOR_LOC (y_vector, 0));
  691.     XPoint * scan_points = points;
  692.     unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw));
  693.     while (scan_x < end_x)
  694.       {
  695.     (scan_points -> x) = (border + (X_COORDINATE ((*scan_x++), xw, 0)));
  696.     (scan_points -> y) = (border + (X_COORDINATE ((*scan_y++), xw, 0)));
  697.     scan_points += 1;
  698.       }
  699.     (*return_n_points) = n_points;
  700.     return (points);
  701.   }
  702. }
  703.  
  704. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINTS", Prim_x_graphics_draw_points, 3, 3,
  705.   "(X-GRAPHICS-DRAW-POINTS WINDOW X-VECTOR Y-VECTOR)\n\
  706. Draw multiple points.")
  707. {
  708.   PRIMITIVE_HEADER (3);
  709.   {
  710.     PTR position = dstack_position;
  711.     struct xwindow * xw = (x_window_arg (1));
  712.     unsigned int n_points;
  713.     XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points)));
  714.     while (n_points > 0)
  715.       {
  716.     unsigned int this_send = ((n_points <= 4093) ? n_points : 4093);
  717.     n_points -= this_send;
  718.     XDrawPoints ((XW_DISPLAY (xw)),
  719.              (XW_WINDOW (xw)),
  720.              (XW_NORMAL_GC (xw)),
  721.              points,
  722.              this_send,
  723.              CoordModeOrigin);
  724.     points += this_send;
  725.       }
  726.     dstack_set_position (position);
  727.   }
  728.   PRIMITIVE_RETURN (UNSPECIFIC);
  729. }
  730.  
  731. DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINES", Prim_x_graphics_draw_lines, 3, 3,
  732.   "(X-GRAPHICS-DRAW-LINES WINDOW X-VECTOR Y-VECTOR)\n\
  733. Draw multiple lines.")
  734. {
  735.   PRIMITIVE_HEADER (3);
  736.   {
  737.     PTR position = dstack_position;
  738.     struct xwindow * xw = (x_window_arg (1));
  739.     unsigned int n_points;
  740.     XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points)));
  741.     while (n_points > 0)
  742.       {
  743.     unsigned int this_send = ((n_points <= 2047) ? n_points : 2047);
  744.     n_points -= this_send;
  745.     XDrawLines ((XW_DISPLAY (xw)),
  746.             (XW_WINDOW (xw)),
  747.             (XW_NORMAL_GC (xw)),
  748.             points,
  749.             this_send,
  750.             CoordModeOrigin);
  751.     points += (this_send - 1);
  752.       }
  753.     dstack_set_position (position);
  754.   }
  755.   PRIMITIVE_RETURN (UNSPECIFIC);
  756. }
  757.  
  758. DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0)
  759. {
  760.   PRIMITIVE_HEADER (2);
  761.   {
  762.     struct xwindow * xw = (x_window_arg (1));
  763.     Display * display = (XW_DISPLAY (xw));
  764.     unsigned int fill_style = (arg_ulong_index_integer (2, 4));
  765.     XSetFillStyle (display, (XW_NORMAL_GC (xw)), fill_style);
  766.     XSetFillStyle (display, (XW_REVERSE_GC (xw)), fill_style);
  767.   }
  768.   PRIMITIVE_RETURN (UNSPECIFIC);
  769. }
  770.  
  771. DEFINE_PRIMITIVE ("X-GRAPHICS-SET-LINE-STYLE", Prim_x_graphics_set_line_style, 2, 2, 0)
  772. {
  773.   PRIMITIVE_HEADER (2);
  774.   {
  775.     struct xwindow * xw = (x_window_arg (1));
  776.     Display * display = (XW_DISPLAY (xw));
  777.     unsigned int style = (arg_ulong_index_integer (2, 3));
  778.     XSetLineAttributes
  779.       (display, (XW_NORMAL_GC (xw)), 0, style, CapButt, JoinMiter);
  780.     XSetLineAttributes
  781.       (display, (XW_REVERSE_GC (xw)), 0, style, CapButt, JoinMiter);
  782.   }
  783.   PRIMITIVE_RETURN (UNSPECIFIC);
  784. }
  785.  
  786. DEFINE_PRIMITIVE ("X-GRAPHICS-SET-DASHES", Prim_x_graphics_set_dashes, 3, 3, 0)
  787. {
  788.   PRIMITIVE_HEADER (3);
  789.   {
  790.     struct xwindow * xw = (x_window_arg (1));
  791.     Display * display = (XW_DISPLAY (xw));
  792.     char * dash_list = (STRING_ARG (3));
  793.     unsigned int dash_list_length = (STRING_LENGTH (ARG_REF (3)));
  794.     unsigned int dash_offset = (arg_ulong_index_integer (2, dash_list_length));
  795.     XSetDashes
  796.       (display, (XW_NORMAL_GC (xw)), dash_offset, dash_list, dash_list_length);
  797.     XSetDashes
  798.       (display, (XW_REVERSE_GC (xw)), dash_offset, dash_list,
  799.        dash_list_length);
  800.   }
  801.   PRIMITIVE_RETURN (UNSPECIFIC);
  802. }
  803.  
  804. DEFINE_PRIMITIVE ("X-GRAPHICS-COPY-AREA", Prim_x_graphics_copy_area, 8, 8, 0)
  805. {
  806.   PRIMITIVE_HEADER (7);
  807.   {
  808.     struct xwindow * source_xw = x_window_arg (1);
  809.     struct xwindow * destination_xw = x_window_arg (2);
  810.     unsigned int source_internal_border_width
  811.       = (XW_INTERNAL_BORDER_WIDTH (source_xw));
  812.     unsigned int destination_internal_border_width
  813.       = (XW_INTERNAL_BORDER_WIDTH (destination_xw));
  814.     Display *source_display = XW_DISPLAY (source_xw);
  815.     Display *destination_display = XW_DISPLAY (destination_xw);
  816.     if (source_display != destination_display)
  817.       error_bad_range_arg (2);
  818.     XCopyArea (source_display,
  819.            (XW_WINDOW (source_xw)),
  820.            (XW_WINDOW (destination_xw)),
  821.            (XW_NORMAL_GC (source_xw)),
  822.            (source_internal_border_width
  823.         + (arg_x_coordinate (3, source_xw, -1))),
  824.            (source_internal_border_width
  825.         + (arg_y_coordinate (4, source_xw, 1))),
  826.            (X_LENGTH ((arg_real_number (5)), source_xw)),
  827.            (Y_LENGTH ((arg_real_number (6)), source_xw)),
  828.            (destination_internal_border_width
  829.         + (arg_x_coordinate (7, destination_xw, -1))),
  830.            (destination_internal_border_width
  831.         + (arg_y_coordinate (8, destination_xw, 1))));
  832.     PRIMITIVE_RETURN (UNSPECIFIC);
  833.   }
  834. }
  835.  
  836. static XPoint *
  837. DEFUN (x_polygon_vector_arg, (xw, argno),
  838.        struct xwindow * xw AND
  839.        unsigned int argno)
  840. {
  841.   SCHEME_OBJECT vector = (VECTOR_ARG (argno));
  842.   unsigned long length = (VECTOR_LENGTH (vector));
  843.   unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw));
  844.   if ((length % 2) != 0)
  845.     error_bad_range_arg (argno);
  846.   {
  847.     XPoint * result = (x_malloc ((length / 2) * (sizeof (XPoint))));
  848.     XPoint * scan_result = result;
  849.     SCHEME_OBJECT * scan = (& (VECTOR_REF (vector, 0)));
  850.     SCHEME_OBJECT * end = (scan + length);
  851.     SCHEME_OBJECT coord;
  852.     while (scan < end)
  853.       {
  854.     coord = (*scan++);
  855.     if (! ((REAL_P (coord)) && (real_number_to_double_p (coord))))
  856.       error_bad_range_arg (argno);
  857.     (scan_result -> x)
  858.       = (border
  859.          + (X_COORDINATE ((real_number_to_double (coord)), xw, 0)));
  860.     coord = (*scan++);
  861.     if (! ((REAL_P (coord)) && (real_number_to_double_p (coord))))
  862.       error_bad_range_arg (argno);
  863.     (scan_result -> y)
  864.       = (border
  865.          + (Y_COORDINATE ((real_number_to_double (coord)), xw, 0)));
  866.     scan_result += 1;
  867.       }
  868.     return (result);
  869.   }
  870. }
  871.  
  872. DEFINE_PRIMITIVE ("X-GRAPHICS-FILL-POLYGON", Prim_x_graphics_fill_polygon, 2, 2, 0)
  873. {
  874.   PRIMITIVE_HEADER (2);
  875.   {
  876.     struct xwindow * xw = x_window_arg (1);
  877.     XPoint * points = (x_polygon_vector_arg (xw, 2));
  878.     unsigned long length = VECTOR_LENGTH (VECTOR_ARG (2));
  879.     XFillPolygon ((XW_DISPLAY (xw)),
  880.           (XW_WINDOW (xw)),
  881.           (XW_NORMAL_GC (xw)),
  882.           points,
  883.           (length / 2),
  884.           Nonconvex,
  885.           CoordModeOrigin);
  886.     free (points);
  887.     PRIMITIVE_RETURN (UNSPECIFIC);
  888.   }
  889. }
  890.  
  891. static int
  892. find_pixmap_format (Display * dpy, int depth, XPixmapFormatValues * format)
  893. {
  894.   XPixmapFormatValues * pixmap_formats;
  895.   int n_pixmap_formats;
  896.   XPixmapFormatValues * scan_pixmap_formats;
  897.   XPixmapFormatValues * end_pixmap_formats;
  898.  
  899.   pixmap_formats = (XListPixmapFormats (dpy, (&n_pixmap_formats)));
  900.   if (pixmap_formats == 0)
  901.     return (0);
  902.   scan_pixmap_formats = pixmap_formats;
  903.   end_pixmap_formats = (pixmap_formats + n_pixmap_formats);
  904.   while (1)
  905.     {
  906.       if (scan_pixmap_formats >= end_pixmap_formats)
  907.     return (0);
  908.       if ((scan_pixmap_formats -> depth) == depth)
  909.     {
  910.       (*format) = (*scan_pixmap_formats);
  911.       XFree (pixmap_formats);
  912.       return (1);
  913.     }
  914.       scan_pixmap_formats += 1;
  915.     }
  916. }
  917.  
  918. DEFINE_PRIMITIVE ("X-CREATE-IMAGE", Prim_x_create_image, 3, 3,
  919.   "(window width height)\n\
  920. Creates and returns an XImage object, of dimensions WIDTH by HEIGHT.\n\
  921. WINDOW is used to set the Display, Visual, and Depth characteristics.\n\
  922. The image is created by calling XCreateImage.")
  923. {
  924.   PRIMITIVE_HEADER (3);
  925.   {
  926.     struct xwindow * xw = (x_window_arg (1));
  927.     Window window = (XW_WINDOW (xw));
  928.     Display * dpy = (XW_DISPLAY (xw));
  929.     unsigned int width = (arg_ulong_integer (2));
  930.     unsigned int height = (arg_ulong_integer (3));
  931.     XWindowAttributes attrs;
  932.     XPixmapFormatValues pixmap_format;
  933.     unsigned int bits_per_line;
  934.     unsigned int bitmap_pad;
  935.     unsigned int bytes_per_line;
  936.  
  937.     XGetWindowAttributes (dpy, window, (&attrs));
  938.     if (!find_pixmap_format (dpy, (attrs . depth), (&pixmap_format)))
  939.       error_external_return ();
  940.     bits_per_line = ((pixmap_format . bits_per_pixel) * width);
  941.     bitmap_pad = (pixmap_format . scanline_pad);
  942.     if ((bits_per_line % bitmap_pad) != 0)
  943.       bits_per_line += (bitmap_pad - (bits_per_line % bitmap_pad));
  944.     bytes_per_line = ((bits_per_line + (CHAR_BIT - 1)) / CHAR_BIT);
  945.     PRIMITIVE_RETURN
  946.       (X_IMAGE_TO_OBJECT
  947.        (XCreateImage
  948.     (dpy,
  949.      (DefaultVisualOfScreen (attrs . screen)),
  950.      (attrs . depth),
  951.      ZPixmap,
  952.      0,
  953.      ((char *) (x_malloc (height * bytes_per_line))),
  954.      width,
  955.      height,
  956.      bitmap_pad,
  957.      bytes_per_line)));
  958.   }
  959. }
  960.  
  961. DEFINE_PRIMITIVE ("X-BYTES-INTO-IMAGE", Prim_x_bytes_into_image, 2, 2,
  962.   "(vector image)\n\
  963. VECTOR is a vector or vector-8b of pixel values stored in row-major\n\
  964. order; it must have the same number of pixels as IMAGE.\n\
  965. These pixels are written onto IMAGE by repeated calls to XPutPixel.\n\
  966. This procedure is equivalent to calling X-SET-PIXEL-IN-IMAGE for each\n\
  967. pixel in VECTOR.")
  968. {
  969.   PRIMITIVE_HEADER (2);
  970.   {
  971.     SCHEME_OBJECT vector = (ARG_REF (1));
  972.     XImage * image = (XI_IMAGE (x_image_arg (2)));
  973.     unsigned long width = (image -> width);
  974.     unsigned long height = (image -> height);
  975.     if (STRING_P (vector))
  976.       {
  977.     unsigned char * vscan;
  978.     unsigned long x;
  979.     unsigned long y;
  980.  
  981.     if ((STRING_LENGTH (vector)) != (width * height))
  982.       error_bad_range_arg (1);
  983.     vscan = (STRING_LOC (vector, 0));
  984.     for (y = 0; (y < height); y += 1)
  985.       for (x = 0; (x < width); x += 1)
  986.         XPutPixel (image, x, y, ((unsigned long) (*vscan++)));
  987.       }
  988.     else if (VECTOR_P (vector))
  989.       {
  990.     unsigned long vlen;
  991.     SCHEME_OBJECT * vscan;
  992.     SCHEME_OBJECT * vend;
  993.     unsigned long x;
  994.     unsigned long y;
  995.  
  996.     vlen = (VECTOR_LENGTH (vector));
  997.     if (vlen != (width * height))
  998.       error_bad_range_arg (1);
  999.     vscan = (VECTOR_LOC (vector, 0));
  1000.     vend = (VECTOR_LOC (vector, vlen));
  1001.     while (vscan < vend)
  1002.       {
  1003.         SCHEME_OBJECT elt = (*vscan++);
  1004.         if (! ((INTEGER_P (elt)) && (integer_to_ulong_p (elt))))
  1005.           error_bad_range_arg (1);
  1006.       }
  1007.     vscan = (VECTOR_LOC (vector, 0));
  1008.     for (y = 0; (y < height); y += 1)
  1009.       for (x = 0; (x < width); x += 1)
  1010.         XPutPixel (image, x, y, (integer_to_ulong (*vscan++)));
  1011.       }
  1012.     else
  1013.       error_wrong_type_arg (1);
  1014.     PRIMITIVE_RETURN (UNSPECIFIC);
  1015.   }
  1016. }
  1017.  
  1018. DEFINE_PRIMITIVE ("X-GET-PIXEL-FROM-IMAGE", Prim_x_get_image_pixel, 3, 3,
  1019.   "(image x y)\n\
  1020. The value of pixel (X,Y) of IMAGE is returned as an integer.\n\
  1021. This is accomplished by calling XGetPixel.")
  1022. {
  1023.   PRIMITIVE_HEADER (3);
  1024.   {
  1025.     XImage * image = (XI_IMAGE (x_image_arg (1)));
  1026.     PRIMITIVE_RETURN
  1027.       (ulong_to_integer
  1028.        (XGetPixel (image,
  1029.            (arg_index_integer (2, (image -> width))),
  1030.            (arg_index_integer (3, (image -> height))))));
  1031.   }
  1032. }
  1033.  
  1034. DEFINE_PRIMITIVE ("X-SET-PIXEL-IN-IMAGE", Prim_x_set_image_pixel, 4, 4,
  1035.   "(image x y pixel-value)\n\
  1036. The pixel (X,Y) of IMAGE is modified to contain PIXEL-VALUE.\n\
  1037. This is accomplished by calling XPutPixel.")
  1038. {
  1039.   PRIMITIVE_HEADER (4);
  1040.   {
  1041.     XImage * image = (XI_IMAGE (x_image_arg (1)));
  1042.     XPutPixel (image,
  1043.            (arg_index_integer (2, (image -> width))),
  1044.            (arg_index_integer (3, (image -> height))),
  1045.            (arg_ulong_integer (4)));
  1046.     PRIMITIVE_RETURN (UNSPECIFIC);
  1047.   }
  1048. }
  1049.  
  1050. DEFINE_PRIMITIVE ("X-DESTROY-IMAGE", Prim_x_destroy_image, 1, 1,
  1051.   "(image)\n\
  1052. IMAGE is deallocated by calling XDestroyImage.")
  1053. {
  1054.   PRIMITIVE_HEADER (1);
  1055.   {
  1056.     struct ximage * xi = (x_image_arg (1));
  1057.     XDestroyImage (XI_IMAGE (xi));
  1058.     deallocate_x_image (xi);
  1059.     PRIMITIVE_RETURN (UNSPECIFIC);
  1060.   }
  1061. }
  1062.  
  1063. DEFINE_PRIMITIVE ("X-DISPLAY-IMAGE", Prim_x_display_image, 8, 8,
  1064.   "(image image-xoff image-yoff window window_xoff window_yoff width height)\n\
  1065. IMAGE is drawn on WINDOW by calling XPutImage.")
  1066. {
  1067.   PRIMITIVE_HEADER (8);
  1068.   {
  1069.     XImage * image = (XI_IMAGE (x_image_arg (1)));
  1070.     unsigned int image_width = (image -> width);
  1071.     unsigned int image_height = (image -> height);
  1072.     unsigned int x_offset = (arg_ulong_index_integer (2, image_width));
  1073.     unsigned int y_offset = (arg_ulong_index_integer (3, image_height));
  1074.     struct xwindow * xw = (x_window_arg (4));
  1075.     XPutImage
  1076.       ((XW_DISPLAY (xw)),(XW_WINDOW (xw)),(XW_NORMAL_GC (xw)),
  1077.        image, x_offset, y_offset,
  1078.        (arg_x_coordinate (5, xw, -1)),
  1079.        (arg_y_coordinate (6, xw, 1)),
  1080.        (arg_index_integer (7, ((image_width - x_offset) + 1))),
  1081.        (arg_index_integer (8, ((image_height - y_offset) + 1))));
  1082.     PRIMITIVE_RETURN (UNSPECIFIC);
  1083.   }
  1084. }
  1085.  
  1086. DEFINE_PRIMITIVE ("X-READ-IMAGE", Prim_x_read_image, 8, 8,
  1087.   "(image image-xoff image-yoff window window_xoff window_yoff width height)\n\
  1088. Reads the specified rectangle of WINDOW into IMAGE by calling XGetSubImage.")
  1089. {
  1090.   /* Called with Image, X-offset in image, Y-offset in image,
  1091.      Window, X-offset in window, Y-offset in window,
  1092.      Width, Height */
  1093.   PRIMITIVE_HEADER (8);
  1094.   { struct ximage * xi = x_image_arg (1);
  1095.     long XImageOffset = arg_integer(2);
  1096.     long YImageOffset = arg_integer(3);
  1097.     struct xwindow * xw = x_window_arg(4);
  1098.     long XWindowOffset = arg_integer(5);
  1099.     long YWindowOffset = arg_integer(6);
  1100.     long Width = arg_integer(7);
  1101.     long Height = arg_integer(8);
  1102.  
  1103.     XGetSubImage(XW_DISPLAY(xw), XW_WINDOW(xw), XWindowOffset, YWindowOffset,
  1104.          Width, Height, -1, ZPixmap,
  1105.          XI_IMAGE(xi), XImageOffset, YImageOffset);
  1106.     PRIMITIVE_RETURN (UNSPECIFIC);
  1107.   }
  1108. }
  1109.  
  1110. DEFINE_PRIMITIVE ("X-WINDOW-DEPTH", Prim_x_window_depth, 1, 1,
  1111.   "(window)\n\
  1112. Returns the pixel depth of WINDOW as an integer.")
  1113. {
  1114.   PRIMITIVE_HEADER (1);
  1115.   {
  1116.     struct xwindow * xw = (x_window_arg (1));
  1117.     XWindowAttributes attrs;
  1118.     XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&attrs));
  1119.     PRIMITIVE_RETURN (long_to_integer (attrs . depth));
  1120.   }
  1121. }
  1122.  
  1123. DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-X-COORDINATE", Prim_x_graphics_map_x_coordinate, 2, 2, 0)
  1124. {
  1125.   PRIMITIVE_HEADER (2);
  1126.   {
  1127.     struct xwindow * xw = (x_window_arg (1));
  1128.     unsigned int xp = (arg_ulong_integer (2));
  1129.     int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw)));
  1130.     PRIMITIVE_RETURN
  1131.       (x_coordinate_map
  1132.        (xw,
  1133.     ((bx < 0) ? 0
  1134.      : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1)
  1135.      : bx)));
  1136.   }
  1137. }
  1138.  
  1139. DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-Y-COORDINATE", Prim_x_graphics_map_y_coordinate, 2, 2, 0)
  1140. {
  1141.   PRIMITIVE_HEADER (2);
  1142.   {
  1143.     struct xwindow * xw = (x_window_arg (1));
  1144.     unsigned int yp = (arg_ulong_integer (2));
  1145.     int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw)));
  1146.     PRIMITIVE_RETURN
  1147.       (y_coordinate_map
  1148.        (xw,
  1149.     ((by < 0) ? 0
  1150.      : (by >= (XW_Y_SIZE (xw))) ? ((XW_Y_SIZE (xw)) - 1)
  1151.      : by)));
  1152.   }
  1153. }
  1154.