code_perl/Maasha/BBrowser/Draw.pm

   1 package Maasha::BBrowser::Draw;
   2
   3 # Copyright (C) 2009 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # Routines for creating Biopieces Browser graphics using Cairo and Pango.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use Cairo;
  35 use Pango;
  36
  37 use vars qw( @ISA @EXPORT );
  38
  39 @ISA = qw( Exporter );
  40
  41
  42 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  43
  44
  45 sub draw_feature
  46 {
  47     # Martin A. Hansen, November 2009
  48
  49     # Given a list of features add these to
  50     # a Cairo::Context object.
  51
  52     my ( $cr,         # Cairo::Context object
  53          $features,   # List of features
  54        ) = @_;
  55
  56     # Returns nothing.
  57
  58     my ( $feature );
  59
  60     foreach $feature ( @{ $features } )
  61     {
  62         $cr->set_source_rgb( @{ $feature->{ 'color' } } );
  63
  64         if ( $feature->{ 'type' } eq 'line' )
  65         {
  66             $cr->set_line_width( $feature->{ 'line_width' } );
  67             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  68             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  69         }
  70         elsif ( $feature->{ 'type' } eq 'rect' )
  71         {
  72             $cr->rectangle(
  73                 $feature->{ 'x1' },
  74                 $feature->{ 'y1' },
  75                 $feature->{ 'x2' } - $feature->{ 'x1' },
  76                 $feature->{ 'y2' } - $feature->{ 'y1' },
  77             );
  78
  79             $cr->fill;
  80         }
  81         elsif ( $feature->{ 'type' } eq 'text' )
  82         {
  83             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  84             $cr->set_font_size( $feature->{ 'font_size' } );
  85             $cr->show_text( $feature->{ 'txt' } );
  86         }
  87
  88         $cr->stroke;
  89     }
  90 }
  91
  92
  93 sub palette
  94 {
  95     # Martin A. Hansen, November 2009.
  96
  97     # Given a color number, pick that color from
  98     # the color palette and return.
  99
 100     my ( $i,   # color number
 101        ) = @_;
 102
 103     # Returns a arrayref
 104
 105     my ( $palette, $color );
 106
 107     $palette = [
 108         [  30, 130, 130 ],
 109         [  30,  50, 150 ],
 110         [ 130, 130,  50 ],
 111         [ 130,  90, 130 ],
 112         [ 130,  70,  70 ],
 113         [  70, 170, 130 ],
 114         [ 130, 170,  50 ],
 115         [  30, 130, 130 ],
 116         [  30,  50, 150 ],
 117         [ 130, 130,  50 ],
 118         [ 130,  90, 130 ],
 119         [ 130,  70,  70 ],
 120         [  70, 170, 130 ],
 121         [ 130, 170,  50 ],
 122     ];
 123
 124     $color = $palette->[ $i ];
 125
 126     map { $_ /= 255 } @{ $color };
 127
 128     return $color;
 129 }
 130
 131
 132 sub file_png
 133 {
 134     # Martin A. Hansen, October 2009.
 135
 136     # Prints a Cairo::Surface object to a PNG file.
 137
 138     my ( $surface,   # Cairo::Surface object
 139          $file,      # path to PNG file
 140        ) = @_;
 141
 142     # Returns nothing
 143
 144     $surface->write_to_png( $file );
 145 }
 146
 147
 148 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 149
 150 1;
 151
 152