code_perl/Maasha/KISS/Draw.pm

   1 package Maasha::KISS::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 KISS 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 track_text
  46 {
  47     # Given a sequence list add this to
  48     # a Cairo::Context object.
  49
  50     my ( $cr,         # Cairo::Context object
  51          $text,       # List of hashrefs { txt =>, x => y => }
  52          $color,      # Color of features
  53        ) = @_;
  54
  55     # Returns nothing.
  56
  57     $cr->set_source_rgb( color_name2rgb( $color ) );
  58
  59     my ( $txt );
  60
  61     $cr->set_font_size( 10 );
  62
  63     foreach $txt ( @{ $text } )
  64     {
  65         $cr->move_to( $txt->{ 'x' }, $txt->{ 'y' } );
  66         $cr->show_text( $txt->{ 'txt' } );
  67         $cr->stroke();
  68     }
  69 }
  70
  71
  72 sub track_feature
  73 {
  74     # Given a list of features add these to
  75     # a Cairo::Context object.
  76
  77     my ( $cr,         # Cairo::Context object
  78          $features,   # List of features
  79          $color,      # Color of features
  80        ) = @_;
  81
  82     # Returns nothing.
  83
  84     my ( $feature );
  85
  86     foreach $feature ( @{ $features } )
  87     {
  88         $cr->set_source_rgb( color_name2rgb( $feature->{ 'color' } ) );
  89         $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
  90
  91         if ( $feature->{ 'type' } eq 'line' )
  92         {
  93             $cr->set_line_width( $feature->{ 'line_width' } );
  94             $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
  95         }
  96         elsif ( $feature->{ 'type' } eq 'text' )
  97         {
  98             $cr->set_font_size( $feature->{ 'font_size' } );
  99             $cr->show_text( $feature->{ 'txt' } );
 100         }
 101
 102         $cr->stroke;
 103     }
 104 }
 105
 106
 107 sub color_name2rgb
 108 {
 109     my ( $color_name
 110        ) = @_;
 111
 112     my ( %color_hash, $rgb );
 113
 114     %color_hash = (
 115         'black' => [   0,   0,   0 ],
 116         'red'   => [ 255,   0,   0 ],
 117         'green' => [   0, 255,   0 ],
 118         'blue'  => [   0,   0, 255 ],
 119     );
 120
 121     if ( exists $color_hash{ $color_name } ) {
 122         $rgb = $color_hash{ $color_name };
 123     } else {
 124         $rgb = [ 0, 0, 0 ];
 125     }
 126
 127     return wantarray ? @{ $rgb } : $rgb;
 128 }
 129
 130
 131 sub file_png
 132 {
 133     # Martin A. Hansen, October 2009.
 134
 135     # Prints a Cairo::Surface object to a PNG file.
 136
 137     my ( $surface,   # Cairo::Surface object
 138          $file,      # path to PNG file
 139        ) = @_;
 140
 141     # Returns nothing
 142
 143     $surface->write_to_png( $file );
 144 }
 145
 146
 147 sub hdump
 148 {
 149     my ( $foo ) = @_;
 150
 151     my ( @html );
 152
 153     @html = "Content-Type: text/html; charset=ISO-8859-1\n\n";
 154
 155     push @html, "<pre>\n";
 156     push @html, Dumper( $foo );
 157     push @html, "</pre>\n";
 158
 159     return wantarray ? @html : \@html;
 160 }
 161
 162
 163 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 164
 165 1;
 166
 167