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.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use SVG;
  35
  36 use vars qw( @ISA @EXPORT );
  37
  38 @ISA = qw( Exporter );
  39
  40
  41 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  42
  43
  44 sub svg_init
  45 {
  46     # Martin A. Hansen, October 2005.
  47
  48     # inititalizes SVG object, which is returned.
  49
  50     my ( $height,   # Height in pixels
  51          $width,    # Width in pixels
  52        ) = @_;
  53
  54     my $svg;
  55
  56     $svg = SVG->new(
  57         id          => 'KISS',
  58         height      => $height,
  59         width       => $width,
  60     );
  61
  62     return $svg;
  63 }
  64
  65
  66 sub svg_frame
  67 {
  68     # Martin A. Hansen, October 2009.
  69
  70     # Adds a top level layer frame of given
  71     # height and width to an SVG object.
  72
  73     my ( $height,   # Height in pixels
  74          $width,    # Width in pixels
  75          $svg,      # SVG objact
  76        ) = @_;
  77
  78     # Returns nothing.
  79
  80     my ( $frame );
  81
  82     $frame = $svg->group(
  83         id => 'GROUP_FRAME',
  84     );
  85
  86     $frame->rectangle(
  87         id     => 'FRAME',
  88         x      => 0,
  89         y      => 0,
  90         width  => $width,
  91         height => $height,
  92         rx     => 10,
  93         ry     => 10,
  94         style  => {
  95             fill           => 'none',
  96             'stroke'       => 'red',
  97             'stroke-width' => 3,
  98         }
  99     );
 100 }
 101
 102
 103 sub svg_track_dna
 104 {
 105
 106 }
 107
 108
 109 sub svg_track_feature
 110 {
 111     # Martin A. Hansen, October 2009.
 112
 113     # Given a list of features add these to
 114     # a SVG object.
 115
 116     my ( $height,     # Height in pixels
 117          $width,      # Width in pixels
 118          $svg,        # SVG object
 119          $features,   # List of features
 120          $track_id,   # Unique track id
 121          $color,      # Color of features
 122        ) = @_;
 123
 124     # Returns nothing.
 125
 126     my ( $track, $i, $id, $x, $y, $w, $h );
 127
 128     $track = $svg->group(
 129         id => $track_id,
 130         style => {
 131             'stroke-width' => 5,
 132             stroke         => $color,
 133         }
 134     );
 135
 136     for ( $i = 0; $i < @{ $features }; $i++ )
 137     {
 138         $id = "FEAT_$i";
 139         $x  = $features->[ $i ]->{ 'x' };
 140         $y  = $features->[ $i ]->{ 'y' };
 141         $h  = $features->[ $i ]->{ 'height' };
 142         $w  = $features->[ $i ]->{ 'width' };
 143
 144         # $track->rectangle( id => $id, x => $x, y => $y, width => $w, height => $h );
 145
 146         $track->line( id => $id, x1 => $x, y1 => $y, x2 => $x + $w, y2 => $y );
 147     }
 148 }
 149
 150
 151 sub svg_track_histogram
 152 {
 153     # Given a list of features add these to
 154     # a SVG object.
 155
 156     my ( $svg,        # SVG object
 157          $features,   # List of features
 158          $track_id,   # Unique track id
 159          $color,      # Color of features
 160        ) = @_;
 161
 162     # Returns nothing.
 163
 164     my ( $track, $i );
 165
 166     $track = $svg->group(
 167         id => $track_id,
 168         style => {
 169             'stroke-width' => 5,
 170             stroke         => $color,
 171         }
 172     );
 173
 174     for ( $i = 0; $i < @{ $features }; $i++ )
 175     {
 176         $track->line(
 177             id => "HIST_$i",
 178             x1 => $features->[ $i ]->{ 'x1' },
 179             y1 => $features->[ $i ]->{ 'y1' },
 180             x2 => $features->[ $i ]->{ 'x2' },
 181             y2 => $features->[ $i ]->{ 'y2' },
 182         );
 183     }
 184 }
 185
 186
 187 sub svg_print
 188 {
 189     # Martin A. Hansen, October 2009.
 190
 191     # Prints XML output from a SVG object.
 192
 193     my ( $svg,   # SVG object
 194          $fh,    # file handle  -  OPTIONAL
 195        ) = @_;
 196
 197     # Returns nothing
 198
 199     $fh ||= \*STDOUT;
 200
 201     print $fh $svg->xmlify;
 202 }
 203
 204
 205 sub hdump
 206 {
 207     my ( $foo ) = @_;
 208
 209     my ( @html );
 210
 211     @html = "Content-Type: text/html; charset=ISO-8859-1\n\n";
 212
 213     push @html, "<pre>\n";
 214     push @html, Dumper( $foo );
 215     push @html, "</pre>\n";
 216
 217     return wantarray ? @html : \@html;
 218 }
 219
 220
 221 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 222
 223 1;
 224
 225