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 / starbase.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  15KB  |  462 lines
  1. /* -*-C-*-
  2.  
  3. $Id: starbase.c,v 1.7 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1989, 1990, 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. /* Starbase graphics for HP 9000 machines. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include <starbase.c.h>
  27.  
  28. static void
  29. set_vdc_extent (descriptor, xmin, ymin, xmax, ymax)
  30.      int descriptor;
  31.      float xmin, ymin, xmax, ymax;
  32. {
  33.   vdc_extent (descriptor, xmin, ymin, (0.0), xmax, ymax, (0.0));
  34.   clip_indicator (descriptor, CLIP_TO_VDC);
  35.   clear_control (descriptor, CLEAR_VDC_EXTENT);
  36.   return;
  37. }
  38.  
  39. static void
  40. set_line_color_index (descriptor, color_index)
  41.      int descriptor;
  42.      long color_index;
  43. {
  44.   line_color_index (descriptor, color_index);
  45.   text_color_index (descriptor, color_index);
  46.   perimeter_color_index (descriptor, color_index);
  47.   fill_color_index (descriptor, color_index);
  48.   return;
  49. }
  50.  
  51. static int
  52. inquire_cmap_size (fildes)
  53.      int fildes;
  54. {
  55.   float physical_limits [2][3];
  56.   float resolution [3];
  57.   float p1 [3];
  58.   float p2 [3];
  59.   int cmap_size;
  60.   inquire_sizes (fildes, physical_limits, resolution, p1, p2, (& cmap_size));
  61.   return (cmap_size);
  62. }
  63.  
  64. #define SB_DEVICE_ARG(arg) (arg_nonnegative_integer (arg))
  65.  
  66. DEFINE_PRIMITIVE ("STARBASE-OPEN-DEVICE", Prim_starbase_open_device, 2, 2,
  67.   "(STARBASE-OPEN-DEVICE DEVICE-NAME DRIVER-NAME)")
  68. {
  69.   PRIMITIVE_HEADER (2);
  70.   gerr_print_control (NO_ERROR_PRINTING);
  71.   {
  72.     int descriptor = (gopen ((STRING_ARG (1)), OUTDEV, (STRING_ARG (2)), 0));
  73.     gerr_print_control (PRINT_ERRORS);
  74.     if (descriptor == (-1))
  75.       PRIMITIVE_RETURN (SHARP_F);
  76.     set_vdc_extent (descriptor, (-1.0), (-1.0), (1.0), (1.0));
  77.     mapping_mode (descriptor, DISTORT);
  78.     set_line_color_index (descriptor, 1);
  79.     line_type (descriptor, 0);
  80.     drawing_mode (descriptor, 3);
  81.     text_alignment
  82.       (descriptor, TA_NORMAL_HORIZONTAL, TA_NORMAL_VERTICAL, (0.0), (0.0));
  83.     interior_style (descriptor, INT_HOLLOW, 1);
  84.     PRIMITIVE_RETURN (long_to_integer (descriptor));
  85.   }
  86. }
  87.  
  88. DEFINE_PRIMITIVE ("STARBASE-CLOSE-DEVICE", Prim_starbase_close_device, 1, 1, 0)
  89. {
  90.   PRIMITIVE_HEADER (1);
  91.   gclose (SB_DEVICE_ARG (1));
  92.   PRIMITIVE_RETURN (UNSPECIFIC);
  93. }
  94.  
  95. DEFINE_PRIMITIVE ("STARBASE-FLUSH", Prim_starbase_flush, 1, 1, 0)
  96. {
  97.   PRIMITIVE_HEADER (1);
  98.   make_picture_current (SB_DEVICE_ARG (1));
  99.   PRIMITIVE_RETURN (UNSPECIFIC);
  100. }
  101.  
  102. DEFINE_PRIMITIVE ("STARBASE-CLEAR", Prim_starbase_clear, 1, 1,
  103.   "(STARBASE-CLEAR DEVICE)\n\
  104. Clear the graphics section of the screen.\n\
  105. Uses the Starbase CLEAR_VIEW_SURFACE procedure.")
  106. {
  107.   PRIMITIVE_HEADER (1);
  108.   clear_view_surface (SB_DEVICE_ARG (1));
  109.   PRIMITIVE_RETURN (UNSPECIFIC);
  110. }
  111.  
  112. DEFINE_PRIMITIVE ("STARBASE-DRAW-POINT", Prim_starbase_draw_point, 3, 3,
  113.   "(STARBASE-DRAW-POINT DEVICE X Y)\n\
  114. Draw one point at the given coordinates.\n\
  115. Subsequently move the graphics cursor to those coordinates.\n\
  116. Uses the starbase procedures `move2d' and `draw2d'.")
  117. {
  118.   PRIMITIVE_HEADER (3);
  119.   {
  120.     int descriptor = (SB_DEVICE_ARG (1));
  121.     fast float x = (arg_real_number (2));
  122.     fast float y = (arg_real_number (3));
  123.     move2d (descriptor, x, y);
  124.     draw2d (descriptor, x, y);
  125.   }
  126.   PRIMITIVE_RETURN (UNSPECIFIC);
  127. }
  128.  
  129. DEFINE_PRIMITIVE ("STARBASE-MOVE-CURSOR", Prim_starbase_move_cursor, 3, 3,
  130.   "(STARBASE-MOVE-CURSOR DEVICE X Y)\n\
  131. Move the graphics cursor to the given coordinates.\n\
  132. Uses the starbase procedure `move2d'.")
  133. {
  134.   PRIMITIVE_HEADER (3);
  135.   move2d ((SB_DEVICE_ARG (1)), (arg_real_number (2)), (arg_real_number (3)));
  136.   PRIMITIVE_RETURN (UNSPECIFIC);
  137. }
  138.  
  139. DEFINE_PRIMITIVE ("STARBASE-DRAG-CURSOR", Prim_starbase_drag_cursor, 3, 3,
  140.   "(STARBASE-DRAG-CURSOR DEVICE X Y)\n\
  141. Draw a line from the graphics cursor to the given coordinates.\n\
  142. Subsequently move the graphics cursor to those coordinates.\n\
  143. Uses the starbase procedure `draw2d'.")
  144. {
  145.   PRIMITIVE_HEADER (3);
  146.   draw2d ((SB_DEVICE_ARG (1)), (arg_real_number (2)), (arg_real_number (3)));
  147.   PRIMITIVE_RETURN (UNSPECIFIC);
  148. }
  149.  
  150. DEFINE_PRIMITIVE ("STARBASE-DRAW-LINE", Prim_starbase_draw_line, 5, 5,
  151.   "(STARBASE-DRAW-LINE DEVICE X-START Y-START X-END Y-END)\n\
  152. Draw a line from the start coordinates to the end coordinates.\n\
  153. Subsequently move the graphics cursor to the end coordinates.\n\
  154. Uses the starbase procedures `move2d' and `draw2d'.")
  155. {
  156.   PRIMITIVE_HEADER (5);
  157.   {
  158.     int descriptor = (SB_DEVICE_ARG (1));
  159.     fast float x_start = (arg_real_number (2));
  160.     fast float y_start = (arg_real_number (3));
  161.     fast float x_end = (arg_real_number (4));
  162.     fast float y_end = (arg_real_number (5));
  163.     move2d (descriptor, x_start, y_start);
  164.     draw2d (descriptor, x_end, y_end);
  165.   }
  166.   PRIMITIVE_RETURN (UNSPECIFIC);
  167. }
  168.  
  169. DEFINE_PRIMITIVE ("STARBASE-SET-LINE-STYLE", Prim_starbase_set_line_style, 2, 2,
  170.   "(STARBASE-SET-LINE-STYLE DEVICE STYLE)\n\
  171. Changes the line drawing style.\n\
  172. The STYLE argument is an integer in the range 0-7 inclusive.\n\
  173. See the description of the starbase procedure `line_type'.")
  174. {
  175.   PRIMITIVE_HEADER (2);
  176.   line_type ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 8)));
  177.   PRIMITIVE_RETURN (UNSPECIFIC);
  178. }
  179.  
  180. DEFINE_PRIMITIVE ("STARBASE-SET-DRAWING-MODE", Prim_starbase_set_drawing_mode, 2, 2,
  181.   "(STARBASE-SET-DRAWING-MODE DEVICE MODE)\n\
  182. Changes the replacement rule used when drawing.\n\
  183. The MODE argument is an integer in the range 0-15 inclusive.\n\
  184. See the description of the starbase procedure `drawing_mode'.")
  185. {
  186.   PRIMITIVE_HEADER (2);
  187.   drawing_mode ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 16)));
  188.   PRIMITIVE_RETURN (UNSPECIFIC);
  189. }
  190.  
  191. DEFINE_PRIMITIVE ("STARBASE-DEVICE-COORDINATES", Prim_starbase_device_coordinates, 1, 1, 0)
  192. {
  193.   float physical_limits [2][3];
  194.   float resolution [3];
  195.   float p1 [3];
  196.   float p2 [3];
  197.   int cmap_size;
  198.   PRIMITIVE_HEADER (1);
  199.   inquire_sizes
  200.     ((SB_DEVICE_ARG (1)), physical_limits, resolution, p1, p2, (& cmap_size));
  201.   {
  202.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
  203.     VECTOR_SET (result, 0, (FLOAT_TO_FLONUM (physical_limits[0][0])));
  204.     VECTOR_SET (result, 1, (FLOAT_TO_FLONUM (physical_limits[0][1])));
  205.     VECTOR_SET (result, 2, (FLOAT_TO_FLONUM (physical_limits[1][0])));
  206.     VECTOR_SET (result, 3, (FLOAT_TO_FLONUM (physical_limits[1][1])));
  207.     PRIMITIVE_RETURN (result);
  208.   }
  209. }
  210.  
  211. DEFINE_PRIMITIVE ("STARBASE-SET-VDC-EXTENT", Prim_starbase_set_vdc_extent, 5, 5, 0)
  212. {
  213.   PRIMITIVE_HEADER (5);
  214.   set_vdc_extent
  215.     ((SB_DEVICE_ARG (1)),
  216.      (arg_real_number (2)),
  217.      (arg_real_number (3)),
  218.      (arg_real_number (4)),
  219.      (arg_real_number (5)));
  220.   PRIMITIVE_RETURN (UNSPECIFIC);
  221. }
  222.  
  223. DEFINE_PRIMITIVE ("STARBASE-RESET-CLIP-RECTANGLE", Prim_starbase_reset_clip_rectangle, 1, 1,
  224.   "(STARBASE-RESET-CLIP-RECTANGLE DEVICE)\n\
  225. Undo the clip rectangle.  Subsequently, clipping is not affected by it.")
  226. {
  227.   PRIMITIVE_HEADER (1);
  228.   {
  229.     int descriptor = (SB_DEVICE_ARG (1));
  230.     clip_indicator (descriptor, CLIP_TO_VDC);
  231.     clear_control (descriptor, CLEAR_VDC_EXTENT);
  232.   }
  233.   PRIMITIVE_RETURN (UNSPECIFIC);
  234. }
  235.  
  236. DEFINE_PRIMITIVE ("STARBASE-SET-CLIP-RECTANGLE", Prim_starbase_set_clip_rectangle, 5, 5,
  237.   "(STARBASE-SET-CLIP-RECTANGLE X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\
  238. Restrict the graphics drawing primitives to the area in the given rectangle.")
  239. {
  240.   PRIMITIVE_HEADER (5);
  241.   {
  242.     int descriptor = (SB_DEVICE_ARG (1));
  243.     fast float x_left = (arg_real_number (2));
  244.     fast float y_bottom = (arg_real_number (3));
  245.     fast float x_right = (arg_real_number (4));
  246.     fast float y_top = (arg_real_number (5));
  247.     clip_rectangle (descriptor, x_left, x_right, y_bottom, y_top);
  248.     clip_indicator (descriptor, CLIP_TO_RECT);
  249.     clear_control (descriptor, CLEAR_CLIP_RECTANGLE);
  250.   }
  251.   PRIMITIVE_RETURN (UNSPECIFIC);
  252. }
  253.  
  254. DEFINE_PRIMITIVE ("STARBASE-DRAW-TEXT", Prim_starbase_draw_text, 4, 4,
  255.   "(STARBASE-DRAW-TEXT DEVICE X Y STRING)")
  256. {
  257.   PRIMITIVE_HEADER (4);
  258.   text2d
  259.     ((SB_DEVICE_ARG (1)),
  260.      (arg_real_number (2)),
  261.      (arg_real_number (3)),
  262.      (STRING_ARG (4)),
  263.      VDC_TEXT,
  264.      FALSE);
  265.   PRIMITIVE_RETURN (UNSPECIFIC);
  266. }
  267.  
  268. DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-HEIGHT", Prim_starbase_set_text_height, 2, 2,
  269.   "(STARBASE-SET-TEXT-HEIGHT DEVICE HEIGHT)")
  270. {
  271.   PRIMITIVE_HEADER (2);
  272.   character_height ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
  273.   PRIMITIVE_RETURN (UNSPECIFIC);
  274. }
  275.  
  276. DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ASPECT", Prim_starbase_set_text_aspect, 2, 2,
  277.   "(STARBASE-SET-TEXT-ASPECT DEVICE ASPECT)")
  278. {
  279.   PRIMITIVE_HEADER (2);
  280.   character_expansion_factor ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
  281.   PRIMITIVE_RETURN (UNSPECIFIC);
  282. }
  283.  
  284. DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-SLANT", Prim_starbase_set_text_slant, 2, 2,
  285.   "(STARBASE-SET-TEXT-SLANT DEVICE SLANT)")
  286. {
  287.   PRIMITIVE_HEADER (2);
  288.   character_slant ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
  289.   PRIMITIVE_RETURN (UNSPECIFIC);
  290. }
  291.  
  292. DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ROTATION", Prim_starbase_set_text_rotation, 2, 2,
  293.   "(STARBASE-SET-TEXT-ROTATION DEVICE ANGLE)")
  294. {
  295.   PRIMITIVE_HEADER (2);
  296.   {
  297.     fast float angle = (arg_real_number (2));
  298.     fast int path_style;
  299.     if ((angle > 315.0) || (angle <=  45.0))
  300.       path_style = PATH_RIGHT;
  301.     else if ((angle > 45.0) && (angle <= 135.0))
  302.       path_style = PATH_DOWN;
  303.     else if ((angle > 135.0) && (angle <= 225.0))
  304.       path_style = PATH_LEFT;
  305.     else if ((angle > 225.0) && (angle <= 315.0))
  306.       path_style = PATH_UP;
  307.     text_path ((SB_DEVICE_ARG (1)), path_style);
  308.   }
  309.   PRIMITIVE_RETURN (UNSPECIFIC);
  310. }
  311.  
  312. DEFINE_PRIMITIVE ("STARBASE-COLOR-MAP-SIZE", Prim_starbase_color_map_size, 1, 1, 0)
  313. {
  314.   PRIMITIVE_HEADER (1);
  315.   PRIMITIVE_RETURN (long_to_integer (inquire_cmap_size (SB_DEVICE_ARG (1))));
  316. }
  317.  
  318. DEFINE_PRIMITIVE ("STARBASE-DEFINE-COLOR", Prim_starbase_define_color, 5, 5,
  319.   "(STARBASE-DEFINE-COLOR DEVICE COLOR-INDEX RED GREEN BLUE)\n\
  320. COLOR-INDEX must be a valid index for the current device's color map.\n\
  321. RED, GREEN, and BLUE must be numbers between 0 and 1 inclusive.\n\
  322. Changes the color map, defining COLOR-INDEX to be the given RGB color.")
  323. {
  324.   int descriptor;
  325.   float colors [1][3];
  326.   PRIMITIVE_HEADER (5);
  327.   descriptor = (SB_DEVICE_ARG (1));
  328.   (colors [0] [0]) = (arg_real_number (3));
  329.   (colors [0] [1]) = (arg_real_number (4));
  330.   (colors [0] [2]) = (arg_real_number (5));
  331.   define_color_table
  332.     (descriptor,
  333.      (arg_index_integer (2, (inquire_cmap_size (descriptor)))),
  334.      1,
  335.      colors);
  336.   PRIMITIVE_RETURN (UNSPECIFIC);
  337. }
  338.  
  339. DEFINE_PRIMITIVE ("STARBASE-SET-LINE-COLOR", Prim_starbase_set_line_color, 2, 2,
  340.   "(STARBASE-SET-LINE-COLOR DEVICE COLOR-INDEX)\n\
  341. COLOR-INDEX must be a valid index for the current device's color map.\n\
  342. Changes the color used for drawing most things.\n\
  343. Does not take effect until the next starbase output operation.")
  344. {
  345.   int descriptor;
  346.   PRIMITIVE_HEADER (2);
  347.   descriptor = (SB_DEVICE_ARG (1));
  348.   set_line_color_index
  349.     (descriptor, (arg_index_integer (2, (inquire_cmap_size (descriptor)))));
  350.   PRIMITIVE_RETURN (UNSPECIFIC);
  351. }
  352.  
  353. /* Graphics Screen Dump */
  354.  
  355. static void print_graphics ();
  356.  
  357. DEFINE_PRIMITIVE ("STARBASE-WRITE-IMAGE-FILE", Prim_starbase_write_image_file, 3, 3,
  358.   "(STARBASE-WRITE-IMAGE-FILE DEVICE FILENAME INVERT?)\n\
  359. Write a file containing an image of the DEVICE's screen, in a format\n\
  360. suitable for printing on an HP laserjet printer.\n\
  361. If INVERT? is not #F, invert black and white in the output.")
  362. {
  363.   PRIMITIVE_HEADER (3);
  364.   print_graphics ((SB_DEVICE_ARG (1)), (STRING_ARG (2)), (BOOLEAN_ARG (3)));
  365.   PRIMITIVE_RETURN (UNSPECIFIC);
  366. }
  367.  
  368. static char rasres[] = "\033*t100R";
  369. static char rastop[] = "\033&l2E";
  370. static char raslft[] = "\033&a2L";
  371. static char rasbeg[] = "\033*r0A";
  372. static char raslen[] = "\033*b96W";
  373. static char rasend[] = "\033*rB";
  374.  
  375. static int
  376. inquire_cmap_mask (fildes)
  377.      int fildes;
  378. {
  379.   int cmap_size = (inquire_cmap_size (fildes));
  380.   return
  381.     (((cmap_size >= 0) && (cmap_size < 8))
  382.      ? ((1 << cmap_size) - 1)
  383.      : (-1));
  384. }
  385.  
  386. static int
  387. open_dumpfile (dumpname)
  388.   char * dumpname;
  389. {
  390.   int dumpfile = (creat (dumpname, 0666));
  391.   if (dumpfile == (-1))
  392.     {
  393.       fprintf (stderr, "\nunable to create graphics dump file.");
  394.       fflush (stderr);
  395.       error_external_return ();
  396.     }
  397.   dumpfile = (open (dumpname, OUTINDEV));
  398.   if (dumpfile == (-1))
  399.     {
  400.       fprintf (stderr, "\nunable to open graphics dump file.");
  401.       fflush (stderr);
  402.       error_external_return ();
  403.     }
  404.   return (dumpfile);
  405. }
  406.  
  407. static void
  408. print_graphics (descriptor, dumpname, inverse_p)
  409.      int descriptor;
  410.      char * dumpname;
  411.      int inverse_p;
  412. {
  413.   int dumpfile = (open_dumpfile (dumpname));
  414.   write (dumpfile, rasres, (strlen (rasres)));
  415.   write (dumpfile, rastop, (strlen (rastop)));
  416.   write (dumpfile, raslft, (strlen (raslft)));
  417.   write (dumpfile, rasbeg, (strlen (rasbeg)));
  418.   {
  419.     fast unsigned char mask = (inquire_cmap_mask (descriptor));
  420.     int col;
  421.     for (col = (1024 - 16); (col >= 0); col = (col - 16))
  422.       {
  423.     unsigned char pixdata [(16 * 768)];
  424.     {
  425.       fast unsigned char * p = (& (pixdata [0]));
  426.       fast unsigned char * pe = (& (pixdata [sizeof (pixdata)]));
  427.       while (p < pe)
  428.         (*p++) = '\0';
  429.     }
  430.     dcblock_read (descriptor, col, 0, 16, 768, pixdata, 0);
  431.     {
  432.       int x;
  433.       for (x = (16 - 1); (x >= 0); x -= 1)
  434.         {
  435.           unsigned char rasdata [96];
  436.           fast unsigned char * p = (& (pixdata [x]));
  437.           fast unsigned char * r = rasdata;
  438.           int n;
  439.           for (n = 0; (n < 96); n += 1)
  440.         {
  441.           fast unsigned char c = 0;
  442.           int nn;
  443.           for (nn = 0; (nn < 8); nn += 1)
  444.             {
  445.               c <<= 1;
  446.               if (((* p) & mask) != 0)
  447.             c |= 1;
  448.               p += 16;
  449.             }
  450.           (*r++) = (inverse_p ? (~ c) : c);
  451.         }
  452.           write (dumpfile, raslen, (strlen (raslen)));
  453.           write (dumpfile, rasdata, 96);
  454.         }
  455.     }
  456.       }
  457.   }
  458.   write (dumpfile, rasend, (strlen (rasend)));
  459.   close (dumpfile);
  460.   return;
  461. }
  462.