File Coverage

blib/lib/Math/PlanePath/ToothpickTree.pm
Criterion Covered Total %
statement 421 689 61.1
branch 186 340 54.7
condition 34 92 36.9
subroutine 24 38 63.1
pod 24 24 100.0
total 689 1183 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   3424 use 5.004;
  2         6  
127 2     2   11 use strict;
  2         2  
  2         48  
128 2     2   10 use Carp 'croak';
  2         4  
  2         166  
129             #use List::Util 'max','min';
130             *max = \&Math::PlanePath::_max;
131             *min = \&Math::PlanePath::_min;
132              
133 2     2   8 use vars '$VERSION', '@ISA';
  2         4  
  2         114  
134             $VERSION = 18;
135 2     2   1139 use Math::PlanePath;
  2         6850  
  2         77  
136             @ISA = ('Math::PlanePath');
137              
138             use Math::PlanePath::Base::Generic
139 2         91 'is_infinite',
140 2     2   11 'round_nearest';
  2         4  
141             use Math::PlanePath::Base::Digits
142 2     2   742 'round_down_pow';
  2         1692  
  2         98  
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   10 use constant n_start => 0;
  2         4  
  2         180  
151 2         109 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   9 ];
  2         13  
166              
167 2     2   10 use constant class_x_negative => 1;
  2         3  
  2         84  
168 2     2   9 use constant class_y_negative => 1;
  2         3  
  2         1296  
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 50 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 2 my ($self) = @_;
208 1         4 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   12 use constant tree_num_children_list => (0,1,2);
  2         3  
  2         11009  
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 8429 my $self = shift->SUPER::new(@_);
360 41   100     365 my $parts = ($self->{'parts'} ||= 4);
361 41 50       132 if (! exists $parts_depth_adjust{$parts}) {
362 0         0 croak "Unrecognised parts: ",$parts;
363             }
364 41         96 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 33476 my ($self, $n) = @_;
386             ### ToothpickTree n_to_xy(): $n
387              
388 319 50       767 if ($n < 0) { return; }
  0         0  
389 319 50       794 if (is_infinite($n)) { return ($n,$n); }
  0         0  
390              
391             {
392 319         2010 my $int = int($n);
  319         425  
393             ### $int
394             ### $n
395 319 50       590 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         454 $n = $int; # BigFloat int() gives BigInt, use that
404             }
405 319         398 my $zero = $n*0;
406              
407 319         491 my $parts = $self->{'parts'};
408              
409 319 100       953 if (my $initial = $initial_n_to_xy{$parts}) {
410 238 100       567 if ($n <= $#$initial) {
411             ### initial_n_to_xy{}: $initial->[$n]
412 32         37 return @{$initial->[$n]};
  32         111  
413             }
414             }
415              
416 287         555 (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         423 my $x = 0;
432 287         323 my $y = 0;
433 287         329 my $hdx = 1;
434 287         313 my $hdy = 0;
435 287         300 my $vdx = 0;
436 287         282 my $vdy = 1;
437 287         312 my $mirror = 0;
438 287         403 $depth += $parts_depth_adjust{$parts};
439             ### depth in parts=4 style: $depth
440              
441 287 50       1019 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         807 my $add = _depth_to_octant_added([$depth],[1],$zero);
513             ### $add
514              
515 287 100       793 if ($parts eq '3') {
516 59         164 my $add_plus1 = _depth_to_octant_added([$depth+1],[1],$zero);
517 59         112 my $add_quad = $add_plus1 + $add - 1;
518             ### parts=3 lower quad: $add_quad
519 59 100       107 if ($n < $add_quad) {
520             ### initial block 1, rotate 90 ...
521 23         25 $depth += 1;
522 23         26 $add = $add_plus1;
523 23         27 $x = -1;
524 23         37 $hdx = 0; $hdy = -1; $vdx = 1; $vdy = 0;
  23         27  
  23         23  
  23         24  
525 23         39 $parts = '1';
526             } else {
527             # now parts=2 style remaining
528 36         59 $n -= $add_quad;
529             }
530             }
531              
532 287 100       650 if ($parts ne '1') {
533 183         479 my $add_sub1 = _depth_to_octant_added([$depth-1], [1], $zero);
534 183         350 my $add_quad = $add + $add_sub1 - 1;
535              
536 183 100       383 if ($parts eq '4') {
537 85         116 my $add_half = 2*$add_quad;
538 85 100       179 if ($n >= $add_half) {
539 38         43 $n -= $add_half;
540 38         41 $hdx = -1; $vdy = -1; # rotate 180
  38         57  
541             }
542             }
543              
544             # parts=2 style two quadrants
545 183 100       382 if ($n >= $add_quad) {
546             ### second quadrant ...
547 88         99 $n -= $add_quad;
548              
549 88 100       142 if ($n >= $add_sub1) {
550             ### fourth octant ...
551 22         28 $n -= $add_sub1;
552 22         25 $n += 1; # unduplicate diagonal
553 22         26 $mirror = 1;
554 22         28 $hdx = -$hdx; $hdy = -$hdy; # reflect horizontally
  22         31  
555             } else {
556             ### third octant ...
557 66         84 $depth -= 1;
558 66         114 ($hdx,$hdy, $vdx,$vdy) # rotate -90
559             = ($vdx,$vdy, -$hdx,-$hdy);
560 66         102 $x += $hdx;
561 66         85 $y += $hdy;
562             }
563 88         128 $add = $n+1;
564             }
565             }
566              
567             ### first quadrant split: "add=$add n=$n depth=$depth"
568 287 100       590 if ($n >= $add) {
569             ### top half of quad ...
570 47         57 $depth -= 1;
571 47         54 $n -= $add;
572 47         58 $n += 1; # unduplicate diagonal
573 47         61 $mirror ^= 1;
574 47         56 $x += $vdx;
575 47         56 $y += $vdy;
576 47         107 ($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         705 my ($pow,$exp) = round_down_pow ($depth, 2);
584 287         2912 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       886 if ($depth < $pow) {
588             ### block 0 ...
589 41         92 next;
590             }
591 428         465 $depth -= $pow;
592              
593 428 100       860 if ($depth == $pow-1) {
594             ### pow-1 end toothpick ...
595 48         73 $x += $pow * ($hdx + $vdx) - $hdx;
596 48         69 $y += $pow * ($hdy + $vdy) - $hdy;
597 48         57 last;
598             }
599              
600 380         552 $x += $pow/2 * ($hdx + $vdx);
601 380         555 $y += $pow/2 * ($hdy + $vdy);
602             ### diagonal to: "depth=$depth xy=$x,$y"
603              
604 380 100       730 if ($depth == 0) {
605             ### toothpick A ...
606 134         155 last;
607             }
608 246 100       455 if ($depth == 1) {
609             ### toothpick B,other up,down ...
610 105 100 66     409 if ($exp && $n == $mirror) {
611             ### toothpick other (down): "subtract vdxdy=$vdx,$vdy"
612 72         85 $x -= $vdx;
613 72         93 $y -= $vdy;
614             } else {
615             ### toothpick B (up): "add vdxdy=$vdx,$vdy"
616 33         36 $x += $vdx;
617 33         38 $y += $vdy;
618             }
619 105         131 last;
620             }
621              
622 141 100       250 if ($mirror) {
623             # /
624             # /3
625             # /--
626             # /|\2
627             # /0|1\
628 45         122 my $add = _depth_to_octant_added([$depth],[1],$zero);
629             ### add in mirror block2,3: $add
630              
631 45 100       122 if ($n < $add) {
632             ### mirror block 3, same ...
633 3         10 next;
634             }
635 42         53 $n -= $add;
636              
637 42 100       95 if ($n < $add) {
638             ### mirror block 2, unmirror, vertical invert ...
639 37         43 $vdx = -$vdx;
640 37         49 $vdy = -$vdy;
641 37         49 $mirror = 0;
642 37         107 next;
643             }
644 5         6 $n -= $add;
645 5         8 $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         8 $depth += 1;
650 5         5 $x -= $hdx; # offset
651 5         6 $y -= $hdy;
652 5         21 ($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       223 if ($depth+1 < $pow) {
664 96         249 my $add = _depth_to_octant_added([$depth+1],[1],$zero) - 1;
665             ### add in block1, sans diagonal: $add
666 96 100       227 if ($n < $add) {
667             ### block 1 "lower", rotate +90 ...
668 7         9 $depth += 1;
669 7         11 $x -= $hdx; # offset
670 7         8 $y -= $hdy;
671 7         15 ($hdx,$hdy, $vdx,$vdy) # rotate 90 in direction v toward h
672             = (-$vdx,-$vdy, $hdx,$hdy);
673 7         20 next;
674             }
675 89         130 $n -= $add;
676             }
677              
678 89         213 my $add = _depth_to_octant_added([$depth],[1],$zero);
679             ### add in block2: $add
680              
681 89 100       227 if ($n < $add) {
682             ### block 2 "upper", vertical invert ...
683 47         58 $vdx = -$vdx;
684 47         55 $vdy = -$vdy;
685 47         137 $mirror = 1;
686             } else {
687             ### block 3 "extend", same ...
688 42         111 $n -= $add;
689             ### assert: $n < $add
690             }
691             }
692             }
693              
694             ### n_to_xy() return: "$x,$y (depth=$depth n=$n)"
695 287         757 return ($x,$y);
696             }
697              
698             sub xy_to_n {
699 252     252 1 20794 my ($self, $x, $y) = @_;
700             ### ToothpickTree xy_to_n(): "$x, $y"
701              
702 252         629 $x = round_nearest ($x);
703 252         1836 $y = round_nearest ($y);
704              
705 252         1510 my $zero = $x * 0 * $y;
706 252         304 my $n = $zero;
707 252         284 my @add_offset;
708             my @add_mult;
709 252         274 my $mirror = 0;
710 252         286 my $depth = 0;
711 252         283 my $depth_adjust = 0;
712              
713 252         372 my $parts = $self->{'parts'};
714              
715 252 50       950 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       724 if ($parts eq '1') {
    100          
    100          
805 51 50 33     232 if ($x < 1 || $y < 1) { return undef; }
  0         0  
806 51         67 $depth_adjust = 2;
807              
808             } elsif ($parts eq '2') {
809 51 50       106 if ($y < 1) { return undef; }
  0         0  
810 51 100       98 if ($x == 0) {
811 1 50       11 if ($y == 1) { return 0; }
  1         3  
812             }
813 50 100       98 if ($y == 1) {
814 8 100       16 if ($x == 1) { return 1; }
  1         3  
815 7 100       16 if ($x == -1) { return 2; }
  1         4  
816             }
817 48         68 $depth_adjust = 1;
818              
819             } elsif ($parts eq '3') {
820 51 100       106 if ($x == 0) {
821 5 100       10 if ($y == 0) { return 0; }
  1         4  
822 4 100       11 if ($y == -1) { return 1; }
  1         3  
823 3 100       8 if ($y == 1) { return 2; }
  1         3  
824             }
825 48 100       86 if ($y < 0) {
826 18 50       35 if ($x < 0) {
827 0         0 return undef;
828             }
829             ### parts=3 rotate +90 ...
830 18         30 ($x,$y) = (-$y,$x+1);
831 18         27 $depth_adjust = 1;
832             } else {
833 30         42 push @add_offset, -1,0; # one quadrant
834 30         42 push @add_mult, 1,1;
835 30         41 $n -= 1; # unduplicate shared diagonal
836             }
837              
838             } else {
839             ### assert: $parts eq '4'
840 99 100       237 if ($x == 0) {
841 6 100       13 if ($y == 0) { return 0; }
  2         7  
842 4 100       11 if ($y == 1) { return 1; }
  2         7  
843 2 50       6 if ($y == -1) { return 2; }
  2         6  
844             }
845 93 100       208 if ($y < 0) {
846 42         60 $x = -$x; $y = -$y; # rotate 180
  42         51  
847 42         67 push @add_offset, 0,1; # two quadrants
848 42         73 push @add_mult, 2,2;
849 42         61 $n -= 2; # unduplicate shared diagonal
850             }
851             }
852              
853 240 100       469 if ($x < 0) {
854             ### X negative mirror ...
855 82         106 $x = -$x;
856 82         86 $mirror = 1;
857 82         117 push @add_offset, 0,1; # one quadrant
858 82         101 push @add_mult, 1,1;
859 82         119 $n -= 1; # unduplicate shared diagonal
860             }
861              
862 240 100       439 if ($y <= $x) {
863             ### lower octant ...
864 126 100       251 if ($mirror) {
865 42         50 push @add_offset, 1;
866 42         56 push @add_mult, 1;
867 42         58 $n -= 1; # unduplicate shared diagonal
868             }
869             } else {
870             ### upper octant ...
871 114         236 ($x,$y) = ($y-1,$x);
872 114         240 foreach (@add_offset) { $_-- }
  148         214  
873 114         181 $depth_adjust--;
874 114 100       228 if (! $mirror) {
875 74         106 push @add_offset, -1;
876 74         88 push @add_mult, 1;
877 74         96 $n -= 1; # unduplicate shared diagonal
878             }
879 114         167 $mirror ^= 1;
880             }
881             }
882             ### $depth_adjust
883             ### xy: "$x,$y"
884              
885 240 50 33     1524 if ($x < 1|| $y < 1 || $y > $x+1) {
      33        
886 0         0 return undef;
887             }
888              
889 240         656 my ($pow,$exp) = round_down_pow (max($x,$y-1), 2);
890 240         3869 $pow *= 2;
891 240 50       597 if (is_infinite($exp)) {
892 0         0 return ($exp);
893             }
894              
895             # /
896             # /3
897             # /--
898             # /|\2
899             # /0|1\
900              
901 240         1457 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       981 if ($x < $pow) {
925 267 50 33     676 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         293 $x -= $pow;
934 259         292 $y -= $pow;
935 259         329 $depth += 2*$pow;
936              
937 259 100       557 if ($y == 0) {
    100          
938 67 50       113 if ($x == 0) {
939             ### toothpick B, stop ...
940 67         81 last;
941             } else {
942 0         0 return undef;
943             }
944              
945             } elsif ($y > 0) {
946             ### block 3, same ...
947 57 50 66     229 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       116 if (! $mirror) {
956 30         39 push @add_offset, $depth-1, $depth; # past block 1,2
957 30         40 push @add_mult, 1, 1;
958 30         43 $n -= 1; # unduplicate shared diagonal
959             }
960              
961             } else {
962 135 100 100     520 if ($y == -1 && $x == 0) {
963             ### middle below point, stop ...
964 56         60 $depth += 1;
965 56 100       100 if ($mirror) {
966 28         33 $n += 1;
967             }
968 56         80 last;
969             }
970 79 100       146 if ($x >= -$y) {
971             ### block 2, vertical flip mirror ...
972 59 50       103 if ($y > -1) {
973 0         0 return undef; # no such point
974             }
975 59         77 $y = -$y;
976 59 100       96 if ($mirror) {
977 28         38 push @add_offset, $depth; # past block 3
978 28         39 push @add_mult, 1;
979             } else {
980 31         43 push @add_offset, $depth-1; # past block 1
981 31         38 push @add_mult, 1;
982 31         39 $n -= 1; # unduplicate shared diagonal
983             }
984 59         83 $mirror ^= 1;
985              
986             } else {
987             ### block 1, rotate and offset ...
988 20         25 $depth -= 1;
989 20         33 ($x,$y) = (-$y,$x+1); # rotate +90, offset
990 20 100       44 if ($mirror) {
991 8         11 push @add_offset, $depth+1; # past block 3,2
992 8         10 push @add_mult, 2;
993 8         13 $n -= 1; # unduplicate shared diagonal 2,1
994             }
995             }
996             }
997             }
998              
999 403 100       863 if (--$exp < 0) {
1000             ### final xy: "$x,$y"
1001 117 50 33     429 if ($x == 1 && $y == 1) {
    0 0        
1002 117         142 $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         170 last;
1010             }
1011 286         360 $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         597 $n += $self->tree_depth_to_n($depth - $depth_adjust);
1021              
1022 240 100       553 if (@add_offset) {
1023 210         330 foreach my $add_offset (@add_offset) {
1024 551         757 $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         441 $n += _depth_to_octant_added (\@add_offset, \@add_mult, $zero);
1030             }
1031              
1032             ### xy_to_n() return n: $n
1033 240         749 return $n;
1034             }
1035              
1036              
1037             # Shared with ToothpickReplicate.
1038             # not exact
1039             sub rect_to_n_range {
1040 108     108 1 8500 my ($self, $x1,$y1, $x2,$y2) = @_;
1041             ### ToothpickTree rect_to_n_range(): "$x1,$y1 $x2,$y2"
1042              
1043 108         252 $x1 = round_nearest ($x1);
1044 108         695 $y1 = round_nearest ($y1);
1045 108         656 $x2 = round_nearest ($x2);
1046 108         672 $y2 = round_nearest ($y2);
1047              
1048 108 100       629 ($x1,$x2) = ($x2,$x1) if $x1 > $x2;
1049 108 100       190 ($y1,$y2) = ($y2,$y1) if $y1 > $y2;
1050              
1051 108         140 my $parts = $self->{'parts'};
1052 108 50 33     448 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     381 if ($parts eq '4' || $parts eq 'two_horiz') {
1058 22 50       43 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         60 my ($len,$level) = round_down_pow (max(-$x1,
1065             $x2,
1066             -1-$y1,
1067             $y2-1),
1068             2);
1069 22         329 return (0, (32*$len*$len-2)/3);
1070             }
1071              
1072 86 100       154 if ($parts eq '3') {
1073 16 50 66     38 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         51 my ($len,$level) = round_down_pow (max(-$x1,
1086             $x2,
1087             -$y1,
1088             $y2-1),
1089             2);
1090 16         239 return (0, 8*$len*$len);
1091              
1092             }
1093 70 50       127 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     295 if ($x2 < 1 || $y2 < 1) {
1107 0         0 return (1,0);
1108             }
1109 70         168 my ($len,$level) = round_down_pow (max($x2, $y2-1),
1110             2);
1111 70         1123 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 4288 my ($self, $n) = @_;
1180             ### tree_n_to_depth(): "$n"
1181              
1182 882 50       1722 if ($n < 0) {
1183 0         0 return undef;
1184             }
1185 882         1663 my ($depth) = _n0_to_depth_and_rem($self, int($n));
1186             ### n0 depth: $depth
1187 882         1891 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   1535 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         2982 my ($pow,$exp) = round_down_pow (12*$n, # /$self->{'parts'}
1208             4);
1209 1169 50       12149 if (is_infinite($exp)) {
1210 0         0 return ($exp,0);
1211             }
1212             ### $pow
1213             ### $exp
1214              
1215 1169         7106 my $depth = 0;
1216 1169         1346 my $n_depth = 0;
1217 1169         1319 $pow = 2 ** $exp; # pow=2^exp down to 1, inclusive
1218              
1219 1169         2555 while ($exp-- >= 0) {
1220 6021         8174 my $try_depth = $depth + $pow;
1221 6021         11854 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       12280 if ($try_n_depth <= $n) {
1229             ### use this tried depth ...
1230 2808         2881 $depth = $try_depth;
1231 2808         3589 $n_depth = $try_n_depth;
1232             }
1233 6021         13762 $pow /= 2;
1234             }
1235              
1236             ### _n0_to_depth_and_rem() final ...
1237             ### $depth
1238             ### remainder: $n - $n_depth
1239              
1240 1169         2247 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 55821 my ($self, $depth) = @_;
1283             ### tree_depth_to_n(): "$depth parts=$self->{'parts'}"
1284              
1285 7491 50       14364 if ($depth < 0) {
1286 0         0 return undef;
1287             }
1288 7491         8212 $depth = int($depth);
1289              
1290 7491         10486 my $parts = $self->{'parts'};
1291             {
1292 7491         9034 my $initial = $tree_depth_to_n{$parts};
  7491         10529  
1293 7491 100       17452 if ($depth <= $#$initial) {
1294 123         319 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         10494 $depth += $parts_depth_adjust{$parts};
1306              
1307             # +1 for parts=3 using depth+1
1308 7368         19852 my ($pow,$exp) = round_down_pow ($depth+1, 2);
1309 7368 50       75736 if (is_infinite($exp)) {
1310 0         0 return $exp;
1311             }
1312             ### $pow
1313             ### $exp
1314              
1315 7368         44398 my $zero = $depth*0;
1316 7368         11933 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         7863 my @pending;
1327             my @mult;
1328              
1329 7368 100 100     43775 if ($parts eq 'octant' || $parts eq 'octant_up') {
    100          
    50          
    100          
    100          
1330 883         1278 @pending = ($depth);
1331 883         1524 @mult = (1+$zero);
1332              
1333             } elsif ($parts eq 'wedge') {
1334             # wedge(depth) = 2*oct(depth-1) + 4
1335 66         118 @pending = ($depth);
1336 66         102 @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         56 $n -= 4*$depth - 16; # overlapping spines
1346 40         68 @pending = ($depth,$depth-3);
1347 40         76 @mult = ((4+$zero) x 2);
1348              
1349             } elsif ($parts eq '3') {
1350 1557         3177 @pending = ($depth+1, $depth, $depth-1);
1351 1557         2744 @mult = (1+$zero, 3+$zero, 2+$zero);
1352 1557         2206 $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         8903 @pending = ($depth, $depth-1);
1359 4822         8463 @mult = ($parts + $zero) x 2;
1360 4822         7632 $n -= $parts*($depth-3);
1361             }
1362              
1363 7368         15620 while (--$exp >= 0) {
1364 25649 100       48153 last unless @pending;
1365              
1366             ### @pending
1367             ### @mult
1368             ### $exp
1369             ### $pow
1370              
1371 22423         26759 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         31872 foreach my $depth (@pending) {
1381 46603         53998 my $mult = shift @mult;
1382             ### assert: $depth >= 2
1383             ### assert: $depth < 2*$pow
1384              
1385 46603 100       86396 if ($depth <= 3) {
1386 11148 100       23903 if ($depth eq '3') {
1387             ### depth==3 total=1 ...
1388 6927         9079 $n += $mult;
1389             } else {
1390             ### depth==2 total=0 ...
1391             }
1392 11148         17286 next;
1393             }
1394              
1395 35455 100       68531 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         8346 push @new_pending, $depth;
1400 6689         7786 push @new_mult, $mult;
1401 6689         10112 next;
1402             }
1403 28766         37155 my $rem = $depth - $pow;
1404              
1405             ### $depth
1406             ### $mult
1407             ### $rem
1408             ### assert: $rem >= 0 && $rem < $pow
1409              
1410 28766         31205 my $basemult = $mult; # multiple of oct(2^k) base part
1411              
1412 28766 100       60550 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         6971 $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         23305 $n += (4-$rem)*$mult;
1423              
1424 18234         19858 $rem += 1; # to give rem+1
1425 18234 100 100     59727 if ($rem == $pow) {
    100          
1426             ### rem+1==pow so oct(2^k) by increasing basemult ...
1427 4927         5889 $basemult += $mult;
1428             } elsif (@new_pending && $new_pending[-1] == $rem) {
1429             ### combine rem+1 here with rem of previous ...
1430 6971         10264 $new_mult[-1] += $mult;
1431             } else {
1432 6336         8988 push @new_pending, $rem;
1433 6336         8532 push @new_mult, $mult;
1434             }
1435 18234 50       38631 if ($rem -= 1) { # to give plain rem again
1436 18234         22007 push @new_pending, $rem;
1437 18234         28034 push @new_mult, 2*$mult;
1438             }
1439             }
1440              
1441             # oct(2^k) = (4^(k-1) - 4)/3 + 2^(k-1)
1442 28766   66     79361 $tpow ||= ($pow*$pow - 16)/12 + $pow/2;
1443 28766         52993 $n += $basemult * $tpow;
1444             }
1445 22423         38482 @pending = @new_pending;
1446 22423         33294 @mult = @new_mult;
1447 22423         57220 $pow /= 2;
1448             }
1449              
1450             ### return: $n
1451 7368         16977 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   2844 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         3409 my ($pow,$exp) = round_down_pow ($depth_list->[0], 2);
1485 1268 50       12868 if (is_infinite($exp)) {
1486 0         0 return $exp;
1487             }
1488             ### $pow
1489             ### $exp
1490              
1491 1268         7752 my $add = $zero;
1492              
1493 1268         2652 while (--$exp >= 0) { # running $pow down to 2 (inclusive)
1494             ### assert: $pow >= 2
1495 3695 100       7349 last unless @$depth_list;
1496              
1497             ### pending: join(',',@$depth_list)
1498             ### mult : join(',',@$mult_list)
1499             ### $exp
1500             ### $pow
1501              
1502 3227         3503 my @new_depth_list;
1503             my @new_mult_list;
1504              
1505 3227         4661 foreach my $depth (@$depth_list) {
1506 6463         7867 my $mult = shift @$mult_list;
1507             ### assert: $depth >= 0
1508             ### assert: $depth == int($depth)
1509              
1510 6463 100       13083 if ($depth <= 3) {
1511             ### depth==2or3 add=1 ...
1512 2334         2459 $add += $mult;
1513 2334         3648 next;
1514             }
1515              
1516 4129 100       8242 if ($depth < $pow) {
1517             # less than 2^exp so unchanged
1518 1077         1434 push @new_depth_list, $depth;
1519 1077         1234 push @new_mult_list, $mult;
1520 1077         1626 next;
1521             }
1522              
1523 3052         3725 my $rem = $depth - $pow;
1524              
1525             ### $depth
1526             ### $mult
1527             ### $rem
1528             ### assert: $rem >= 0 && $rem <= $pow
1529              
1530 3052 100 100     11165 if ($rem == 0 || $rem == $pow-1) {
1531             ### rem==0, A of each, add=1 ...
1532             ### or depth=2*pow-1, add=1 ...
1533 802         1410 $add += $mult;
1534              
1535             } else {
1536             ### rem >= 2, formula ...
1537             # A(pow+rem) = A(rem+1) + 2A(rem) - 1
1538 2250         2501 $add -= $mult;
1539              
1540 2250         2728 $rem += 1; # to make rem+1
1541 2250 100 100     6623 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         914 $new_mult_list[-1] += $mult;
1545             } else {
1546 1527         2269 push @new_depth_list, $rem;
1547 1527         2237 push @new_mult_list, $mult;
1548             }
1549 2250         3502 push @new_depth_list, $rem-1; # back to plain rem
1550 2250         4381 push @new_mult_list, 2*$mult;
1551             }
1552             }
1553 3227         4471 $depth_list = \@new_depth_list;
1554 3227         4643 $mult_list = \@new_mult_list;
1555 3227         8794 $pow /= 2;
1556             }
1557              
1558             ### return: $add
1559 1268         2690 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 2988 my ($self, $level) = @_;
1761             return (0,
1762             $self->tree_depth_to_n_end(2**($level+2)
1763 52         226 - $level_depth_offset{$self->{'parts'}}));
1764             }
1765             sub n_to_level {
1766 44     44 1 12181 my ($self, $n) = @_;
1767 44         115 my $depth = $self->tree_n_to_depth($n);
1768 44 50       97 if (! defined $depth) { return undef; }
  0         0  
1769             my ($pow, $exp) = round_down_pow
1770 44         159 ($depth + $level_depth_offset{$self->{'parts'}} - 1,
1771             2);
1772 44         514 return max(0, $exp - 1);
1773             }
1774              
1775             #------------------------------------------------------------------------------
1776             1;
1777             __END__