package Turtle; use warnings; use Math::Trig; use POSIX; use File::Temp; use RGBColor; sub new() { my $class=shift; my $self ={ savestack=>[ { x=>0, y=>0, direction=>0, linewitdh=>1, color=>RGBColor->new([0, 0, 0]), scale=>1, } ], bbox=>{llx=>0, lly=>0, urx=>0, ury=>0}, tmpfile=>File::Temp->new(template=>'Turtle-XXXXXXXX'), }; bless $self, $class; return $self; } sub save() { my $self=shift; push @{$self->{savestack}}, {}; $self->writePostScript('gsave'); } sub restore() { my $self=shift; die "$0: Стек состояний пуст\n" if @{$self->{savestack}}==1; pop @{$self->{savestack}}; $self->writePostScript('grestore'); } sub setProperty($$) { my $self=shift; my $property=shift; $self->{savestack}[-1]{$property}=shift; } sub getProperty($) { my $self=shift; my $property=shift; my $savestack=$self->{savestack}; for(my $i=$#$savestack; $i>=0; $i--) { return $savestack->[$i]{$property} if exists $savestack->[$i]{$property}; } } sub setXY($$) { my $self=shift; $self->setProperty('x', shift); $self->setProperty('y', shift); } sub getXY() { my $self=shift; return ($self->getProperty('x'), $self->getProperty('y')); } sub setScale($) { shift->setProperty('scale', shift); } sub getScale() { return shift->getProperty('scale'); } sub setDirection($) { shift->setProperty('direction', shift); } sub getDirection() { return shift->getProperty('direction'); } sub setLineWidth($) { my $self=shift; my $linewitdh=shift; $self->setProperty('linewitdh', $linewitdh); $self->writePostScript($linewitdh, 'setlinewidth'); } sub getLineWidth() { return shift->getProperty('linewitdh'); } sub setColor($) { my $self=shift; my $color=RGBColor->new(shift); $self->setProperty('color', $color); $self->writePostScript(@$color, 'setrgbcolor'); } sub getColor() { return shift->getProperty('color'); } sub rotate($) { my $self=shift; $self->setDirection($self->getDirection+shift); } sub jump($) { my $self=shift; my $step=shift; $step*=$self->getScale; my ($x, $y)=$self->getXY; my $angleRad=deg2rad($self->getDirection); $self->setXY($x+$step*cos($angleRad), $y+$step*sin($angleRad)); } sub forward($) { my $self=shift; my $step=shift; my ($x, $y)=$self->getXY; $self->modifyBBox; $self->jump($step); $self->modifyBBox; $self->writePostScript ( 'newpath', $x, $y, 'moveto', $self->getXY, 'lineto', 'stroke' ); } sub modifyBBox() { my $self=shift; my $lineWidthHalf=$self->getLineWidth/2; my ($x, $y)=$self->getXY; $self->{bbox}{llx}=min($self->{bbox}{llx}, $x-$lineWidthHalf); $self->{bbox}{lly}=min($self->{bbox}{lly}, $y-$lineWidthHalf); $self->{bbox}{urx}=max($self->{bbox}{urx}, $x+$lineWidthHalf); $self->{bbox}{ury}=max($self->{bbox}{ury}, $y+$lineWidthHalf); } sub min($$) { return $_[$_[0]<$_[1]? 0: 1]; } sub max($$) { return $_[$_[0]>$_[1]? 0: 1]; } sub writePostScript(@) { shift->{tmpfile}->print("@_\n"); } sub writePicture(;$$$) { my $self=shift; my $outputFileName=shift//'TurtleOut.eps'; my $device=shift//'epswrite'; my $resolution=shift//72; my %bbox=%{$self->{bbox}}; my @hiResBoundingBox=@bbox{sort keys %bbox}; my $width=ceil(($bbox{urx}-$bbox{llx})*$resolution/72); my $height=ceil(($bbox{ury}-$bbox{lly})*$resolution/72); my @boundingBox =( floor($hiResBoundingBox[0]), floor($hiResBoundingBox[1]), ceil($hiResBoundingBox[2]), ceil($hiResBoundingBox[3]) ); open my $gsPipe, '|-', sprintf("gs -q -dNOPAUSE -dEPSCrop -sDEVICE=\"\%s\" -r\%s -o\"\%s\" -", $device, $resolution, $outputFileName); $gsPipe->print(<<__POSTSCRIPT__); \%!PS-Adobe-3.0 EPSF-3.0; \%\%BoundingBox: @boundingBox \%\%HiResBoundingBox: @hiResBoundingBox \%\%EndComments 1 setlinecap __POSTSCRIPT__ $self->{tmpfile}->flush; open my $tmpReader, '<', $self->{tmpfile}->filename; $gsPipe->print(<$tmpReader>); $tmpReader->close; $gsPipe->print("showpage\n"); $gsPipe->print("\%\%EOF\n"); $gsPipe->close or die "$0: Продолжать невозможно: GhostScript завершился с ошибкой\n"; my $outputFileSize=-s $outputFileName; print(<<__REPORT__); * Записан файл: «$outputFileName» * Размер файла: $outputFileSize * Устройство: $device * Размер: ${width}×$height * Разрешение: $resolution dpi ** __REPORT__ } return 1;
package RGBColor; use warnings; my %colorByName =( aliceblue=>'#F0F8FF', antiquewhite=>'#FAEBD7', aqua=>'#00FFFF', aquamarine=>'#7FFFD4', azure=>'#F0FFFF', beige=>'#F5F5DC', bisque=>'#FFE4C4', black=>'#000000', blanchedalmond=>'#FFEBCD', blue=>'#0000FF', blueviolet=>'#8A2BE2', brown=>'#A52A2A', burlywood=>'#DEB887', cadetblue=>'#5F9EA0', chartreuse=>'#7FFF00', chocolate=>'#D2691E', coral=>'#FF7F50', cornflowerblue=>'#6495ED', cornsilk=>'#FFF8DC', crimson=>'#DC143C', cyan=>'#00FFFF', darkblue=>'#00008B', darkcyan=>'#008B8B', darkgoldenrod=>'#B8860B', darkgray=>'#A9A9A9', darkgreen=>'#006400', darkgrey=>'#A9A9A9', darkkhaki=>'#BDB76B', darkmagenta=>'#8B008B', darkolivegreen=>'#556B2F', darkorange=>'#FF8C00', darkorchid=>'#9932CC', darkred=>'#8B0000', darksalmon=>'#E9967A', darkseagreen=>'#8FBC8F', darkslateblue=>'#483D8B', darkslategray=>'#2F4F4F', darkslategrey=>'#2F4F4F', darkturquoise=>'#00CED1', darkviolet=>'#9400D3', deeppink=>'#FF1493', deepskyblue=>'#00BFFF', dimgray=>'#696969', dimgrey=>'#696969', dodgerblue=>'#1E90FF', firebrick=>'#B22222', floralwhite=>'#FFFAF0', forestgreen=>'#228B22', fuchsia=>'#FF00FF', gainsboro=>'#DCDCDC', ghostwhite=>'#F8F8FF', gold=>'#FFD700', goldenrod=>'#DAA520', gray=>'#808080', green=>'#008000', greenyellow=>'#ADFF2F', grey=>'#808080', honeydew=>'#F0FFF0', hotpink=>'#FF69B4', indianred=>'#CD5C5C', indigo=>'#4B0082', ivory=>'#FFFFF0', khaki=>'#F0E68C', lavender=>'#E6E6FA', lavenderblush=>'#FFF0F5', lawngreen=>'#7CFC00', lemonchiffon=>'#FFFACD', lightblue=>'#ADD8E6', lightcoral=>'#F08080', lightcyan=>'#E0FFFF', lightgoldenrodyellow=>'#FAFAD2', lightgray=>'#D3D3D3', lightgreen=>'#90EE90', lightgrey=>'#D3D3D3', lightpink=>'#FFB6C1', lightsalmon=>'#FFA07A', lightseagreen=>'#20B2AA', lightskyblue=>'#87CEFA', lightslategray=>'#778899', lightslategrey=>'#778899', lightsteelblue=>'#B0C4DE', lightyellow=>'#FFFFE0', lime=>'#00FF00', limegreen=>'#32CD32', linen=>'#FAF0E6', magenta=>'#FF00FF', maroon=>'#800000', mediumaquamarine=>'#66CDAA', mediumblue=>'#0000CD', mediumorchid=>'#BA55D3', mediumpurple=>'#9370DB', mediumseagreen=>'#3CB371', mediumslateblue=>'#7B68EE', mediumspringgreen=>'#00FA9A', mediumturquoise=>'#48D1CC', mediumvioletred=>'#C71585', midnightblue=>'#191970', mintcream=>'#F5FFFA', mistyrose=>'#FFE4E1', moccasin=>'#FFE4B5', navajowhite=>'#FFDEAD', navy=>'#000080', oldlace=>'#FDF5E6', olive=>'#808000', olivedrab=>'#6B8E23', orange=>'#FFA500', orangered=>'#FF4500', orchid=>'#DA70D6', palegoldenrod=>'#EEE8AA', palegreen=>'#98FB98', paleturquoise=>'#AFEEEE', palevioletred=>'#DB7093', papayawhip=>'#FFEFD5', peachpuff=>'#FFDAB9', peru=>'#CD853F', pink=>'#FFC0CB', plum=>'#DDA0DD', powderblue=>'#B0E0E6', purple=>'#800080', red=>'#FF0000', rosybrown=>'#BC8F8F', royalblue=>'#4169E1', saddlebrown=>'#8B4513', salmon=>'#FA8072', sandybrown=>'#F4A460', seagreen=>'#2E8B57', seashell=>'#FFF5EE', sienna=>'#A0522D', silver=>'#C0C0C0', skyblue=>'#87CEEB', slateblue=>'#6A5ACD', slategray=>'#708090', slategrey=>'#708090', snow=>'#FFFAFA', springgreen=>'#00FF7F', steelblue=>'#4682B4', tan=>'#D2B48C', teal=>'#008080', thistle=>'#D8BFD8', tomato=>'#FF6347', turquoise=>'#40E0D0', violet=>'#EE82EE', wheat=>'#F5DEB3', white=>'#FFFFFF', whitesmoke=>'#F5F5F5', yellow=>'#FFFF00', yellowgreen=>'#9ACD32', ); sub new($); sub new($) { my $class=shift; my $color=shift; my $self; if(ref $color eq 'ARRAY') { $self=$color; } elsif(ref $color eq 'RGBColor') { $self=[@$color]; } elsif($color=~m/^#([[:xdigit:]])([[:xdigit:]])([[:xdigit:]])$/) { $self=[hex($1)/15, hex($2)/15, hex($3)/15]; } elsif($color=~m/^#([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})$/) { $self=[hex($1)/255, hex($2)/255, hex($3)/255]; } elsif(exists $colorByName{$color}) { $self=RGBColor->new($colorByName{$color}); } else { warn "$0: Неизвестный цвет «$color», используется чёрный\n"; $self=[0, 0, 0]; } return bless $self, $class; } sub interpolate($$) { my $self=shift; my $color=shift; my $t=shift; my $result=[]; $result->[$_]=(1-$t)*$self->[$_]+$t*$color->[$_] for 0 .. 2; return RGBColor->new($result); } return 1;