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 use POSIX;
  38
  39 use vars qw( @ISA @EXPORT );
  40
  41 @ISA = qw( Exporter );
  42
  43
  44 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  45
  46
  47 sub draw_feature
  48 {
  49     # Martin A. Hansen, November 2009
  50
  51     # Given a list of features add these to
  52     # a Cairo::Context object.
  53
  54     my ( $cr,         # Cairo::Context object
  55          $features,   # List of features
  56        ) = @_;
  57
  58     # Returns nothing.
  59
  60     my ( $feature, $first );
  61
  62     $first = 1;
  63
  64     foreach $feature ( @{ $features } )
  65     {
  66         $cr->set_source_rgb( @{ $feature->{ 'color' } } );
  67
  68         if ( $feature->{ 'type' } eq 'line' )
  69         {
  70             $cr->set_line_width( $feature->{ 'line_width' } );
  71             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  72             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  73         }
  74         elsif ( $feature->{ 'type' } eq 'grid' )
  75         {
  76             $cr->set_line_width( $feature->{ 'line_width' } );
  77             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  78             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  79         }
  80         elsif ( $feature->{ 'type' } eq 'wiggle' )
  81         {
  82             $cr->set_line_width( $feature->{ 'line_width' } );
  83
  84             if ( $first )
  85             {
  86                 $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  87
  88                 undef $first;
  89             }
  90
  91             $cr->line_to( $feature->{ 'x1' }, $feature->{ 'y2' } );
  92             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  93         }
  94         elsif ( $feature->{ 'type' } eq 'arrow' )
  95         {
  96             draw_arrow_horizontal(
  97                 $cr,
  98                 $feature->{ 'x1' },
  99                 $feature->{ 'y1' },
 100                 $feature->{ 'x2' },
 101                 $feature->{ 'y2' },
 102                 $feature->{ 'strand' },
 103             );
 104
 105         }
 106         elsif ( $feature->{ 'type' } eq 'rect' )
 107         {
 108             $cr->rectangle(
 109                 $feature->{ 'x1' },
 110                 $feature->{ 'y1' },
 111                 $feature->{ 'x2' } - $feature->{ 'x1' } + 1,
 112                 $feature->{ 'y2' } - $feature->{ 'y1' } + 1,
 113             );
 114
 115             $cr->fill;
 116         }
 117         elsif ( $feature->{ 'type' } eq 'text' )
 118         {
 119             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
 120             $cr->set_font_size( $feature->{ 'font_size' } );
 121             $cr->show_text( $feature->{ 'txt' } );
 122         }
 123         elsif ( $feature->{ 'type' } eq 'track_name' )
 124         {
 125             $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
 126             $cr->set_font_size( $feature->{ 'font_size' } );
 127             $cr->show_text( $feature->{ 'txt' } );
 128         }
 129
 130         #$cr->stroke;
 131     }
 132
 133     $cr->fill_preserve;
 134     $cr->stroke;
 135 }
 136
 137
 138 sub draw_arrow_horizontal
 139 {
 140     # Draws a horizontal arraw that
 141     # consists of a shaft and arrow head.
 142
 143     my ( $cr,   # Cairo::Context object
 144          $x1,
 145          $y1,
 146          $x2,
 147          $y2,
 148          $strand,
 149        ) = @_;
 150
 151     # Returns nothing.
 152
 153     my ( $x_diff, $y_diff, $mid, $width, $s_width );
 154
 155     $x_diff = abs( $x2 - $x1 );
 156     $y_diff = abs( $y2 - $y1 );
 157
 158     $mid = $y_diff / 2;
 159
 160     if ( $x_diff < $mid ) {
 161         $width = $x_diff;
 162     } else {
 163         $width = $mid;
 164     }
 165
 166     # Draw arrow head
 167
 168     $cr->set_line_width( 1 );
 169
 170     if ( $strand eq '+' )
 171     {
 172         $cr->move_to( $x2 - $width, $y1 );
 173         $cr->line_to( $x2, $y1 + $mid );
 174         $cr->line_to( $x2 - $width, $y2 );
 175     }
 176     else
 177     {
 178         $cr->move_to( $x1 + $width, $y1 );
 179         $cr->line_to( $x1, $y1 + $mid );
 180         $cr->line_to( $x1 + $width, $y2 );
 181     }
 182
 183     $cr->close_path;
 184     $cr->fill_preserve;
 185     $cr->stroke;
 186
 187     # Draw arrow shaft
 188
 189     if ( $x_diff > $mid )
 190     {
 191         if ( $strand eq '+' ) {
 192             $cr->rectangle( $x1, $y1, ( $x2 - $width ) - $x1, $y2 - $y1 );
 193         } else {
 194             $cr->rectangle( $x1 + $width, $y1, $x2 - ( $x1 + $width ), $y2 - $y1 );
 195         }
 196
 197         $cr->fill_preserve;
 198         $cr->stroke;
 199     }
 200 }
 201
 202
 203 sub palette
 204 {
 205     # Martin A. Hansen, November 2009.
 206
 207     # Given a color number, pick that color from
 208     # the color palette and return.
 209
 210     my ( $i,   # color number
 211        ) = @_;
 212
 213     # Returns a arrayref
 214
 215     my ( $palette, $color );
 216
 217     $palette = [
 218         [  30, 130, 130 ],
 219         [  30,  50, 150 ],
 220         [ 130, 130,  50 ],
 221         [ 130,  90, 130 ],
 222         [ 130,  70,  70 ],
 223         [  70, 170, 130 ],
 224         [ 130, 170,  50 ],
 225         [  30, 130, 130 ],
 226         [  30,  50, 150 ],
 227         [ 130, 130,  50 ],
 228         [ 130,  90, 130 ],
 229         [ 130,  70,  70 ],
 230         [  70, 170, 130 ],
 231         [ 130, 170,  50 ],
 232         [  30, 130, 130 ],
 233         [  30,  50, 150 ],
 234         [ 130, 130,  50 ],
 235         [ 130,  90, 130 ],
 236         [ 130,  70,  70 ],
 237         [  70, 170, 130 ],
 238         [ 130, 170,  50 ],
 239         [  30, 130, 130 ],
 240         [  30,  50, 150 ],
 241         [ 130, 130,  50 ],
 242         [ 130,  90, 130 ],
 243         [ 130,  70,  70 ],
 244         [  70, 170, 130 ],
 245         [ 130, 170,  50 ],
 246     ];
 247
 248     $color = $palette->[ $i ];
 249
 250     map { $_ /= 255 } @{ $color };
 251
 252     return $color;
 253 }
 254
 255
 256 sub render_png
 257 {
 258     # Martin A. Hansen, March 2010.
 259
 260     # Given a list of BGB tracks, render the
 261     # PNG surface stream and return the base64
 262     # encoded PNG data.
 263
 264     my ( $width,    # image width
 265          $height,   # image height
 266          $tracks,   # list of BGB tracks to render
 267        ) = @_;
 268
 269     # Returns a string.
 270
 271     my ( $surface, $cr, $track, $png_data );
 272
 273     $surface = Cairo::ImageSurface->create( 'argb32', $width, $height );
 274     $cr      = Cairo::Context->create( $surface );
 275
 276     $cr->rectangle( 0, 0, $width, $height );
 277     $cr->set_source_rgb( 1, 1, 1 );
 278     $cr->fill;
 279
 280     foreach $track ( @{ $tracks } ) {
 281         draw_feature( $cr, $track ) if $track;
 282     }
 283
 284     $png_data = base64_png( $surface );
 285
 286     return $png_data;
 287 }
 288
 289
 290 sub render_pdf_file
 291 {
 292     # Martin A. Hansen, March 2010.
 293
 294     # Given a list of BGB tracks, render these and save
 295     # to a PDF file.
 296
 297     my ( $file,     # path to PDF file
 298          $width,    # image width
 299          $height,   # image height
 300          $tracks,   # list of BGB tracks to render
 301        ) = @_;
 302
 303     # Returns nothing.
 304
 305     my ( $surface, $cr, $track );
 306
 307     $surface = Cairo::PdfSurface->create ( $file, $width, $height );
 308     $cr      = Cairo::Context->create( $surface );
 309
 310     $cr->rectangle( 0, 0, $width, $height );
 311     $cr->set_source_rgb( 1, 1, 1 );
 312     $cr->fill;
 313
 314     foreach $track ( @{ $tracks } ) {
 315         draw_feature( $cr, $track ) if $track;
 316     }
 317 }
 318
 319
 320 sub render_svg_file
 321 {
 322     # Martin A. Hansen, March 2010.
 323
 324     # Given a list of BGB tracks, render these and save
 325     # to a SVG file.
 326
 327     my ( $file,     # path to PDF file
 328          $width,    # image width
 329          $height,   # image height
 330          $tracks,   # list of BGB tracks to render
 331        ) = @_;
 332
 333     # Returns nothing.
 334
 335     my ( $surface, $cr, $track );
 336
 337     $surface = Cairo::SvgSurface->create ( $file, $width, $height );
 338     $cr      = Cairo::Context->create( $surface );
 339
 340     $cr->rectangle( 0, 0, $width, $height );
 341     $cr->set_source_rgb( 1, 1, 1 );
 342     $cr->fill;
 343
 344     foreach $track ( @{ $tracks } ) {
 345         draw_feature( $cr, $track ) if $track;
 346     }
 347 }
 348
 349
 350 sub file_png
 351 {
 352     # Martin A. Hansen, October 2009.
 353
 354     # Prints a Cairo::Surface object to a PNG file.
 355
 356     my ( $surface,   # Cairo::Surface object
 357          $file,      # path to PNG file
 358        ) = @_;
 359
 360     # Returns nothing
 361
 362     $surface->write_to_png( $file );
 363 }
 364
 365
 366 sub base64_png
 367 {
 368     # Martin A. Hansen, December 2009.
 369
 370     # Extract a PNG stream from a Cairo::Surface object
 371     # and convert it to base64 before returning it.
 372
 373     my ( $surface,   # Cairo::Surface object
 374        ) = @_;
 375
 376     # Returns a string.
 377
 378     my ( $png_data, $callback, $base64 );
 379
 380     $png_data = "";
 381
 382     $callback = sub { $png_data .= $_[ 1 ] };
 383
 384     $surface->write_to_png_stream( $callback );
 385
 386     $base64 = MIME::Base64::encode_base64( $png_data );
 387
 388     return $base64;
 389 }
 390
 391
 392 sub get_distinct_colors
 393 {
 394     # Martin A. Hansen, November 2003.
 395
 396     # returns a number of distinct colors
 397
 398     my ( $num_colors
 399        ) = @_;
 400
 401     # returns triplet of colors [ 0, 255, 127 ]
 402
 403     my ( $num_discrete, @color_vals, $c, @colors, $r_idx, $g_idx, $b_idx, $i );
 404
 405     $num_discrete = POSIX::ceil( $num_colors ** ( 1 / 3 ) );
 406
 407     @color_vals = map {
 408         $c = 1 - ($_ / ($num_discrete - 1) );
 409         $c < 0 ? 0 : ($c > 1 ? 1 : $c);
 410     } 0 .. $num_discrete;
 411
 412     ( $r_idx, $g_idx, $b_idx ) = ( 0, 0, 0 );
 413
 414     foreach $i ( 1 .. $num_colors )
 415     {
 416         push @colors, [ @color_vals [ $r_idx, $g_idx, $b_idx ] ];
 417
 418         if ( ++$b_idx >= $num_discrete )
 419         {
 420             if ( ++$g_idx >= $num_discrete ) {
 421                 $r_idx = ( $r_idx + 1 ) % $num_discrete;
 422             }
 423
 424             $g_idx %= $num_discrete;
 425         }
 426
 427         $b_idx %= $num_discrete;
 428     }
 429
 430     @colors = map { [ int( $_->[ 0 ] * 255), int( $_->[ 1 ] * 255), int( $_->[ 2 ] * 255 ) ] } @colors;
 431
 432     return wantarray ? @colors : \@colors;
 433 }
 434
 435
 436 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 437
 438 1;
 439
 440