Viewing file:  tiger.pl (8.01 KB) -rw-r--r--
Select action/file-type:
 (+) |  (+) |  (+) | Code (+) | Session (+) |  (+) | SDB (+) |  (+) |  (+) |  (+) |  (+) |  (+) |
=pod
=head1 NAME
examples/tiger.pl - draw eps file
=head1 FEATURES
Demonstrates capabilities of C<Prima::Drawable::Path> - curves, lines, and
matrix transformations, similar to those in the PostScript language. The PS
interpreter is very dumb and minimal, to parse F<tiger.eps> file only.
=cut
use strict;
use warnings;
use FindBin qw($Bin);
use Prima qw(Application);
my ( $device, %globals, %sym, %def, $line, @stack, @code_stack, @array_stack, @graphics_stack);
my $debug = 0;
use constant CLASS => 0;
use constant VALUE => 1;
$SIG{__DIE__} = sub {
print "stack:\n";
print "* @$_\n" for @stack;
die @_;
};
sub ntok($$) { [ @_ ] }
sub spush($) { push @stack, $_[0] }
sub spushn($) { spush ntok num => shift }
sub spop { pop @stack or die "stack undeflow\n" }
sub spopx($)
{
my ($pop, $class) = (spop, shift);
die "$class expected\n" unless $pop->[CLASS] eq $class;
return $pop->[VALUE];
}
sub spopn { spopx 'num' }
sub spopy { spopx 'sym' }
sub spopc { spopx 'code' }
sub spopnx($) { reverse ( map { spopn } 1 .. $_[0] ) }
sub gc { $graphics_stack[-1] }
sub newpath {
my $m = gc->{path}->last_matrix;
gc->{path} = $device->new_path;
gc->{path}->matrix( @$m ) if $m;
gc->{path_actual} = 0;
}
sub path { gc->{path} }
sub execute
{
my $code = shift;
for my $t ( @$code ) {
if ( $debug ) {
my $ns = @stack;
print STDERR "$ns:$t->[CLASS] $t->[VALUE]\n";
if ( $debug > 1 ) {
for ( @stack ) {
print STDERR " * $_->[CLASS] $_->[VALUE]\n";
}
}
}
if ( $t->[CLASS] =~ /^(id|num|sym|code|array|dict)/) {
push @stack, $t;
} elsif ( $t->[CLASS] eq 'fun') {
my $m = $t->[VALUE];
main->can($m)->();
} elsif ( $t->[CLASS] eq 'call' ) {
my $d = $def{ $t->[VALUE] };
die "$t->[VALUE] is undefined\n" unless $d;
execute($d->[VALUE]);
} else {
die "Unknown opcode $t->[CLASS]\n";
}
}
}
sub __log { use Data::Dumper; print STDERR Dumper(spop) }
sub _add { spushn spopn + spopn }
sub _begin { }
sub _bind { }
sub _cleartomark { }
sub _closepath { path->close }
sub _copy {
my $n = spopn;
return if $n < 1;
push @stack, ((splice( @stack, -$n )) x 2);
}
sub _countdictstack { spushn 0 }
sub _currentflat { spushn 24 }
sub _currentpoint {
spushn gc->{point}->[0];
spushn gc->{point}->[1];
}
sub _curveto {
gc->{path_actual} = 1;
my @p = spopnx 6;
path->spline( [ @{ gc->{point} }, @p ], degree => 3 );
gc->{point} = [ @p[4,5] ];
}
sub _def {
my $v = spop;
$v = ntok code => [$v] unless $v->[CLASS] eq 'code';
$def{spopy()} = $v;
}
sub _dict { spopn; spush ntok dict => {} }
sub _dup { my $p = spop; spush $p; spush $p }
sub _end { }
sub _eq {
my ( $y, $x ) = ( spop, spop );
spushn $x->[CLASS] eq $x->[CLASS] && $x->[VALUE] eq $y->[VALUE];
}
sub _exch { push @stack, spop, spop }
sub _fill { path-> fill if gc->{path_actual}; newpath }
sub _get { spush ntok fun => "_" . spopy }
sub _grestore {
pop @graphics_stack;
$device->lineWidth(gc->{lw});
$device->color(gc->{color});
}
sub _gsave {
my %last = %{ gc() };
$last{path} = $last{path}->dup;
$last{point} = [ @{$last{point}} ];
push @graphics_stack, \%last;
}
sub _if {
my ( $code, $bool ) = ( spopc, spopn );
execute($code) if $bool;
}
sub _ifelse {
my ( $code2, $code1, $bool ) = ( spopc, spopc, spopn );
execute($bool ? $code1 : $code2);
}
sub _index { spush ($stack[ spopn ] or die "No such value at index") }
sub _itransform { }
sub _lineto {
unless ( gc->{path_actual}) {
path->line( @{ gc->{point} });
gc->{path_actual} = 1;
}
path->line( @{gc->{point}} = spopnx 2 );
}
sub _load {
my $arg = spopy;
return spush $def{$arg} if exists $def{$arg};
return spush ntok fun => "_$arg" if main->can("_$arg");
die "No such symbol: $arg\n";
}
sub _lt { spushn( spopn() >= spopn()) }
sub _mark { }
sub _moveto {
newpath if gc->{path_actual};
gc->{point} = [spopnx 2];
}
sub _neg { spushn - spopn }
sub _newpath { newpath }
sub _pop { spop }
sub _repeat { my ($c, $n) = (spopc, spopn); execute($c) for 1..$n }
sub _restore { }
sub _roll {
my ( $n, $j ) = spopnx 2;
return unless $j;
my @r = splice( @stack, -$n );
if ( $j < 0 ) {
push @r, shift @r for 1 .. -$j;
} else {
unshift @r, pop @r for 1 .. $j;
}
push @stack, @r;
}
sub _round { spushn int spopn }
sub _save { }
sub _scale { path->scale(spopnx 2) }
sub _setdash { spop, spop }
sub _setflat { spopn }
sub _setgray {$device->color(gc->{color} = int( 255 * spopn ) * ( 65536 + 256 + 1 )) }
sub _setmiterlimit { spopn }
sub _setlinecap { spopn }
sub _setlinejoin { spopn }
sub _setlinewidth { $device->lineWidth( gc->{lw} = spopn ) }
sub _setcmybcolor {
my @k = map { 1 - spopn } 0 .. 3;
my @c = map { int 255 * $k[0] * $_ } @k[1..3];
$device->color(gc->{color} = ($c[2] << 16) | ($c[1] << 8) | $c[0]);
}
sub _setrgbcolor {
my @c = map { int( 255 * spopn ) } 0 .. 2;
$device->color(gc->{color} = ($c[2] << 16) | ($c[1] << 8) | $c[0]);
}
sub _showpage { }
sub _stroke { path->stroke if gc->{path_actual}; newpath }
sub _sub { spushn( spopn - spopn )}
sub _transform { }
sub _translate { path->translate(spopnx 2) }
sub _where { spushn(main->can('_' . spopy) // 0) }
sub tok
{{
if ( m/\G([_a-z][\.\w]*)/gcsi ) {
return ntok call => $1 if exists $sym{$1};
return ntok fun => "_$1" if main->can("_$1");
die "Unknown identifier: $1 at line $line\n";
}
m/\G([+-]?(?:\.\d+|\d+(?:\.\d+)?))/gcs and return ntok num => $1;
m/\G\/([\.\w]+)/gcs and return $sym{$1} = ntok sym => $1;
m/\G\{/gcs and return ntok code_begin => undef;
m/\G\}/gcs and return ntok code_end => undef;
m/\G\[/gcs and return ntok arr_begin => undef;
m/\G\]/gcs and return ntok arr_end => undef;
m/\G\s+/gcs and redo;
m/\G$/gcs and return;
m/\G(.*)/gcs;
die "Unknown token: $1 at line $line\n";
}}
# parse
my $f = "$Bin/tiger.eps";
open F, "<", $f or die "cannot open $f:$!\n";
$line = 0;
push @code_stack, [];
while (<F>) {
$line++;
chomp;
if ( m/^%(.)(.*)/ ) {
my ( $s, $t ) = ( $1, $2 );
if ( $s eq '%' ) {
my $v;
($t, $v) = ($1, $2) if $t =~ /(.*)\s*\:\s*(.*)/;
$globals{$t} = $v;
}
next;
}
s/^\s+//;
s/\s*$//;
next unless length;
while ( my $t = tok ) {
if ( $t->[CLASS] =~ /^(id|num|call|fun|sym)/) {
push @{ $code_stack[-1] }, $t;
} elsif ( $t->[CLASS] eq 'code_begin' ) {
push @code_stack, [];
} elsif ( $t->[CLASS] eq 'code_end' ) {
@code_stack > 1 or die "Unexpected } at line $line\n";
my $nt = ntok code => pop(@code_stack);
push @{ $code_stack[-1] }, $nt;
} elsif ( $t->[CLASS] eq 'arr_begin' ) {
push @code_stack, [];
push @array_stack, 1;
} elsif ( $t->[CLASS] eq 'arr_end' ) {
pop @array_stack or die "Unexpected ] at line $line\n";
push @{ $code_stack[-1] }, ntok array => pop(@code_stack);
} else {
die "Unknown token $t->[CLASS] at line $line\n";
}
}
}
close F;
die "Unclosed array\n" if @array_stack;
die "Unclosed code\n" if 1 < @code_stack;
die "No code\n" unless @code_stack;
# execute
my @bb = split ' ', ($globals{BoundingBox} // '0 0 1000 1000');
#$device = Prima::DeviceBitmap->new(
# type => dbt::Pixmap,
# width => $bb[2] - $bb[0],
# height => $bb[3] - $bb[1],
# backColor => cl::White,
# color => cl::Black,
#);
#$device->clear;
#$device->translate( -$bb[0], -$bb[1]);
#execute( $code_stack[0] );
sub init
{
@graphics_stack = ({
color => 0,
point => [0,0],
path => $device->new_path,
path_actual => 0,
lw => 0,
});
@stack = ();
}
my $w = Prima::MainWindow->new(
text => 'Tiger',
backColor => cl::White,
color => cl::Black,
onPaint => sub {
my ( $self, $canvas ) = @_;
$canvas->clear;
my @sz = $canvas-> size;
my @ps = ( $bb[2] - $bb[0], $bb[3] - $bb[1] );
my @ratios = map { $sz[$_] / $ps[$_] } 0, 1;
my ( $dx, $dy ) = (0,0);
my $r;
if ( $ratios[0] < $ratios[1] ) {
$r = $ratios[0];
$dy = ( $sz[1] - $ps[1] * $r ) / 2;
} else {
$r = $ratios[1];
$dx = ( $sz[0] - $ps[0] * $r ) / 2;
}
$device = $canvas;
$device->translate( $dx - $r * $bb[0], $dy - $r * $bb[1]);
init;
path->scale($r);
execute( $code_stack[0] );
}
);
run Prima;
|