home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / qd.pl < prev   
Perl Script  |  1996-09-12  |  33KB  |  899 lines
  1. #!/usr/local/bin/perl
  2.  
  3. # $Id: qd.pl,v 1.2 1994/09/29 01:24:24 lstein Exp $
  4.  
  5. # This is a package of routines that let you create Macintosh 
  6. # PICT files from within perl.  It implements a subset of Quickdraw
  7. # drawing commands, primarily those related to line drawing, rectangles,
  8. # ovals, polygons, and text.  Flagrantly absent are: regions and the 
  9. # snazzy color transfer modes.  Regions are absent because they were
  10. # more trouble than I had time for, and the transfer modes because I
  11. # never use them.  (The latter shouldn't be too hard to add.)  Also 
  12. # missing are the pixmap commands.  If you want to do pixmaps, you
  13. # should be using the ppm utilities.
  14.  
  15. # A QUICK TUTORIAL ON QUICKDRAW
  16. # 
  17. # Quickdraw is not Postscript.  You cannot write routines in it or get
  18. # (any useful) information out of it.  Quickdraw pictures are a series of
  19. # drawing commands, concatenated together in a binary format.
  20. #
  21. # A Macintosh picture consists of a header describing the size of the
  22. # picture and its bounding rectangle, followed by a series of drawing
  23. # commands, followed by a termination code.  This perl library is
  24. # modeled closely on the way that you would draw a picture on the Mac.
  25. # First you open the picture with the &qd'OpenPicture() command.  This
  26. # initializes some data structures.  Then you call a series of drawing
  27. # subroutines, such as &qd'TextFont(), &qd'MoveTo(), &qd'DrawString().
  28. # These routines append their data to the growing (but still private)
  29. # picture.  You then close the picture with &qd'ClosePicture.  This
  30. # returns a scalar variable containing the binary picture data.
  31.  
  32. # RECTANGLES
  33. #
  34. # To open a picture you need to define a rectangle that will serve as
  35. # its frame and will define its drawing area.  The rectangle is (of 
  36. # course) a binary structure.  The following utilities allow you to
  37. # create and manipulate rectangles:
  38. #
  39. #   &qd'SetRect(*myRect,left,top,right,bottom); # Set the sides of $myRect
  40. #   &qd'OffsetRect(*myRect,deltaH,deltaV);      # Shift the rectangle as indicated
  41. #   &qd'InsetRect(*myRect,deltaH,deltaV);       # Shrink rectangle by size indicated
  42.  
  43.  
  44. # OPENING A PICTURE
  45. #
  46. # Pass a previously-defined rectangle to the routine OpenPicture.  Only one picture
  47. # may be open at a time.  The rectangle defines the drawing area in pixels.
  48. # A printer page is 8.5 x 11 inches, at 72 pixels per inch = 612 x 792 pixels.
  49. #
  50. #   &qd'OpenPicture($myRect);
  51. #
  52. # You will next very likely want to set the clipping rectangle to the same rectangle
  53. # you used to open the picture with.  Clipping rectangles limit quickdraw's drawing
  54. # to the area within the rectangle.  Even if you don't use clipping, however, it's a
  55. # good idea to define the rectangle because some drawing programs behave eratically
  56. # when displaying unclipped pictures.
  57. # 
  58. # You then issue drawing commands.  When you're done you can get the picture data with
  59. # something like $pictData = &qd'ClosePicture;
  60.  
  61. # 
  62. # SETTING THE FOREGROUND AND BACKGROUND COLORS
  63. #
  64. # The foreground color is the color of the ink when a "frame" or "paint" command
  65. # is given.  The background color is the color of the erased area when an "erase"
  66. # command is given.  The defaults are black and white.  The colors can be changed
  67. # in either of two ways:
  68. #
  69. #  1. The "old" 8-color system: black, white, red, green, blue, cyan, magenta, yellow
  70. #     Call the routines &qd'FgColor() and &qd'BgColor() with one of the constants
  71. #     $qd'REDCOLOR,$qd'GREENCOLOR, etc.  This gives you a limited number of highly
  72. #     satured colors.
  73. #
  74. #  2. The new 24-bit color system.  Call the routines &qd'RGBForeColor() and 
  75. #     &qd'RGBBackColor(), passing the routines the red, green and blue components
  76. #     of the color.  These components are two-byte unsigned integers, so you can choose
  77. #     any value between 0x000 and 0xFFFF.  Higher is darker, so:
  78. #     (0x0000,0x0000,0x0000) = BLACK
  79. #     (0xFFFFF,0xFFFF,0xFFFF) = WHITE
  80. #     (0xFFFFF,0x0000,0x0000) = PURE RED
  81. #     etc.
  82.  
  83.  
  84. # SETTING THE PATTERN
  85. #
  86. # Like colors, the drawing commands use the current pattern, a 32 row x 32 column 
  87. # bit array that defines the pattern of the "ink".
  88. # The default pattern is $qd'BLACK, which is solid black.  The only
  89. # other pattern I've defined is $qd'GRAY, which is a 50% checkerboard.  You
  90. # might want to define others.
  91. #
  92. # The current pattern is set using &qd'PenPat($myPattern).
  93.  
  94.  
  95. # LINE DRAWING
  96. #
  97. # Quickdraw has the concept of the "current point" of the pen.  Generally
  98. # you move the pen to a point and then start drawing.  The next time you draw,
  99. # the pen will be wherever the last drawing command left it.  In addition, the
  100. # pen has a width, a pattern and a color.  In the below descriptions, 
  101. # h=horizontal, v=vertical
  102. #
  103. # &qd'MoveTo(h,v)           # Move to indicated coordinates (0,0 is upper left of picture)
  104. # &qd'LineTo(h,v)           # Draw from current position to indicated position
  105. # &qd'Line(dh,dv)           # Draw a line dh pixels horizontally, dv pixels vertically,
  106. #                             starting at current position
  107. # &qd'PenSize(h,v)          # Set the size of the pen to h pixels wide, v pixels high
  108.  
  109.  
  110. # PEN SCALING
  111. #
  112. # The original quickdraw was incapable of drawing at higher than the screen resolution,
  113. # so even if the PenSize is set to (1,1) the lines will appear chunky when printed out
  114. # on the laserwriter (which has four times the resolution of the screen).  Call 
  115. # &qd'Scale(1,4) to fix this problem by shrinking the pen down to a quarter of its
  116. # (1,1) size.
  117. #
  118. # &qd'Scale(numerator,denominator) # Scale the pen by the fraction numerator/denominator
  119.  
  120.  
  121. # TEXT
  122. #
  123. # &qd'TextFont(fontCode)    # Set the current font to indicated code.  Currently
  124. #                             defined fonts are $qd'TIMES, $qd'NEWCENTURYSCHOOLBK,
  125. #                             $qd'SYMBOL, $qd'HELVETICA, and $qd'COURIER.
  126. #
  127. # &qd'TextSize(size)        # Set the current font size (in points).  12 point is typical
  128. #
  129. # &qd'TextFace(attributes)  # Set one or more font style attributes.  Currently defined
  130. #                             are $qd'PLAIN, $qd'BOLD, $qd'ITALIC, $qd'UNDERLINE, and
  131. #                             can be used in combination: 
  132. #                             &qd'TextFace($qd'BOLD + $qd'ITALIC);
  133. #
  134. # &qd'DrawString(string)    # Draw the indicated text.  It will be drawn from the
  135. #                             current pen location.  Word wrap is NOT supported.
  136. #                             Rotated text is NOT supported.
  137. #
  138. # &qd'TextWidth(string)     # This will return an approximate width for the string
  139. #                             when it is printed in the current size, font and face.
  140. #                             Unfortunately, since perl has no access to the Macintosh
  141. #                             font description tables, the number returned by this
  142. #                             routine will be wildly inaccurate at best.
  143. #                             However, if you have X11R5 bdf fonts installed, we look 
  144. #                             in the directory $qd'X11FONTS in order to find a bdf metrics
  145. #                             font to use.  This will give you extremely accurate measurements.
  146. #                             Please set this variable to whatever is correct for your local
  147. #                             system.  To add more fonts, put them in your bdf font directory
  148. #                             and update the %qd'font_metric_files array at the bottom of this
  149. #                             file.  It maps a key consisting of the Quickdraw font number, 
  150. #                             font size, and font style (0 for plain, 1 for italic, 2 for bold,
  151. #                             3 for both) to the appropriate bdf file.
  152.  
  153. # RECTANGLES
  154. #
  155. # Draw rectangles using the routines:
  156. #   &qd'FrameRect($myRect);                     # Draw wire-frame rectangle
  157. #   &qd'PaintRect($myRect);                     # Fill rectangle with current foreground
  158. #                                                 color and pattern
  159. #   &qd'EraseRect($myRect);                     # Erase the rectangle (fill with bg color)
  160. #   &qd'InvertRect($myRect);                    # Invert black and white in rectangle
  161.  
  162.  
  163. # OVALS
  164. #
  165. # Draw ovals using the routines:
  166. #   &qd'FrameOval($myRect);                     # Draw wire-frame oval
  167. #   &qd'PaintOval($myRect);                     # Fill oval with current foreground
  168. #                                                 color and pattern
  169. #   &qd'EraseOval($myRect);                     # Erase the oval (fill with bg color)
  170. #   &qd'InvertOval($myRect);                    # Invert black and white in oval
  171. #   &qd'FillOval($myRect,$pat);                 # Fill with specified pattern
  172. # 
  173.  
  174. # ROUND RECTANGLES
  175. # 
  176. # Draw round-cornered rectangles with these routines.  They each take an oval radius
  177. # to determine the amount of curvature.  Values of 10-20 are typical.
  178. #   &qd'FrameRoundRect($myRect,$ovalWidth,$ovalHeight); # wire-frame outline
  179. #   &qd'PaintRoundRect($myRect,$ovalWidth,$ovalHeight); # fill with current foreground
  180. #   &qd'EraseRoundRect($myRect,$ovalWidth,$ovalHeight); # erase
  181. #   &qd'InvertRoundRect($myRect,$ovalWidth,$ovalHeight);# invert
  182. #   &qd'FillRoundRect($myRect,$ovalWidth,$ovalHeight,$pat); # fill with specified pattern
  183.  
  184. # ARCS
  185. # Draw an arc subtending the specified rectangle.  Angles are in degrees and
  186. # start pointing northward and get larger clockwise:
  187. # e.g. PaintArc($r,45,90) gives you a pie wedge from 2 o'clock to 5 o'clock
  188. #   &qd'FrameArc($rect,$startAngle,$arcAngle);  # wire-frame the arc
  189. #   &qd'PaintArc($rect,$startAngle,$arcAngle);  # fill with current foreground
  190. #   &qd'EraseArc($rect,$startAngle,$arcAngle);  # erase arc
  191. #   &qd'InvertArc($rect,$startAngle,$arcAngle);  # flip white and black
  192. #   &qd'FillArc($rect,,$startAngle,$arcAngle,$pat);  # fill with specified pattern
  193.  
  194. # POLYGONS
  195. # Calling OpenPoly returns the name of a variable in which a growing
  196. # polygon structure will be stored.  Once a polygon is opened, all drawing
  197. # commands cease to have an effect on the picture.  Instead, all MoveTo,
  198. # LineTo and Line commands accumulate polygon vertices into the data structure.
  199. # Call ClosePoly to stop recording drawing commands.  The polygon can now
  200. # be moved, scaled, drawn, filled and erased as many times as wished.  Call
  201. # KillPoly to release the memory taken up by the polygon
  202. #   $polygon = &qd'OpenPoly;                      # begin recording drawing commands
  203. #   &qd'ClosePoly($polygon);                      # stop recording drawing commands
  204. #   &qd'FramePoly($polygon);                      # wire-frame the polygon
  205. #   &qd'PaintPoly($polygon);                      # fill with current foreground
  206. #   &qd'ErasePoly($polygon);                      # erase polygon
  207. #   &qd'FillPoly($polygon,$pat);                  # fill polygon with pattern
  208. #   &qd'OffsetPoly($polygon,$dh,$dv);             # translate poly by dh horizontally, dv vertically
  209. #   &qd'MapPoly($polygon,$srcRect,$destRect);     # map polygon from coordinate system defined by
  210.                                                   #  source rectangle to that defined by destination
  211.                                                   #  rectangle (moving or resizing it as needed)
  212.  
  213. # PRINTING OUT THE PICTURE IN A FORM THAT THE MACINTOSH CAN READ
  214. #
  215. # The Mac expects its picture files to begin with 512 bytes of "application specific"
  216. # data.  By default the picture data that you get will be proceeded by 512 bytes of
  217. # 0's.  If you want something else, or if you just want the picture data, set the
  218. # package variable $qd'PICTHEADER to whatever you desire before calling ClosePicture.
  219. # In order for the picture data to be readable on the Macintosh, the file type must
  220. # be set to 'PICT'.  A number of UNIX utilities, including mcvert and BinHex allow
  221. # you to do this.  Or you can use the picttoppm utility (part of the netppm suite of
  222. # graphics tools) to translate the file into any format you desire.
  223.  
  224. # A WORKING EXAMPLE
  225. # require "qd.pl";
  226. # &qd'SetRect(*myRect,0,0,500,500);          # Define a 500 pixel square
  227. # &qd'OpenPicture($myRect);                  # Begin defining the picture
  228. # &qd'ClipRect($myRect);                     # Always a good idea
  229. # &qd'MoveTo(5,5);                           # Move the pen to a starting point
  230. # &qd'LineTo(400,400);                       # A diagonal line
  231. # &qd'TextFont($qd'COURIER);                 # Set the font
  232. # &qd'MoveTo(50,20);                         # Move the pen to a new starting point
  233. # &qd'DrawString("Hello there!");            # Friendly greeting
  234. # &qd'SetRect(*myRect,80,80,250,250);        # New rectangle
  235. # &qd'RGBForeColor(0x0000,0x0000,0xFFFF);    # Set the color to blue
  236. # &qd'PaintRect($myRect);                    # Fill rectangle with that color
  237. # $data = &qd'ClosePicture;                  # Close picture and retrieve data
  238.  
  239. #  # Pipe through binhex, setting the creator type to JVWR for JPEG Viewer
  240. #  # Note: BinHex is available at <ftp://genome.wi.mit.edu/software/util/BinHex>
  241. # open (BINHEX "| BinHex -t PICT -c JVWR -n 'An Example'"); 
  242. # print BINHEX $data;
  243. # close BINHEX;
  244.  
  245. # # Turn it into a GIF file, using the ppm utilities
  246. # open (GIF, "| picttoppm | ppmtogif -transparent white");
  247. # print GIF $data;
  248. # close GIF;
  249.  
  250.  
  251. # MISCELLANEOUS NOTES
  252. # NOTE: For some reason the various FILL routines don't work as
  253. # advertised.  They are simulated by a PnPat followed by a paint
  254.  
  255. # --------------------------------------------------------------------
  256. # Quickdraw-like functions -- now using PICT2
  257. # --------------------------------------------------------------------
  258. {
  259. package qd;
  260.  
  261. # Directory to look in to find font metric definitions -- change this
  262. # for your installation
  263. $X11FONTS = '/usr/local/X11R5/X11/fonts/bdf';
  264.  
  265. # Apple quickdraw constants
  266. $TIMES = 20;
  267. $HELVETICA = 21;
  268. $COURIER = 22;
  269. $SYMBOL = 23;
  270. $NEWCENTURYSCHOOLBK = 34;
  271.  
  272. $PLAIN = 0;
  273. $BOLD = 1;
  274. $ITALIC = 2;
  275. $UNDERLINE = 4;
  276.  
  277. # Some minimal patterns -- define your own if you like
  278. $GRAY = pack ('n4',0xAA55,0xAA55,0xAA55,0xAA55);
  279. $DKGRAY = pack ('n4',0xDD77,0xDD77,0xDD77,0xDD77);
  280. $LTGRAY = pack ('n4',0x8822,0x8822,0x8822,0x8822);
  281. $WHITE = pack('n4',0x0000,0x0000,0x0000,0x0000);
  282. $BLACK = pack ('n4',0xFFFF,0xFFFF,0xFFFF,0xFFFF);
  283.  
  284. # absolute colors to be used with FgColor/BgColor
  285. # (for better control, use RGBFgColor/RGBBgColor)
  286. $BLACKCOLOR = 33;
  287. $WHITECOLOR = 30;
  288. $REDCOLOR = 209;
  289. $GREENCOLOR = 329;
  290. $BLUECOLOR = 389;
  291. $CYANCOLOR = 269;
  292. $MAGENTACOLOR = 149;
  293. $YELLOWCOLOR = 89;
  294.  
  295. # This defines the header used at the beginning of PICT files:
  296. $PICTHEADER = "\0" x 512;
  297.  
  298. # These are phoney font metrics which we use when no font metrics files are
  299. # around to help us out.
  300. $fudgefactor = 0.55;
  301. $ITALICEXTRA = 0.05;
  302. $BOLDEXTRA = 0.08;
  303.  
  304. # Initial starting values
  305. $textFont = $HELVETICA;
  306. $textSize = 12;
  307. $textFace = $PLAIN;
  308. $rgbfgcolor = pack('n*',0xFFFF,0xFFFF,0xFFFF);
  309. $rgbbgcolor = pack('n*',0,0,0);
  310. $fgcolor = $BLACKCOLOR;
  311. $bgcolor = $WHITECOLOR;
  312. $polySave = undef;
  313.  
  314. $_PnPattern = $BLACK;
  315. $_polyName = "polygon000";
  316.  
  317. sub OpenPicture {               # begin a picture
  318.     local($rect) = @_;
  319.     $currH = $currV = 0;        # current pen position
  320.     $pict = $PICTHEADER;        # the header
  321.     $pict .= pack('n',0);       # size int (placeholder)
  322.     $pict .= $rect;             # pict frame
  323.     $pict .= pack('n',0x0011);  # Type 2 picture
  324.     $pict .= pack('n',0x02FF);  # version number
  325.     $pict .= pack('nC24',0x0C00,0);     # reserved header opcode + 24 bytes of reserved data
  326.     # initialize the font and size
  327.     &TextFont($textFont);
  328.     &TextSize($textSize);
  329.     &TextFace($textFace);
  330. }
  331.  
  332. sub ClosePicture {              # close pict and return it
  333.     $pict .= pack ('n',0x00FF); # end of pict code
  334.     substr($pict,512,2) = pack('n',length($pict) - 512); # fill in length 
  335.     return $pict;
  336. }
  337.  
  338. sub ClipRect {
  339.     local($rect) = @_;
  340.     $pict .= pack('nn',0x0001,0x0A) . $rect;
  341. }
  342.  
  343. sub PenPat {
  344.     local($newpat) = @_;
  345.     return unless $newpat ne $_PnPattern;
  346.     $_PnPattern = $newpat;
  347.     $pict .= pack('n',0x0009) . $_PnPattern;
  348. }
  349.  
  350. sub RGBForeColor {
  351.     local($rgb) = pack('n3',@_);
  352.     return unless $rgb ne $rgbfgcolor;
  353.     $rgbfgcolor = $rgb;
  354.     $pict .= pack('n',0x001A) . $rgbfgcolor;
  355. }
  356.  
  357. sub RGBBackColor {
  358.     local($rgb) = pack('n3',@_);
  359.     return unless $rgb ne $rgbbgcolor;
  360.     $rgbbgcolor = $rgb;
  361.     $pict .= pack('n',0x001B) . $rgbbgcolor;
  362. }
  363.  
  364. sub FgColor {
  365.     local($color) = @_;
  366.     return unless $color != $fgcolor;
  367.     $fgcolor = $color;
  368.     $pict .= pack('nL',0x000E,$color);
  369. }
  370.  
  371. sub BgColor {
  372.     local($color) = @_;
  373.     return unless $color != $bgcolor;
  374.     $bgcolor = $color;
  375.     $pict .= pack('nL',0x000F,$color);
  376. }
  377.  
  378. sub TextFont {
  379.     local($font) = @_;
  380.     $textFont = $font;
  381.     $pict .= pack('nn',0x0003,$font);
  382. }
  383.  
  384. sub TextSize {
  385.     local($size) = @_;
  386.     $textSize = $size;
  387.     $pict .= pack('nn',0x000D,$size);
  388. }
  389.  
  390. sub PenSize {
  391.     local($h,$v) = @_;
  392.     $pict .= pack('nnn',0x0007,$v,$h);
  393. }
  394.  
  395. sub TextFace {
  396.     return if $textFace == @_[0];
  397.     $textFace = @_[0];
  398.     $pict .= pack ('nCC',0x0004,$textFace,0); # (zero added to pad to word)
  399. }
  400.  
  401. sub DrawString {
  402.     local($text) = @_;
  403.     $text .= "\0" x ((length($text) + 1) % 2); # pad text to an odd length
  404.     $pict .= pack('nnnC',0x0028,$currV,$currH,length($text)) . $text;
  405. }
  406.  
  407. # RECTANGLE MANIPULATION ROUTINES.  Note that
  408. # the rectangles are passed by NAME rather than by value,
  409. # in accordance with the MacOS way of doing things.
  410. sub SetRect {
  411.     local(*r,$h1,$v1,$h2,$v2) = @_;
  412.     $r = pack ('n4',$v1,$h1,$v2,$h2);
  413. }
  414.  
  415. sub OffsetRect {
  416.     local(*r,$x,$y) = @_;
  417.     local($v1,$h1,$v2,$h2) = unpack('n4',$r);
  418.     $h1 += $x; $h2 += $x;
  419.     $v1 += $y; $v2 += $y;
  420.     $r = pack ('n4',$v1,$h1,$v2,$h2);    
  421. }
  422.  
  423. sub InsetRect {
  424.     local(*r,$x,$y) = @_;
  425.     local($v1,$h1,$v2,$h2) = unpack('n4',$r);
  426.     $h1 -= int($x/2); $h2 -= int($x/2);
  427.     $v1 -= int($y/2); $v2 -= int($y/2);
  428.     $r = pack ('n4',$v1,$h1,$v2,$h2);    
  429. }
  430.  
  431. # A few utility routine to translate between perl
  432. # arrays and rectangles.
  433.  
  434. # four-element perl array to quickdraw rect structure
  435. sub a2r {
  436.     local($top,$left,$bottom,$right) = @_;
  437.     return pack('n4',$top,$left,$bottom,$right);
  438. }
  439.  
  440. # rectangle to four-element perl array
  441. sub r2a {
  442.     local($rect) = @_;
  443.     return unpack('n4',$rect);
  444. }
  445.  
  446. # associative array in which the keys are 'top','left','bottom','right'
  447. # to quickdraw rect structure
  448. sub aa2r {
  449.     local(%r) = @_;
  450.     return pack('n4',$r{'top'},$r{'left'},$r{'bottom'},$r{'right'});
  451. }
  452.  
  453. # quickdraw rect structure to associative array
  454. sub r2aa {
  455.     local($r) = @_;
  456.     local(%r);
  457.     ($r{'top'},$r{'left'},$r{'bottom'},$r{'right'}) = unpack('n4',$r);
  458.     return %r;
  459. }
  460.  
  461. # LINE DRAWING ROUTINES
  462. sub MoveTo {
  463.     ($currH,$currV) = @_;
  464. }
  465.  
  466. sub Move {
  467.     local($dh,$dv) = @_;
  468.     $currH += $dh;
  469.     $currV += $dv;
  470. }
  471.  
  472. sub LineTo {
  473.     local($h,$v) = @_;
  474.     # Special handling for polygons
  475.     if (defined(@polySave)) {
  476.         &_addVertex(*polySave,$h,$v)
  477.     } else {
  478.         $pict .= pack('nn4',0x0020,$currV,$currH,$v,$h);
  479.     }
  480.     ($currH,$currV) = ($h,$v);
  481. }
  482.  
  483. sub Line {
  484.     local($dh,$dv) = @_;
  485.     # Special handling for polygons
  486.     if (defined(@polySave)) {
  487.         &_addVertex(*polySave,$h,$v);
  488.     } else {
  489.         $pict .= pack('nn4',0x0020,$currV,$currH,$currV+$dv,$currH+$dh);
  490.     }
  491.     ($currH,$currV) = ($currH+$dh,$currV+$dv);
  492. }
  493.  
  494. sub Scale { #use picComment to set laserwriter line scaling
  495.     local($numerator,$denominator)= @_;
  496.     $pict .= pack('nnnn2',0x00A1,182,4,$numerator,$denominator);
  497. }
  498.  
  499.  
  500. # Rectangles
  501. sub FrameRect {
  502.     local($rect) = @_;
  503.     $pict .= pack('n',0x0030) . $rect;
  504. }
  505.  
  506. sub PaintRect {
  507.     local($rect) = @_;
  508.     $pict .= pack('n',0x0031) . $rect;
  509. }
  510.  
  511. sub EraseRect {
  512.     local($rect) = @_;
  513.     $pict .= pack('n',0x0032) . $rect;
  514. }
  515.  
  516. sub InvertRect {
  517.     local($rect) = @_;
  518.     $pict .= pack('n',0x0033) . $rect;
  519. }
  520.  
  521. sub FillRect {
  522.     local($rect,$pattern) = @_;
  523.     local($oldpat) = $_PnPattern;
  524.     &PenPat($pattern);
  525.     &PaintRect($rect);
  526.     &PenPat($oldpat);
  527. }
  528.  
  529. # Ovals
  530. sub FrameOval {
  531.     local($rect) = @_;
  532.     $pict .= pack('n',0x0050) . $rect;
  533. }
  534.  
  535. sub PaintOval {
  536.     local($rect) = @_;
  537.     $pict .= pack('n',0x0051) . $rect;
  538. }
  539.  
  540. sub EraseOval {
  541.     local($rect) = @_;
  542.     $pict .= pack('n',0x0052) . $rect;
  543. }
  544.  
  545. sub InvertOval {
  546.     local($rect) = @_;
  547.     $pict .= pack('n',0x0053) . $rect;
  548. }
  549.  
  550. sub FillOval {
  551.     local($rect,$pattern) = @_;
  552.     local($oldpat) = $_PnPattern;
  553.     &PenPat($pattern);
  554.     &PaintOval($rect);
  555.     &PenPat($oldpat);
  556. }
  557.  
  558. # Arcs
  559. sub FrameArc {
  560.     local($rect,$startAngle,$arcAngle) = @_;
  561.     $pict .= pack('n',0x0060) . $rect;
  562.     $pict .= pack('nn',$startAngle,$arcAngle);
  563. }
  564.  
  565. sub PaintArc {
  566.     local($rect,$startAngle,$arcAngle) = @_;
  567.     $pict .= pack('n',0x0061) . $rect;
  568.     $pict .= pack('nn',$startAngle,$arcAngle);
  569. }
  570.  
  571. sub EraseArc {
  572.     local($rect,$startAngle,$arcAngle) = @_;
  573.     $pict .= pack('n',0x0062) . $rect;
  574.     $pict .= pack('nn',$startAngle,$arcAngle);
  575. }
  576.  
  577. sub InvertArc {
  578.     local($rect,$startAngle,$arcAngle) = @_;
  579.     $pict .= pack('n',0x0063) . $rect;
  580.     $pict .= pack('nn',$startAngle,$arcAngle);
  581. }
  582.  
  583. sub FillArc {
  584.     local($rect,$startAngle,$arcAngle,$pattern) = @_;
  585.     local($oldpat) = $_PnPattern;
  586.     &PenPat($pattern);
  587.     &PaintArc($rect,$startAngle,$arcAngle);
  588.     &PenPat($oldpat);
  589. }
  590.  
  591. # Round rects
  592. sub FrameRoundRect {
  593.     local($rect,$ovalWidth,$ovalHeight) = @_;
  594.     unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
  595.         $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
  596.         $_roundRectCurvature = "$ovalWidth $ovalHeight";
  597.     }
  598.     $pict .= pack('n',0x0040) . $rect;
  599. }
  600.  
  601. sub PaintRoundRect {
  602.     local($rect,$ovalWidth,$ovalHeight) = @_;
  603.     unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
  604.         $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
  605.         $_roundRectCurvature = "$ovalWidth $ovalHeight";
  606.     }
  607.     $pict .= pack('n',0x0041) . $rect;
  608. }
  609.  
  610. sub EraseRoundRect {
  611.     local($rect,$ovalWidth,$ovalHeight) = @_;
  612.     unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
  613.         $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
  614.         $_roundRectCurvature = "$ovalWidth $ovalHeight";
  615.     }
  616.     $pict .= pack('n',0x0042) . $rect;
  617. }
  618.  
  619. sub InvertRoundRect {
  620.     local($rect,$ovalWidth,$ovalHeight) = @_;
  621.     unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
  622.         $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
  623.         $_roundRectCurvature = "$ovalWidth $ovalHeight";
  624.     }
  625.     $pict .= pack('n',0x0043) . $rect;
  626. }
  627.  
  628. sub FillRoundRect {
  629.     local($rect,$ovalWidth,$ovalHeight,$pattern) = @_;
  630.     local($oldpat) = $_PnPattern;
  631.     &PenPat($pattern);
  632.     &PaintRoundRect($rect,$ovalWidth,$ovalHeight);
  633.     &PenPat($oldpat);
  634. }
  635.  
  636. # Polygons -- you are only allowed to create one polygon at a time.
  637. # You will be returned a "handle" which contains the growing polygon
  638. # structure.  The "handle" is actually the NAME of the scalar
  639. sub OpenPoly {
  640.     $_polyName++;
  641.     undef $polySave;            # close one if it was already defined
  642.     *polySave = $_polyName;
  643.     @polySave = (10,0,0,0,0); # initialize it to empty size and rectangle
  644.     return $_polyName;
  645. }
  646.  
  647. sub ClosePoly {
  648.     *polySave = 'scratch';
  649.     undef @polySave;
  650. }
  651.  
  652. # Kill the poly -- really a no-op in perl
  653. sub KillPoly {
  654.     local(*poly) = @_;
  655.     undef @poly;
  656. }
  657.  
  658. # Polygon drawing
  659. sub FramePoly {
  660.     local(*poly) = @_;
  661.     return unless @poly;
  662.     $pict .= pack('n*',0x0070,@poly);
  663. }
  664.  
  665. sub PaintPoly {
  666.     local(*poly) = @_;
  667.     return unless @poly;
  668.     $pict .= pack('n*',0x0071,@poly);
  669. }
  670.  
  671. sub ErasePoly {
  672.     local(*poly) = @_;
  673.     return unless @poly;
  674.     $pict .= pack('n*',0x0072,@poly);
  675. }
  676.  
  677. sub InvertPoly {
  678.     local(*poly) = @_;
  679.     return unless @poly;
  680.     $pict .= pack('n*',0x0073,@poly);
  681. }
  682.  
  683. sub FillPoly {
  684.     local(*poly,$pattern) = @_;
  685.     return unless @poly;
  686.     local($oldpat) = $_PnPattern;
  687.     &PenPat($pattern);
  688.     &PaintPoly(*poly);
  689.     &PenPat($oldpat);
  690. }
  691.  
  692. sub OffsetPoly {
  693.     local(*poly,$dh,$dv) = @_; 
  694.   return unless @poly;
  695.     local($size,@vertices) = @poly;
  696.     local($i);
  697.     for ($i=0;$i<@vertices;$i+=2) {
  698.         $vertices[$i] += $dv;
  699.         $vertices[$i+1] += $dh;
  700.     }
  701.     @poly = ($size,@vertices);
  702. }
  703.  
  704. sub MapPoly {
  705.     local(*poly,$srcRect,$destRect) = @_;
  706.     return unless @poly;
  707.     local($size,@vertices) = @poly;
  708.     local(@src) = unpack('n4',$srcRect);
  709.     local(@dest) = unpack('n4',$destRect);
  710.     local($factorV) = ($dest[2]-$dest[0])/($src[2]-$src[0]);
  711.     local($factorH) = ($dest[3]-$dest[1])/($src[3]-$src[1]);
  712.     for ($i=0;$i<@vertices;$i+=2) {
  713.         $vertices[$i] = int($dest[0] + ($vertices[$i] - $src[0]) * $factorV);
  714.         $vertices[$i+1] = int($dest[1] + ($vertices[$i+1] - $src[1]) * $factorH);
  715.     }
  716.     @poly = ($size,@vertices);
  717. }
  718.  
  719. # A utility routine to add a vertex to the growing polygon structure
  720. # We need to grow both the size of the polygon and increase the bounding
  721. # rectangle.  A special case occurs when we add the first vertex:
  722. # we store both the current position 
  723. sub _addVertex {
  724.     local(*polygon,$h,$v) = @_;
  725.     local($size,$top,$left,$bottom,$right,@vertices) = @polygon;
  726.     # Special case for empty vertices -- add the current point
  727.     unless (@vertices) {
  728.         push(@vertices,$currV,$currH);
  729.         $size += 4;
  730.         $top = $bottom = $currV;
  731.         $left = $right = $currH;
  732.     }
  733.  
  734.     # IM V1 implies that all vertices are stored relative to
  735.     # the first point -- I don't know if this is really the case
  736.     push (@vertices,$v,$h);
  737.  
  738.     $size += 4;
  739.     $top = $v if $v < $top;
  740.     $bottom = $v if $v > $bottom;
  741.     $left = $h if $h < $left;
  742.     $right = $h if $h > $right;
  743.     @polygon=($size,$top,$left,$bottom,$right,@vertices);
  744. }
  745.  
  746. # We try to get the metrics from an X11 bdf font file, if possible.
  747. sub TextWidth {
  748.     local($text) = @_;
  749.  
  750.     # See if we can derive the character widths from a metrics file
  751.     local($face) = 0xFB & $textFace; # underlining don't count
  752.     local($metric_name) = &_getFontMetrics($textFont,$textSize,$face);
  753.     if ($metric_name && (*metrics = $metric_name) && defined(%metrics)) {
  754.         local($length);
  755.         foreach (split('',$text)) {
  756.             $length += $metrics{ord($_)};
  757.         }
  758.         return $length;
  759.     } else {                    # we get here if we don't have any metrics - make it up
  760.         local($extra);
  761.         $extra += $ITALICEXTRA if vec($textFace,$ITALIC,1);
  762.         $extra += $BOLDEXTRA if vec($textFace,$BOLD,1);
  763.         return length($text) * $textSize * ($fudgefactor+$extra);
  764.     }
  765. }
  766.  
  767. # Utility routine to read text widths out of bdf files.  We create a metrics
  768. # array on the fly.  The names of the metrics files are stored in an array
  769. # called _metricsArrays.  We return the name of the array, or undef if inapplicable.
  770. sub _getFontMetrics {
  771.     local($font,$size,$face) = @_;
  772.     local($key) = "$font $size $face";
  773.     return $_metricsArrays{$key} if $_metricsArrays{$key};
  774.  
  775.     # If we get here, we don't have a metrics array to return.  See if we can
  776.     # construct one from a bdf file.
  777.  
  778.     # Don't bother unless this font is defined.
  779.     return undef unless $font_metric_files{$key};
  780.  
  781.     # Don't bother if we tried before and failed
  782.     return undef if $_failed_metric{$key};
  783.  
  784.     # Try to open up the bdf file.  Remember if we fail
  785.     unless (open(BDF,"$font_metric_files{$key}")) {
  786.         $_failed_metric_files{$key}++;
  787.         return undef;
  788.     }
  789.  
  790.     # Wow! We're golden.  Create a new metrics array
  791.     $next_metric++;             # bump up the name
  792.     local(*metrics) = $next_metric; local($char);
  793.     while (<BDF>) {
  794.         next unless /^STARTCHAR/../^ENDCHAR/;
  795.         if (/^ENCODING\s+(\d+)/) { $char = $1; }
  796.         elsif (/^DWIDTH\s+(\d+)/)   { $metrics{$char}=$1; }
  797.     }
  798.     close(BDF);
  799.     
  800.     # Remember the name of the metrics array and return it
  801.     return $_metricsArrays{$key} = $next_metric;
  802. }
  803.  
  804. # Ugly stuff that I want to hide at the bottom
  805.  
  806. # For the purposes of mapping from quickdraw fonts to X11fonts, we define
  807. # the following dictionary:
  808. %font_metric_files = (
  809.                       "22 8 1","$X11FONTS/courB08.bdf",
  810.                       "22 10 1","$X11FONTS/courB10.bdf",
  811.                       "22 12 1","$X11FONTS/courB12.bdf",
  812.                       "22 14 1","$X11FONTS/courB14.bdf",
  813.                       "22 18 1","$X11FONTS/courB18.bdf",
  814.                       "22 24 1","$X11FONTS/courB24.bdf",
  815.                       "22 8 2","$X11FONTS/courO08.bdf",
  816.                       "22 10 2","$X11FONTS/courO10.bdf",
  817.                       "22 12 2","$X11FONTS/courO12.bdf",
  818.                       "22 14 2","$X11FONTS/courO14.bdf",
  819.                       "22 18 2","$X11FONTS/courO18.bdf",
  820.                       "22 24 2","$X11FONTS/courO24.bdf",
  821.                       "22 8 0","$X11FONTS/courR08.bdf",
  822.                       "22 10 0","$X11FONTS/courR10.bdf",
  823.                       "22 12 0","$X11FONTS/courR12.bdf",
  824.                       "22 14 0","$X11FONTS/courR14.bdf",
  825.                       "22 18 0","$X11FONTS/courR18.bdf",
  826.                       "22 24 0","$X11FONTS/courR24.bdf",
  827.                       "21 8 1","$X11FONTS/helvB08.bdf",
  828.                       "21 10 1","$X11FONTS/helvB10.bdf",
  829.                       "21 12 1","$X11FONTS/helvB12.bdf",
  830.                       "21 14 1","$X11FONTS/helvB14.bdf",
  831.                       "21 18 1","$X11FONTS/helvB18.bdf",
  832.                       "21 24 1","$X11FONTS/helvB24.bdf",
  833.                       "21 8 2","$X11FONTS/helvO08.bdf",
  834.                       "21 10 2","$X11FONTS/helvO10.bdf",
  835.                       "21 12 2","$X11FONTS/helvO12.bdf",
  836.                       "21 14 2","$X11FONTS/helvO14.bdf",
  837.                       "21 18 2","$X11FONTS/helvO18.bdf",
  838.                       "21 24 2","$X11FONTS/helvO24.bdf",
  839.                       "21 8 0","$X11FONTS/helvR08.bdf",
  840.                       "21 10 0","$X11FONTS/helvR10.bdf",
  841.                       "21 12 0","$X11FONTS/helvR12.bdf",
  842.                       "21 14 0","$X11FONTS/helvR14.bdf",
  843.                       "21 18 0","$X11FONTS/helvR18.bdf",
  844.                       "21 24 0","$X11FONTS/helvR24.bdf",
  845.                       "20 8 1","$X11FONTS/timB08.bdf",
  846.                       "20 10 1","$X11FONTS/timB10.bdf",
  847.                       "20 12 1","$X11FONTS/timB12.bdf",
  848.                       "20 14 1","$X11FONTS/timB14.bdf",
  849.                       "20 18 1","$X11FONTS/timB18.bdf",
  850.                       "20 24 1","$X11FONTS/timB24.bdf",
  851.                       "20 8 3","$X11FONTS/timBI08.bdf",
  852.                       "20 10 3","$X11FONTS/timBI10.bdf",
  853.                       "20 12 3","$X11FONTS/timBI12.bdf",
  854.                       "20 14 3","$X11FONTS/timBI14.bdf",
  855.                       "20 18 3","$X11FONTS/timBI18.bdf",
  856.                       "20 24 3","$X11FONTS/timBI24.bdf",
  857.                       "20 8 2","$X11FONTS/timI08.bdf",
  858.                       "20 10 2","$X11FONTS/timI10.bdf",
  859.                       "20 12 2","$X11FONTS/timI12.bdf",
  860.                       "20 14 2","$X11FONTS/timI14.bdf",
  861.                       "20 18 2","$X11FONTS/timI18.bdf",
  862.                       "20 24 2","$X11FONTS/timI24.bdf",
  863.                       "20 8 0","$X11FONTS/timR08.bdf",
  864.                       "20 10 0","$X11FONTS/timR10.bdf",
  865.                       "20 12 0","$X11FONTS/timR12.bdf",
  866.                       "20 14 0","$X11FONTS/timR14.bdf",
  867.                       "20 18 0","$X11FONTS/timR18.bdf",
  868.                       "20 24 0","$X11FONTS/timR24.bdf",
  869.                       "34 8 1","$X11FONTS/ncenB08.bdf",
  870.                       "34 10 1","$X11FONTS/ncenB10.bdf",
  871.                       "34 12 1","$X11FONTS/ncenB12.bdf",
  872.                       "34 14 1","$X11FONTS/ncenB14.bdf",
  873.                       "34 18 1","$X11FONTS/ncenB18.bdf",
  874.                       "34 24 1","$X11FONTS/ncenB24.bdf",
  875.                       "34 8 3","$X11FONTS/ncenBI08.bdf",
  876.                       "34 10 3","$X11FONTS/ncenBI10.bdf",
  877.                       "34 12 3","$X11FONTS/ncenBI12.bdf",
  878.                       "34 14 3","$X11FONTS/ncenBI14.bdf",
  879.                       "34 18 3","$X11FONTS/ncenBI18.bdf",
  880.                       "34 24 3","$X11FONTS/ncenBI24.bdf",
  881.                       "34 8 2","$X11FONTS/ncenI08.bdf",
  882.                       "34 10 2","$X11FONTS/ncenI10.bdf",
  883.                       "34 12 2","$X11FONTS/ncenI12.bdf",
  884.                       "34 14 2","$X11FONTS/ncenI14.bdf",
  885.                       "34 18 2","$X11FONTS/ncenI18.bdf",
  886.                       "34 24 2","$X11FONTS/ncenI24.bdf",
  887.                       "34 8 0","$X11FONTS/ncenR08.bdf",
  888.                       "34 10 0","$X11FONTS/ncenR10.bdf",
  889.                       "34 12 0","$X11FONTS/ncenR12.bdf",
  890.                       "34 14 0","$X11FONTS/ncenR14.bdf",
  891.                       "34 18 0","$X11FONTS/ncenR18.bdf",
  892.                       "34 24 0","$X11FONTS/ncenR24.bdf"
  893.                       );
  894. $next_metric = "metrics0000";   # name of our metrics arrays - dynamically allocated
  895.  
  896. 1;
  897. }       #end of package qd
  898.  
  899.