code_perl/Maasha/BGB/Draw.pm

   1 package Maasha::BGB::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 use MIME::Base64;
  37
  38 use vars qw( @ISA @EXPORT );
  39
  40 @ISA = qw( Exporter );
  41
  42
  43 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  44
  45
  46 sub draw_feature
  47 {
  48     # Martin A. Hansen, November 2009
  49
  50     # Given a list of features add these to
  51     # a Cairo::Context object.
  52
  53     my ( $cr,         # Cairo::Context object
  54          $features,   # List of features
  55        ) = @_;
  56
  57     # Returns nothing.
  58
  59     my ( $feature );
  60
  61     foreach $feature ( @{ $features } )
  62     {
  63         $cr->set_source_rgb( @{ $feature->{ 'color' } } );
  64
  65         if ( $feature->{ 'type' } eq 'line' )
  66         {
  67             $cr->set_line_width( $feature->{ 'line_width' } );
  68             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  69             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  70         }
  71         elsif ( $feature->{ 'type' } eq 'rect' )
  72         {
  73             $cr->rectangle(
  74                 $feature->{ 'x1' },
  75                 $feature->{ 'y1' },
  76                 $feature->{ 'x2' } - $feature->{ 'x1' },
  77                 $feature->{ 'y2' } - $feature->{ 'y1' },
  78             );
  79
  80             $cr->fill;
  81         }
  82         elsif ( $feature->{ 'type' } eq 'text' )
  83         {
  84             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  85             $cr->set_font_size( $feature->{ 'font_size' } );
  86             $cr->show_text( $feature->{ 'txt' } );
  87         }
  88
  89         $cr->stroke;
  90     }
  91 }
  92
  93
  94 sub palette
  95 {
  96     # Martin A. Hansen, November 2009.
  97
  98     # Given a color number, pick that color from
  99     # the color palette and return.
 100
 101     my ( $i,   # color number
 102        ) = @_;
 103
 104     # Returns a arrayref
 105
 106     my ( $palette, $color );
 107
 108     $palette = [
 109         [  30, 130, 130 ],
 110         [  30,  50, 150 ],
 111         [ 130, 130,  50 ],
 112         [ 130,  90, 130 ],
 113         [ 130,  70,  70 ],
 114         [  70, 170, 130 ],
 115         [ 130, 170,  50 ],
 116         [  30, 130, 130 ],
 117         [  30,  50, 150 ],
 118         [ 130, 130,  50 ],
 119         [ 130,  90, 130 ],
 120         [ 130,  70,  70 ],
 121         [  70, 170, 130 ],
 122         [ 130, 170,  50 ],
 123         [  30, 130, 130 ],
 124         [  30,  50, 150 ],
 125         [ 130, 130,  50 ],
 126         [ 130,  90, 130 ],
 127         [ 130,  70,  70 ],
 128         [  70, 170, 130 ],
 129         [ 130, 170,  50 ],
 130         [  30, 130, 130 ],
 131         [  30,  50, 150 ],
 132         [ 130, 130,  50 ],
 133         [ 130,  90, 130 ],
 134         [ 130,  70,  70 ],
 135         [  70, 170, 130 ],
 136         [ 130, 170,  50 ],
 137     ];
 138
 139     $color = $palette->[ $i ];
 140
 141     map { $_ /= 255 } @{ $color };
 142
 143     return $color;
 144 }
 145
 146
 147 sub file_png
 148 {
 149     # Martin A. Hansen, October 2009.
 150
 151     # Prints a Cairo::Surface object to a PNG file.
 152
 153     my ( $surface,   # Cairo::Surface object
 154          $file,      # path to PNG file
 155        ) = @_;
 156
 157     # Returns nothing
 158
 159     $surface->write_to_png( $file );
 160 }
 161
 162
 163 sub base64_png
 164 {
 165     # Martin A. Hansen, December 2009.
 166
 167     # Extract a PNG stream from a Cairo::Surface object
 168     # and convert it to base64 before returning it.
 169
 170     my ( $surface,   # Cairo::Surface object
 171        ) = @_;
 172
 173     # Returns a string.
 174
 175     my ( $png_data, $callback, $base64 );
 176
 177     $png_data = "";
 178
 179     $callback = sub { $png_data .= $_[ 1 ] };
 180
 181     $surface->write_to_png_stream( $callback );
 182
 183     $base64 = MIME::Base64::encode_base64( $png_data );
 184
 185     return $base64;
 186 }
 187
 188
 189 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 190
 191 1;
 192
 193