| Current Path : /usr/local/lib/perl5/site_perl/5.8.9/mach/ |
FreeBSD hs32.drive.ne.jp 9.1-RELEASE FreeBSD 9.1-RELEASE #1: Wed Jan 14 12:18:08 JST 2015 root@hs32.drive.ne.jp:/sys/amd64/compile/hs32 amd64 |
| Current File : //usr/local/lib/perl5/site_perl/5.8.9/mach/qd.pl |
#!/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