File Coverage

blib/lib/Lingua/SV/Numbers.pm
Criterion Covered Total %
statement 15 63 23.8
branch 0 32 0.0
condition 0 21 0.0
subroutine 5 14 35.7
pod 2 2 100.0
total 22 132 16.6


line stmt bran cond sub pod time code
1             package Lingua::SV::Numbers;
2              
3 1     1   70575 use Exporter 5.57 'import';
  1         33  
  1         51  
4             @EXPORT_OK = qw/num2sv num2sv_cardinal num2sv_ordinal/;
5              
6 1     1   6 use warnings;
  1         1  
  1         29  
7 1     1   6 use strict;
  1         6  
  1         43  
8 1     1   6 use Carp;
  1         2  
  1         83  
9              
10             use constant {
11 1         5181 ORDINAL => 1, # flag passed to _translate()
12 1     1   5 };
  1         2  
13              
14              
15              
16             #--------------
17              
18             # According to SAOL:
19             # biljon: en miljon miljoner
20             # triljon: en miljon biljoner
21             # kvadriljon: en miljon triljoner
22             my %bases;
23             @bases{0..20,30,40,50,60,70,80,90,100,1_000,10**6,10**9,10**12,10**18} = qw/
24             noll ett två tre fyra fem sex sju åtta nio tio
25             elva tolv tretton fjorton femton sexton sjutton arton nitton
26             tjugo trettio fyrtio femtio sextio sjuttio åttio nittio
27             hundra tusen miljon miljard biljon triljon
28             /;
29             my %ordinalBases;
30             @ordinalBases{sort {$a<=>$b} keys %bases} = qw/
31             nollte första andra tredje fjärde femte sjätte sjunde åttonde nionde tionde
32             elfte tolfte trettonde fjortonde femtonde sextonde sjuttonde artonde nittonde
33             tjugonde trettionde fyrtionde femtionde sextionde sjuttionde åttionde nittionde
34             hundrade tusende miljonte miljardte biljonte triljonte
35             /;
36              
37              
38              
39             #--------------
40              
41              
42             *num2sv = \&num2sv_cardinal;
43             sub num2sv_cardinal {
44 0     0 1   _num2sv( 0, @_ );
45             }
46             sub num2sv_ordinal {
47 0     0 1   _num2sv( ORDINAL, @_ );
48             }
49             sub _num2sv {
50 0     0     my $flags = shift;
51 0 0         carp "not exactly one argument given" if ( @_ != 1 );
52 0           my $x = shift;
53 0 0         if ( $x =~ m/^-?\d+$/ ) {
54 0           return _translate( $flags, _reduce( $x ) );
55             } else {
56 0           carp "not an integer";
57 0           return $x;
58             }
59             }
60              
61             #--------------
62              
63             # Translates an array of reduced components.
64             sub _translate {
65 0     0     my $flags = shift;
66 0           my $str = '';
67 0 0         if ( $_[0] eq '-' ) {
68 0           $str = 'minus ';
69 0           shift;
70             }
71 0           my $prev;
72 0           while ( @_ ) {
73 0           my $cur = shift;
74 0           my $next = $_[0];
75              
76 0 0 0       if ( $prev && $prev > $cur && _precedingOne( $cur ) ) {
      0        
77 0 0         $str .= ( _tWord( $cur ) ? 'ett' : 'en' );
78             }
79              
80 0 0 0       if ( ! $next && $flags & ORDINAL ) {
    0 0        
    0 0        
      0        
      0        
81 0 0         if ( $cur > 10**6 ) {
82 0           carp( "There is no word for ordinal $cur in Swedish" );
83             }
84 0           $str .= $ordinalBases{$cur};
85             } elsif ( $cur == 1 && $next ) {
86 0 0         if ( _precedingOne( $next ) ) {
87 0 0         $str .= _tWord( $next ) ? 'ett' : 'en';
88             }
89             } elsif (
90             $prev && 1 < $prev && $prev < $cur &&
91             ! _degeneratePlural( $cur )
92             ) {
93 0           $str .= $bases{$cur} . 'er';
94             } else {
95 0           $str .= $bases{$cur};
96             }
97 0           $prev = $cur;
98             }
99 0           $str =~ s/(.)\1{2,}/$1$1/g;
100 0           return $str;
101             }
102              
103             # Returns true if the gender of the base word is t (ett).
104             sub _tWord {
105 0     0     my $num = shift;
106 0 0         warn "not a base word: $num" unless exists $bases{$num};
107 0           return $num <= 1000;
108             }
109             sub _nWord {
110 0     0     return not _tWord( shift );
111             }
112             # returns true if the base word should be preceded by en/ett in singular
113             sub _precedingOne {
114 0     0     return ( shift() >= 100 );
115             }
116             # returns true if the base word does not change in plural
117             sub _degeneratePlural {
118 0     0     return ( shift() <= 1000 );
119             }
120              
121             # Reduces a number. Returns array of reduced components.
122             sub _reduce {
123 0     0     my $x = shift;
124              
125 0 0         return ('-', -$x ) if $x < 0;
126 0 0         return $x if ( exists $bases{$x} );
127 0           for my $num ( sort {$b<=>$a} keys %bases ) {
  0            
128 0 0         next if ( $num > $x );
129 0           my $factor = int( $x / $num );
130 0           my $remainder = $x - $factor * $num;
131             #printf "splitting %.0f into %d * %.0f + %d\n", $x, $factor, $num, $x-$factor*$num;
132 0 0         return $remainder
133             ? ( _reduce( $factor ), $num, _reduce( $x - $factor*$num ) )
134             : ( _reduce( $factor ), $num );
135             }
136              
137 0           warn "no reduction found for $x";
138 0           return undef;
139             }
140              
141             =head1 NAME
142              
143             Lingua::SV::Numbers - Convert numbers into Swedish words.
144              
145             =head1 VERSION
146              
147             Version 0.03
148              
149             =cut
150              
151             our $VERSION = '0.04';
152              
153              
154             =head1 SYNOPSIS
155              
156             use Lingua::SV::Numbers qw/num2sv num2sv_ordinal/;
157             print num2sv( 99 ) . " luftballonger\n"; #-> nittionio luftballonger
158             print num2sv_ordinal( 13 ) . " timmen\n"; #-> trettonde timmen
159              
160             =head1 FUNCTIONS
161              
162             These functions are provided but not exported by default.
163              
164             =over 4
165              
166             =item num2sv EXPR
167              
168             Alias for C.
169              
170             =item num2sv_cardinal EXPR
171              
172             Returns a Swedish string of the cardinal number corresponding to EXPR. Only
173             integers (positive and negative) are supported. E.g. 3 => "tre"
174              
175             =item num2sv_ordinal EXPR
176              
177             Returns a Swedish string of the ordinal number corresponding to EXPR. Only
178             integers (positive and negative) are supported. E.g. 3 => "tredje"
179              
180             =back
181              
182             =head1 TODO
183              
184             =over 4
185              
186             =item * support fractions
187              
188             =item * support scientific notation
189              
190             =item * support thousand-dividing commas
191              
192             =back
193              
194             =head1 AUTHOR
195              
196             Tim Nordenfur, C<< >>
197              
198             =head1 BUGS
199              
200             Please report any bugs or feature requests to C, or through
201             the web interface at L. I will be notified, and then you'll
202             automatically be notified of progress on your bug as I make changes.
203              
204              
205              
206              
207             =head1 SUPPORT
208              
209             You can find documentation for this module with the perldoc command.
210              
211             perldoc Lingua::SV::Numbers
212              
213              
214             You can also look for information at:
215              
216             =over 4
217              
218             =item * RT: CPAN's request tracker
219              
220             L
221              
222             =item * AnnoCPAN: Annotated CPAN documentation
223              
224             L
225              
226             =item * CPAN Ratings
227              
228             L
229              
230             =item * Search CPAN
231              
232             L
233              
234             =back
235              
236              
237             =head1 ACKNOWLEDGEMENTS
238              
239              
240             =head1 LICENSE AND COPYRIGHT
241              
242             Copyright 2010 Tim Nordenfur.
243              
244             This program is free software; you can redistribute it and/or modify it
245             under the terms of either: the GNU General Public License as published
246             by the Free Software Foundation; or the Artistic License.
247              
248             See http://dev.perl.org/licenses/ for more information.
249              
250              
251             =cut
252              
253             1; # End of Lingua::SV::Numbers