code_perl/Maasha/KISS/Track.pm

   1 package Maasha::KISS::Track;
   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 tracks.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use Maasha::Calc;
  35 use vars qw( @ISA @EXPORT );
  36
  37 @ISA = qw( Exporter );
  38
  39
  40 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  41
  42
  43 sub entries_sort
  44 {
  45     my ( $entries,   # list of KISS entries
  46        ) = @_;
  47
  48     # Returns nothing.
  49
  50     @{ $entries } = sort { $a->{ 'S_BEG' } <=> $b->{ 'S_BEG' } or
  51                            $a->{ 'S_END' } <=> $b->{ 'S_END' } } @{ $entries };
  52 }
  53
  54
  55 sub track_feature
  56 {
  57     my ( $width,     # draw window width
  58          $y_offset,  # y axis draw offset
  59          $beg,       # base window beg
  60          $end,       # base window end
  61          $entries,   # list of sorted KISS entries
  62        ) = @_;
  63
  64     # Returns a list.
  65
  66     my ( $factor, $entry, $y_step, @ladder, $i, $x, $y, $w, @features );
  67
  68     $factor = $width / ( $end - $beg );
  69     $y_step = 0;
  70
  71     foreach $entry ( @{ $entries } )
  72     {
  73         $w = sprintf( "%.0f", ( $entry->{ 'S_END' } - $entry->{ 'S_BEG' } + 1 ) * $factor );
  74
  75         if ( $w >= 1 )
  76         {
  77             $x = sprintf( "%.0f", ( $entry->{ 'S_BEG' } - $beg ) * $factor );
  78
  79             for ( $y_step = 0; $y_step < @ladder; $y_step++ )
  80             {
  81                 last if $x >= $ladder[ $y_step ] + 1;
  82             }
  83
  84             $y = $y_offset + ( 5 * $y_step );
  85
  86             push @features, {
  87 #                id     => $entry->{ 'Q_ID' },
  88                 x      => $x,
  89                 y      => $y,
  90                 height => 5,
  91                 width  => $w,
  92             };
  93
  94             $ladder[ $y_step ] = $x + $w;
  95         }
  96     }
  97
  98     return wantarray ? @features : \@features;
  99 }
 100
 101
 102 sub track_histogram
 103 {
 104     my ( $width,     # draw window width
 105          $y_offset,  # y axis draw offset
 106          $min,       # minimum base position
 107          $max,       # maximum base position
 108          $entries,   # list of sorted KISS entries
 109        ) = @_;
 110
 111     # Returns a list.
 112
 113     my ( $hist_height, $bucket_width, $factor_heigth, $factor_width, $entry, $max_height, $bucket_beg, $bucket_end, $i, @buckets, $bucket, @hist, $x, $h );
 114
 115     return if $max == $min;
 116
 117     $hist_height  = 100;   # pixels
 118     $bucket_width = 5;     # pixels
 119
 120     $factor_width = ( $width / $bucket_width ) / ( $max - $min );
 121
 122     $max_height = 0;
 123
 124     foreach $entry ( @{ $entries } )
 125     {
 126         $bucket_beg = int( $entry->{ 'S_BEG' } * $factor_width );
 127         $bucket_end = int( $entry->{ 'S_END' } * $factor_width );
 128
 129         # print "$bucket_beg   $bucket_end\n";
 130
 131         for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
 132         {
 133             $buckets[ $i ]++;
 134
 135             $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
 136         }
 137     }
 138
 139     # print Maasha::KISS::Draw::hdump( \@buckets );
 140     #print Dumper( $max_height );
 141
 142     if ( $max_height > 0 )
 143     {
 144         $factor_heigth = $hist_height / $max_height;
 145
 146         $x = 0;
 147
 148         for ( $i = int( $entries->[ 0 ]->{ 'S_BEG' } * $factor_width ); $i < @buckets; $i++ )
 149         {
 150             if ( defined $buckets[ $i ] )
 151             {
 152                 $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
 153
 154                 if ( $h >= 1 )
 155                 {
 156                     push @hist, {
 157                         x1      => $x,
 158                         y1      => $y_offset + $hist_height,
 159                         x2      => $x,
 160                         y2      => $y_offset + $hist_height - $h,
 161                     };
 162                 }
 163             }
 164
 165             $x += $bucket_width;
 166         }
 167     }
 168
 169     return wantarray ? @hist : \@hist;
 170 }
 171
 172
 173 sub bucket_round
 174 {
 175     my ( $num,
 176          $bucket_size,
 177        ) = @_;
 178
 179     my ( $div, $int );
 180
 181     $div = $num / $bucket_size;
 182     $int = int $div;
 183
 184     if ( $div - $int >= 0.5 ) {
 185         return $bucket_size * ( $int + 1 );
 186     } else {
 187         return $bucket_size * $int;
 188     }
 189 }
 190
 191
 192 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 193
 194 1;
 195
 196