Prima::PS::Fonts - PostScript device fonts metrics

	use Prima;
	use Prima::PS::Fonts;

#
#  Copyright (c) 1997-2002 The Protein Laboratory, University of Copenhagen
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
#  Created by Dmitry Karasik <dk@plab.ku.dk>
#  $Id$
#
package Prima::PS::Fonts;


use strict;
use Prima;
use Prima::Utils;
use Prima::PS::Encodings;
use vars qw(%files %enum_families $defaultFontName 
	$variablePitchName $fixedPitchName $symbolFontName);

my %cache;
$defaultFontName   = 'Helvetica';
$variablePitchName = 'Helvetica';
$fixedPitchName    = 'Courier';
$symbolFontName    = 'Symbol';

sub query_metrics
{
	my $f = $_[0];
	my ( $file, $name, $family);
	if ( exists $enum_families{$f}) {
		$family = $f;
		$f = $enum_families{$f};
	} 
	$name = $f;
	if ( exists $files{$f}) {
		$file = $files{ $f};
		unless ( defined $family) {
		# pick up family
			for ( keys %enum_families) {
				$family = $_, last if $f =~ m[^$_];
			}
		}
		$family = $defaultFontName unless defined $family;
	} else {
		$family = $defaultFontName;
		$name   = $enum_families{$family};
		$file   = $files{ $name};
	}
	
	return $cache{$file} if exists $cache{$file};

	my $defFN = $files{ $defaultFontName};
	my $fx = Prima::Utils::find_image( $file);

	unless ( $fx) {
		if ( $name eq $defaultFontName) {
			warn("Prima::PS::Fonts: can't load default font\n");
			return undef;
		} else {
			warn("Broken Prima::PS::Fonts installation: $name not found\n"), 
				return query_metrics( $defaultFontName) 
		}   
	}   
	unless ( open F, $fx) {
		warn( "Prima::PS::Fonts: cannot open file: $fx\n") ;
		return undef if $f eq $defaultFontName;
		return query_metrics( $defaultFontName);
	}
	{
		local $/;
		my @ra;
		my $z = '@ra = ' . <F>;
		close F;
		eval($z);
		
		if ( $@ || scalar(@ra) < 2) {
			warn( "Prima::PS::Fonts: invalid file: $fx\n");
			return undef if $name eq $defaultFontName;
			return query_metrics( $defaultFontName);
		}
		$ra[1]-> {docname}  = $name;
		$ra[1]-> {name}     = $name;
		$ra[1]-> {family}   = $family;
		$ra[1]-> {charheight} = $ra[1]-> {height};
		$cache{$file} = $ra[1];
	}
	return $cache{$file};
}

sub enum_fonts
{
	my ( $family, $encoding) = @_;
	my @names;
	$family   = undef if defined $family   && !length $family;
	$encoding = undef if defined $encoding && !length $encoding;
	if ( defined $family) {
		return [] unless defined $enum_families{$family};
		for ( keys %enum_families) {
			push @names, $_ if $_ eq $family;
		}
	} else {
		@names = keys %enum_families;
	}
	my @ret;
	for ( @names) {
		my %x = %{query_metrics( $_)};
		$x{name} = $x{family};
		delete $x{docname};
		delete $x{chardata};
		$_ = \%x;
		my $latin = exists( $Prima::PS::Encodings::files{$x{encoding}});
		next if defined($encoding) && (
			$latin ? 
			! exists $Prima::PS::Encodings::files{$encoding} :
			($x{encoding} ne $encoding)
			);
		if ( !defined $family && !defined $encoding) {
			$x{encodings} = $latin ?  [ Prima::PS::Encodings::unique ] : [ $x{encoding} ];
		}
		if ( 
			defined $family && 
			!defined $encoding && 
			exists( $Prima::PS::Encodings::files{$x{encoding}})
		) {
			push @ret, map { 
				my %n = %x;
				$n{encoding} = $_;
				\%n;
			} Prima::PS::Encodings::unique;
		} else {
			$_-> {encoding} = $encoding if defined( $encoding) && $latin;
			push @ret, $_;
		}
	}
	return \@ret;
}

sub enum_family
{
	my $family = $_[0];
	my @names;
	return unless defined $enum_families{$family};
	for ( keys %files) {
		push @names, $_ if m/^$family/;
	}
	return @names;
}


sub font_pick
{
	my ( $src, $dest, %options) = @_;
	my $bySize = exists( $src-> {size}) && !exists( $src-> {height});
	$dest = Prima::Drawable-> font_match( $src, $dest, 0);

	$dest-> {encoding} = '' 
		if ( ! exists ( $Prima::PS::Encodings::fontspecific{ $dest-> {encoding}}) && 
			! exists ( $Prima::PS::Encodings::files{ $dest-> {encoding}}));

	# find name
	my $m1   = query_metrics( $dest-> {name});

	# find encoding
	if ( length $dest-> {encoding}) { 
		if ( defined $dest-> {encoding}) {
			if ( exists ( $Prima::PS::Encodings::files{ $dest-> {encoding}} ) && 
				! exists ( $Prima::PS::Encodings::files{ $m1-> {encoding}})) {
					$m1 = query_metrics( $fixedPitchName);
					$dest-> {encoding} = $m1-> {encoding};
					$dest-> {name}     = $m1-> {name};
					$dest-> {family}   = $m1-> {family};
			} elsif (
				exists ( $Prima::PS::Encodings::fontspecific{ $dest-> {encoding}}) &&
			! exists ( $Prima::PS::Encodings::fontspecific{ $m1-> {encoding}}) 
			) {
				$m1 = query_metrics( $symbolFontName);
				$dest-> {encoding} = $m1-> {encoding};
				$dest-> {name}     = $m1-> {name};
				$dest-> {family}   = $m1-> {family};
			}
		}
	} else {
		$dest-> {encoding} = $m1-> {encoding};
	}
	
	# find pitch
	if ( $dest-> {pitch} != fp::Default && $dest-> {pitch} != $m1-> {pitch}) {
		if ( $dest-> {pitch} == fp::Variable) {
			$m1 = query_metrics( $variablePitchName);
		} else {
			$m1 = query_metrics( $fixedPitchName);
		}
	}
	
	# get all family members
	my @famx = map { query_metrics( $_) } enum_family( $m1-> {family});
	
	# find style
	my $m2; 
	for ( @famx) { # exact match
		$m2 = $_, last if $_-> {style} == $dest-> {style};
	}
	unless ( $m2) { # second pass
		my $maxDiff = 1000;
		my ( $italic, $bold) = (
			( $dest-> {style} & fs::Italic) ? 1 : 0, 
			($dest-> {style} & fs::Bold) ? 1 :0
		);
		for ( @famx) {
			my ( $i, $b) = (
				( $_-> {style} & fs::Italic) ? 1 : 0, 
				( $_-> {style} & fs::Bold) ? 1 : 0
			);
			my $diff = (( $i == $italic) ? 0 : 2) + (( $b == $bold) ? 0 : 1);
			$m2 = $_, $maxDiff = $diff if $diff < $maxDiff;
		}
	}
	$m2 = $m1 unless defined $m2;

	# scale dimensions
	my $res = $options{resolution} ? $options{resolution} : $m2-> {yDeviceRes};
	if ( $bySize) {
		$dest-> {height} = int( $dest-> {size} * $res / 72.27 + 0.5); 
	} else {
		$dest-> {size} = int( $dest-> {height} * 72.27 / $res + 0.5);
	}
	my $a = $dest-> {height} / $m2-> {height};
	my %muls = %$m2;
	my $charheight = $muls{height};
	my $du   = $dest-> {style} & fs::Underlined;
	my $ds   = $dest-> {style} & fs::StruckOut;
	my $dw   = $dest-> {width};
	$muls{$_} = int ( $muls{$_} * $a + 0.5) for
	qw( height ascent descent width maximalWidth internalLeading externalLeading);
	delete $muls{size};
	my $enc = $dest-> {encoding};
	$dest-> {$_}     = $muls{$_} for keys %muls;
	$dest-> {encoding} = $enc;
	$dest-> {style} |= fs::Underlined if $du;
	$dest-> {style} |= fs::StruckOut if $ds;
	$dest-> {width} = $dw if $dw != 0;
	$dest-> {charheight} = $charheight; 
	return $dest;
}

%files = map { $_ => "PS/fonts/$_" } (
	'Bookman-Demi'                ,
	'Bookman-DemiItalic'          ,
	'Bookman-Light'               ,
	'Bookman-LightItalic'         ,
	'Courier'                     ,
	'Courier-Oblique'             ,
	'Courier-Bold'                ,
	'Courier-BoldOblique'         ,
	'AvantGarde-Book'             ,
	'AvantGarde-BookOblique'      ,
	'AvantGarde-Demi'             ,
	'AvantGarde-DemiOblique'      ,
	'Helvetica'                   ,
	'Helvetica-Oblique'           ,
	'Helvetica-Bold'              ,
	'Helvetica-BoldOblique'       ,
	'Helvetica-Narrow'            ,
	'Helvetica-Narrow-Oblique'    ,
	'Helvetica-Narrow-Bold'       ,
	'Helvetica-Narrow-BoldOblique',
	'Palatino-Roman'              ,
	'Palatino-Italic'             ,
	'Palatino-Bold'               ,
	'Palatino-BoldItalic'         ,
	'NewCenturySchlbk-Roman'      ,
	'NewCenturySchlbk-Italic'     ,
	'NewCenturySchlbk-Bold'       ,
	'NewCenturySchlbk-BoldItalic' ,
	'Times-Roman'                 ,
	'Times-Italic'                ,
	'Times-Bold'                  ,
	'Times-BoldItalic'            ,
	'Symbol'                      ,
	'ZapfChancery-MediumItalic'   , 
	'ZapfDingbats'                ,
);


# The keys of %enum_families are only font names, - in Prima terms.
# The only problem that the family field is always the same as the 
# font name

%enum_families = (
	'Bookman'                => 'Bookman-Light',
	'Courier'                => 'Courier',
	'AvantGarde'             => 'AvantGarde-Book',
	'Helvetica'              => 'Helvetica',
	'Helvetica-Narrow'       => 'Helvetica-Narrow',
	'Palatino'               => 'Palatino-Roman',
	'NewCenturySchlbk'       => 'NewCenturySchlbk-Roman',
	'Times'                  => 'Times-Roman',
	'Symbol'                 => 'Symbol', 
	'ZapfChancery'           => 'ZapfChancery-MediumItalic',
	'ZapfDingbats'           => 'ZapfDingbats',
);

1;

__END__