Viewing file:  fontdlg.pl (25.44 KB) -rw-r--r--
Select action/file-type:
 (+) |  (+) |  (+) | Code (+) | Session (+) |  (+) | SDB (+) |  (+) |  (+) |  (+) |  (+) |  (+) |
package fontdlg;
=pod
=head1 NAME
examples/fontdlg.pl - An alternate font selection window
=head1 FEATURES
Demonstrates Prima font API and its usage.
Note the inability to set a font with a particular size and width factor in one
call ( in $re_sample sub ). A font size and width is accepted, however.
Tests the Prima font interface implementation. A constant pain here is the
correspondence of a font metrics before and after the font load. X is known
for the problem, that can not be solved easily and without certain compromises.
See L<prima-gp-problems> manpage for details.
Note the left-mouse drag effect from a font screen widget.
=cut
use strict;
use warnings;
use Carp;
use Prima;
use Prima::Application name => "Font Dialog";
use Prima qw(Lists Sliders Buttons Dialog::FileDialog);
use Encode;
# try to use perl5.8 glyph names
eval "use charnames qw(:full);";
my $use_charnames = $@ ? 0 : 1;
sub run {
my $w = 0;
my @fontItems = ();
my %fontList = ();
my $displayRes;
my $fs = 0;
my $fd = 0;
my $fpitch = fp::Default;
my $fvector = fv::Default;
my $fwidth = 0;
our %languages = (
'aa' => q(Afar),
'ab' => q(Abkhazia),
'af' => q(Afrikaans),
'ak' => q(Akan),
'am' => q(Amharic),
'an' => q(Aragonese),
'ar' => q(Arabic),
'as' => q(Assamese),
'ast' => q(Asturian),
'av' => q(Avaric),
'ay' => q(Aymara),
'az-az' => q(Azerbaijani in Azerbaijan),
'az-ir' => q(Azerbaijani in Iran),
'ba' => q(Bashkir),
'be' => q(Byelorussian),
'ber-dz' => q(Berber in Algeria),
'ber-ma' => q(Berber in Morocco),
'bg' => q(Bulgarian),
'bh' => q(Bihari),
'bho' => q(Bhojpuri),
'bi' => q(Bislama),
'bin' => q(Edo or Bini),
'bm' => q(Bambara),
'bn' => q(Bengali),
'bo' => q(Tibetan),
'br' => q(Breton),
'brx' => q(Bodo),
'bs' => q(Bosnian),
'bua' => q(Buriat),
'byn' => q(Blin),
'ca' => q(Catalan),
'ce' => q(Chechen),
'ch' => q(Chamorro),
'chm' => q(Mari),
'chr' => q(Cherokee),
'co' => q(Corsican),
'crh' => q(Crimean Tatar),
'cs' => q(Czech),
'csb' => q(Kashubian),
'cu' => q(Old Church Slavonic),
'cv' => q(Chuvash),
'cy' => q(Welsh),
'da' => q(Danish),
'de' => q(German),
'doi' => q(Dogri),
'dv' => q(Divehi),
'dz' => q(Dzongkha),
'ee' => q(Ewe),
'el' => q(Greek),
'en' => q(English),
'eo' => q(Esperanto),
'es' => q(Spanish),
'et' => q(Estonian),
'eu' => q(Basque),
'fa' => q(Persian),
'fat' => q(Fanti),
'ff' => q(Fulah),
'fi' => q(Finnish),
'fil' => q(Filipino),
'fj' => q(Fijian),
'fo' => q(Faroese),
'fr' => q(French),
'fur' => q(Friulian),
'fy' => q(Frisian),
'ga' => q(Irish),
'gd' => q(Scots Gaelic),
'gez' => q(Ethiopic),
'gl' => q(Galician),
'gn' => q(Guaraní),
'gu' => q(Gujarati),
'gv' => q(Manx Gaelic),
'ha' => q(Hausa),
'haw' => q(Hawaiian),
'he' => q(Hebrew),
'hi' => q(Hindi),
'hne' => q(Chhattisgarhi),
'ho' => q(Hiri Motu),
'hr' => q(Croatian),
'hsb' => q(Upper Sorbian),
'ht' => q(Haitian),
'hu' => q(Hungarian),
'hy' => q(Armenian),
'hz' => q(Herero),
'ia' => q(Interlingua),
'id' => q(Indonesian),
'ie' => q(Interlingue),
'ig' => q(Igbo),
'ii' => q(Sichuan Yi),
'ik' => q(Inupiaq),
'io' => q(Ido),
'is' => q(Icelandic),
'it' => q(Italian),
'iu' => q(Inuktitut),
'ja' => q(Coverage from JIS X 0208),
'jv' => q(Javanese),
'ka' => q(Georgian),
'kaa' => q(Kara-Kalpak),
'kab' => q(Kabyle),
'ki' => q(Kikuyu),
'kj' => q(Kuanyama),
'kk' => q(Kazakh),
'kl' => q(Greenlandic),
'km' => q(Central Khmer),
'kn' => q(Kannada),
'ko' => q(Korean),
'kok' => q(Kokani),
'kr' => q(Kanuri),
'ks' => q(Kashmiri),
'ku-am' => q(Kurdish in Armenia),
'ku-iq' => q(Kurdish in Iraq),
'ku-ir' => q(Kurdish in Iran),
'ku-tr' => q(Kurdish in Turkey),
'kum' => q(Kumyk),
'kv' => q(Komi),
'kw' => q(Cornish),
'kwm' => q(Kwambi),
'ky' => q(Kirgiz),
'la' => q(Latin),
'lah' => q(Lahnda),
'lb' => q(Luxembourgish),
'lez' => q(Lezghian),
'lg' => q(Ganda),
'li' => q(Limburgan),
'ln' => q(Lingala),
'lo' => q(Lao),
'lt' => q(Lithuanian),
'lv' => q(Latvian),
'mai' => q(Maithili),
'mg' => q(Malagasy),
'mh' => q(Marshallese),
'mi' => q(Maori),
'mk' => q(Macedonian),
'ml' => q(Malayalam),
'mn-cn' => q(Mongolian in China),
'mn-mn' => q(Mongolian in Mongolia),
'mni' => q(Maniputi),
'mo' => q(Moldavian),
'mr' => q(Marathi),
'ms' => q(Malay),
'mt' => q(Maltese),
'my' => q(Burmese),
'na' => q(Nauru),
'nb' => q(Norwegian Bokmål),
'nds' => q(Low Saxon),
'ne' => q(Nepali),
'ng' => q(Ndonga),
'nl' => q(Dutch),
'nn' => q(Norwegian Nynorsk),
'no' => q(Norwegian),
'nqo' => q(N'Ko),
'nr' => q(Ndebele, South),
'nso' => q(Northern Sotho),
'nv' => q(Navajo),
'ny' => q(Chichewa),
'oc' => q(Occitan),
'om' => q(Oromo or Galla),
'or' => q(Oriya),
'os' => q(Ossetic),
'ota' => q(Ottoman Turkish),
'pa' => q(Panjabi),
'pa-pk' => q(Panjabi),
'pap-an' => q(Papiamento in Netherlands Antilles),
'pap-aw' => q(Papiamento in Aruba),
'pes' => q(Western Farsi),
'pl' => q(Polish),
'prs' => q(Dari),
'ps-af' => q(Pashto in Afghanistan),
'ps-pk' => q(Pashto in Pakistan),
'pt' => q(Portuguese),
'qu' => q(Quechua),
'quz' => q(Cusco Quechua),
'rm' => q(Rhaeto-Romance),
'rn' => q(Rundi),
'ro' => q(Romanian),
'ru' => q(Russian),
'rw' => q(Kinyarwanda),
'sa' => q(Sanskrit),
'sah' => q(Yakut),
'sat' => q(Santali),
'sc' => q(Sardinian),
'sco' => q(Scots),
'sd' => q(Sindhi),
'se' => q(North Sámi),
'sel' => q(Selkup),
'sg' => q(Sango),
'sh' => q(Serbo-Croatian),
'shs' => q(Secwepemctsin),
'si' => q(Sinhala),
'sid' => q(Sidamo),
'sk' => q(Slovak),
'sl' => q(Slovenian),
'sm' => q(Samoan),
'sma' => q(South Sámi),
'smj' => q(Lule Sámi),
'smn' => q(Inari Sámi),
'sms' => q(Skolt Sámi),
'sn' => q(Shona),
'so' => q(Somali),
'sq' => q(Albanian),
'sr' => q(Serbian),
'ss' => q(Swati),
'st' => q(Sotho, Southern),
'su' => q(Sundanese),
'sv' => q(Swedish),
'sw' => q(Swahili),
'syr' => q(Syriac),
'ta' => q(Tamil),
'te' => q(Telugu),
'tg' => q(Tajik),
'th' => q(Thai),
'ti-er' => q(Eritrean Tigrinya),
'ti-et' => q(Ethiopian Tigrinya),
'tig' => q(Tigre),
'tk' => q(Turkmen),
'tl' => q(Tagalog),
'tn' => q(Tswana),
'to' => q(Tonga),
'tr' => q(Turkish),
'ts' => q(Tsonga),
'tt' => q(Tatar),
'tw' => q(Twi),
'ty' => q(Tahitian),
'tyv' => q(Tuvinian),
'ug' => q(Uyghur),
'uk' => q(Ukrainian),
'ur' => q(Urdu),
'uz' => q(Uzbek),
've' => q(Venda),
'vi' => q(Vietnamese),
'vo' => q(Volapük),
'vot' => q(Votic),
'wa' => q(Walloon),
'wal' => q(Wolaitta),
'wen' => q(Sorbian languages),
'wo' => q(Wolof),
'xh' => q(Xhosa),
'yap' => q(Yapese),
'yi' => q(Yiddish),
'yo' => q(Yoruba),
'za' => q(Zhuang),
'zh-cn' => q(Chinese),
'zh-hk' => q(Chinese Hong Kong Supplementary Character Set),
'zh-mo' => q(Chinese in Macau),
'zh-sg' => q(Chinese in Singapore),
'zh-tw' => q(Chinese),
'zu' => q(Zulu),
);
my $re_sample = sub {
return if $w-> {exampleFontSet};
my $fid = $w-> NameList-> get_item_text( $w-> NameList-> focusedItem);
my $fn = ($fid =~ /not defined/) ? 'Default' : $fontList{$fid}{name};
$w-> {exampleFontSet} = 1;
my $i = $w-> SizeList-> focusedItem;
my $enc = $w-> Encoding-> get_item_text( $w-> Encoding-> focusedItem);
$enc = '' if $enc eq '(any)';
$w-> Example-> lock;
my %font = (
name => $fn,
size => $w-> SizeList-> get_item_text( $i),
style => $fs,
direction => $fd,
pitch => $fpitch,
vector => $fvector,
encoding => $enc,
);
$w-> Example-> font( %font,
width => 0,
);
$w-> Example-> font( %font,
width => $w-> Example-> font-> width * $fwidth,
) if $fwidth;
$w-> Example-> unlock;
$w-> {exampleFontSet} = undef;
};
my $lastSizeSel = 12;
my $lastEncSel = "";
my $re_size = sub {
my $name_changed = $_[0];
my $fid = $w-> NameList-> get_item_text( $w-> NameList-> focusedItem);
my $fn = ($fid =~ /not defined/) ? undef : $fontList{$fid}{name};
my @sizes = ();
my $current_encoding = ( $lastEncSel eq '(any)' || $name_changed) ? '' : $lastEncSel;
my @list = $fn ?
@{$::application-> fonts( $fn, $name_changed ? '' : $current_encoding)} :
({vector => 1});
if ( $name_changed) {
my %enc;
my @enc_items;
for ( grep { defined } map { $_-> {encoding}} @list) {
next if $enc{$_};
push ( @enc_items, $_ );
$enc{$_} = 1;
}
unshift @enc_items, "(any)";
my $found = 0;
my $i = 0;
for ( @enc_items) {
$found = $i, last if $_ eq $lastEncSel;
$i++;
}
$w-> Encoding-> set_items( \@enc_items);
$w-> Encoding-> set_focused_item( $found);
}
for ( @list)
{
next if length( $current_encoding) && ( $current_encoding ne $_-> {encoding});
if ( $_-> { vector})
{
@sizes = qw( 8 9 10 11 12 14 16 18 20 22 24 26 28 32 48 72);
last;
} else {
push ( @sizes, $_-> {size});
}
}
my %k = map { $_ => 1 } @sizes;
@sizes = sort { $a <=> $b } keys %k;
@sizes = (10) unless scalar @sizes;
my $i;
my $found = 0;
for ( $i = 0; $i < scalar @sizes; $i++)
{
if ( $sizes[$i] == $lastSizeSel)
{
$found = 1;
last;
}
}
unless ( $found)
{
for ( $i = 0; $i < scalar @sizes; $i++)
{
last if ( $sizes[$i] > $lastSizeSel);
}
$i-- if $i = scalar @sizes;
}
$w-> SizeList-> set_items(\@sizes);
$w-> SizeList-> set_focused_item($i);
};
$w = Prima::MainWindow-> create( text => "Font Window",
origin => [ 200, 200],
size => [ 500, 590],
designScale => [7,16],
borderStyle => bs::Dialog,
);
sub create_info_window
{
my $w = shift;
my $f = $w-> Example-> font;
my $ww = Prima::Window-> create(
size => [ 500, $f-> height * 3 + $f-> externalLeading + $f-> descent + 450 ],
font => $f,
text => $f-> size.'.['.$f-> height.'x'.$f-> width.']'.$f-> name,
onPaint => sub {
my ( $self, $p) = @_;
my @size = $p-> size;
$p-> clear;
$p-> font-> direction(0);
my $m = $p-> get_font;
my $xtext = Encode::decode('latin1', "\x{c5}Mg");
my $s = $size[1] - $m-> {height} - $m-> {externalLeading} - 20;
my $w = $p-> get_text_width($xtext) + 66;
$p-> textOutBaseline(1);
$p-> text_out($xtext, 20, $s);
my $cachedFacename = $p-> font-> name;
my $hsf = $p-> font-> height / 6;
$hsf = 10 if $hsf < 10;
$p-> font-> set(
height => $hsf,
style => fs::Italic,
name => '',
encoding => '',
);
$p-> line( 2, $s, $w, $s);
$p-> textOutBaseline(0);
$p-> text_out( "Baseline", $w - 8, $s);
my $sd = $s - $m-> {descent};
$p-> line( 2, $sd, $w, $sd);
$p-> text_out( "Descent", $w - 8, $sd);
$sd = $s + $m-> {ascent};
$p-> line( 2, $sd, $w, $sd);
$p-> text_out( "Ascent", $w - 8, $sd);
$sd = $s + $m-> {ascent} + $m-> {externalLeading};
if ( $m-> {ascent} > 4) {
$p-> line( $w - 12, $s + 1, $w - 12, $s + $m-> {ascent});
$p-> line( $w - 12, $s + $m-> {ascent}, $w - 14, $s + $m-> {ascent} - 2);
$p-> line( $w - 12, $s + $m-> {ascent}, $w - 10, $s + $m-> {ascent} - 2);
}
if ( ($m-> {ascent}-$m-> {internalLeading}) > 4) {
my $pt = $m-> {ascent}-$m-> {internalLeading};
$p-> line( $w - 16, $s + 1, $w - 16, $s + $pt);
$p-> line( $w - 16, $s + $pt, $w - 18, $s + $pt - 2);
$p-> line( $w - 16, $s + $pt, $w - 14, $s + $pt - 2);
}
if ( $m-> {descent} > 4) {
$p-> line( $w - 13, $s - 1, $w - 13, $s - $m-> {descent});
$p-> line( $w - 13, $s - $m-> {descent}, $w - 15, $s - $m-> {descent} + 2);
$p-> line( $w - 13, $s - $m-> {descent}, $w - 11, $s - $m-> {descent} + 2)
}
my $str;
$p-> text_out( "External Leading", 2, $sd);
$p-> line( 2, $sd, $w, $sd);
$sd = $s + $m-> {ascent} - $m-> {internalLeading};
$str = "Point size in device units";
$p-> text_out( $str, $w - 16 - $p-> get_text_width( $str), $sd);
$p-> linePattern( lp::Dash);
$p-> line( 2, $sd, $w, $sd);
$p-> font-> set(
height => 16,
pitch => fp::Fixed,
);
my $fh = $p-> font-> height;
$sd = $s - $m-> {descent} - $fh * 3;
$p-> text_out( 'nominal size : '.$m-> {size}, 2, $sd); $sd -= $fh;
$p-> text_out( 'cell height : '.$m-> {height }, 2, $sd); $sd -= $fh;
$p-> text_out( 'average width : '.$m-> {width }, 2, $sd); $sd -= $fh;
$p-> text_out( 'ascent : '.$m-> {ascent }, 2, $sd); $sd -= $fh;
$p-> text_out( 'descent : '.$m-> {descent }, 2, $sd); $sd -= $fh;
$p-> text_out( 'weight : '.$m-> {weight }, 2, $sd); $sd -= $fh;
$p-> text_out( 'internal leading : '.$m-> {internalLeading}, 2, $sd); $sd -= $fh;
$p-> text_out( 'external leading : '.$m-> {externalLeading}, 2, $sd); $sd -= $fh;
$p-> text_out( 'maximal width : '.$m-> {maximalWidth}, 2, $sd); $sd -= $fh;
$p-> text_out( 'vector : '.$m-> {vector}, 2, $sd); $sd -= $fh;
$p-> text_out( 'horizontal dev.res. : '.$m-> {xDeviceRes}, 2, $sd); $sd -= $fh;
$p-> text_out( 'vertical dev.res. : '.$m-> {yDeviceRes}, 2, $sd); $sd -= $fh;
$p-> text_out( 'first char : '.$m-> {firstChar}, 2, $sd); $sd -= $fh;
$p-> text_out( 'last char : '.$m-> {lastChar }, 2, $sd); $sd -= $fh;
$p-> text_out( 'break char : '.$m-> {breakChar}, 2, $sd); $sd -= $fh;
$p-> text_out( 'default char : '.$m-> {defaultChar}, 2, $sd); $sd -= $fh;
$p-> text_out( 'family : '.$m-> {family }, 2, $sd); $sd -= $fh;
$p-> text_out( 'face name : '.$cachedFacename, 2, $sd); $sd -= $fh;
unless ( $p-> Languages-> visible ) {
my $l = $p-> Languages;
my $em = $p->get_text_width('m');
$l->origin( 2 + $em * 22, $sd );
$l->font( $p-> font );
$l->size( $em * 30, $fh);
$l->show;
}
$p-> text_out( 'languages : ', 2, $sd); $sd -= $fh;
},
);
$ww-> insert( ComboBox =>
name => 'Languages',
style => cs::DropDownList,
items => [
sort map { $languages{$_} // $_ }
@{$ww->get_font_languages // ['<none>']}
],
growMode => gm::GrowLoY,
visible => 0,
text => '',
);
my %wf = ( %$f, direction => 0 );
my @gsize= ( $f->maximalWidth + 10 , $f->height + 10 );
my $glyph = $ww-> insert( Widget =>
text => ' ',
font => \%wf,
size => \@gsize,
origin => [ $ww-> width - $gsize[0] - 10, $ww-> height - $gsize[1] - 10 ],
growMode => gm::GrowLoX|gm::GrowLoY,
backColor => cl::White,
#buffered => 1,
name => 'Glyph',
textOutBaseline => 1,
onPaint => sub {
my $self = shift;
$self-> clear;
my $C = $self-> text;
my ( $a, $b, $c ) = @{ $self->get_font_abc( ord($C), ord($C), utf8::is_utf8($C)) };
my ( $d, $e, $f ) = @{ $self->get_font_def( ord($C), ord($C), utf8::is_utf8($C)) };
my $w = (( $a < 0 ) ? 0 : $a) + $b + (( $c < 0 ) ? 0 : $c);
my $h = (( $d < 0 ) ? 0 : $d) + $e + (( $f < 0 ) ? 0 : $f);
$w = ( $self-> width - $w ) / 2;
$h = ( $self-> height - $h ) / 2;
$self-> translate($w, $h);
my $dx = 0;
my $dy = 0;
$dx -= $a if $a < 0;
$dy -= $d if $d < 0;
my $fh = $self-> font->height;
$self-> text_out( $C, $dx, $dy + $self->font-> descent);
$dx = abs($a);
$dy = abs($d);
$self-> linePattern(lp::Dot);
$self-> line($dx, 0, $dx, $self->height);
$dx = (( $a < 0 ) ? 0 : $a) + $b + (( $c < 0 ) ? 0 : $c) - abs($c);
$self-> line($dx, 0, $dx, $self->height);
$self-> line(-$w, $self->font->descent, $self->width, $self->font->descent);
$self-> line(0, $dy, $self->width, $dy);
$dy = (( $d < 0 ) ? 0 : $d) + $e + (( $f < 0 ) ? 0 : $f) - abs($f);
$self-> line(0, $dy, $self->width, $dy);
$self-> linePattern(lp::Solid);
$self-> color(cl::LightRed);
my $path = $self-> new_path;
$path->translate( -$a, 0 ) if $a < 0;
$path-> text( $C, baseline => 0 );
$path->stroke;
},
);
my @ranges = ([]);
for ( @{$w-> Example-> get_font_ranges}) {
( 2 > scalar @{$ranges[-1]}) ?
push @{$ranges[-1]}, $_ :
push @ranges, [$_];
}
@ranges = sort { $a->[0] <=> $b-> [0] } @ranges;
my %charmap;
my $count = 0;
for ( @ranges) {
$charmap{$count++} = $_ for $$_[0] .. $$_[1];
}
my $ih = int($f-> height * 1.5);
my $l = $ww-> insert( AbstractListViewer =>
origin => [0,0],
size => [$ww-> width, $ww-> height - $f-> height - $f-> externalLeading - $f-> descent - 360],
growMode => gm::Client,
font => $f,
multiColumn => 1,
itemWidth => $ih,
itemHeight => $ih,
gridColor => cl::Back,
hScroll => 1,
onSelectItem => sub {
my ( $self, $item, $sel) = @_;
if ( defined( my $c = $charmap{$item->[0]} )) {
my $pretty = sprintf( "0x%x", $c);
if ( $use_charnames) {
my $x = charnames::viacode($c);
$pretty .= " - $x" if defined $x;
}
$self-> hint( $pretty );
$self-> hintVisible(1);
$glyph->text(chr($c));
$glyph->repaint;
}
},
onDrawItem => sub {
my ($self, $canvas, $itemIndex, $x, $y, $x2, $y2, $selected, $focused, $prelight) = @_;
$canvas-> line( $x, $y, $x2, $y);
$canvas-> line( $x2+1, $y, $x2+1, $y2);
my @cs;
if ( $focused || $prelight) {
@cs = ( $canvas-> color, $canvas-> backColor);
my $fo = $focused ? $canvas-> hiliteColor : $canvas-> color ;
my $bk = $focused ? $canvas-> hiliteBackColor : $canvas-> backColor ;
$canvas-> set( color => $fo, backColor => $bk );
}
$self-> draw_item_background( $canvas, $x, $y + 1, $x2, $y2, $prelight );
if ( defined( my $c = $charmap{$itemIndex} )) {
$canvas-> text_out( chr($c), $x + $ih / 4, $y + $ih / 4);
}
$canvas-> set( color => $cs[0], backColor => $cs[1]) if $focused || $prelight;
},
);
$l-> count( $count);
$ww-> select;
return $ww;
}
$displayRes = ($w-> resolution)[1];
my $load_fonts = sub {
%fontList = ();
@fontItems = ("<not defined>");
for ( sort { $a-> {name} cmp $b-> {name}} @{$::application-> fonts})
{
$fontList{$_-> {name}} = $_;
push ( @fontItems, $_-> {name});
}
};
$load_fonts->();
$w-> insert( ListBox =>
name => "NameList",
origin => [25, 25],
size => [ 225, 315],
items => [@fontItems],
onSelectItem => sub {
&$re_size(1);
&$re_sample;
},
);
$w-> insert( ListBox =>
name => 'SizeList',
origin => [ 270, 230],
size => [ 200, 110],
onSelectItem => sub {
$lastSizeSel = $_[0]-> get_item_text( $_[0]-> focusedItem);
&$re_sample;
},
);
$w-> insert( ListBox =>
origin => [ 270, 160],
size => [ 200, 55],
name => 'Encoding',
onSelectItem => sub {
$lastEncSel = $_[0]-> get_item_text( $_[0]-> focusedItem);
&$re_size(0);
&$re_sample;
},
);
my $scaling = $::application->font->height / ($w->designScale)[1];
$w-> insert( Button =>
origin => [ 24, 348],
size => [ 32, 32],
text => 'B',
name => 'Bold',
selectable => 0,
font => {
height => 20 * $scaling,
style => fs::Bold,
},
checkable => 1,
onClick => sub {
$fs = ( $fs & fs::Bold ? $fs & ~fs::Bold : $fs | fs::Bold);
&$re_sample;
},
);
$w-> insert( Button =>
origin => [ 60, 348],
size => [ 32, 32],
text => 'I',
name => 'Italic',
selectable => 0,
font => {
height => 20 * $scaling,
style => fs::Italic,
},
checkable => 1,
onClick => sub {
$fs = (( $fs & fs::Italic) ? ($fs & ~fs::Italic) : ($fs | fs::Italic));
&$re_sample;
},
);
$w-> insert( Button =>
origin => [ 96, 348],
size => [ 32, 32],
text => 'U',
selectable => 0,
name => 'Underlined',
font => {
height => 20 * $scaling,
style => fs::Underlined,
},
checkable => 1,
onClick => sub {
$fs = (( $fs & fs::Underlined) ? ($fs & ~fs::Underlined) : ($fs | fs::Underlined));
&$re_sample;
},
);
$w-> insert( Button =>
origin => [ 142, 348],
size => [ 32, 32],
text => 'i',
selectable => 0,
name => 'Info',
color => cl::Blue,
font => { height => 28 * $scaling, style => fs::Bold },
onClick => sub { create_info_window($w) },
);
$w-> insert( Button =>
origin => [ 180, 348],
size => [ 32, 32],
text => '+',
hint => 'Add new font',
selectable => 0,
name => 'Load',
font => { height => 20 * $scaling },
onClick => sub {
my $d = Prima::Dialog::FileDialog-> new;
my $f = $d->execute;
return unless defined $f;
my $error = '';
local $SIG{__WARN__} = sub { $error = ": @_" };
unless ($::application->load_font($d->fileName)) {
$error =~ s/at examples.*//;
return Prima::message("Error loading font$error");
}
$load_fonts->();
$w->NameList->items(\@fontItems);
}
);
my $csl = $w-> insert( CircularSlider =>
origin => [ 370, 348],
size => [ 100, 100],
name => 'Angle',
buttons => 0,
font => {size => 5},
min => -180,
max => 180,
scheme => ss::Axis,
increment => 30,
step => 10,
onChange => sub { $fd = $_[0]-> value; &$re_sample; },
);
$csl-> insert( Button =>
origin => [ 10, 10],
size => [ 14, 14],
text => 'o',
onClick => sub { $_[0]-> owner-> value(0); },
);
my $rg = $w-> insert( RadioGroup =>
origin => [ 25, 525],
size => [ 445, 58],
name => 'Pitch',
);
$rg-> insert( Radio =>
name => 'Default',
origin => [ 15, 5],
onClick => sub { $fpitch = fp::Default; &$re_sample; },
checked => 1,
);
$rg-> insert( Radio =>
name => 'Fixed',
origin => [ 160, 5],
onClick => sub { $fpitch = fp::Fixed; &$re_sample; },
font => { style => fs::Bold, pitch => fp::Fixed},
);
$rg-> insert( Radio =>
name => 'Variable',
origin => [ 305, 5],
font => { style => fs::Bold|fs::Italic, pitch => fp::Variable},
onClick => sub { $fpitch = fp::Variable; &$re_sample; },
);
my $rg2 = $w-> insert( RadioGroup =>
origin => [ 25, 460],
size => [ 445, 58],
name => 'Vector',
);
$rg2-> insert( Radio =>
name => 'Default',
origin => [ 15, 5],
onClick => sub { $fvector = fv::Default; &$re_sample; },
checked => 1,
);
$rg2-> insert( Radio =>
name => 'Bitmap',
origin => [ 160, 5],
onClick => sub { $fvector = fv::Bitmap; &$re_sample; },
font => { style => fs::Bold, pitch => fp::Fixed}, # yes, fixed
);
$rg2-> insert( Radio =>
name => 'Outline',
origin => [ 305, 5],
font => { vector => fv::Outline, style => fs::Italic },
onClick => sub { $fvector = fv::Outline; &$re_sample; },
);
$w-> insert( Slider =>
name => 'Stretcher',
origin => [ 25, 382],
size => [ 225, 58],
vertical => 0,
min => -5,
max => 5,
scheme => ss::Axis,
step => 0.5,
increment=> 5,
value => 0,
onChange => sub {
$fwidth = $_[0]-> value;
if ( $fwidth > 0) {
$fwidth += 1;
} elsif ( $fwidth < 0) {
$fwidth = -1 / ( $fwidth - 1);
}
&$re_sample;
},
);
$w-> insert( Button =>
origin => [ 130, 440],
size => [ 14, 14],
text => 'o',
font => {size => 5},
onClick => sub { $w-> Stretcher-> value(0); },
);
$w-> insert( Widget =>
name => 'Example',
origin => [ 270, 25],
size => [ 200, 120],
backColor => cl::White,
onPaint => sub {
my ($fore, $back, $x, $y) =
($_[0]-> color, $_[0]-> backColor, $_[1]-> width, $_[1]-> height);
$_[1]-> color( $back);
$_[1]-> bar( 0, 0, $x, $y);
$_[1]-> color( $fore);
my $m = $_[1]-> get_font;
my $probe;
my @ranges = @{$_[1]-> get_font_ranges};
my $vec = '';
my ($i,$j);
my ($latin,$non_latin)=('','');
RANGES: for ( $i = 0; $i < @ranges; $i += 2) {
for ( $j = $ranges[$i]; $j < $ranges[$i+1]; $j++) {
$latin .= chr($j) if $j > 45 && $j < 128;
$non_latin .= chr($j) if $j > 256 && ( !$use_charnames || (charnames::viacode($j) || '') !~
/(space|punctuation|mark|accent|point|combining|modifier)/i);
last RANGES if length($latin) > 32 || length($non_latin) > 32;
}
}
$probe = (length($latin) > 32) ? $_[1]-> font-> size.".".$_[1]-> font-> name : substr($non_latin, 0, 12);
my @box = @{$_[1]-> get_text_box( $probe)};
pop @box;
pop @box;
my $width = $_[1]-> get_text_width( $probe);
my ( $ox, $oy) = (( $x - $width) / 2, ( $y - $_[1]-> font-> height) / 2);
$box[$_] += $ox for 0,2,4,6;
$box[$_] += $oy for 1,3,5,7;
@box[4,5,6,7] = @box[6,7,4,5];
$_[1]-> color( cl::Yellow);
$_[1]-> fillpoly(\@box);
$_[1]-> color( cl::Black);
$_[1]-> text_out( $probe, $ox, $oy);
},
onFontChanged => sub {
unless ( defined $w-> {exampleFontSet})
{
my $font = $_[0]-> font;
my $name = $font-> name;
my $size = $font-> size;
$fs = $font-> style;
$fd = $font-> direction;
my ( $i, $j);
for ( $i = 0; $i < scalar @fontItems; $i++)
{
last if $name eq $fontItems[ $i];
}
$w-> NameList-> set_focused_item( $i);
my @sizes = @{$w-> SizeList-> items};
for ( $j = 0; $j < scalar @sizes; $j++)
{
last if $size == $sizes[ $j];
}
$w-> SizeList-> set_focused_item( $j);
$w-> Bold-> checked( $fs & fs::Bold);
$w-> Italic-> checked( $fs & fs::Italic);
$w-> Underlined-> checked( $fs & fs::Underlined);
$w-> Angle-> value( $fd);
}
},
onMouseDown => sub {
return if $_[0]-> {drag};
$_[0]-> {drag} = 1;
$_[0]-> capture(1);
$_[0]-> pointer( cr::Invalid)
},
onMouseUp => sub {
return unless $_[0]-> {drag};
$_[0]-> capture(0);
$_[0]-> {drag} = 0;
$_[0]-> pointer( cr::Default);
my $x = $::application-> get_widget_from_point(
$_[0]-> client_to_screen( $_[3], $_[4])
);
return unless $x;
$x-> font( $_[0]-> font);
},
);
&$re_size(1);
&$re_sample;
#$w->NameList->focusedItem($#fontItems);
#create_info_window($w)->size(800, 800);
}
run;
run Prima;
|