File Coverage

blib/lib/Math/PlanePath/ToothpickTree.pm
Criterion Covered Total %
statement 422 690 61.1
branch 186 340 54.7
condition 34 92 36.9
subroutine 24 38 63.1
pod 24 24 100.0
total 690 1184 58.2


line stmt bran cond sub pod time code
1             # Copyright 2012, 2013, 2014, 2015 Kevin Ryde
2              
3             # This file is part of Math-PlanePath-Toothpick.
4             #
5             # Math-PlanePath-Toothpick is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU General Public License as published
7             # by the Free Software Foundation; either version 3, or (at your option) any
8             # later version.
9             #
10             # Math-PlanePath-Toothpick is distributed in the hope that it will be
11             # useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
13             # Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Math-PlanePath-Toothpick. If not, see .
17              
18              
19             #------------------------------------------------------------------------------
20             # cf A153003 total cells 0, 1, 4, 7, 10
21             # A153004 added cells +1, 3, 3, 3, 6
22             # A153005 total which are primes
23             # clipping parts=4 pattern to 3 quadrants,
24             # X=0,Y=0 as a half toothpick not counted
25             # X=0,Y=-1 as a half toothpick not counted
26             # X=1,Y=-1 "root" would begin at depth=1, or count it as child of 1
27             #
28             # | |
29             # 2---1---2
30             # | | |
31             # X
32             # | |
33             # ---X---2
34             # |
35             #
36             #------------------------------------------------------------------------------
37             # A160740 toothpick starting from 4 as cross
38             # doesn't maintain XYeven=vertical, XYodd=horizontal
39             # |
40             # *
41             # |
42             # ---*--- ---*---
43             # |
44             # *
45             # |
46             # A160426 cross with one long end for 5 initial toothpicks
47             # A160730 right angle of 2 toothpicks
48             # A168112 45-degree something related to 2 toothpick right-angle
49             # A160732 T of 3 toothpicks
50             #
51             #------------------------------------------------------------------------------
52             # cf A183004 toothpicks placed at ends, alternately vert,horiz
53             # A183005 added 0,1,4,6,8,8,16,22,16,8,16,
54             #
55             # .-4-.-4-.-4-.-4- middle "3" touch two ends
56             # 3 3 counts just once
57             # . .-2-.-2-.
58             # 3 1 3
59             # . .-2-.-2-.
60             # 3 3
61             # .-4-.-4-.-4-.-4-.
62             #
63             #------------------------------------------------------------------------------
64             # cf A160172 T-toothpick sequence
65             #
66             # A139250 total cells OFFSET=0 value=0
67             # a(2^k) = A007583(k) = (2^(2n+1) + 1)/3
68             # a(2^k-1) = A000969(2^k-2), A000969=floor (2*n+3)*(n+1)/3
69             # A139251 cells added
70             # a(2^i)=2^i
71             # a(2^i+j) = 2a(j)+a(j+1
72             # 0, 1, 2,
73             # 4, 4,
74             # 4, 8, 12, 8,
75             # 4, 8, 12, 12, 16, 28, 32, 16,
76             # 4, 8, 12, 12, 16, 28, 32, 20, 16, 28, 36, 40, 60, 88, 80, 32,
77             # 4, 8, 12, 12, 16, 28, 32, 20, 16, 28, 36, 40, 60, 88, 80, 36, 16, 28, 36, 40, 60, 88, 84, 56, 60, 92, 112, 140, 208, 256, 192, 64,
78             # 4, 8, 12, 12, 16, 28, 32, 20, 16, 28
79              
80             # A160570 triangle, row sums are toothpick cumulative
81             # A160552 a(2^i+j)=2*a(j)+a(j+1) starting 0,1
82             # A151548 A160552 row 2^k totals
83             # A151549 half A151548
84             # A160762 convolution
85             #
86             # cf A160808 count cells Fibonacci spiral
87             # A160809 cells added Fibonacci spiral
88             #
89             # A160164 "I"-toothpick
90             # A187220 gull
91              
92             # "Q"
93             # A187210, A211001-A211003, A211010, A211020-A211024.
94             # A211011
95             # A210838 Coordinates (x,y) of the endpoint
96             # A210841 Coordinates (x,y) of the endpoint
97             # A211000 Coordinates (x,y) of the endpoint inflection at primes
98             # http://www.njohnston.ca/2011/03/the-q-toothpick-cellular-automaton/
99             # maybe hearts A188346 == toothpicks A139250
100             #
101             # T(level) = 4 * T(level-1) + 2
102             # T(level) = 2 * (4^level - 1) / 3
103             # total = T(level) + 2
104             # N = (4^level - 1)*2/3
105             # 4^level - 1 = 3*N/2
106             # 4^level = 3*N/2 + 1
107             #
108             # len=2^level
109             # total = (len*len-1)*2/3 + 2
110              
111              
112             # | | |
113             # * -*- * -*- *
114             # | | |
115             # | |
116             # -*- o -*- * -*-
117             # | |
118             # | | |
119             # * -*- * -*- *
120             # | | |
121             #
122             #------------------------------------------------------------------------------
123              
124              
125             package Math::PlanePath::ToothpickTree;
126 2     2   2346 use 5.004;
  2         5  
  2         64  
127 2     2   9 use strict;
  2         3  
  2         54  
128 2     2   7 use Carp 'croak';
  2         2  
  2         141  
129             #use List::Util 'max','min';
130             *max = \&Math::PlanePath::_max;
131             *min = \&Math::PlanePath::_min;
132              
133 2     2   7 use vars '$VERSION', '@ISA';
  2         2  
  2         90  
134             $VERSION = 17;
135 2     2   727 use Math::PlanePath;
  2         6394  
  2         56  
136             @ISA = ('Math::PlanePath');
137              
138             use Math::PlanePath::Base::Generic
139 2         73 'is_infinite',
140 2     2   11 'round_nearest';
  2         2  
141             use Math::PlanePath::Base::Digits
142 2     2   518 'round_down_pow';
  2         2058  
  2         105  
143              
144             # uncomment this to run the ### lines
145             # use Smart::Comments;
146              
147              
148             # Note: some of this shared with ToothpickReplicate
149             #
150 2     2   11 use constant n_start => 0;
  2         2  
  2         171  
151 2         96 use constant parameter_info_array =>
152             [ { name => 'parts',
153             share_key => 'parts_toothpicktree',
154             display => 'Parts',
155             type => 'enum',
156             default => '4',
157             choices => ['4','3','2','1','octant','octant_up',
158             'wedge','two_horiz',
159             ],
160             choices_display => ['4','3','2','1','Octant','Octant Up',
161             'Wedge','Two Horiz',
162             ],
163             description => 'Which parts of the pattern to generate.',
164             },
165 2     2   10 ];
  2         2  
166              
167 2     2   9 use constant class_x_negative => 1;
  2         2  
  2         70  
168 2     2   8 use constant class_y_negative => 1;
  2         2  
  2         989  
169             {
170             my %x_negative = (4 => 1,
171             3 => 1,
172             2 => 1,
173             1 => 0,
174             octant => 0,
175             octant_up => 0,
176             wedge => 1,
177             'wedge+1' => 1,
178             two_horiz => 1,
179             );
180             sub x_negative {
181 1     1 1 46 my ($self) = @_;
182 1         8 return $x_negative{$self->{'parts'}};
183             }
184             }
185             {
186             my %x_minimum = (1 => 1,
187             octant => 1,
188             octant_up => 1,
189             # otherwise no minimum so undef
190             );
191             sub x_minimum {
192 0     0 1 0 my ($self) = @_;
193 0         0 return $x_minimum{$self->{'parts'}};
194             }
195             }
196             {
197             my %y_negative = (4 => 1,
198             3 => 1,
199             2 => 0,
200             1 => 0,
201             octant => 0,
202             octant_up => 0,
203             wedge => 0,
204             two_horiz => 1,
205             );
206             sub y_negative {
207 1     1 1 4 my ($self) = @_;
208 1         5 return $y_negative{$self->{'parts'}};
209             }
210             }
211             {
212             my %y_minimum = (2 => 1,
213             1 => 1,
214             octant => 1,
215             octant_up => 2,
216             wedge => 0,
217             'wedge+1' => -1,
218             # otherwise no minimum, undef
219             );
220             sub y_minimum {
221 0     0 1 0 my ($self) = @_;
222 0         0 return $y_minimum{$self->{'parts'}};
223             }
224             }
225              
226             {
227             my %x_negative_at_n = (4 => 4,
228             3 => 5,
229             2 => 2,
230             1 => undef,
231             octant => undef,
232             octant_up => undef,
233             wedge => 3,
234             'wedge+1' => 1,
235             two_horiz => 1,
236             );
237             sub x_negative_at_n {
238 0     0 1 0 my ($self) = @_;
239 0         0 return $x_negative_at_n{$self->{'parts'}};
240             }
241             }
242             {
243             my %y_negative_at_n = (4 => 2,
244             3 => 1,
245             2 => undef,
246             1 => undef,
247             octant => undef,
248             octant_up => undef,
249             wedge => undef,
250             'wedge+1' => 1,
251             two_horiz => 4,
252             );
253             sub y_negative_at_n {
254 0     0 1 0 my ($self) = @_;
255 0         0 return $y_negative_at_n{$self->{'parts'}};
256             }
257             }
258              
259             {
260             my %sumxy_minimum = (1 => 2, # X=1,Y=1
261             octant => 2, # X=1,Y=1
262             octant_up => 3, # X=1,Y=2
263             wedge => 0, # X=0,Y=0
264             'wedge+1' => -1,
265             # otherwise no minimum, undef
266             );
267             sub sumxy_minimum {
268 0     0 1 0 my ($self) = @_;
269 0         0 return $sumxy_minimum{$self->{'parts'}};
270             }
271             }
272             {
273             my %sumabsxy_minimum = (2 => 1, # X=1,Y=0
274             1 => 2, # X=1,Y=1
275             octant => 2, # X=1,Y=1
276             octant_up => 3, # X=1,Y=2
277             wedge => 0, # X=0,Y=0
278             );
279             sub sumabsxy_minimum {
280 0     0 1 0 my ($self) = @_;
281 0   0     0 return ($sumabsxy_minimum{$self->{'parts'}} || 0);
282             }
283             }
284              
285             {
286             my %diffxy_minimum = (octant => -1, # X=1,Y=2
287             );
288             sub diffxy_minimum {
289 0     0 1 0 my ($self) = @_;
290 0         0 return $diffxy_minimum{$self->{'parts'}};
291             }
292             }
293             {
294             my %diffxy_maximum = (octant_up => 0, # Y>=X so X-Y<=0
295             wedge => 0, # Y>=X so X-Y<=0
296             'wedge+1' => 1,
297             );
298             sub diffxy_maximum {
299 0     0 1 0 my ($self) = @_;
300 0         0 return $diffxy_maximum{$self->{'parts'}};
301             }
302             }
303              
304             {
305             my %rsquared_minimum = (2 => 1, # X=0,Y=1
306             1 => 2, # X=1,Y=1
307             octant => 2, # X=1,Y=1
308             octant_up => 5, # X=1,Y=2
309             # otherwise 0
310             );
311             sub rsquared_minimum {
312 0     0 1 0 my ($self) = @_;
313 0   0     0 return ($rsquared_minimum{$self->{'parts'}} || 0);
314             }
315             }
316 2     2   8 use constant tree_num_children_list => (0,1,2);
  2         2  
  2         7141  
317              
318              
319             # parts=1 Dir4 max 5,-4
320             # 14,-9
321             # 62,-33
322             # 126,-65
323             # 2*2^k-2, -2^k+1 -> 2,-1
324             # parts=3 same as parts=1
325             #
326             # parts=4 dX=0,dY=-1 South, apparently
327             {
328             my %dir_maximum_dxdy = (4 => [0,-2], # at N=1 South dX=0,dY=-2
329             2 => [0,0], # supremum, dX=big,dY=-1
330             3 => [2,-1], # supremum
331             1 => [2,-1], # supremum
332             octant => [1,-2], # at N=4
333             octant_up => [0,-2], # at N=16 South
334             wedge => [0,-2], # at N=35 South
335             'wedge+1' => [0,0], # supremum, dX=big,dY=-1
336             two_horiz => [0,0], # supremum, dX=big,dY=-1
337             );
338             sub dir_maximum_dxdy {
339 0     0 1 0 my ($self) = @_;
340 0         0 return @{$dir_maximum_dxdy{$self->{'parts'}}};
  0         0  
341             }
342             }
343              
344             #------------------------------------------------------------------------------
345              
346             # add to $depth to give parts=4 style numbering
347             my %parts_depth_adjust = (4 => 0,
348             3 => 0,
349             2 => 1,
350             1 => 2,
351             octant => 2,
352             octant_up => 2,
353             wedge => -1,
354             # 'wedge+1' => 0, # not working
355             two_horiz => 2,
356             );
357              
358             sub new {
359 41     41 1 4098 my $self = shift->SUPER::new(@_);
360 41   100     610 my $parts = ($self->{'parts'} ||= 4);
361 41 50       125 if (! exists $parts_depth_adjust{$parts}) {
362 0         0 croak "Unrecognised parts: ",$parts;
363             }
364 41         94 return $self;
365             }
366              
367              
368             #------------------------------------------------------------------------------
369             # n_to_xy()
370              
371             my %initial_n_to_xy
372             = (4 => [ [0,0], [0,1], [0,-1], [1,1], [-1,1], [-1,-1], [1,-1] ],
373             3 => [ [0,0], [0,-1], [0,1], [1,-1], [1,1], [-1,1] ],
374             2 => [ [0,1], [1,1], [-1,1] ],
375             # 1 => [ ],
376             # octant => [ ],
377             # octant_up => [ ],
378             wedge => [ [0,0], [0,1], [1,1],[-1,1] ],
379             # 'wedge+1' => [ [0,0], [0,1],[0,-1], [1,1],[-1,1] ],
380             two_horiz => [ [1,0],[-1,0], [2,0],[-2,0],
381             [2,-1],[2,1],[-2,1],[-2,-1] ],
382             );
383              
384             sub n_to_xy {
385 319     319 1 7702 my ($self, $n) = @_;
386             ### ToothpickTree n_to_xy(): $n
387              
388 319 50       504 if ($n < 0) { return; }
  0         0  
389 319 50       523 if (is_infinite($n)) { return ($n,$n); }
  0         0  
390              
391             {
392 319         1232 my $int = int($n);
  319         234  
393             ### $int
394             ### $n
395 319 50       396 if ($n != $int) {
396 0         0 my ($x1,$y1) = $self->n_to_xy($int);
397 0         0 my ($x2,$y2) = $self->n_to_xy($int+1);
398 0         0 my $frac = $n - $int; # inherit possible BigFloat
399 0         0 my $dx = $x2-$x1;
400 0         0 my $dy = $y2-$y1;
401 0         0 return ($frac*$dx + $x1, $frac*$dy + $y1);
402             }
403 319         219 $n = $int; # BigFloat int() gives BigInt, use that
404             }
405 319         248 my $zero = $n*0;
406              
407 319         274 my $parts = $self->{'parts'};
408              
409 319 100       515 if (my $initial = $initial_n_to_xy{$parts}) {
410 238 100       349 if ($n <= $#$initial) {
411             ### initial_n_to_xy{}: $initial->[$n]
412 32         23 return @{$initial->[$n]};
  32         70  
413             }
414             }
415              
416 287         401 (my $depth, $n) = _n0_to_depth_and_rem($self, $n);
417             ### $depth
418             ### remainder n: $n
419              
420             # $hdx,$hdy is the dx,dy offsets which is "horizontal". Initially this is
421             # hdx=1,hdy=0 so horizontal along the X axis, but subsequent blocks rotate
422             # around or mirror to point other directions.
423             #
424             # $vdx,$vdy is similar dx,dy which is "vertical". Initially vdx=0,vdy=1
425             # so vertical along the Y axis.
426             #
427             # $mirror is true if in a "mirror image" block. The difference is that in
428             # a plain block points are numbered around anti-clockwise, but when
429             # mirrored they're numbered clockwise.
430             #
431 287         238 my $x = 0;
432 287         188 my $y = 0;
433 287         170 my $hdx = 1;
434 287         176 my $hdy = 0;
435 287         228 my $vdx = 0;
436 287         220 my $vdy = 1;
437 287         183 my $mirror = 0;
438 287         263 $depth += $parts_depth_adjust{$parts};
439             ### depth in parts=4 style: $depth
440              
441 287 50       687 if ($parts eq 'octant') {
    50          
    50          
    50          
442              
443             } elsif ($parts eq 'octant_up') {
444 0         0 $mirror = 1;
445 0         0 $y = 1;
446 0         0 $hdx = 0; $hdy = 1; # initial transpose X,Y
  0         0  
447 0         0 $vdx = 1; $vdy = 0;
  0         0  
448              
449             } elsif ($parts eq 'wedge') {
450 0         0 $y = 1;
451 0         0 $hdx = 0; $hdy = 1; $vdy = 0;
  0         0  
  0         0  
452 0         0 my $add = _depth_to_octant_added([$depth],[1],$zero);
453 0 0       0 if ($n < $add) {
454             # right half
455 0         0 $mirror = 1;
456 0         0 $vdx = 1;
457             } else {
458             # left half
459 0         0 $n -= $add;
460 0         0 $vdx = -1;
461             }
462              
463             } elsif ($parts eq 'two_horiz') {
464 0         0 my $add = _depth_to_octant_added([$depth],[1],$zero);
465 0 0       0 if ($n < $add) {
466             ### first eighth ...
467 0         0 $hdx = 0; $hdy = -1; $vdx = 1; $vdy = 0;
  0         0  
  0         0  
  0         0  
468 0         0 $y = 1;
469             } else {
470 0         0 my $add3 = _depth_to_octant_added([$depth-3],[1],$zero);
471 0         0 my $quad = $add + $add3 - 1;
472 0         0 my $half = 2*$quad;
473             ### $add
474             ### $add3
475             ### $quad
476             ### $half
477 0 0       0 if ($n >= $half) {
478 0         0 $n -= $half;
479 0         0 $hdx = -1; $vdy = -1; # rotate 180
  0         0  
480             }
481 0 0       0 if ($n < $quad) {
482 0 0       0 if ($n < $add) {
483             ### fifth octant ...
484 0         0 $hdx = 0; $hdy = 1; $vdx = -1; $vdy = 0;
  0         0  
  0         0  
  0         0  
485 0         0 $y = -1;
486              
487             } else {
488             ### second/sixth eighth ...
489 0         0 $n -= $add - 1; # and unduplicate spine
490 0         0 $x = 2*$hdx;
491 0         0 $depth -= 3;
492 0         0 $mirror = 1;
493 0         0 $hdy = -$hdy; $vdy = -$vdy; # reflect across X axis
  0         0  
494             }
495             } else {
496 0         0 $n -= $quad;
497 0 0       0 if ($n < $add3-1) {
498             ### third/seventh eighth ...
499 0         0 $depth -= 3;
500 0         0 $x = 2*$hdx;
501             } else {
502             ### fourth/eighth eighth ...
503 0         0 $n -= $add3-1;
504 0         0 $y = -$vdy;
505 0         0 $mirror = 1;
506 0         0 ($hdx,$hdy, $vdx,$vdy) = ($vdx,$vdy, $hdx,$hdy); # transpose X,Y
507             }
508             }
509             }
510              
511             } else {
512 287         632 my $add = _depth_to_octant_added([$depth],[1],$zero);
513             ### $add
514              
515 287 100       544 if ($parts eq '3') {
516 59         97 my $add_plus1 = _depth_to_octant_added([$depth+1],[1],$zero);
517 59         68 my $add_quad = $add_plus1 + $add - 1;
518             ### parts=3 lower quad: $add_quad
519 59 100       67 if ($n < $add_quad) {
520             ### initial block 1, rotate 90 ...
521 23         19 $depth += 1;
522 23         16 $add = $add_plus1;
523 23         70 $x = -1;
524 23         14 $hdx = 0; $hdy = -1; $vdx = 1; $vdy = 0;
  23         14  
  23         22  
  23         25  
525 23         28 $parts = '1';
526             } else {
527             # now parts=2 style remaining
528 36         48 $n -= $add_quad;
529             }
530             }
531              
532 287 100       399 if ($parts ne '1') {
533 183         348 my $add_sub1 = _depth_to_octant_added([$depth-1], [1], $zero);
534 183         222 my $add_quad = $add + $add_sub1 - 1;
535              
536 183 100       261 if ($parts eq '4') {
537 85         91 my $add_half = 2*$add_quad;
538 85 100       129 if ($n >= $add_half) {
539 38         36 $n -= $add_half;
540 38         32 $hdx = -1; $vdy = -1; # rotate 180
  38         34  
541             }
542             }
543              
544             # parts=2 style two quadrants
545 183 100       396 if ($n >= $add_quad) {
546             ### second quadrant ...
547 88         89 $n -= $add_quad;
548              
549 88 100       105 if ($n >= $add_sub1) {
550             ### fourth octant ...
551 22         22 $n -= $add_sub1;
552 22         18 $n += 1; # unduplicate diagonal
553 22         19 $mirror = 1;
554 22         21 $hdx = -$hdx; $hdy = -$hdy; # reflect horizontally
  22         14  
555             } else {
556             ### third octant ...
557 66         55 $depth -= 1;
558 66         120 ($hdx,$hdy, $vdx,$vdy) # rotate -90
559             = ($vdx,$vdy, -$hdx,-$hdy);
560 66         60 $x += $hdx;
561 66         61 $y += $hdy;
562             }
563 88         107 $add = $n+1;
564             }
565             }
566              
567             ### first quadrant split: "add=$add n=$n depth=$depth"
568 287 100       402 if ($n >= $add) {
569             ### top half of quad ...
570 47         54 $depth -= 1;
571 47         40 $n -= $add;
572 47         61 $n += 1; # unduplicate diagonal
573 47         52 $mirror ^= 1;
574 47         32 $x += $vdx;
575 47         38 $y += $vdy;
576 47         78 ($hdx,$hdy, $vdx,$vdy) # transpose X,Y
577             = ($vdx,$vdy, $hdx,$hdy);
578             ### transpose to: "hdxy=$hdx,$hdy vdxy=$vdx,$vdy n=$n depth=$depth"
579             }
580             }
581             ### in parts=4 style: "n=$n depth=$depth x=$x y=$y hdxy=$hdx,$hdy vdxy=$vdx,$vdy"
582              
583 287         480 my ($pow,$exp) = round_down_pow ($depth, 2);
584 287         1878 for ( ; --$exp >= 0; $pow /=2) {
585             ### at: "pow=$pow depth=$depth n=$n mirror=$mirror xy=$x,$y h=$hdx,$hdy v=$vdx,$vdy"
586              
587 469 100       608 if ($depth < $pow) {
588             ### block 0 ...
589 41         51 next;
590             }
591 428         287 $depth -= $pow;
592              
593 428 100       558 if ($depth == $pow-1) {
594             ### pow-1 end toothpick ...
595 48         50 $x += $pow * ($hdx + $vdx) - $hdx;
596 48         47 $y += $pow * ($hdy + $vdy) - $hdy;
597 48         32 last;
598             }
599              
600 380         348 $x += $pow/2 * ($hdx + $vdx);
601 380         304 $y += $pow/2 * ($hdy + $vdy);
602             ### diagonal to: "depth=$depth xy=$x,$y"
603              
604 380 100       445 if ($depth == 0) {
605             ### toothpick A ...
606 134         107 last;
607             }
608 246 100       305 if ($depth == 1) {
609             ### toothpick B,other up,down ...
610 105 100 66     294 if ($exp && $n == $mirror) {
611             ### toothpick other (down): "subtract vdxdy=$vdx,$vdy"
612 72         52 $x -= $vdx;
613 72         68 $y -= $vdy;
614             } else {
615             ### toothpick B (up): "add vdxdy=$vdx,$vdy"
616 33         34 $x += $vdx;
617 33         31 $y += $vdy;
618             }
619 105         87 last;
620             }
621              
622 141 100       175 if ($mirror) {
623             # /
624             # /3
625             # /--
626             # /|\2
627             # /0|1\
628 45         101 my $add = _depth_to_octant_added([$depth],[1],$zero);
629             ### add in mirror block2,3: $add
630              
631 45 100       98 if ($n < $add) {
632             ### mirror block 3, same ...
633 3         7 next;
634             }
635 42         47 $n -= $add;
636              
637 42 100       85 if ($n < $add) {
638             ### mirror block 2, unmirror, vertical invert ...
639 37         29 $vdx = -$vdx;
640 37         49 $vdy = -$vdy;
641 37         40 $mirror = 0;
642 37         64 next;
643             }
644 5         6 $n -= $add;
645 5         12 $n += 1; # undouble upper/lower diagonal
646              
647             ### mirror block 1, rotate 90 ...
648             ### assert: $n < _depth_to_octant_added([$depth+1],[1],$zero);
649 5         4 $depth += 1;
650 5         6 $x -= $hdx; # offset
651 5         6 $y -= $hdy;
652 5         16 ($hdx,$hdy, $vdx,$vdy) # rotate 90 in direction v toward h
653             = (-$vdx,-$vdy, $hdx,$hdy);
654              
655             } else {
656             ### assert: $mirror==0
657             # /
658             # /3
659             # /--
660             # /|\2
661             # /0|1\
662              
663 96 50       177 if ($depth+1 < $pow) {
664 96         197 my $add = _depth_to_octant_added([$depth+1],[1],$zero) - 1;
665             ### add in block1, sans diagonal: $add
666 96 100       162 if ($n < $add) {
667             ### block 1 "lower", rotate +90 ...
668 7         9 $depth += 1;
669 7         8 $x -= $hdx; # offset
670 7         7 $y -= $hdy;
671 7         11 ($hdx,$hdy, $vdx,$vdy) # rotate 90 in direction v toward h
672             = (-$vdx,-$vdy, $hdx,$hdy);
673 7         14 next;
674             }
675 89         71 $n -= $add;
676             }
677              
678 89         148 my $add = _depth_to_octant_added([$depth],[1],$zero);
679             ### add in block2: $add
680              
681 89 100       161 if ($n < $add) {
682             ### block 2 "upper", vertical invert ...
683 47         53 $vdx = -$vdx;
684 47         51 $vdy = -$vdy;
685 47         93 $mirror = 1;
686             } else {
687             ### block 3 "extend", same ...
688 42         85 $n -= $add;
689             ### assert: $n < $add
690             }
691             }
692             }
693              
694             ### n_to_xy() return: "$x,$y (depth=$depth n=$n)"
695 287         529 return ($x,$y);
696             }
697              
698             sub xy_to_n {
699 252     252 1 4442 my ($self, $x, $y) = @_;
700             ### ToothpickTree xy_to_n(): "$x, $y"
701              
702 252         410 $x = round_nearest ($x);
703 252         1146 $y = round_nearest ($y);
704              
705 252         838 my $zero = $x * 0 * $y;
706 252         172 my $n = $zero;
707 252         156 my @add_offset;
708             my @add_mult;
709 252         186 my $mirror = 0;
710 252         165 my $depth = 0;
711 252         178 my $depth_adjust = 0;
712              
713 252         239 my $parts = $self->{'parts'};
714              
715 252 50       612 if ($parts eq 'octant') {
    50          
    50          
    50          
716             # if ($x < 1 || $y < 1 || $y > $x+1) { return undef; }
717 0         0 $depth_adjust = 2;
718              
719             } elsif ($parts eq 'octant_up') {
720             # if ($x > $y || $x < 1 || $y < 2) { return undef; }
721 0         0 ($x,$y) = ($y-1,$x);
722 0         0 $mirror = 1;
723 0         0 $depth_adjust = 2;
724              
725             } elsif ($parts eq 'wedge') {
726 0 0 0     0 if ($x > $y || $x < -$y) { return undef; }
  0         0  
727 0         0 $depth_adjust = -1;
728 0         0 $y -= 1;
729 0 0       0 if ($y <= 0) {
730 0 0       0 if ($y < 0) { return 0; } # X=0,Y=0 N=0
  0         0  
731             # otherwise Y=1
732 0 0       0 if ($x == 0) { return 1; }
  0         0  
733 0 0       0 if ($x == 1) { return 2; }
  0         0  
734 0 0       0 if ($x == -1) { return 3; }
  0         0  
735             }
736              
737 0 0       0 if ($x >= 0) {
738             ### wedge X positive half, transpose ...
739 0         0 ($x,$y) = ($y,$x);
740 0         0 $mirror = 1;
741             } else {
742             ### wedge X negative half, rotate -90 ...
743 0         0 ($x,$y) = ($y,-$x); # rotate -90
744 0         0 push @add_offset, 0;
745 0         0 push @add_mult, 1;
746             }
747             ### wedge: "x=$x y=$y"
748              
749             } elsif ($parts eq 'two_horiz') {
750 0 0 0     0 if ($x == -1 && $y == 0) { return 1; }
  0         0  
751 0 0 0     0 if ($x == -2 && $y == 0) { return 3; }
  0         0  
752              
753 0         0 my $mult = 0;
754 0         0 my $mult3 = 0;
755 0 0       0 if ($x < 0) {
756 0         0 $x = -$x; $y = -$y; # rotate 180
  0         0  
757 0         0 $mult = 2;
758 0         0 $mult3 = 2;
759 0         0 $n -= 2; # unduplicate shared diagonals in first two quarters
760             ### rotate 180 to: "$x,$y"
761             }
762 0 0       0 if ($y > 0) {
763 0         0 $mult++;
764 0         0 $mult3++;
765 0         0 $n -= 1; # unduplicate shared diagonal in first quarter
766 0 0       0 if ($x < $y+2) {
767             ### fourth/eighth eighth ...
768 0         0 $depth_adjust = 2;
769 0         0 $mult3++;
770 0         0 $n -= 1; # unduplicate shared diagonal
771 0         0 ($x,$y) = ($y+1,$x); # transpose and offset
772 0         0 $mirror = 1;
773             } else {
774             ### third/seventh eighth ...
775 0         0 $x -= 2;
776 0         0 $depth_adjust = -1;
777             }
778             } else { # $y < 0
779 0 0       0 if ($x > 2-$y) {
780             ### second/sixth eighth ...
781 0         0 $y = -$y; # mirror across X axis
782 0         0 $x -= 2;
783 0         0 $mirror = 1;
784 0         0 $mult++;
785 0         0 $n -= 1; # unduplicate shared diagonal
786 0         0 $depth_adjust = -1;
787             } else {
788             ### first/fifth eighth ...
789 0         0 ($x,$y) = (1-$y,$x); # rotate +90 and offset
790 0         0 $depth_adjust = 2;
791             }
792             }
793 0 0       0 if ($mult) {
794 0         0 push @add_offset, $depth_adjust - 2;
795 0         0 push @add_mult, $mult;
796 0 0       0 if ($mult3) {
797 0         0 push @add_offset, $depth_adjust + 1;
798 0         0 push @add_mult, $mult3;
799             }
800             }
801              
802             } else {
803              
804 252 100       393 if ($parts eq '1') {
    100          
    100          
805 51 50 33     155 if ($x < 1 || $y < 1) { return undef; }
  0         0  
806 51         40 $depth_adjust = 2;
807              
808             } elsif ($parts eq '2') {
809 51 50       87 if ($y < 1) { return undef; }
  0         0  
810 51 100       69 if ($x == 0) {
811 1 50       3 if ($y == 1) { return 0; }
  1         3  
812             }
813 50 100       68 if ($y == 1) {
814 8 100       15 if ($x == 1) { return 1; }
  1         2  
815 7 100       20 if ($x == -1) { return 2; }
  1         2  
816             }
817 48         37 $depth_adjust = 1;
818              
819             } elsif ($parts eq '3') {
820 51 100       77 if ($x == 0) {
821 5 100       9 if ($y == 0) { return 0; }
  1         2  
822 4 100       10 if ($y == -1) { return 1; }
  1         2  
823 3 100       6 if ($y == 1) { return 2; }
  1         2  
824             }
825 48 100       61 if ($y < 0) {
826 18 50       31 if ($x < 0) {
827 0         0 return undef;
828             }
829             ### parts=3 rotate +90 ...
830 18         24 ($x,$y) = (-$y,$x+1);
831 18         17 $depth_adjust = 1;
832             } else {
833 30         35 push @add_offset, -1,0; # one quadrant
834 30         26 push @add_mult, 1,1;
835 30         35 $n -= 1; # unduplicate shared diagonal
836             }
837              
838             } else {
839             ### assert: $parts eq '4'
840 99 100       133 if ($x == 0) {
841 6 100       9 if ($y == 0) { return 0; }
  2         4  
842 4 100       9 if ($y == 1) { return 1; }
  2         9  
843 2 50       5 if ($y == -1) { return 2; }
  2         4  
844             }
845 93 100       147 if ($y < 0) {
846 42         39 $x = -$x; $y = -$y; # rotate 180
  42         31  
847 42         42 push @add_offset, 0,1; # two quadrants
848 42         34 push @add_mult, 2,2;
849 42         36 $n -= 2; # unduplicate shared diagonal
850             }
851             }
852              
853 240 100       328 if ($x < 0) {
854             ### X negative mirror ...
855 82         73 $x = -$x;
856 82         69 $mirror = 1;
857 82         81 push @add_offset, 0,1; # one quadrant
858 82         74 push @add_mult, 1,1;
859 82         73 $n -= 1; # unduplicate shared diagonal
860             }
861              
862 240 100       268 if ($y <= $x) {
863             ### lower octant ...
864 126 100       181 if ($mirror) {
865 42         35 push @add_offset, 1;
866 42         63 push @add_mult, 1;
867 42         35 $n -= 1; # unduplicate shared diagonal
868             }
869             } else {
870             ### upper octant ...
871 114         163 ($x,$y) = ($y-1,$x);
872 114         264 foreach (@add_offset) { $_-- }
  148         128  
873 114         102 $depth_adjust--;
874 114 100       175 if (! $mirror) {
875 74         80 push @add_offset, -1;
876 74         64 push @add_mult, 1;
877 74         66 $n -= 1; # unduplicate shared diagonal
878             }
879 114         123 $mirror ^= 1;
880             }
881             }
882             ### $depth_adjust
883             ### xy: "$x,$y"
884              
885 240 50 33     1049 if ($x < 1|| $y < 1 || $y > $x+1) {
      33        
886 0         0 return undef;
887             }
888              
889 240         479 my ($pow,$exp) = round_down_pow (max($x,$y-1), 2);
890 240         2702 $pow *= 2;
891 240 50       363 if (is_infinite($exp)) {
892 0         0 return ($exp);
893             }
894              
895             # /
896             # /3
897             # /--
898             # /|\2
899             # /0|1\
900              
901 240         875 for (;;) {
902             ### at: "x=$x,y=$y pow=$pow depth=$depth mirror=$mirror n=$n"
903             ### assert: $x >= 1
904             ### assert: $y >= 1 || $y!=$y
905             ### assert: $y <= $x+1 || $y!=$y
906              
907             # if ($x == $pow) {
908             # if ($y == $pow) {
909             # }
910             # if ($y == $pow+1) {
911             # ### toothpick B, stop ...
912             # $depth += 2*$pow - 1;
913             # $n += 1-$mirror; # "other" first if not mirrored
914             # last;
915             # }
916             # if ($y == $pow-1) {
917             # ### toothpick other, stop ...
918             # $depth += 2*$pow - 1;
919             # $n += $mirror; # B first if not mirrored
920             # last;
921             # }
922             # }
923              
924 526 100       511 if ($x < $pow) {
925 267 50 33     447 if ($y == $pow && $x == $pow-1) {
926             ### toothpick A, stop ...
927 0         0 $depth += 2*$pow - 1;
928 0         0 last;
929             }
930             ### block 0, no action ...
931              
932             } else {
933 259         168 $x -= $pow;
934 259         190 $y -= $pow;
935 259         192 $depth += 2*$pow;
936              
937 259 100       420 if ($y == 0) {
    100          
938 67 50       80 if ($x == 0) {
939             ### toothpick B, stop ...
940 67         56 last;
941             } else {
942 0         0 return undef;
943             }
944              
945             } elsif ($y > 0) {
946             ### block 3, same ...
947 57 50 66     210 if ($y == 1 && $x == 0) {
948             ### middle above point, stop ...
949 0         0 $depth += 1;
950 0 0       0 if (! $mirror) {
951 0         0 $n += 1;
952             }
953 0         0 last;
954             }
955 57 100       102 if (! $mirror) {
956 30         47 push @add_offset, $depth-1, $depth; # past block 1,2
957 30         33 push @add_mult, 1, 1;
958 30         37 $n -= 1; # unduplicate shared diagonal
959             }
960              
961             } else {
962 135 100 100     362 if ($y == -1 && $x == 0) {
963             ### middle below point, stop ...
964 56         47 $depth += 1;
965 56 100       105 if ($mirror) {
966 28         22 $n += 1;
967             }
968 56         60 last;
969             }
970 79 100       134 if ($x >= -$y) {
971             ### block 2, vertical flip mirror ...
972 59 50       107 if ($y > -1) {
973 0         0 return undef; # no such point
974             }
975 59         111 $y = -$y;
976 59 100       90 if ($mirror) {
977 28         30 push @add_offset, $depth; # past block 3
978 28         27 push @add_mult, 1;
979             } else {
980 31         40 push @add_offset, $depth-1; # past block 1
981 31         39 push @add_mult, 1;
982 31         39 $n -= 1; # unduplicate shared diagonal
983             }
984 59         74 $mirror ^= 1;
985              
986             } else {
987             ### block 1, rotate and offset ...
988 20         21 $depth -= 1;
989 20         35 ($x,$y) = (-$y,$x+1); # rotate +90, offset
990 20 100       37 if ($mirror) {
991 8         9 push @add_offset, $depth+1; # past block 3,2
992 8         7 push @add_mult, 2;
993 8         8 $n -= 1; # unduplicate shared diagonal 2,1
994             }
995             }
996             }
997             }
998              
999 403 100       512 if (--$exp < 0) {
1000             ### final xy: "$x,$y"
1001 117 50 33     320 if ($x == 1 && $y == 1) {
    0 0        
1002 117         97 $depth += 2;
1003             } elsif ($x == 1 && $y == 2) {
1004 0         0 $depth += 3;
1005             } else {
1006             ### not in final position ...
1007 0         0 return undef;
1008             }
1009 117         97 last;
1010             }
1011 286         269 $pow /= 2;
1012             }
1013              
1014             ### final depth: $depth - $depth_adjust
1015             ### $n
1016             ### depth_to_n: $self->tree_depth_to_n($depth - $depth_adjust)
1017             ### add_offset: join(',',@add_offset)
1018             ### add_mult: join(',',@add_mult)
1019              
1020 240         416 $n += $self->tree_depth_to_n($depth - $depth_adjust);
1021              
1022 240 100       343 if (@add_offset) {
1023 210         194 foreach my $add_offset (@add_offset) {
1024 551         439 $add_offset = $depth - $add_offset; # mutate array
1025             ### add: "unadj depth=$add_offset", _depth_to_octant_added([$add_offset],[1], $zero)." x add_mult"
1026             # .$add_mult[$i]
1027             }
1028             ### total add: _depth_to_octant_added ([@add_offset], [@add_mult], $zero)
1029 210         352 $n += _depth_to_octant_added (\@add_offset, \@add_mult, $zero);
1030             }
1031              
1032             ### xy_to_n() return n: $n
1033 240         408 return $n;
1034             }
1035              
1036              
1037             # Shared with ToothpickReplicate.
1038             # not exact
1039             sub rect_to_n_range {
1040 108     108 1 9217 my ($self, $x1,$y1, $x2,$y2) = @_;
1041             ### ToothpickTree rect_to_n_range(): "$x1,$y1 $x2,$y2"
1042              
1043 108         270 $x1 = round_nearest ($x1);
1044 108         644 $y1 = round_nearest ($y1);
1045 108         539 $x2 = round_nearest ($x2);
1046 108         558 $y2 = round_nearest ($y2);
1047              
1048 108 100       576 ($x1,$x2) = ($x2,$x1) if $x1 > $x2;
1049 108 100       185 ($y1,$y2) = ($y2,$y1) if $y1 > $y2;
1050              
1051 108         155 my $parts = $self->{'parts'};
1052 108 50 33     454 if ($parts eq 'wedge' || $parts eq 'wedge+1') {
1053 0         0 my ($len,$level) = round_down_pow ($y2, 2);
1054 0         0 return (0, (8*$len*$len-5)/3 + 2*$len);
1055             }
1056              
1057 108 100 66     371 if ($parts eq '4' || $parts eq 'two_horiz') {
1058 22 50       41 if ($parts eq 'two_horiz') {
1059 0         0 $x2 += 3;
1060 0         0 $x1 -= 3;
1061 0         0 $y2 += 2;
1062 0         0 $y1 -= 2;
1063             }
1064 22         71 my ($len,$level) = round_down_pow (max(-$x1,
1065             $x2,
1066             -1-$y1,
1067             $y2-1),
1068             2);
1069 22         373 return (0, (32*$len*$len-2)/3);
1070             }
1071              
1072 86 100       288 if ($parts eq '3') {
1073 16 50 66     40 if ($x2 < 0 && $y2 < 0) {
1074             ### third quadrant only, no points ...
1075 0         0 return (1,0);
1076             }
1077             # +---------+-------------+
1078             # | x1,y2-1 | x2,y2-1 |
1079             # +---------+-------------+
1080             # | rot and X-1 |
1081             # | x2-1+1,y1 |
1082             # +-------------+
1083             # Point N=28 X=3,Y=-4 and further X=2^k-1,Y=-2^k belong in previous
1084             # $level level, but don't worry about that for now.
1085 16         52 my ($len,$level) = round_down_pow (max(-$x1,
1086             $x2,
1087             -$y1,
1088             $y2-1),
1089             2);
1090 16         269 return (0, 8*$len*$len);
1091              
1092             }
1093 70 50       113 if ($parts eq '2') {
1094 0 0       0 if ($y2 < 0) {
1095 0         0 return (1,0);
1096             }
1097 0         0 my ($len,$level) = round_down_pow (max(-$x1,
1098             $x2,
1099             $y2-1),
1100             2);
1101 0         0 return (0, (16*$len*$len-4)/3);
1102              
1103             }
1104              
1105             ### assert: $parts eq '1'
1106 70 50 33     260 if ($x2 < 1 || $y2 < 1) {
1107 0         0 return (1,0);
1108             }
1109 70         202 my ($len,$level) = round_down_pow (max($x2, $y2-1),
1110             2);
1111 70         1404 return (0, (8*$len*$len-5)/3);
1112             }
1113              
1114             #------------------------------------------------------------------------------
1115              
1116             # Is it possible to calculate this by the bits of N rather than by X,Y?
1117             sub tree_n_children {
1118 0     0 1 0 my ($self, $n) = @_;
1119             ### tree_n_children(): $n
1120              
1121 0 0       0 my ($x,$y) = $self->n_to_xy($n)
1122             or return; # before n_start(), no children
1123              
1124 0         0 my ($n1,$n2);
1125 0 0       0 if (($x + $y) % 2) {
1126             # odd, horizontal to children
1127 0         0 $n1 = $self->xy_to_n($x-1,$y);
1128 0         0 $n2 = $self->xy_to_n($x+1,$y);
1129             } else {
1130             # even, vertical to children
1131 0         0 $n1 = $self->xy_to_n($x,$y-1);
1132 0         0 $n2 = $self->xy_to_n($x,$y+1);
1133             }
1134             ### $n1
1135             ### $n2
1136 0 0 0     0 if (($n1||0) > ($n2||0)) {
      0        
1137 0         0 ($n1,$n2) = ($n2,$n1); # sorted
1138             }
1139 0 0 0     0 return ((defined $n1 && $n1 > $n ? $n1 : ()),
    0 0        
1140             (defined $n2 && $n2 > $n ? $n2 : ()));
1141             }
1142              
1143             my %parts_to_numroots = (two_horiz => 2,
1144             # everything else 1 root
1145             );
1146             sub tree_num_roots {
1147 0     0 1 0 my ($self) = @_;
1148 0   0     0 return ($parts_to_numroots{$self->{'parts'}} || 1);
1149             }
1150              
1151             sub tree_n_parent {
1152 0     0 1 0 my ($self, $n) = @_;
1153             ### tree_n_parent(): $n
1154              
1155 0         0 $n = int($n);
1156 0 0 0     0 if ($n < ($parts_to_numroots{$self->{'parts'}} || 1)) {
1157 0         0 return undef;
1158             }
1159 0 0       0 my ($x,$y) = $self->n_to_xy($n)
1160             or return undef;
1161              
1162             ### parent at: "xy=$x,$y"
1163             ### parent odd list: (($x%2) ^ ($y%2)) && ($self->xy_to_n_list($x,$y-1), $self->xy_to_n_list($x,$y+1))
1164             ### parent even list: !(($x%2) ^ ($y%2)) && ($self->xy_to_n_list($x-1,$y), $self->xy_to_n_list($x+1,$y))
1165             ### parent min: min($self->xy_to_n_list($x-1,$y), $self->xy_to_n_list($x+1,$y),$self->xy_to_n_list($x,$y-1), $self->xy_to_n_list($x,$y+1))
1166              
1167 0 0       0 return min((($x%2) ^ ($y%2))
1168             ?
1169             # odd X,Y, vertical to parent
1170             ($self->xy_to_n_list($x,$y-1),
1171             $self->xy_to_n_list($x,$y+1))
1172             :
1173             # even X,Y, horizontal to parent
1174             ($self->xy_to_n_list($x-1,$y),
1175             $self->xy_to_n_list($x+1,$y)));
1176             }
1177              
1178             sub tree_n_to_depth {
1179 882     882 1 3254 my ($self, $n) = @_;
1180             ### tree_n_to_depth(): "$n"
1181              
1182 882 50       1374 if ($n < 0) {
1183 0         0 return undef;
1184             }
1185 882         1233 my ($depth) = _n0_to_depth_and_rem($self, int($n));
1186             ### n0 depth: $depth
1187 882         1435 return $depth;
1188             }
1189              
1190              
1191             # Do a binary search for the bits of depth which give Ndepth <= N.
1192             #
1193             # Ndepth grows as roughly depth*depth, so this is about log4(N) many
1194             # compares. For large N wouldn't want to a table to search through to
1195             # sqrt(N).
1196              
1197             sub _n0_to_depth_and_rem {
1198 1169     1169   897 my ($self, $n) = @_;
1199             ### _n0_to_depth_and_rem(): "n=$n parts=$self->{'parts'}"
1200              
1201             # For parts=4 have depth=2^exp formula
1202             # T[2^exp] = parts*(4^exp-1)*2/3 + 3
1203             # parts*(4^exp-1)*2/3 + 3 = N
1204             # 4^exp = (N-3)*3/2parts, round down
1205             # but must be bigger ... (WHY-IS-IT-SO?)
1206             #
1207 1169         2370 my ($pow,$exp) = round_down_pow (12*$n, # /$self->{'parts'}
1208             4);
1209 1169 50       8716 if (is_infinite($exp)) {
1210 0         0 return ($exp,0);
1211             }
1212             ### $pow
1213             ### $exp
1214              
1215 1169         5123 my $depth = 0;
1216 1169         895 my $n_depth = 0;
1217 1169         822 $pow = 2 ** $exp; # pow=2^exp down to 1, inclusive
1218              
1219 1169         1577 while ($exp-- >= 0) {
1220 6021         5108 my $try_depth = $depth + $pow;
1221 6021         7919 my $try_n_depth = $self->tree_depth_to_n($try_depth);
1222              
1223             ### $depth
1224             ### $pow
1225             ### $try_depth
1226             ### $try_n_depth
1227              
1228 6021 100       7812 if ($try_n_depth <= $n) {
1229             ### use this tried depth ...
1230 2808         1965 $depth = $try_depth;
1231 2808         2108 $n_depth = $try_n_depth;
1232             }
1233 6021         9461 $pow /= 2;
1234             }
1235              
1236             ### _n0_to_depth_and_rem() final ...
1237             ### $depth
1238             ### remainder: $n - $n_depth
1239              
1240 1169         1602 return ($depth, $n - $n_depth);
1241             }
1242              
1243             # First unsorted @pending
1244             # depth=119 parts=4 pow=64 119
1245             # depth=119 parts=4 pow=32 56,55
1246             # depth=119 parts=4 pow=16 25,24,23
1247             # depth=119 parts=4 pow=8 10,9,8,7 <- list crosses pow=8 boundary
1248             # depth=119 parts=4 pow=4 3,2,7
1249             # depth=119 parts=4 pow=2 3
1250              
1251             # T(2^k+rem) = T(2^k) + T(rem) + 2T(rem-1) rem>=1
1252              
1253              
1254             #------------------------------------------------------------------------------
1255             # tree_depth_to_n()
1256              
1257             # initial toothpicks not counted by the blocks crunching
1258             my %depth_to_n_initial
1259             = (4 => 3, # 1 origin + 1 above + 1 below
1260             3 => 2, # 1 origin + 1 above
1261             2 => 1, # 1 middle X=0,Y=1
1262             1 => 0,
1263             octant => 0,
1264             octant_up => 0,
1265             wedge => 4,
1266             'wedge+1' => 3,
1267             two_horiz => 0,
1268             );
1269              
1270             my %tree_depth_to_n = (4 => [ 0, 1, 3 ],
1271             3 => [ 0, 1, 3 ],
1272             2 => [ 0, 1 ],
1273             1 => [ 0, 1 ],
1274             octant => [ 0, 1 ],
1275             octant_up => [ 0, 1 ],
1276             wedge => [ 0, 1, 2 ],
1277             'wedge+1' => [ 0, 1 ],
1278             two_horiz => [ 0, 2, 4 ],
1279             );
1280              
1281             sub tree_depth_to_n {
1282 7491     7491 1 23067 my ($self, $depth) = @_;
1283             ### tree_depth_to_n(): "$depth parts=$self->{'parts'}"
1284              
1285 7491 50       9978 if ($depth < 0) {
1286 0         0 return undef;
1287             }
1288 7491         5221 $depth = int($depth);
1289              
1290 7491         7640 my $parts = $self->{'parts'};
1291             {
1292 7491         5088 my $initial = $tree_depth_to_n{$parts};
  7491         7267  
1293 7491 100       12029 if ($depth <= $#$initial) {
1294 123         234 return $initial->[$depth];
1295             }
1296             }
1297              
1298             # Adjust $depth so it's parts=4 style counting from the origin X=0,Y=0 as
1299             # depth=0. So for example parts=1 is adjusted $depth+=2 since its depth=0
1300             # is at X=1,Y=1 which is 2 levels down.
1301             #
1302             # The parts=4 style means that depth=2^k is the "A" point of a new
1303             # replication.
1304             #
1305 7368         6700 $depth += $parts_depth_adjust{$parts};
1306              
1307             # +1 for parts=3 using depth+1
1308 7368         14080 my ($pow,$exp) = round_down_pow ($depth+1, 2);
1309 7368 50       55685 if (is_infinite($exp)) {
1310 0         0 return $exp;
1311             }
1312             ### $pow
1313             ### $exp
1314              
1315 7368         31531 my $zero = $depth*0;
1316 7368         7395 my $n = $depth_to_n_initial{$parts} + $zero;
1317              
1318             # @pending is a list of depth values.
1319             # @mult is the multiple of T[depth] desired for that @pending entry.
1320             #
1321             # @pending has its values mostly in order high to low and growing by one
1322             # more value at each $exp level, but sometimes it grows a bit more and
1323             # sometimes values are not entirely high to low and may even be
1324             # duplicated.
1325             #
1326 7368         5316 my @pending;
1327             my @mult;
1328              
1329 7368 100 100     30385 if ($parts eq 'octant' || $parts eq 'octant_up') {
    100          
    50          
    100          
    100          
1330 883         1229 @pending = ($depth);
1331 883         1145 @mult = (1+$zero);
1332              
1333             } elsif ($parts eq 'wedge') {
1334             # wedge(depth) = 2*oct(depth-1) + 4
1335 66         63 @pending = ($depth);
1336 66         60 @mult = (2+$zero);
1337              
1338             } elsif ($parts eq 'wedge+1') {
1339             # wedge(depth) = 2*oct(depth-1) + depth - depth&1
1340 0         0 $n += $depth - ($depth%2);
1341 0         0 @pending = ($depth-1);
1342 0         0 @mult = (2+$zero);
1343              
1344             } elsif ($parts eq 'two_horiz') {
1345 40         35 $n -= 4*$depth - 16; # overlapping spines
1346 40         44 @pending = ($depth,$depth-3);
1347 40         48 @mult = ((4+$zero) x 2);
1348              
1349             } elsif ($parts eq '3') {
1350 1557         2288 @pending = ($depth+1, $depth, $depth-1);
1351 1557         1824 @mult = (1+$zero, 3+$zero, 2+$zero);
1352 1557         1268 $n -= 3*$depth - 8;
1353              
1354             } else {
1355             # quadrant(depth) = oct(depth) + oct(depth-1) - (d-3)
1356             # half(depth) = 2*quadrant(depth) + 1
1357             # full(depth) = 4*quadrant(depth) + 3
1358 4822         6476 @pending = ($depth, $depth-1);
1359 4822         5942 @mult = ($parts + $zero) x 2;
1360 4822         4508 $n -= $parts*($depth-3);
1361             }
1362              
1363 7368         10076 while (--$exp >= 0) {
1364 25649 100       34513 last unless @pending;
1365              
1366             ### @pending
1367             ### @mult
1368             ### $exp
1369             ### $pow
1370              
1371 22423         15530 my @new_pending;
1372             my @new_mult;
1373 0         0 my $tpow;
1374              
1375             # if (1||join(',',@pending) ne join(',',reverse sort {$a<=>$b} @pending)) {
1376             # # print "depth=$depth parts=$parts pow=$pow ",join(',',@pending),"\n";
1377             # print "mult ",join(',',@mult),"\n";
1378             # }
1379              
1380 22423         19689 foreach my $depth (@pending) {
1381 46603         35067 my $mult = shift @mult;
1382             ### assert: $depth >= 2
1383             ### assert: $depth < 2*$pow
1384              
1385 46603 100       57231 if ($depth <= 3) {
1386 11148 100       15123 if ($depth eq '3') {
1387             ### depth==3 total=1 ...
1388 6927         5299 $n += $mult;
1389             } else {
1390             ### depth==2 total=0 ...
1391             }
1392 11148         11892 next;
1393             }
1394              
1395 35455 100       44117 if ($depth < $pow) {
1396             # Smaller than $pow, keep unchanged. Cannot stop processing
1397             # @pending on finding one $depth<$pow because @pending is not quite
1398             # sorted and therefore might have a later $depth>=$pow.
1399 6689         5521 push @new_pending, $depth;
1400 6689         4990 push @new_mult, $mult;
1401 6689         8346 next;
1402             }
1403 28766         20385 my $rem = $depth - $pow;
1404              
1405             ### $depth
1406             ### $mult
1407             ### $rem
1408             ### assert: $rem >= 0 && $rem < $pow
1409              
1410 28766         18623 my $basemult = $mult; # multiple of oct(2^k) base part
1411              
1412 28766 100       37408 if ($rem == 0) {
    100          
1413             ### rem==0, so just the oct(2^k) part ...
1414              
1415             } elsif ($rem == 1) {
1416             ### rem==1 "A" ...
1417 5263         4226 $n += $mult;
1418              
1419             } else {
1420             ### rem >= 2, formula ...
1421             # formula oct(pow+rem) = oct(pow) + oct(rem+1) + 2*oct(rem) - rem + 4
1422 18234         15185 $n += (4-$rem)*$mult;
1423              
1424 18234         12041 $rem += 1; # to give rem+1
1425 18234 100 100     39278 if ($rem == $pow) {
    100          
1426             ### rem+1==pow so oct(2^k) by increasing basemult ...
1427 4927         3782 $basemult += $mult;
1428             } elsif (@new_pending && $new_pending[-1] == $rem) {
1429             ### combine rem+1 here with rem of previous ...
1430 6971         5707 $new_mult[-1] += $mult;
1431             } else {
1432 6336         5806 push @new_pending, $rem;
1433 6336         5394 push @new_mult, $mult;
1434             }
1435 18234 50       24761 if ($rem -= 1) { # to give plain rem again
1436 18234         14775 push @new_pending, $rem;
1437 18234         16048 push @new_mult, 2*$mult;
1438             }
1439             }
1440              
1441             # oct(2^k) = (4^(k-1) - 4)/3 + 2^(k-1)
1442 28766   66     56256 $tpow ||= ($pow*$pow - 16)/12 + $pow/2;
1443 28766         37400 $n += $basemult * $tpow;
1444             }
1445 22423         29143 @pending = @new_pending;
1446 22423         20462 @mult = @new_mult;
1447 22423         37294 $pow /= 2;
1448             }
1449              
1450             ### return: $n
1451 7368         10841 return $n;
1452             }
1453              
1454              
1455             #------------------------------------------------------------------------------
1456             # $depth numbered from origin in parts=4 style.
1457             # Return cells added at that depth,
1458             # ie. added = depth_to_n($depth+1) - depth_to_n($depth)
1459             #
1460             # @$depth_list is a list of $depth values.
1461             # @mult_list is the multiple of T[depth] desired for that @$depth_list entry.
1462             # $depth_list->[0], ie. the first array entry, must be the biggest $depth.
1463             #
1464             # @$depth_list is maintained mostly high to low and growing by one more
1465             # value at each $exp level, but sometimes it's a bit more and some values
1466             # not high to low and possibly duplicated.
1467             #
1468             # added(pow) = 1
1469             # added(pow+1) = 2
1470             # added(pow+rem) = 2*added(rem) + added(rem+1) - 1
1471             #
1472             # added(pow+pow-1) = 2*added(pow-1) + added(pow) - 1
1473             # = 2*added(pow-1) + 1 - 1
1474             # = 2*added(pow-1)
1475             # repeats down to added(2^k-1) = 2^(k-1)
1476              
1477             sub _depth_to_octant_added {
1478 1268     1268   2241 my ($depth_list, $mult_list, $zero) = @_;
1479              
1480             ### _depth_to_octant_added(): join(',',@$depth_list)
1481             ### assert: scalar(@$depth_list) >= 1
1482             ### assert: max(@$depth_list) == $depth_list->[0]
1483              
1484 1268         2488 my ($pow,$exp) = round_down_pow ($depth_list->[0], 2);
1485 1268 50       9518 if (is_infinite($exp)) {
1486 0         0 return $exp;
1487             }
1488             ### $pow
1489             ### $exp
1490              
1491 1268         5254 my $add = $zero;
1492              
1493 1268         1844 while (--$exp >= 0) { # running $pow down to 2 (inclusive)
1494             ### assert: $pow >= 2
1495 3695 100       4897 last unless @$depth_list;
1496              
1497             ### pending: join(',',@$depth_list)
1498             ### mult : join(',',@$mult_list)
1499             ### $exp
1500             ### $pow
1501              
1502 3227         2265 my @new_depth_list;
1503             my @new_mult_list;
1504              
1505 3227         3200 foreach my $depth (@$depth_list) {
1506 6463         5404 my $mult = shift @$mult_list;
1507             ### assert: $depth >= 0
1508             ### assert: $depth == int($depth)
1509              
1510 6463 100       8466 if ($depth <= 3) {
1511             ### depth==2or3 add=1 ...
1512 2334         1677 $add += $mult;
1513 2334         2575 next;
1514             }
1515              
1516 4129 100       5308 if ($depth < $pow) {
1517             # less than 2^exp so unchanged
1518 1077         1077 push @new_depth_list, $depth;
1519 1077         895 push @new_mult_list, $mult;
1520 1077         1560 next;
1521             }
1522              
1523 3052         2528 my $rem = $depth - $pow;
1524              
1525             ### $depth
1526             ### $mult
1527             ### $rem
1528             ### assert: $rem >= 0 && $rem <= $pow
1529              
1530 3052 100 100     8440 if ($rem == 0 || $rem == $pow-1) {
1531             ### rem==0, A of each, add=1 ...
1532             ### or depth=2*pow-1, add=1 ...
1533 802         1226 $add += $mult;
1534              
1535             } else {
1536             ### rem >= 2, formula ...
1537             # A(pow+rem) = A(rem+1) + 2A(rem) - 1
1538 2250         1737 $add -= $mult;
1539              
1540 2250         1702 $rem += 1; # to make rem+1
1541 2250 100 100     5155 if (@new_depth_list && $new_depth_list[-1] == $rem) {
1542             # add to previously pushed pending depth
1543             # print "rem=$rem ",join(',',@new_depth_list),"\n";
1544 723         728 $new_mult_list[-1] += $mult;
1545             } else {
1546 1527         1857 push @new_depth_list, $rem;
1547 1527         1600 push @new_mult_list, $mult;
1548             }
1549 2250         2098 push @new_depth_list, $rem-1; # back to plain rem
1550 2250         3925 push @new_mult_list, 2*$mult;
1551             }
1552             }
1553 3227         3796 $depth_list = \@new_depth_list;
1554 3227         3168 $mult_list = \@new_mult_list;
1555 3227         6332 $pow /= 2;
1556             }
1557              
1558             ### return: $add
1559 1268         1857 return $add;
1560             }
1561              
1562             #------------------------------------------------------------------------------
1563              
1564             sub tree_n_to_subheight {
1565 0     0 1 0 my ($self, $n) = @_;
1566             ### tree_n_to_subheight(): $n
1567              
1568 0 0       0 if ($n < 0) { return undef; }
  0         0  
1569 0 0       0 if (is_infinite($n)) { return $n; }
  0         0  
1570              
1571 0         0 my $zero = $n * 0;
1572 0         0 (my $depth, $n) = _n0_to_depth_and_rem($self, int($n));
1573             ### $depth
1574             ### $n
1575              
1576 0         0 my $parts = $self->{'parts'};
1577 0         0 $depth += $parts_depth_adjust{$parts};
1578             ### depth adjusted to: $depth
1579              
1580 0 0 0     0 if ($parts eq 'octant') {
    0          
    0          
    0          
1581 0         0 my $add = _depth_to_octant_added ([$depth],[1], $zero);
1582 0         0 $n = $add-1 - $n;
1583             ### octant mirror numbering to n: $n
1584              
1585             } elsif ($parts eq 'octant_up') {
1586              
1587             } elsif ($parts eq 'wedge' || $parts eq 'wedge+1') {
1588 0         0 my $add = _depth_to_octant_added ([$depth],[1], $zero);
1589             ### wedge half width: $add
1590 0 0       0 if ($parts eq 'wedge+1') {
1591             # 0, 1 to $add, $add+1 to 2*$add, 2*$add+1
1592 0 0 0     0 if ($n == 0 || $n == 2*$add+1) {
1593 0         0 return 0; # first,last toothpicks don't grow
1594             }
1595 0         0 $n -= 1;
1596             }
1597             ### assert: $n < 2*$add
1598 0 0       0 if ($n >= $add) {
1599             ### wedge second half
1600 0         0 $n = 2*$add-1 - $n; # mirror
1601             }
1602              
1603             } elsif ($parts eq 'two_horiz') {
1604             ### two_horiz ...
1605 0         0 my $add = _depth_to_octant_added([$depth,$depth-3],[1,1], $zero) - 1;
1606             ### add quad: $add
1607             ### assert: $n < 4*$add
1608 0 0       0 if ($n >= 2*$add) {
1609             ### two_horiz symmetric left,right halves ...
1610 0         0 $n -= 2*$add;
1611             ### $n
1612             }
1613 0 0       0 if ($n >= $add) {
1614             ### two_horiz mirror top,bottom quarters ...
1615 0         0 $n = 2*$add-1 - $n;
1616             ### $n
1617             }
1618              
1619 0         0 $add = _depth_to_octant_added ([$depth],[1], $zero);
1620             ### add oct: $add
1621 0 0       0 if ($n < $add) {
1622             ### two_horiz first octant, mirror ...
1623 0         0 $n = $add-1 - $n;
1624             } else {
1625             ### two_horiz second octant, depth-3 ...
1626 0         0 $n -= $add-1;
1627 0         0 $depth -= 3;
1628             }
1629              
1630             } else {
1631             ### assert: $parts eq '1' || $parts eq '2' || $parts eq '3' || $parts eq '4'
1632 0 0       0 if ($parts eq '3') {
1633 0         0 my $add = _depth_to_octant_added ([$depth+1,$depth],[1,1], $zero)
1634             - 1; # undouble spine
1635 0 0       0 if ($n < $add) {
1636 0         0 $depth += 1;
1637             } else {
1638 0         0 $n -= $add;
1639 0         0 $parts = '2';
1640             }
1641             }
1642              
1643 0 0 0     0 if ($parts eq '2' || $parts eq '4') {
1644 0         0 my $add = _depth_to_octant_added([$depth,$depth-1],[1,1], $zero)
1645             - 1; # undouble spine
1646 0 0       0 if ($n >= 2*$add) {
1647             # parts=4 rotate lower ...
1648 0         0 $n -= 2*$add;
1649             }
1650              
1651             ### add quadrant: $add
1652             ### assert: $n < 2*$add
1653 0 0       0 if ($n >= $add) {
1654             ### parts=2 left half mirror ...
1655 0         0 $n = 2*$add-1 - $n;
1656             ### $n
1657             } else {
1658             ### parts=2 right half unchanged ...
1659             }
1660             }
1661              
1662             ### quadrant ...
1663 0         0 my $add = _depth_to_octant_added ([$depth],[1], $zero);
1664 0         0 $n -= $add;
1665 0 0       0 if ($n < 0) {
1666             ### lower octant ...
1667 0         0 $n = -1-$n; # mirror
1668             } else {
1669             ### upper octant ...
1670 0         0 $depth -= 1;
1671 0         0 $n += 1; # undouble spine
1672             }
1673             }
1674              
1675 0 0       0 if ($depth <= 4) {
1676 0         0 return undef; # initial points
1677             }
1678              
1679 0         0 my $dbase;
1680 0         0 my ($pow,$exp) = round_down_pow ($depth, 2);
1681              
1682 0         0 for ( ; $exp--; $pow /= 2) {
1683             ### at: "depth=$depth pow=$pow n=$n dbase=".($dbase||'inf')
1684             ### assert: $n >= 0
1685              
1686 0 0       0 if ($n == 0) {
1687             ### n=0 on spine ...
1688 0         0 last;
1689             }
1690              
1691 0 0       0 next if $depth < $pow;
1692              
1693 0 0       0 if (defined $dbase) { $dbase = $pow; }
  0         0  
1694 0         0 $depth -= $pow;
1695             ### depth remaining: $depth
1696              
1697 0 0       0 if ($depth == 1) {
1698             ### depth=1 is on upper,lower diagonal spine ...
1699             ### assert: $n == 1
1700 0         0 return $pow-3;
1701             }
1702             ### assert: $depth >= 2
1703              
1704 0         0 my $add = _depth_to_octant_added ([$depth],[1], $zero);
1705             ### $add
1706              
1707 0 0       0 if ($n < $add) {
1708             ### extend part ...
1709             } else {
1710 0         0 $dbase = $pow;
1711 0         0 $n -= 2*$add;
1712             ### sub 2add to: $n
1713              
1714 0 0       0 if ($n < 0) {
1715             ### upper part, mirror to n: -1 - $n
1716 0         0 $n = -1 - $n; # mirror, $n = $add-1 - $n = -($n-$add) - 1
1717             } else {
1718             ### lower part ...
1719 0         0 $depth += 1;
1720 0         0 $n += 1; # undouble upper,lower spine
1721             }
1722             }
1723              
1724             }
1725              
1726             ### final ...
1727             ### $dbase
1728             ### $depth
1729 0 0       0 return (defined $dbase ? $dbase - $depth - 2 : undef);
1730             }
1731              
1732             #------------------------------------------------------------------------------
1733             # levels
1734              
1735             # parts depth
1736             # ----- -----
1737             # 4 \
1738             # 3 | 4*2^level - 1 = 3, 7, 15, 31, ...
1739             # wedge |
1740             # two_horiz /
1741             # 2 4*2^level - 2 = 2, 6, 14, 30, ...
1742             # 1 4*2^level - 3 = 1, 5, 13, 29, ...
1743             # octant \ 4*2^level - 4 = 0, 4, 12, 28, ...
1744             # octant_up /
1745             # level=0 level=1 level=2 level=3
1746             # parts=4 level depths 0, 3, 7 4-1=3, 8-1=7, 16-1=15
1747             # parts=1 level depths 1 5, 13 2-3=-1 4-3=1, 8-3=5, 16-3=13
1748             # parts=two_horiz 4-1=3, 8-3=7, 16-4=15
1749             my %level_depth_offset = (4 => 1,
1750             3 => 1,
1751             2 => 2,
1752             1 => 3, #
1753             octant => 4, # sans upper
1754             octant_up => 4, #
1755             wedge => 1, #
1756             two_horiz => 1, # like parts=4
1757             );
1758              
1759             sub level_to_n_range {
1760 52     52 1 948 my ($self, $level) = @_;
1761 52         140 return (0,
1762             $self->tree_depth_to_n_end(2**($level+2)
1763             - $level_depth_offset{$self->{'parts'}}));
1764             }
1765             sub n_to_level {
1766 44     44 1 2356 my ($self, $n) = @_;
1767 44         55 my $depth = $self->tree_n_to_depth($n);
1768 44 50       60 if (! defined $depth) { return undef; }
  0         0  
1769 44         98 my ($pow, $exp) = round_down_pow
1770             ($depth + $level_depth_offset{$self->{'parts'}} - 1,
1771             2);
1772 44         335 return max(0, $exp - 1);
1773             }
1774              
1775             #------------------------------------------------------------------------------
1776             1;
1777             __END__