File Coverage

blib/lib/Acme/POE/Tree.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Acme::POE::Tree;
2              
3 1     1   22283 use warnings;
  1         3  
  1         30  
4 1     1   5 use strict;
  1         1  
  1         31  
5              
6 1     1   434 use Curses;
  0            
  0            
7             use POE qw(Wheel::Curses);
8             use IO::Tty;
9              
10             use constant CYCLE_TYPE => "random"; # "random" or "cycle"
11             use constant LIGHT_TYPE => "strand"; # "random" or "strand"
12             use constant DIM_BULBS => 0; # enable dim bulbs
13              
14             our $VERSION = '1.022';
15              
16             sub new {
17             my ($class, $arg) = @_;
18              
19             my $self = bless { %{$arg || {}} }, $class;
20              
21             $self->{light_delay} ||= 1;
22             $self->{star_delay} ||= 1.33;
23              
24             POE::Session->create(
25             object_states => [
26             $self => {
27             _start => "_setup_tree",
28             got_keystroke => "_handle_keystroke",
29             got_sigwinch => "_handle_sigwinch",
30             paint_tree => "_paint_tree",
31             light_cycle => "_cycle_lights",
32             star_cycle => "_cycle_star",
33             shut_down => "_handle_shut_down",
34             },
35             ],
36             );
37              
38             return $self;
39             }
40              
41             sub run {
42             my $self = shift;
43             POE::Kernel->run();
44             }
45              
46             sub _setup_tree {
47             my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
48              
49             # Tell this session about terminal size changes.
50             $kernel->sig(WINCH => "got_sigwinch");
51              
52             # Set up Curses, and notify this session when there's input.
53             $heap->{console} = POE::Wheel::Curses->new(
54             InputEvent => 'got_keystroke',
55             );
56              
57             # Initialize the tree's color palette.
58             my @light_colors = (
59             COLOR_BLUE, COLOR_YELLOW, COLOR_RED, COLOR_GREEN, COLOR_MAGENTA
60             );
61              
62             init_pair($_, $light_colors[$_-1], COLOR_BLACK) for 1..@light_colors;
63             $heap->{light_colors} = [ map { COLOR_PAIR($_) } (1..@light_colors) ];
64              
65             init_pair(@light_colors + 2, COLOR_GREEN, COLOR_BLACK);
66             $heap->{color_tree} = COLOR_PAIR(@light_colors + 2) | A_DIM;
67              
68             init_pair(@light_colors + 3, COLOR_WHITE, COLOR_BLACK);
69             $heap->{color_bg} = COLOR_PAIR(@light_colors + 3);
70              
71             init_pair(@light_colors + 4, COLOR_YELLOW, COLOR_BLACK);
72             $heap->{color_star} = COLOR_PAIR(@light_colors + 4);
73              
74             # Start the star cycle.
75             $heap->{star_cycle} = 0;
76              
77             # Start the star and light timers.
78             $kernel->delay("light_cycle", $self->{light_delay});
79             $kernel->delay("star_cycle", $self->{star_delay});
80              
81             # Run until an automatic cutoff time has elapsed.
82             $kernel->delay("shut_down", $self->{run_for}) if $self->{run_for};
83              
84             # Cause the tree to be painted.
85             $kernel->yield("paint_tree");
86             }
87              
88             # Some window managers send a lot of window-change signals during a
89             # window resize. This waits for the user to let go before finally
90             # painting the new tree.
91              
92             sub _handle_sigwinch {
93             $_[KERNEL]->delay(paint_tree => 0.5);
94             }
95              
96             # Handle keystrokes. Quit if the user presses "q".
97              
98             sub _handle_keystroke {
99             my $keystroke = $_[ARG0];
100              
101             # Make control and extended keystrokes printable.
102             if ($keystroke lt ' ') {
103             $keystroke = '<' . uc(unctrl($keystroke)) . '>';
104             }
105             elsif ($keystroke =~ /^\d{2,}$/) {
106             $keystroke = '<' . uc(keyname($keystroke)) . '>';
107             }
108              
109             if ( $keystroke eq '<^C>' or $keystroke eq 'q') {
110             $_[KERNEL]->yield("shut_down");
111             }
112             }
113              
114             # Repaint the tree. This happens after every terminal resize.
115              
116             sub _paint_tree {
117             my $heap = $_[HEAP];
118             $heap->{lights} = grow_tree($heap);
119             }
120              
121             # Periodically change which lights are lit.
122              
123             sub _cycle_lights {
124             my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
125              
126             if (CYCLE_TYPE eq "random") {
127             foreach my $light (@{$heap->{lights}}) {
128             next unless rand() < 0.25;
129              
130             $light->{lit} = !$light->{lit};
131             $light->{c_paint} = $light->{c_main} | ($light->{lit} ? A_BOLD : A_DIM);
132              
133             if ($light->{lit} or DIM_BULBS) {
134             attrset($light->{c_paint});
135             addstr($light->{y}, $light->{x}, "o");
136             }
137             else {
138             addstr($light->{y}, $light->{x}, " ");
139             }
140             }
141             }
142             elsif (CYCLE_TYPE eq "cycle") {
143             foreach my $light (@{$heap->{lights}}) {
144             $light->{lit} = (
145             $light->{c_main} == $heap->{light_colors}[$heap->{light_cycle} || 0]
146             ) || 0;
147             $light->{c_paint} = $light->{c_main} | ($light->{lit} ? A_BOLD : A_DIM);
148              
149             if ($light->{lit} or DIM_BULBS) {
150             attrset($light->{c_paint});
151             addstr($light->{y}, $light->{x}, "o");
152             }
153             else {
154             addstr($light->{y}, $light->{x}, " ");
155             }
156             }
157              
158             $heap->{light_cycle}++;
159             $heap->{light_cycle} = 0 if (
160             $heap->{light_cycle} >= @{$heap->{light_colors}}
161             );
162             }
163              
164             do_refresh($heap);
165              
166             $kernel->delay("light_cycle", $self->{light_delay});
167             }
168              
169             # The star periodically shimmers.
170              
171             sub _cycle_star {
172             my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
173              
174             $heap->{star_cycle}++;
175             draw_star($heap);
176              
177             do_refresh($heap);
178              
179             $kernel->delay("star_cycle", $self->{star_delay});
180             }
181              
182             # Grow a new tree. Returns a list of lights to be cycled by timers
183             # later.
184              
185             sub grow_tree {
186             my $heap = shift;
187              
188             # Make sure Curses knows the current terminal size.
189              
190             my ($lines, $cols) = ($LINES, $COLS);
191             eval {
192             my $winsize = " " x 64;
193             ioctl(STDOUT, &IO::Tty::Constant::TIOCGWINSZ, $winsize) or die $!;
194             ($lines, $cols) = unpack("S2", $winsize);
195             };
196              
197             # TODO - How to do this portably?
198             eval { resizeterm($lines, $cols) };
199              
200             # Clear the screen in the default color. Add vertical bars to
201             # either side of the screen, as this sometimes ensures erasure.
202              
203             attrset($heap->{color_bg});
204             clear();
205             addstr($_-1, 0, "|" . (" " x ($cols-2)) . "|") for 1..$lines;
206              
207             # Draw the tree.
208              
209             my $tier_width = 2;
210             my $tier_height = 4;
211             my $tier_width_increment = 8;
212             my $light_density = 0.05;
213              
214             my $center = int($cols / 2);
215              
216             my $tier_pos = 4;
217              
218             my @tiers;
219              
220             TIER: while ($tier_pos < $lines - $tier_height) {
221             for my $subtier (0..$tier_height-1) {
222             last TIER if $tier_width >= $cols - 5;
223              
224             my $y = $tier_pos + $subtier;
225             my $x = $center - int($tier_width / 2);
226             my $w = $tier_width - 1;
227              
228             push @tiers, { y => $y, x => $x + 1, w => $w } if $w > 0;
229              
230             attrset($heap->{color_tree});
231             addstr($y, $center - int($tier_width / 2), "/");
232             addstr($y, $center + int($tier_width / 2), "\\");
233              
234             $tier_width += 2 * ($tier_width_increment / $tier_height);
235             }
236              
237             $tier_pos += $tier_height;
238             $tier_width -= $tier_width_increment;
239             }
240              
241             # Distribute lights throughout the tree's area.
242              
243             my $area = 0;
244             $area += $_->{w} foreach @tiers;
245              
246             my @lights;
247             if (LIGHT_TYPE eq "random") {
248             for my $light_i (1..$area / 10) {
249              
250             my $light_pos = int(rand $area);
251             my ($x, $y);
252             TIER: foreach my $tier (@tiers) {
253             if ($light_pos < $tier->{w}) {
254             $x = $tier->{x} + $light_pos;
255             $y = $tier->{y};
256             last TIER;
257             }
258             $light_pos -= $tier->{w};
259             }
260              
261             next unless defined $x and defined $y;
262             push @lights, { y => $y, x => $x };
263             addstr($y, $x, "o");
264             }
265             }
266             elsif (LIGHT_TYPE eq "strand") {
267             LIGHT: for my $light_i (0..($area/10)) {
268              
269             my $light_pos = $light_i * 10 + int(rand 5) - 2;
270              
271             my ($x, $y);
272             TIER: foreach my $tier (@tiers) {
273             if ($light_pos < $tier->{w}) {
274             $x = $tier->{x} + $light_pos;
275             $y = $tier->{y};
276             next LIGHT if $y < $tiers[2]{y}; # avoid collision with star
277             last TIER;
278             }
279             $light_pos -= $tier->{w};
280             }
281              
282             next LIGHT unless defined $y and defined $x;
283             push @lights, { y => $y, x => $x };
284             }
285             }
286              
287             # Assign colors to each light.
288              
289             for (0..$#lights) {
290             my $light = $lights[$_];
291              
292             my $color_index = $_ % @{$heap->{light_colors}};
293             my $color = $heap->{light_colors}[$color_index];
294              
295             $light->{c_main} = $color;
296             $light->{lit} = 0;
297             $light->{c_paint} = $color | ($light->{lit} ? A_BOLD : A_DIM);
298              
299             if ($light->{lit} or DIM_BULBS) {
300             attrset($light->{c_paint});
301             addstr($light->{y}, $light->{x}, "o");
302             }
303             else {
304             addstr($light->{y}, $light->{x}, " ");
305             }
306             }
307              
308             # Put the star on top of the tree.
309              
310             $heap->{star_center_y} = $tiers[0]{y} - 1;
311             $heap->{star_center_x} = $center;
312             draw_star($heap);
313              
314             do_refresh($heap);
315              
316             return \@lights;
317             }
318              
319             # Draw the star. Also used to shimmer the star based on a moving
320             # "star cycle".
321              
322             sub draw_star {
323             my $heap = shift;
324              
325             my $center_y = $heap->{star_center_y};
326             my $center_x = $heap->{star_center_x};
327             my $cycle = $heap->{star_cycle};
328              
329             my $color_inner = $heap->{color_bg} | ($cycle % 2 ? A_DIM : A_BOLD);
330             my $color_outer = $heap->{color_bg} | ($cycle % 2 ? A_BOLD : A_DIM);
331             my $color_star = $heap->{color_star} | ($cycle % 2 ? A_DIM : A_BOLD);
332              
333             attrset($color_star);
334             addstr($center_y, $center_x, "O");
335              
336             attrset($color_inner);
337             addstr($center_y - 1, $center_x - 1, "\\");
338             addstr($center_y + 1, $center_x + 1, "\\");
339             addstr($center_y - 1, $center_x + 1, "/");
340             addstr($center_y + 1, $center_x - 1, "/");
341              
342             attrset($color_outer);
343             addstr($center_y, $center_x - 1, "=");
344             addstr($center_y, $center_x + 1, "=");
345             addstr($center_y - 1, $center_x, "|");
346             addstr($center_y + 1, $center_x, "|");
347              
348             attrset($color_inner);
349             addstr($center_y, $center_x - 2, "-");
350             addstr($center_y, $center_x + 2, "-");
351             addstr($center_y - 2, $center_x, "|");
352             addstr($center_y + 2, $center_x, "|");
353              
354             attrset($color_outer);
355             addstr($center_y, $center_x - 3, "-");
356             addstr($center_y, $center_x + 3, "-");
357             }
358              
359             # Common refresh code.
360              
361             sub do_refresh {
362             my $heap = shift;
363              
364             attrset($heap->{color_bg});
365             addstr(0, 0, "Press q to quit.");
366             refresh();
367             }
368              
369             # Common shutdown code.
370              
371             sub _handle_shut_down {
372             delete $_[HEAP]{console};
373             $_[KERNEL]->delay("light_cycle", undef);
374             $_[KERNEL]->delay("star_cycle", undef);
375             }
376              
377             1;
378              
379             __END__