1# You may distribute under the terms of either the GNU General Public License 2# or the Artistic License (the same terms as Perl itself) 3# 4# (C) Paul Evans, 2011-2016 -- leonerd@leonerd.org.uk 5 6package Tickit::Utils 0.72; 7 8use v5.14; 9use warnings; 10 11use Carp; 12 13use Exporter 'import'; 14our @EXPORT_OK = qw( 15 string_count 16 string_countmore 17 18 textwidth 19 20 chars2cols 21 cols2chars 22 23 substrwidth 24 25 align 26 27 bound 28 29 distribute 30); 31 32# XS code comes from Tickit itself 33require Tickit; 34 35=head1 NAME 36 37C<Tickit::Utils> - utility functions for C<Tickit> 38 39=head1 DESCRIPTION 40 41This module provides a number of utility functions used across C<Tickit>. 42 43=cut 44 45=head1 FUNCTIONS 46 47=head2 string_count 48 49 $bytes = string_count( $str, $pos, $limit ) 50 51Given a string in C<$str> and a L<Tickit::StringPos> instance in C<$pos>, 52updates the counters in C<$pos> by counting the string, and returns the number 53of bytes consumed. If C<$limit> is given, then it will count no further than 54any of the limits given. 55 56=head2 string_countmore 57 58 $bytes = string_countmore( $str, $pos, $limit ) 59 60Similar to C<string_count> but will not zero the counters before it begins. 61Counters in C<$pos> will still be incremented. 62 63=head2 textwidth 64 65 $cols = textwidth( $str ) 66 67Returns the number of screen columns consumed by the given (Unicode) string. 68 69=cut 70 71# Provided by XS 72 73=head2 chars2cols 74 75 @cols = chars2cols( $text, @chars ) 76 77Given a list of increasing character positions, returns a list of column 78widths of those characters. In scalar context returns the first columns width. 79 80=cut 81 82# Provided by XS 83 84=head2 cols2chars 85 86 @chars = cols2chars( $text, @cols ) 87 88Given a list of increasing column widths, returns a list of character 89positions at those widths. In scalar context returns the first character 90position. 91 92=cut 93 94# Provided by XS 95 96=head2 substrwidth 97 98 $substr = substrwidth $text, $startcol 99 100 $substr = substrwidth $text, $startcol, $widthcols 101 102 $substr = substrwidth $text, $startcol, $widthcols, $replacement 103 104Similar to C<substr>, but counts start offset and length in screen columns 105instead of characters 106 107=cut 108 109sub substrwidth 110{ 111 if( @_ > 2 ) { 112 my ( $start, $end ) = cols2chars( $_[0], $_[1], $_[1]+$_[2] ); 113 if( @_ > 3 ) { 114 return substr( $_[0], $start, $end-$start, $_[3] ); 115 } 116 else { 117 return substr( $_[0], $start, $end-$start ); 118 } 119 } 120 else { 121 my $start = cols2chars( $_[0], $_[1] ); 122 return substr( $_[0], $start ); 123 } 124} 125 126=head2 align 127 128 ( $before, $alloc, $after ) = align( $value, $total, $alignment ) 129 130Returns a list of three integers created by aligning the C<$value> to a 131position within the C<$total> according to C<$alignment>. The sum of the three 132returned values will always add to total. 133 134If the value is not larger than the total then the returned allocation will be 135the entire value, and the remaining space will be divided between before and 136after according to the given fractional alignment, with more of the remainder 137being allocated to the C<$after> position in proportion to the alignment. 138 139If the value is larger than the total, then the total is returned as the 140allocation and the before and after positions will both be given zero. 141 142=cut 143 144sub align 145{ 146 my ( $value, $total, $alignment ) = @_; 147 148 return ( 0, $total, 0 ) if $value >= $total; 149 150 my $spare = $total - $value; 151 my $before = int( $spare * $alignment ); 152 153 return ( $before, $value, $spare - $before ); 154} 155 156=head2 bound 157 158 $val = bound( $min, $val, $max ) 159 160Returns the value of C<$val> bounded by the given minimum and maximum. Either 161limit may be left undefined, causing no limit of that kind to be applied. 162 163=cut 164 165sub bound 166{ 167 my ( $min, $val, $max ) = @_; 168 $val = $min if defined $min and $val < $min; 169 $val = $max if defined $max and $val > $max; 170 return $val; 171} 172 173=head2 distribute 174 175 distribute( $total, @buckets ) 176 177Given a total amount of quota, and a list of buckets, distributes the quota 178among the buckets according to the values given in them. 179 180Each value in the C<@buckets> list is a C<HASH> reference which will be 181modified by the function. On entry, the following keys are inspected. 182 183=over 8 184 185=item base => INT 186 187If present, this bucket shall be a flexible bucket containing initially this 188quantity of quota, but may be allocated more, or less, depending on the value 189of the C<expand> key, and how much spare is remaining. 190 191=item expand => INT 192 193For a C<base> flexible bucket, the relative distribution of C<expand> value 194among the flexible buckets determines how the spare quota is distributed among 195them. If absent, defaults to 0. 196 197=item fixed => INT 198 199If present, this bucket shall be of the exact fixed size given. 200 201=back 202 203On return, the bucket hashes will be modified to contain two more keys: 204 205=over 8 206 207=item value => INT 208 209The amount of quota allocated to this bucket. For C<fixed> buckets, this will 210be the fixed value. For C<base> buckets, this may include extra spare quota 211distributed in proportion to the C<expand> value, or may be reduced in order 212to fit the total. 213 214=item start => INT 215 216Gives the cumulative amount of quota allocated to each previous bucket. The 217first bucket's C<start> value will be 0, the second will be the C<value> 218allocated to the first, and so on. 219 220=back 221 222The bucket hashes will not otherwise be modified; the caller may place any 223extra keys in the hashes as required. 224 225=cut 226 227sub _assert_int 228{ 229 my ( $name, $value ) = @_; 230 $value == int $value or croak "'$name' value must be an integer"; 231 return $value; 232} 233 234sub distribute 235{ 236 my ( $total, @buckets ) = @_; 237 238 _assert_int total => $total; 239 240 my $base_total = 0; 241 my $expand_total = 0; 242 my $fixed_total = 0; 243 244 foreach my $b ( @buckets ) { 245 if( defined $b->{base} ) { 246 $base_total += _assert_int base => $b->{base}; 247 $expand_total += _assert_int expand => $b->{expand} || 0; 248 } 249 elsif( defined $b->{fixed} ) { 250 $fixed_total += _assert_int fixed => $b->{fixed}; 251 } 252 } 253 254 my $allocatable = $total - $fixed_total; 255 my $spare = $allocatable - $base_total; 256 257 if( $spare >= 0 ) { 258 my $err = 0; 259 260 # This algorithm tries to allocate spare quota roughly evenly to the 261 # buckets. It keeps track of rounding errors in $err, to ensure that 262 # rounding-down-to-int() errors don't leave us some spare amount 263 264 my $current = 0; 265 266 foreach my $b ( @buckets ) { 267 die "ARG: ran out of quota" if( $current > $total ); 268 269 my $amount; 270 if( defined $b->{base} ) { 271 my $extra = 0; 272 if( $expand_total ) { 273 $extra = $spare * ( $b->{expand} || 0 ); 274 275 # Avoid floating point divisions 276 $err += $extra % $expand_total; 277 $extra = do { use integer; $extra / $expand_total }; 278 279 $extra++, $err -= $expand_total if $err >= $expand_total; 280 } 281 282 $amount = $b->{base} + $extra; 283 } 284 elsif( defined $b->{fixed} ) { 285 $amount = $b->{fixed}; 286 } 287 288 if( $current + $amount > $total ) { 289 $amount = $total - $current; # All remaining space 290 } 291 292 $b->{start} = $current; 293 $b->{value} = $amount; 294 295 $current += $amount; 296 } 297 } 298 elsif( $allocatable > 0 ) { 299 # Divide it best we can 300 301 my $err = 0; 302 303 my $current = 0; 304 305 foreach my $b ( @buckets ) { 306 my $amount; 307 308 if( defined $b->{base} ) { 309 $amount = $b->{base} * $allocatable / $base_total; 310 311 $err += $amount - int($amount); 312 $amount++, $err-- if $err >= 1; 313 314 $amount = int($amount); 315 } 316 elsif( defined $b->{fixed} ) { 317 $amount = $b->{fixed}; 318 } 319 320 $b->{start} = $current; 321 $b->{value} = $amount; 322 323 $current += $amount; 324 } 325 } 326} 327 328=head1 AUTHOR 329 330Paul Evans <leonerd@leonerd.org.uk> 331 332=cut 333 3340x55AA; 335