path: root/Master/tlpkg/tlperl/lib/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