diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/qd.pl')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/qd.pl | 898 |
1 files changed, 898 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/qd.pl b/Master/tlpkg/tlperl.straw/lib/qd.pl new file mode 100755 index 00000000000..aafc8777a20 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/qd.pl @@ -0,0 +1,898 @@ +#!/usr/local/bin/perl + +# $Id: qd.pl,v 1.1.1.1 2001/12/06 23:25:48 lstein Exp $ + +# This is a package of routines that let you create Macintosh +# PICT files from within perl. It implements a subset of Quickdraw +# drawing commands, primarily those related to line drawing, rectangles, +# ovals, polygons, and text. Flagrantly absent are: regions and the +# snazzy color transfer modes. Regions are absent because they were +# more trouble than I had time for, and the transfer modes because I +# never use them. (The latter shouldn't be too hard to add.) Also +# missing are the pixmap commands. If you want to do pixmaps, you +# should be using the ppm utilities. + +# A QUICK TUTORIAL ON QUICKDRAW +# +# Quickdraw is not Postscript. You cannot write routines in it or get +# (any useful) information out of it. Quickdraw pictures are a series of +# drawing commands, concatenated together in a binary format. +# +# A Macintosh picture consists of a header describing the size of the +# picture and its bounding rectangle, followed by a series of drawing +# commands, followed by a termination code. This perl library is +# modeled closely on the way that you would draw a picture on the Mac. +# First you open the picture with the &qd'OpenPicture() command. This +# initializes some data structures. Then you call a series of drawing +# subroutines, such as &qd'TextFont(), &qd'MoveTo(), &qd'DrawString(). +# These routines append their data to the growing (but still private) +# picture. You then close the picture with &qd'ClosePicture. This +# returns a scalar variable containing the binary picture data. + +# RECTANGLES +# +# To open a picture you need to define a rectangle that will serve as +# its frame and will define its drawing area. The rectangle is (of +# course) a binary structure. The following utilities allow you to +# create and manipulate rectangles: +# +# &qd'SetRect(*myRect,left,top,right,bottom); # Set the sides of $myRect +# &qd'OffsetRect(*myRect,deltaH,deltaV); # Shift the rectangle as indicated +# &qd'InsetRect(*myRect,deltaH,deltaV); # Shrink rectangle by size indicated + + +# OPENING A PICTURE +# +# Pass a previously-defined rectangle to the routine OpenPicture. Only one picture +# may be open at a time. The rectangle defines the drawing area in pixels. +# A printer page is 8.5 x 11 inches, at 72 pixels per inch = 612 x 792 pixels. +# +# &qd'OpenPicture($myRect); +# +# You will next very likely want to set the clipping rectangle to the same rectangle +# you used to open the picture with. Clipping rectangles limit quickdraw's drawing +# to the area within the rectangle. Even if you don't use clipping, however, it's a +# good idea to define the rectangle because some drawing programs behave eratically +# when displaying unclipped pictures. +# +# You then issue drawing commands. When you're done you can get the picture data with +# something like $pictData = &qd'ClosePicture; + +# +# SETTING THE FOREGROUND AND BACKGROUND COLORS +# +# The foreground color is the color of the ink when a "frame" or "paint" command +# is given. The background color is the color of the erased area when an "erase" +# command is given. The defaults are black and white. The colors can be changed +# in either of two ways: +# +# 1. The "old" 8-color system: black, white, red, green, blue, cyan, magenta, yellow +# Call the routines &qd'FgColor() and &qd'BgColor() with one of the constants +# $qd'REDCOLOR,$qd'GREENCOLOR, etc. This gives you a limited number of highly +# satured colors. +# +# 2. The new 24-bit color system. Call the routines &qd'RGBForeColor() and +# &qd'RGBBackColor(), passing the routines the red, green and blue components +# of the color. These components are two-byte unsigned integers, so you can choose +# any value between 0x000 and 0xFFFF. Higher is darker, so: +# (0x0000,0x0000,0x0000) = BLACK +# (0xFFFFF,0xFFFF,0xFFFF) = WHITE +# (0xFFFFF,0x0000,0x0000) = PURE RED +# etc. + + +# SETTING THE PATTERN +# +# Like colors, the drawing commands use the current pattern, a 32 row x 32 column +# bit array that defines the pattern of the "ink". +# The default pattern is $qd'BLACK, which is solid black. The only +# other pattern I've defined is $qd'GRAY, which is a 50% checkerboard. You +# might want to define others. +# +# The current pattern is set using &qd'PenPat($myPattern). + + +# LINE DRAWING +# +# Quickdraw has the concept of the "current point" of the pen. Generally +# you move the pen to a point and then start drawing. The next time you draw, +# the pen will be wherever the last drawing command left it. In addition, the +# pen has a width, a pattern and a color. In the below descriptions, +# h=horizontal, v=vertical +# +# &qd'MoveTo(h,v) # Move to indicated coordinates (0,0 is upper left of picture) +# &qd'LineTo(h,v) # Draw from current position to indicated position +# &qd'Line(dh,dv) # Draw a line dh pixels horizontally, dv pixels vertically, +# starting at current position +# &qd'PenSize(h,v) # Set the size of the pen to h pixels wide, v pixels high + + +# PEN SCALING +# +# The original quickdraw was incapable of drawing at higher than the screen resolution, +# so even if the PenSize is set to (1,1) the lines will appear chunky when printed out +# on the laserwriter (which has four times the resolution of the screen). Call +# &qd'Scale(1,4) to fix this problem by shrinking the pen down to a quarter of its +# (1,1) size. +# +# &qd'Scale(numerator,denominator) # Scale the pen by the fraction numerator/denominator + + +# TEXT +# +# &qd'TextFont(fontCode) # Set the current font to indicated code. Currently +# defined fonts are $qd'TIMES, $qd'NEWCENTURYSCHOOLBK, +# $qd'SYMBOL, $qd'HELVETICA, and $qd'COURIER. +# +# &qd'TextSize(size) # Set the current font size (in points). 12 point is typical +# +# &qd'TextFace(attributes) # Set one or more font style attributes. Currently defined +# are $qd'PLAIN, $qd'BOLD, $qd'ITALIC, $qd'UNDERLINE, and +# can be used in combination: +# &qd'TextFace($qd'BOLD + $qd'ITALIC); +# +# &qd'DrawString(string) # Draw the indicated text. It will be drawn from the +# current pen location. Word wrap is NOT supported. +# Rotated text is NOT supported. +# +# &qd'TextWidth(string) # This will return an approximate width for the string +# when it is printed in the current size, font and face. +# Unfortunately, since perl has no access to the Macintosh +# font description tables, the number returned by this +# routine will be wildly inaccurate at best. +# However, if you have X11R5 bdf fonts installed, we look +# in the directory $qd'X11FONTS in order to find a bdf metrics +# font to use. This will give you extremely accurate measurements. +# Please set this variable to whatever is correct for your local +# system. To add more fonts, put them in your bdf font directory +# and update the %qd'font_metric_files array at the bottom of this +# file. It maps a key consisting of the Quickdraw font number, +# font size, and font style (0 for plain, 1 for italic, 2 for bold, +# 3 for both) to the appropriate bdf file. + +# RECTANGLES +# +# Draw rectangles using the routines: +# &qd'FrameRect($myRect); # Draw wire-frame rectangle +# &qd'PaintRect($myRect); # Fill rectangle with current foreground +# color and pattern +# &qd'EraseRect($myRect); # Erase the rectangle (fill with bg color) +# &qd'InvertRect($myRect); # Invert black and white in rectangle + + +# OVALS +# +# Draw ovals using the routines: +# &qd'FrameOval($myRect); # Draw wire-frame oval +# &qd'PaintOval($myRect); # Fill oval with current foreground +# color and pattern +# &qd'EraseOval($myRect); # Erase the oval (fill with bg color) +# &qd'InvertOval($myRect); # Invert black and white in oval +# &qd'FillOval($myRect,$pat); # Fill with specified pattern +# + +# ROUND RECTANGLES +# +# Draw round-cornered rectangles with these routines. They each take an oval radius +# to determine the amount of curvature. Values of 10-20 are typical. +# &qd'FrameRoundRect($myRect,$ovalWidth,$ovalHeight); # wire-frame outline +# &qd'PaintRoundRect($myRect,$ovalWidth,$ovalHeight); # fill with current foreground +# &qd'EraseRoundRect($myRect,$ovalWidth,$ovalHeight); # erase +# &qd'InvertRoundRect($myRect,$ovalWidth,$ovalHeight);# invert +# &qd'FillRoundRect($myRect,$ovalWidth,$ovalHeight,$pat); # fill with specified pattern + +# ARCS +# Draw an arc subtending the specified rectangle. Angles are in degrees and +# start pointing northward and get larger clockwise: +# e.g. PaintArc($r,45,90) gives you a pie wedge from 2 o'clock to 5 o'clock +# &qd'FrameArc($rect,$startAngle,$arcAngle); # wire-frame the arc +# &qd'PaintArc($rect,$startAngle,$arcAngle); # fill with current foreground +# &qd'EraseArc($rect,$startAngle,$arcAngle); # erase arc +# &qd'InvertArc($rect,$startAngle,$arcAngle); # flip white and black +# &qd'FillArc($rect,,$startAngle,$arcAngle,$pat); # fill with specified pattern + +# POLYGONS +# Calling OpenPoly returns the name of a variable in which a growing +# polygon structure will be stored. Once a polygon is opened, all drawing +# commands cease to have an effect on the picture. Instead, all MoveTo, +# LineTo and Line commands accumulate polygon vertices into the data structure. +# Call ClosePoly to stop recording drawing commands. The polygon can now +# be moved, scaled, drawn, filled and erased as many times as wished. Call +# KillPoly to release the memory taken up by the polygon +# $polygon = &qd'OpenPoly; # begin recording drawing commands +# &qd'ClosePoly($polygon); # stop recording drawing commands +# &qd'FramePoly($polygon); # wire-frame the polygon +# &qd'PaintPoly($polygon); # fill with current foreground +# &qd'ErasePoly($polygon); # erase polygon +# &qd'FillPoly($polygon,$pat); # fill polygon with pattern +# &qd'OffsetPoly($polygon,$dh,$dv); # translate poly by dh horizontally, dv vertically +# &qd'MapPoly($polygon,$srcRect,$destRect); # map polygon from coordinate system defined by + # source rectangle to that defined by destination + # rectangle (moving or resizing it as needed) + +# PRINTING OUT THE PICTURE IN A FORM THAT THE MACINTOSH CAN READ +# +# The Mac expects its picture files to begin with 512 bytes of "application specific" +# data. By default the picture data that you get will be proceeded by 512 bytes of +# 0's. If you want something else, or if you just want the picture data, set the +# package variable $qd'PICTHEADER to whatever you desire before calling ClosePicture. +# In order for the picture data to be readable on the Macintosh, the file type must +# be set to 'PICT'. A number of UNIX utilities, including mcvert and BinHex allow +# you to do this. Or you can use the picttoppm utility (part of the netppm suite of +# graphics tools) to translate the file into any format you desire. + +# A WORKING EXAMPLE +# require "qd.pl"; +# &qd'SetRect(*myRect,0,0,500,500); # Define a 500 pixel square +# &qd'OpenPicture($myRect); # Begin defining the picture +# &qd'ClipRect($myRect); # Always a good idea +# &qd'MoveTo(5,5); # Move the pen to a starting point +# &qd'LineTo(400,400); # A diagonal line +# &qd'TextFont($qd'COURIER); # Set the font +# &qd'MoveTo(50,20); # Move the pen to a new starting point +# &qd'DrawString("Hello there!"); # Friendly greeting +# &qd'SetRect(*myRect,80,80,250,250); # New rectangle +# &qd'RGBForeColor(0x0000,0x0000,0xFFFF); # Set the color to blue +# &qd'PaintRect($myRect); # Fill rectangle with that color +# $data = &qd'ClosePicture; # Close picture and retrieve data + +# # Pipe through binhex, setting the creator type to JVWR for JPEG Viewer +# # Note: BinHex is available at <ftp://genome.wi.mit.edu/software/util/BinHex> +# open (BINHEX "| BinHex -t PICT -c JVWR -n 'An Example'"); +# print BINHEX $data; +# close BINHEX; + +# # Turn it into a GIF file, using the ppm utilities +# open (GIF, "| picttoppm | ppmtogif -transparent white"); +# print GIF $data; +# close GIF; + + +# MISCELLANEOUS NOTES +# NOTE: For some reason the various FILL routines don't work as +# advertised. They are simulated by a PnPat followed by a paint + +# -------------------------------------------------------------------- +# Quickdraw-like functions -- now using PICT2 +# -------------------------------------------------------------------- +{ +package qd; + +# Directory to look in to find font metric definitions -- change this +# for your installation +$X11FONTS = '/usr/local/X11R5/X11/fonts/bdf'; + +# Apple quickdraw constants +$TIMES = 20; +$HELVETICA = 21; +$COURIER = 22; +$SYMBOL = 23; +$NEWCENTURYSCHOOLBK = 34; + +$PLAIN = 0; +$BOLD = 1; +$ITALIC = 2; +$UNDERLINE = 4; + +# Some minimal patterns -- define your own if you like +$GRAY = pack ('n4',0xAA55,0xAA55,0xAA55,0xAA55); +$DKGRAY = pack ('n4',0xDD77,0xDD77,0xDD77,0xDD77); +$LTGRAY = pack ('n4',0x8822,0x8822,0x8822,0x8822); +$WHITE = pack('n4',0x0000,0x0000,0x0000,0x0000); +$BLACK = pack ('n4',0xFFFF,0xFFFF,0xFFFF,0xFFFF); + +# absolute colors to be used with FgColor/BgColor +# (for better control, use RGBFgColor/RGBBgColor) +$BLACKCOLOR = 33; +$WHITECOLOR = 30; +$REDCOLOR = 209; +$GREENCOLOR = 329; +$BLUECOLOR = 389; +$CYANCOLOR = 269; +$MAGENTACOLOR = 149; +$YELLOWCOLOR = 89; + +# This defines the header used at the beginning of PICT files: +$PICTHEADER = "\0" x 512; + +# These are phoney font metrics which we use when no font metrics files are +# around to help us out. +$fudgefactor = 0.55; +$ITALICEXTRA = 0.05; +$BOLDEXTRA = 0.08; + +# Initial starting values +$textFont = $HELVETICA; +$textSize = 12; +$textFace = $PLAIN; +$rgbfgcolor = pack('n*',0xFFFF,0xFFFF,0xFFFF); +$rgbbgcolor = pack('n*',0,0,0); +$fgcolor = $BLACKCOLOR; +$bgcolor = $WHITECOLOR; +$polySave = undef; + +$_PnPattern = $BLACK; +$_polyName = "polygon000"; + +sub OpenPicture { # begin a picture + local($rect) = @_; + $currH = $currV = 0; # current pen position + $pict = $PICTHEADER; # the header + $pict .= pack('n',0); # size int (placeholder) + $pict .= $rect; # pict frame + $pict .= pack('n',0x0011); # Type 2 picture + $pict .= pack('n',0x02FF); # version number + $pict .= pack('nC24',0x0C00,0); # reserved header opcode + 24 bytes of reserved data + # initialize the font and size + &TextFont($textFont); + &TextSize($textSize); + &TextFace($textFace); +} + +sub ClosePicture { # close pict and return it + $pict .= pack ('n',0x00FF); # end of pict code + substr($pict,512,2) = pack('n',length($pict) - 512); # fill in length + return $pict; +} + +sub ClipRect { + local($rect) = @_; + $pict .= pack('nn',0x0001,0x0A) . $rect; +} + +sub PenPat { + local($newpat) = @_; + return unless $newpat ne $_PnPattern; + $_PnPattern = $newpat; + $pict .= pack('n',0x0009) . $_PnPattern; +} + +sub RGBForeColor { + local($rgb) = pack('n3',@_); + return unless $rgb ne $rgbfgcolor; + $rgbfgcolor = $rgb; + $pict .= pack('n',0x001A) . $rgbfgcolor; +} + +sub RGBBackColor { + local($rgb) = pack('n3',@_); + return unless $rgb ne $rgbbgcolor; + $rgbbgcolor = $rgb; + $pict .= pack('n',0x001B) . $rgbbgcolor; +} + +sub FgColor { + local($color) = @_; + return unless $color != $fgcolor; + $fgcolor = $color; + $pict .= pack('nL',0x000E,$color); +} + +sub BgColor { + local($color) = @_; + return unless $color != $bgcolor; + $bgcolor = $color; + $pict .= pack('nL',0x000F,$color); +} + +sub TextFont { + local($font) = @_; + $textFont = $font; + $pict .= pack('nn',0x0003,$font); +} + +sub TextSize { + local($size) = @_; + $textSize = $size; + $pict .= pack('nn',0x000D,$size); +} + +sub PenSize { + local($h,$v) = @_; + $pict .= pack('nnn',0x0007,$v,$h); +} + +sub TextFace { + return if $textFace == @_[0]; + $textFace = @_[0]; + $pict .= pack ('nCC',0x0004,$textFace,0); # (zero added to pad to word) +} + +sub DrawString { + local($text) = @_; + $text .= "\0" x ((length($text) + 1) % 2); # pad text to an odd length + $pict .= pack('nnnC',0x0028,$currV,$currH,length($text)) . $text; +} + +# RECTANGLE MANIPULATION ROUTINES. Note that +# the rectangles are passed by NAME rather than by value, +# in accordance with the MacOS way of doing things. +sub SetRect { + local(*r,$h1,$v1,$h2,$v2) = @_; + $r = pack ('n4',$v1,$h1,$v2,$h2); +} + +sub OffsetRect { + local(*r,$x,$y) = @_; + local($v1,$h1,$v2,$h2) = unpack('n4',$r); + $h1 += $x; $h2 += $x; + $v1 += $y; $v2 += $y; + $r = pack ('n4',$v1,$h1,$v2,$h2); +} + +sub InsetRect { + local(*r,$x,$y) = @_; + local($v1,$h1,$v2,$h2) = unpack('n4',$r); + $h1 -= int($x/2); $h2 -= int($x/2); + $v1 -= int($y/2); $v2 -= int($y/2); + $r = pack ('n4',$v1,$h1,$v2,$h2); +} + +# A few utility routine to translate between perl +# arrays and rectangles. + +# four-element perl array to quickdraw rect structure +sub a2r { + local($top,$left,$bottom,$right) = @_; + return pack('n4',$top,$left,$bottom,$right); +} + +# rectangle to four-element perl array +sub r2a { + local($rect) = @_; + return unpack('n4',$rect); +} + +# associative array in which the keys are 'top','left','bottom','right' +# to quickdraw rect structure +sub aa2r { + local(%r) = @_; + return pack('n4',$r{'top'},$r{'left'},$r{'bottom'},$r{'right'}); +} + +# quickdraw rect structure to associative array +sub r2aa { + local($r) = @_; + local(%r); + ($r{'top'},$r{'left'},$r{'bottom'},$r{'right'}) = unpack('n4',$r); + return %r; +} + +# LINE DRAWING ROUTINES +sub MoveTo { + ($currH,$currV) = @_; +} + +sub Move { + local($dh,$dv) = @_; + $currH += $dh; + $currV += $dv; +} + +sub LineTo { + local($h,$v) = @_; + # Special handling for polygons + if (defined(@polySave)) { + &_addVertex(*polySave,$h,$v) + } else { + $pict .= pack('nn4',0x0020,$currV,$currH,$v,$h); + } + ($currH,$currV) = ($h,$v); +} + +sub Line { + local($dh,$dv) = @_; + # Special handling for polygons + if (defined(@polySave)) { + &_addVertex(*polySave,$h,$v); + } else { + $pict .= pack('nn4',0x0020,$currV,$currH,$currV+$dv,$currH+$dh); + } + ($currH,$currV) = ($currH+$dh,$currV+$dv); +} + +sub Scale { #use picComment to set laserwriter line scaling + local($numerator,$denominator)= @_; + $pict .= pack('nnnn2',0x00A1,182,4,$numerator,$denominator); +} + + +# Rectangles +sub FrameRect { + local($rect) = @_; + $pict .= pack('n',0x0030) . $rect; +} + +sub PaintRect { + local($rect) = @_; + $pict .= pack('n',0x0031) . $rect; +} + +sub EraseRect { + local($rect) = @_; + $pict .= pack('n',0x0032) . $rect; +} + +sub InvertRect { + local($rect) = @_; + $pict .= pack('n',0x0033) . $rect; +} + +sub FillRect { + local($rect,$pattern) = @_; + local($oldpat) = $_PnPattern; + &PenPat($pattern); + &PaintRect($rect); + &PenPat($oldpat); +} + +# Ovals +sub FrameOval { + local($rect) = @_; + $pict .= pack('n',0x0050) . $rect; +} + +sub PaintOval { + local($rect) = @_; + $pict .= pack('n',0x0051) . $rect; +} + +sub EraseOval { + local($rect) = @_; + $pict .= pack('n',0x0052) . $rect; +} + +sub InvertOval { + local($rect) = @_; + $pict .= pack('n',0x0053) . $rect; +} + +sub FillOval { + local($rect,$pattern) = @_; + local($oldpat) = $_PnPattern; + &PenPat($pattern); + &PaintOval($rect); + &PenPat($oldpat); +} + +# Arcs +sub FrameArc { + local($rect,$startAngle,$arcAngle) = @_; + $pict .= pack('n',0x0060) . $rect; + $pict .= pack('nn',$startAngle,$arcAngle); +} + +sub PaintArc { + local($rect,$startAngle,$arcAngle) = @_; + $pict .= pack('n',0x0061) . $rect; + $pict .= pack('nn',$startAngle,$arcAngle); +} + +sub EraseArc { + local($rect,$startAngle,$arcAngle) = @_; + $pict .= pack('n',0x0062) . $rect; + $pict .= pack('nn',$startAngle,$arcAngle); +} + +sub InvertArc { + local($rect,$startAngle,$arcAngle) = @_; + $pict .= pack('n',0x0063) . $rect; + $pict .= pack('nn',$startAngle,$arcAngle); +} + +sub FillArc { + local($rect,$startAngle,$arcAngle,$pattern) = @_; + local($oldpat) = $_PnPattern; + &PenPat($pattern); + &PaintArc($rect,$startAngle,$arcAngle); + &PenPat($oldpat); +} + +# Round rects +sub FrameRoundRect { + local($rect,$ovalWidth,$ovalHeight) = @_; + unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") { + $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth); + $_roundRectCurvature = "$ovalWidth $ovalHeight"; + } + $pict .= pack('n',0x0040) . $rect; +} + +sub PaintRoundRect { + local($rect,$ovalWidth,$ovalHeight) = @_; + unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") { + $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth); + $_roundRectCurvature = "$ovalWidth $ovalHeight"; + } + $pict .= pack('n',0x0041) . $rect; +} + +sub EraseRoundRect { + local($rect,$ovalWidth,$ovalHeight) = @_; + unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") { + $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth); + $_roundRectCurvature = "$ovalWidth $ovalHeight"; + } + $pict .= pack('n',0x0042) . $rect; +} + +sub InvertRoundRect { + local($rect,$ovalWidth,$ovalHeight) = @_; + unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") { + $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth); + $_roundRectCurvature = "$ovalWidth $ovalHeight"; + } + $pict .= pack('n',0x0043) . $rect; +} + +sub FillRoundRect { + local($rect,$ovalWidth,$ovalHeight,$pattern) = @_; + local($oldpat) = $_PnPattern; + &PenPat($pattern); + &PaintRoundRect($rect,$ovalWidth,$ovalHeight); + &PenPat($oldpat); +} + +# Polygons -- you are only allowed to create one polygon at a time. +# You will be returned a "handle" which contains the growing polygon +# structure. The "handle" is actually the NAME of the scalar +sub OpenPoly { + $_polyName++; + undef $polySave; # close one if it was already defined + *polySave = $_polyName; + @polySave = (10,0,0,0,0); # initialize it to empty size and rectangle + return $_polyName; +} + +sub ClosePoly { + *polySave = 'scratch'; + undef @polySave; +} + +# Kill the poly -- really a no-op in perl +sub KillPoly { + local(*poly) = @_; + undef @poly; +} + +# Polygon drawing +sub FramePoly { + local(*poly) = @_; + return unless @poly; + $pict .= pack('n*',0x0070,@poly); +} + +sub PaintPoly { + local(*poly) = @_; + return unless @poly; + $pict .= pack('n*',0x0071,@poly); +} + +sub ErasePoly { + local(*poly) = @_; + return unless @poly; + $pict .= pack('n*',0x0072,@poly); +} + +sub InvertPoly { + local(*poly) = @_; + return unless @poly; + $pict .= pack('n*',0x0073,@poly); +} + +sub FillPoly { + local(*poly,$pattern) = @_; + return unless @poly; + local($oldpat) = $_PnPattern; + &PenPat($pattern); + &PaintPoly(*poly); + &PenPat($oldpat); +} + +sub OffsetPoly { + local(*poly,$dh,$dv) = @_; + return unless @poly; + local($size,@vertices) = @poly; + local($i); + for ($i=0;$i<@vertices;$i+=2) { + $vertices[$i] += $dv; + $vertices[$i+1] += $dh; + } + @poly = ($size,@vertices); +} + +sub MapPoly { + local(*poly,$srcRect,$destRect) = @_; + return unless @poly; + local($size,@vertices) = @poly; + local(@src) = unpack('n4',$srcRect); + local(@dest) = unpack('n4',$destRect); + local($factorV) = ($dest[2]-$dest[0])/($src[2]-$src[0]); + local($factorH) = ($dest[3]-$dest[1])/($src[3]-$src[1]); + for ($i=0;$i<@vertices;$i+=2) { + $vertices[$i] = int($dest[0] + ($vertices[$i] - $src[0]) * $factorV); + $vertices[$i+1] = int($dest[1] + ($vertices[$i+1] - $src[1]) * $factorH); + } + @poly = ($size,@vertices); +} + +# A utility routine to add a vertex to the growing polygon structure +# We need to grow both the size of the polygon and increase the bounding +# rectangle. A special case occurs when we add the first vertex: +# we store both the current position +sub _addVertex { + local(*polygon,$h,$v) = @_; + local($size,$top,$left,$bottom,$right,@vertices) = @polygon; + # Special case for empty vertices -- add the current point + unless (@vertices) { + push(@vertices,$currV,$currH); + $size += 4; + $top = $bottom = $currV; + $left = $right = $currH; + } + + # IM V1 implies that all vertices are stored relative to + # the first point -- I don't know if this is really the case + push (@vertices,$v,$h); + + $size += 4; + $top = $v if $v < $top; + $bottom = $v if $v > $bottom; + $left = $h if $h < $left; + $right = $h if $h > $right; + @polygon=($size,$top,$left,$bottom,$right,@vertices); +} + +# We try to get the metrics from an X11 bdf font file, if possible. +sub TextWidth { + local($text) = @_; + + # See if we can derive the character widths from a metrics file + local($face) = 0xFB & $textFace; # underlining don't count + local($metric_name) = &_getFontMetrics($textFont,$textSize,$face); + if ($metric_name && (*metrics = $metric_name) && defined(%metrics)) { + local($length); + foreach (split('',$text)) { + $length += $metrics{ord($_)}; + } + return $length; + } else { # we get here if we don't have any metrics - make it up + local($extra); + $extra += $ITALICEXTRA if vec($textFace,$ITALIC,1); + $extra += $BOLDEXTRA if vec($textFace,$BOLD,1); + return length($text) * $textSize * ($fudgefactor+$extra); + } +} + +# Utility routine to read text widths out of bdf files. We create a metrics +# array on the fly. The names of the metrics files are stored in an array +# called _metricsArrays. We return the name of the array, or undef if inapplicable. +sub _getFontMetrics { + local($font,$size,$face) = @_; + local($key) = "$font $size $face"; + return $_metricsArrays{$key} if $_metricsArrays{$key}; + + # If we get here, we don't have a metrics array to return. See if we can + # construct one from a bdf file. + + # Don't bother unless this font is defined. + return undef unless $font_metric_files{$key}; + + # Don't bother if we tried before and failed + return undef if $_failed_metric{$key}; + + # Try to open up the bdf file. Remember if we fail + unless (open(BDF,"$font_metric_files{$key}")) { + $_failed_metric_files{$key}++; + return undef; + } + + # Wow! We're golden. Create a new metrics array + $next_metric++; # bump up the name + local(*metrics) = $next_metric; local($char); + while (<BDF>) { + next unless /^STARTCHAR/../^ENDCHAR/; + if (/^ENCODING\s+(\d+)/) { $char = $1; } + elsif (/^DWIDTH\s+(\d+)/) { $metrics{$char}=$1; } + } + close(BDF); + + # Remember the name of the metrics array and return it + return $_metricsArrays{$key} = $next_metric; +} + +# Ugly stuff that I want to hide at the bottom + +# For the purposes of mapping from quickdraw fonts to X11fonts, we define +# the following dictionary: +%font_metric_files = ( + "22 8 1","$X11FONTS/courB08.bdf", + "22 10 1","$X11FONTS/courB10.bdf", + "22 12 1","$X11FONTS/courB12.bdf", + "22 14 1","$X11FONTS/courB14.bdf", + "22 18 1","$X11FONTS/courB18.bdf", + "22 24 1","$X11FONTS/courB24.bdf", + "22 8 2","$X11FONTS/courO08.bdf", + "22 10 2","$X11FONTS/courO10.bdf", + "22 12 2","$X11FONTS/courO12.bdf", + "22 14 2","$X11FONTS/courO14.bdf", + "22 18 2","$X11FONTS/courO18.bdf", + "22 24 2","$X11FONTS/courO24.bdf", + "22 8 0","$X11FONTS/courR08.bdf", + "22 10 0","$X11FONTS/courR10.bdf", + "22 12 0","$X11FONTS/courR12.bdf", + "22 14 0","$X11FONTS/courR14.bdf", + "22 18 0","$X11FONTS/courR18.bdf", + "22 24 0","$X11FONTS/courR24.bdf", + "21 8 1","$X11FONTS/helvB08.bdf", + "21 10 1","$X11FONTS/helvB10.bdf", + "21 12 1","$X11FONTS/helvB12.bdf", + "21 14 1","$X11FONTS/helvB14.bdf", + "21 18 1","$X11FONTS/helvB18.bdf", + "21 24 1","$X11FONTS/helvB24.bdf", + "21 8 2","$X11FONTS/helvO08.bdf", + "21 10 2","$X11FONTS/helvO10.bdf", + "21 12 2","$X11FONTS/helvO12.bdf", + "21 14 2","$X11FONTS/helvO14.bdf", + "21 18 2","$X11FONTS/helvO18.bdf", + "21 24 2","$X11FONTS/helvO24.bdf", + "21 8 0","$X11FONTS/helvR08.bdf", + "21 10 0","$X11FONTS/helvR10.bdf", + "21 12 0","$X11FONTS/helvR12.bdf", + "21 14 0","$X11FONTS/helvR14.bdf", + "21 18 0","$X11FONTS/helvR18.bdf", + "21 24 0","$X11FONTS/helvR24.bdf", + "20 8 1","$X11FONTS/timB08.bdf", + "20 10 1","$X11FONTS/timB10.bdf", + "20 12 1","$X11FONTS/timB12.bdf", + "20 14 1","$X11FONTS/timB14.bdf", + "20 18 1","$X11FONTS/timB18.bdf", + "20 24 1","$X11FONTS/timB24.bdf", + "20 8 3","$X11FONTS/timBI08.bdf", + "20 10 3","$X11FONTS/timBI10.bdf", + "20 12 3","$X11FONTS/timBI12.bdf", + "20 14 3","$X11FONTS/timBI14.bdf", + "20 18 3","$X11FONTS/timBI18.bdf", + "20 24 3","$X11FONTS/timBI24.bdf", + "20 8 2","$X11FONTS/timI08.bdf", + "20 10 2","$X11FONTS/timI10.bdf", + "20 12 2","$X11FONTS/timI12.bdf", + "20 14 2","$X11FONTS/timI14.bdf", + "20 18 2","$X11FONTS/timI18.bdf", + "20 24 2","$X11FONTS/timI24.bdf", + "20 8 0","$X11FONTS/timR08.bdf", + "20 10 0","$X11FONTS/timR10.bdf", + "20 12 0","$X11FONTS/timR12.bdf", + "20 14 0","$X11FONTS/timR14.bdf", + "20 18 0","$X11FONTS/timR18.bdf", + "20 24 0","$X11FONTS/timR24.bdf", + "34 8 1","$X11FONTS/ncenB08.bdf", + "34 10 1","$X11FONTS/ncenB10.bdf", + "34 12 1","$X11FONTS/ncenB12.bdf", + "34 14 1","$X11FONTS/ncenB14.bdf", + "34 18 1","$X11FONTS/ncenB18.bdf", + "34 24 1","$X11FONTS/ncenB24.bdf", + "34 8 3","$X11FONTS/ncenBI08.bdf", + "34 10 3","$X11FONTS/ncenBI10.bdf", + "34 12 3","$X11FONTS/ncenBI12.bdf", + "34 14 3","$X11FONTS/ncenBI14.bdf", + "34 18 3","$X11FONTS/ncenBI18.bdf", + "34 24 3","$X11FONTS/ncenBI24.bdf", + "34 8 2","$X11FONTS/ncenI08.bdf", + "34 10 2","$X11FONTS/ncenI10.bdf", + "34 12 2","$X11FONTS/ncenI12.bdf", + "34 14 2","$X11FONTS/ncenI14.bdf", + "34 18 2","$X11FONTS/ncenI18.bdf", + "34 24 2","$X11FONTS/ncenI24.bdf", + "34 8 0","$X11FONTS/ncenR08.bdf", + "34 10 0","$X11FONTS/ncenR10.bdf", + "34 12 0","$X11FONTS/ncenR12.bdf", + "34 14 0","$X11FONTS/ncenR14.bdf", + "34 18 0","$X11FONTS/ncenR18.bdf", + "34 24 0","$X11FONTS/ncenR24.bdf" + ); +$next_metric = "metrics0000"; # name of our metrics arrays - dynamically allocated + +1; +} #end of package qd + |