File Coverage

blib/lib/Genealogy/Ahnentafel.pm
Criterion Covered Total %
statement 60 60 100.0
branch 9 10 90.0
condition n/a
subroutine 24 24 100.0
pod 1 1 100.0
total 94 95 98.9


line stmt bran cond sub pod time code
1             package Genealogy::Ahnentafel;
2              
3             =head1 NAME
4              
5             Genealogy::Ahnentafel - Handle Ahnentafel numbers in Perl.
6              
7             =head1 SYNOPSIS
8              
9             use Genealogy::Ahnentafel;
10              
11             my $ahnen = ahnen(1);
12             say $ahnen->gen; # 1
13             say $ahnen->gender; # Unknown
14             say $ahnen->description; # Person
15              
16             my $ahnen = ahnen(2);
17             say $ahnen->gen; # 2
18             say $ahnen->gender; # Male
19             say $ahnen->description; # Father
20              
21             my $ahnen = ahnen(5);
22             say $ahnen->gen; # 3
23             say $ahnen->gender; # Female
24             say $ahnen->description; # Grandmother
25              
26             =head1 DESCRIPTION
27              
28             Geologists often use Ahnentafel (from the German for "ancestor table")
29             numbers to identify the direct ancestors of a person. The original
30             person of interest is given the number 1, their father and mother are
31             2 and 3, their paternal grandparents are 4 and 5, their maternal
32             grandparents are 6 and 7 and the list goes on.
33              
34             This class gives you a way to deal with these numbers in Perl.
35              
36             Ahnentafel numbers have some interesting properties. For example, with
37             the exception of the first person in the list (who can, obviously, be
38             of either sex) all of the men have Ahnentafel numbers which are even
39             and the women have Ahnentafel numbers which are even. You can calculate
40             the number of the father of any person on the list simply by doubling
41             the number of the child. You can get the number of their mother by
42             doubling the child's number and adding one.
43              
44             =cut
45              
46 1     1   62450 use strict;
  1         2  
  1         24  
47 1     1   4 use warnings;
  1         2  
  1         50  
48              
49             our $VERSION = '1.0.2';
50              
51             require Exporter;
52             our @ISA = qw[Exporter];
53             our @EXPORT = qw[ahnen];
54              
55 1     1   5 use Carp;
  1         2  
  1         52  
56              
57 1     1   564 use Moo;
  1         9839  
  1         4  
58 1     1   1671 use MooX::ClassAttribute;
  1         17187  
  1         6  
59 1     1   598 use Types::Standard qw( Str Int ArrayRef Bool );
  1         61982  
  1         11  
60 1     1   1462 use Type::Utils qw( declare as where inline_as coerce from );
  1         4154  
  1         9  
61              
62             my $PositiveInt = declare
63             as Int,
64             where { $_ > 0 },
65             inline_as { "defined $_ and $_ =~ /^[0-9]+\$/ and $_ > 0" };
66              
67             use overload
68 14     14   2404 '""' => sub { $_[0]->ahnentafel },
69 1     1   806 fallback => 1;
  1         2  
  1         8  
70              
71             =head1 FUNCTIONS
72              
73             This module exports one function.
74              
75             =head2 ahnen($positive_integer)
76              
77             This function takes a positive integer and returns a Genealogy::Ahnentafel
78             object for that integer. If you pass it something that isn't a positive
79             integer the function will throw an exception.
80              
81             This is just a short-cut for
82              
83             Genealogy::Ahnentafel->new({ ahnentafel => $positive_integer })
84              
85             =cut
86              
87             sub ahnen {
88 53     53 1 18591 return Genealogy::Ahnentafel->new({ ahnentafel => $_[0] });
89             }
90              
91             =head1 CLASS ATTRIBUTES
92              
93             The module provides two class attributes. These define strings that are
94             used in the output of various methods in the class. They are provided to
95             make it easier to subclass this class to support internationalisation.
96              
97             =head2 genders
98              
99             This is a reference to an array that contains two strings that represent
100             the genders male and female. By default, they are the strings "Male" and
101             "Female".
102              
103             =cut
104              
105             class_has genders => (
106             is => 'lazy',
107             isa => ArrayRef[Str],
108             );
109              
110             sub _build_genders {
111 1     1   22 return [ qw[Male Female] ];
112             }
113              
114             =head2 parent_names
115              
116             This is a reference to an array that contains two strings that represent
117             the parent of the two genders. By default, they are the strings "Father"
118             and "Mother".
119              
120             Note that these strings are also used to build more complex relationship
121             names like "Grandfather" and "Great Grandmother".
122              
123             =cut
124              
125             class_has parent_names => (
126             is => 'lazy',
127             isa => ArrayRef[Str],
128             );
129              
130             sub _build_parent_names {
131 1     1   21 return [ qw[Father Mother] ];
132             }
133              
134             =head1 OBJECT ATTRIBUTES
135              
136             Objects of this class have the following attributes. Most them are
137             lazily generated from the Ahnentafel number.
138              
139             =head2 ahnentafel
140              
141             The positive integer that was used to create this object.
142              
143             say ahnen(123)->ahnentafel; # 123
144              
145             =cut
146              
147             has ahnentafel => (
148             is => 'ro',
149             isa => $PositiveInt,
150             required => 1,
151             );
152              
153             =head2 gender
154              
155             The gender of the person represented by this object. This returns "Unknown"
156             for person 1 (as the person at the root of the tree can be of either gender).
157             Other than that people with an even Ahnentafel number are men and people with
158             an odd Ahnentafel are women.
159              
160             =cut
161              
162             has gender => (
163             is => 'lazy',
164             isa => Str,
165             );
166              
167             sub _build_gender {
168 7     7   6118 my $ahnen = $_[0]->ahnentafel;
169 7 100       35 return 'Unknown' if $ahnen == 1;
170 6         79 return $_[0]->genders->[ $ahnen % 2 ];
171             }
172              
173             =head2 gender_description
174              
175             (I'm not convinced by this name. I'll almost certainly change it at some
176             point.)
177              
178             The base word that is used for people of this gender. It is "Person" for
179             person 1 (as we don't know their gender) and either "Father" or "Mother"
180             as appropriate for everyone else.
181              
182             =cut
183              
184             has gender_description => (
185             is => 'lazy',
186             isa => Str,
187             );
188              
189             sub _build_gender_description {
190 10     10   73 my $ahnen = $_[0]->ahnentafel;
191 10 50       21 return 'Person' if $ahnen == 1;
192 10         126 return $_[0]->parent_names->[ $ahnen % 2 ];
193             }
194              
195             =head2 generation
196              
197             The number of the generation that this person is in. Person 1 is in
198             generation 1. People 2 and 3 (the parents) are in generation 2. People
199             4 to 7 (the grandparents) are in generation 3. And so on.
200              
201             =cut
202              
203             has generation => (
204             is => 'lazy',
205             isa => $PositiveInt,
206             );
207              
208             sub _build_generation {
209 22     22   502 my $ahnen = $_[0]->ahnentafel;
210 22         320 return int log( $ahnen ) / log(2) + 1;
211             }
212              
213             =head2 description
214              
215             A description of the relationship between the root person and the current
216             person. For person 1, it is "Person". For people 2 and 3 it is "Father"
217             or "Mother". For people in generation 3, it is "Grandfather" or
218             "Grandmother". After that we prepend the appropriate number of repetitions
219             of "Great" - "Great Grandmother", "Great Great Grandfather", etc.
220              
221             =cut
222              
223             has description => (
224             is => 'lazy',
225             isa => Str,
226             );
227              
228             sub _build_description {
229 12     12   559 my $ahnen = $_[0]->ahnentafel;
230              
231 12         151 my $generation = $_[0]->generation();
232              
233 12 100       242 return 'Person' if $generation == 1;
234              
235 10         145 my $root = $_[0]->gender_description;
236 10 100       453 return $root if $generation == 2;
237 7         16 $root = "Grand\L$root";
238 7 100       74 return $root if $generation == 3;
239 2         3 my $greats = $generation - 3;
240 2         28 return ('Great ' x $greats) . $root;
241             }
242              
243             =head2 ancestry
244              
245             An array of Genealogy::Ahnentafel objects representing all of the people
246             between (and including) the root person and the current person.
247              
248             =cut
249              
250             has ancestry => (
251             is => 'lazy',
252             isa => ArrayRef,
253             );
254              
255             sub _build_ancestry {
256 1     1   62 my @ancestry;
257 1         7 my $curr = $_[0]->ahnentafel;
258              
259 1         4 while ($curr) {
260 3         6 unshift @ancestry, ahnen($curr);
261 3         103 $curr = int($curr / 2);
262             }
263              
264 1         15 return \@ancestry;
265             }
266              
267             =head2 ancestry_string
268              
269             A string representation of ancestry.
270              
271             =cut
272              
273             has ancestry_string => (
274             is => 'lazy',
275             isa => Str,
276             );
277              
278             sub _build_ancestry_string {
279 1     1   470 return join ', ', map { $_->description } @{ $_[0]->ancestry };
  3         81  
  1         14  
280             }
281              
282             =head2 father
283              
284             A Genealogy::Ahnentafel object representing the father of the current
285             person.
286              
287             =cut
288              
289             has father => (
290             is => 'lazy',
291             );
292              
293             sub _build_father {
294 4     4   238 return ahnen($_[0]->ahnentafel * 2);
295             }
296              
297             =head2 mother
298              
299             A Genealogy::Ahnentafel object representing the mother of the current
300             person.
301              
302             =cut
303              
304             has mother => (
305             is => 'lazy',
306             );
307              
308             sub _build_mother {
309 4     4   1177 return ahnen($_[0]->ahnentafel * 2 + 1);
310             }
311              
312             =head2 first_in_generation
313              
314             The lowest Ahnentafel number that appears in the current generation.
315              
316             =cut
317              
318             has first_in_generation => (
319             is => 'lazy',
320             isa => Int,
321             );
322              
323             sub _build_first_in_generation {
324 3     3   210 return 2 ** ($_[0]->generation - 1);
325             }
326              
327             =head2 is_first_in_generation
328              
329             Is this the first Ahnentafel number in the current generation?
330              
331             =cut
332              
333             has is_first_in_generation => (
334             is => 'lazy',
335             isa => Bool,
336             );
337              
338             sub _build_is_first_in_generation {
339 3     3   1610 return $_[0]->first_in_generation == $_[0]->ahnentafel;
340             }
341              
342             =head2 last_in_generation
343              
344             The highest Ahnentafel number that appears in the current generation.
345              
346             =cut
347              
348             has last_in_generation => (
349             is => 'lazy',
350             isa => Int,
351             );
352              
353             sub _build_last_in_generation {
354 3     3   1484 return 2 ** $_[0]->generation - 1;
355             }
356              
357             =head2 is_last_in_generation
358              
359             Is this the last Ahnentafel number in the current generation?
360              
361             =cut
362              
363             has is_last_in_generation => (
364             is => 'lazy',
365             isa => Bool,
366             );
367              
368             sub _build_is_last_in_generation {
369 3     3   1481 return $_[0]->last_in_generation == $_[0]->ahnentafel;
370             }
371              
372             =head1 AUTHOR
373              
374             Dave Cross
375              
376             =head1 COPYRIGHT AND LICENCE
377              
378             Copyright (c) 2016, Magnum Solutions Ltd. All Rights Reserved.
379              
380             This library is free software; you can redistribute it and/or modify it
381             under the same terms as Perl itself.
382              
383             =cut
384              
385             1;