[ViewVC] Annotation of: cvs/rxvt-unicode/src/perl/background

#! perl

#:META:X_RESOURCE:%.expr:string:background expression
#:META:X_RESOURCE:%.enable:boolean:some boolean
#:META:X_RESOURCE:%.extra.:value:extra config

our $EXPR;
#$EXPR = 'move W * 0.1, -H * 0.1, resize W * 0.5, H * 0.5, repeat_none load "opensource.png"';
$EXPR = 'border; move -X, -Y, load "argb.png"';
#$EXPR = '
#   rotate W, H, 50, 50, counter 1/59.95, repeat_mirror,
#   clip X, Y, W, H, repeat_mirror,
#   load "/root/pix/das_fette_schwein.jpg"
#';
#$EXPR = 'solid "red"';
#$EXPR = 'blur root, 10, 10'
#$EXPR = 'blur move (root, -x, -y), 5, 5'
#resize load "/root/pix/das_fette_schwein.jpg", w, h

use Safe;

our $border;
our ($bgdsl_self, $old, $new);
our ($l, $t, $w, $h);

# enforce at least this interval between updates
our $MIN_INTERVAL = 1/100;

{
   package urxvt::bgdsl; # background language

#   *repeat_empty  = \&urxvt::RepeatNone;
#   *repeat_tile   = \&urxvt::RepeatNormal;
#   *repeat_pad    = \&urxvt::RepeatPad;
#   *repeat_mirror = \&urxvt::RepeatReflect;

=head2 PROVIDERS/GENERATORS

=over 4

=item load $path

=cut

   sub load($) {
      my ($path) = @_;

      $new->{load}{$path} = $old->{load}{$path} || $bgdsl_self->new_img_from_file ($path);
   }

   sub root() {
      $new->{rootpmap_sensitive} = 1;
      die "root op not supported, exg, we need you";
   }

   sub solid($;$$) {
      my $img = $bgdsl_self->new_img (urxvt::PictStandardARGB32, $_[1] || 1, $_[2] || 1);
      $img->fill ($_[0]);
      $img
   }

=back

=head2 VARIABLES

=over 4

=cut

   sub X() { $new->{position_sensitive} = 1; $l }
   sub Y() { $new->{position_sensitive} = 1; $t }
   sub W() { $new->{size_sensitive}     = 1; $w }
   sub H() { $new->{size_sensitive}     = 1; $h }

   sub now() { urxvt::NOW }

   sub again($) {
      $new->{again} = $_[0];
   }

   sub counter($) {
      $new->{again} = $_[0];
      $bgdsl_self->{counter} + 0
   }

=back

=head2 TILING MODES

The following operators modify the tiling mode of an image, that is, the
way that pixels outside the image area are painted when the image is used.

=over 4

=item tile $img

Tiles the whole plane with the image and returns this new image - or in
other words, it returns a copy of the image in plane tiling mode.

=item mirror $img

Similar to tile, but reflects the image each time it uses a new copy, so
that top edges always touch top edges, right edges always touch right
edges and so on (with normal tiling, left edges always touch right edges
and top always touch bottom edges).

=item pad $img

Takes an image and modifies it so that all pixels outside the image area
become transparent. This mode is most useful when you want to place an
image over another image or the background colour while leaving all
background pixels outside the image unchanged.

=item extend $img

Extends the image over the whole plane, using the closest pixel in the
area outside the image. This mode is mostly useful when you more complex
filtering operations and want the pixels outside the image to have the
same values as the pixels near the edge.

=cut

   sub pad($) {
      my $img = $_[0]->clone;
      $img->repeat_mode (urxvt::RepeatNone);
      $img
   }

   sub tile($) {
      my $img = $_[0]->clone;
      $img->repeat_mode (urxvt::RepeatNormal);
      $img
   }

   sub mirror($) {
      my $img = $_[0]->clone;
      $img->repeat_mode (urxvt::RepeatReflect);
      $img
   }

   sub extend($) {
      my $img = $_[0]->clone;
      $img->repeat_mode (urxvt::RepeatPad);
      $img
   }

=back

=head2 PIXEL OPERATORS

The following operators modify the image pixels in various ways.

=over 4

=item clone $img

Returns an exact copy of the image.

=cut

   sub clone($) {
      $_[0]->clone
   }

=item clip $img

=item clip $width, $height, $img

=item clip $x, $y, $width, $height, $img

Clips an image to the given rectangle. If the rectangle is outside the
image area (e.g. when C<$x> or C<$y> are negative) or the rectangle is
larger than the image, then the tiling mode defines how the extra pixels
will be filled.

If C<$x> an C<$y> are missing, then C<0> is assumed for both.

If C<$width> and C<$height> are missing, then the window size will be
assumed.

Example: load an image, blur it, and clip it to the window size to save
memory.

   clip blur 10, load "mybg.png"

=cut

   sub clip($;$$;$$) {
      my $img = pop;
      my $h = pop || H;
      my $w = pop || W;
      $img->sub_rect ($_[0], $_[1], $w, $h)
   }

=item scale $img

=item scale $size_percent, $img

=item scale $width_percent, $height_percent, $img

Scales the image by the given percentages in horizontal
(C<$width_percent>) and vertical (C<$height_percent>) direction.

If only one percentage is give, it is used for both directions.

If no percentages are given, scales the image to the window size without
keeping aspect.

=item resize $width, $height, $img

Resizes the image to exactly C<$width> times C<$height> pixels.

=cut

#TODO: maximise, maximise_fill?

   sub scale($$$) {
      my $img = pop;

      @_ == 2 ? $img->scale ($_[0] * $img->w * 0.01, $_[1] * $img->h * 0.01)
      : @_    ? $img->scale ($_[0] * $img->w * 0.01, $_[0] * $img->h * 0.01)
              : $img->scale (W, H)
   }

   sub resize($$$) {
      my $img = pop;
      $img->scale ($_[0], $_[1])
   }

   # TODO: ugly
   sub move($$;$) {
      my $img = pop->clone;
      $img->move ($_[0], $_[1]);
      $img
#      my $img = pop;
#      $img->sub_rect (
#         $_[0], $_[1],
#         $img->w, $img->h,
#         $_[2],
#      )
   }

   sub rotate($$$$$$) {
      my $img = pop;
      $img->rotate (
         $_[0],
         $_[1],
         $_[2] * $img->w * .01,
         $_[3] * $img->h * .01,
         $_[4] * (3.14159265 / 180),
      )
   }

   sub blur($$;$) {
      my $img = pop;

      $img->blur ($_[0], @_ >= 2 ? $_[1] : $_[0]);
   }

   sub contrast($$;$$;$) {
      my $img = pop;
      my ($r, $g, $b, $a) = @_;

      ($g, $b) = ($r, $r) if @_ < 4;
      $a       = 1        if @_ < 5;

      $img = $img->clone;
      $img->contrast ($r, $g, $b, $a);
      $img
   }

   sub brightness($$;$$;$) {
      my $img = pop;
      my ($r, $g, $b, $a) = @_;

      ($g, $b) = ($r, $r) if @_ < 4;
      $a       = 1        if @_ < 5;

      $img = $img->clone;
      $img->brightness ($r, $g, $b, $a);
      $img
   }

=back

=head2 SETTINGS

=over 4

=item border $respect_border=1

Sets whether the image should respect the terminal border (argument true
or missing), or whether it should fill the whole window (the default).

By default, the image will cover the whole toplevel window. If C<border>
is enabled, then it will only fill the character area and leave a normal
border in the background colour around it and behind the scrollbar.

=cut

   sub border {
      $border = @_ ? $_[0] : 1;
   }

=back

=cut

}

sub parse_expr {
   my $expr = eval "sub {\npackage urxvt::bgdsl;\n#line 0 'background expression'\n$_[0]\n}";
   die if $@;
   $expr
}

# compiles a parsed expression
sub set_expr {
   my ($self, $expr) = @_;

   $self->{expr} = $expr;
   $self->recalculate;
}

# evaluate the current bg expression
sub recalculate {
   my ($self) = @_;

   # rate limit evaluation

   if ($self->{next_refresh} > urxvt::NOW) {
      $self->{next_refresh_timer} = urxvt::timer->new->after ($self->{next_refresh} - urxvt::NOW)->cb (sub {
         $self->recalculate;
      });
      return;
   }

   $self->{next_refresh} = urxvt::NOW + $MIN_INTERVAL;

   # set environment to evaluate user expression

   local $bgdsl_self = $self;
   local $border;

   local $old = $self->{state};
   local $new = my $state = $self->{state} = {};

   ($l, $t, $w, $h) =
      $self->get_geometry;

      warn "$l,$t,$w,$h\n";#d#

   # evaluate user expression

   my $img = eval { $self->{expr}->() };
   warn $@ if $@;#d#
   die if !UNIVERSAL::isa $img, "urxvt::img";

   # if the expression is sensitive to external events, prepare reevaluation then

   my $repeat;

   if (my $again = $state->{again}) {
      $repeat = 1;
      $state->{timer} = $again == $old->{again}
                        ? $old->{timer}
                        : urxvt::timer->new->after ($again)->interval ($again)->cb (sub {
                             ++$self->{counter};
                             $self->recalculate
                          });
   }

   if (delete $state->{position_sensitive}) {
      $repeat = 1;
      $self->enable (position_change => sub { $_[0]->recalculate });
   } else {
      $self->disable ("position_change");
   }

   if (delete $state->{size_sensitive}) {
      $repeat = 1;
      $self->enable (size_change => sub { $_[0]->recalculate });
   } else {
      $self->disable ("size_change");
   }

   if (delete $state->{rootpmap_sensitive}) {
      $repeat = 1;
      $self->enable (rootpmap_change => sub { $_[0]->recalculate });
   } else {
      $self->disable ("rootpmap_change");
   }

   # clear stuff we no longer need

   %$old = ();

   unless ($repeat) {
      delete $self->{state};
      delete $self->{expr};
   }

   # prepare and set background pixmap

   $img = $img->sub_rect (0, 0, $w, $h)
      if $img->w != $w || $img->h != $h;

   $self->set_background ($img, $border);
   $self->scr_recolour (0);
   $self->want_refresh;
}

sub on_start {
   my ($self) = @_;

   $self->set_expr (parse_expr $EXPR);

   ()
}

Revision:	1.28
Committed:	Thu Jun 7 12:56:27 2012 UTC (11 years, 11 months ago) by root
Branch:	MAIN
Changes since 1.27:	+150 -11 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	#! perl
2
3	root	1.16	#:META:X_RESOURCE:%.expr:string:background expression
4			#:META:X_RESOURCE:%.enable:boolean:some boolean
5	root	1.18	#:META:X_RESOURCE:%.extra.:value:extra config
6	root	1.12
7	root	1.28	our $EXPR;
8			#$EXPR = 'move W * 0.1, -H * 0.1, resize W * 0.5, H * 0.5, repeat_none load "opensource.png"';
9			$EXPR = 'border; move -X, -Y, load "argb.png"';
10	root	1.19	#$EXPR = '
11			# rotate W, H, 50, 50, counter 1/59.95, repeat_mirror,
12			# clip X, Y, W, H, repeat_mirror,
13			# load "/root/pix/das_fette_schwein.jpg"
14			#';
15			#$EXPR = 'solid "red"';
16	root	1.1	#$EXPR = 'blur root, 10, 10'
17			#$EXPR = 'blur move (root, -x, -y), 5, 5'
18			#resize load "/root/pix/das_fette_schwein.jpg", w, h
19
20			use Safe;
21
22	root	1.28	our $border;
23	root	1.3	our ($bgdsl_self, $old, $new);
24			our ($l, $t, $w, $h);
25
26	root	1.16	# enforce at least this interval between updates
27	root	1.10	our $MIN_INTERVAL = 1/100;
28	root	1.9
29	root	1.1	{
30			package urxvt::bgdsl; # background language
31
32	root	1.20	# *repeat_empty = \&urxvt::RepeatNone;
33			# *repeat_tile = \&urxvt::RepeatNormal;
34			# *repeat_pad = \&urxvt::RepeatPad;
35			# *repeat_mirror = \&urxvt::RepeatReflect;
36	root	1.1
37	root	1.15	=head2 PROVIDERS/GENERATORS
38
39			=over 4
40
41			=item load $path
42
43			=cut
44
45	root	1.2	sub load($) {
46	root	1.1	my ($path) = @_;
47
48	root	1.3	$new->{load}{$path} = $old->{load}{$path} \|\| $bgdsl_self->new_img_from_file ($path);
49	root	1.1	}
50
51	root	1.2	sub root() {
52	root	1.9	$new->{rootpmap_sensitive} = 1;
53	root	1.1	die "root op not supported, exg, we need you";
54			}
55
56	root	1.15	sub solid($;$$) {
57			my $img = $bgdsl_self->new_img (urxvt::PictStandardARGB32, $_[1] \|\| 1, $_[2] \|\| 1);
58			$img->fill ($_[0]);
59			$img
60			}
61
62			=back
63
64	root	1.20	=head2 VARIABLES
65
66			=over 4
67
68			=cut
69
70			sub X() { $new->{position_sensitive} = 1; $l }
71			sub Y() { $new->{position_sensitive} = 1; $t }
72			sub W() { $new->{size_sensitive} = 1; $w }
73			sub H() { $new->{size_sensitive} = 1; $h }
74
75			sub now() { urxvt::NOW }
76
77			sub again($) {
78			$new->{again} = $_[0];
79			}
80
81			sub counter($) {
82			$new->{again} = $_[0];
83			$bgdsl_self->{counter} + 0
84			}
85
86			=back
87
88	root	1.28	=head2 TILING MODES
89
90			The following operators modify the tiling mode of an image, that is, the
91			way that pixels outside the image area are painted when the image is used.
92	root	1.15
93			=over 4
94
95	root	1.28	=item tile $img
96
97			Tiles the whole plane with the image and returns this new image - or in
98			other words, it returns a copy of the image in plane tiling mode.
99
100			=item mirror $img
101
102			Similar to tile, but reflects the image each time it uses a new copy, so
103			that top edges always touch top edges, right edges always touch right
104			edges and so on (with normal tiling, left edges always touch right edges
105			and top always touch bottom edges).
106
107			=item pad $img
108
109			Takes an image and modifies it so that all pixels outside the image area
110			become transparent. This mode is most useful when you want to place an
111			image over another image or the background colour while leaving all
112			background pixels outside the image unchanged.
113
114			=item extend $img
115
116			Extends the image over the whole plane, using the closest pixel in the
117			area outside the image. This mode is mostly useful when you more complex
118			filtering operations and want the pixels outside the image to have the
119			same values as the pixels near the edge.
120
121	root	1.15	=cut
122
123	root	1.28	sub pad($) {
124			my $img = $_[0]->clone;
125			$img->repeat_mode (urxvt::RepeatNone);
126			$img
127			}
128
129			sub tile($) {
130			my $img = $_[0]->clone;
131			$img->repeat_mode (urxvt::RepeatNormal);
132			$img
133			}
134
135			sub mirror($) {
136			my $img = $_[0]->clone;
137			$img->repeat_mode (urxvt::RepeatReflect);
138			$img
139			}
140	root	1.4
141	root	1.28	sub extend($) {
142	root	1.24	my $img = $_[0]->clone;
143	root	1.28	$img->repeat_mode (urxvt::RepeatPad);
144	root	1.24	$img
145			}
146
147	root	1.28	=back
148
149			=head2 PIXEL OPERATORS
150
151			The following operators modify the image pixels in various ways.
152
153			=over 4
154
155			=item clone $img
156
157			Returns an exact copy of the image.
158
159			=cut
160
161			sub clone($) {
162			$_[0]->clone
163			}
164
165			=item clip $img
166
167			=item clip $width, $height, $img
168
169			=item clip $x, $y, $width, $height, $img
170
171			Clips an image to the given rectangle. If the rectangle is outside the
172			image area (e.g. when C<$x> or C<$y> are negative) or the rectangle is
173			larger than the image, then the tiling mode defines how the extra pixels
174			will be filled.
175
176			If C<$x> an C<$y> are missing, then C<0> is assumed for both.
177
178			If C<$width> and C<$height> are missing, then the window size will be
179			assumed.
180
181			Example: load an image, blur it, and clip it to the window size to save
182			memory.
183
184			clip blur 10, load "mybg.png"
185
186			=cut
187
188	root	1.20	sub clip($;$$;$$) {
189	root	1.7	my $img = pop;
190	root	1.21	my $h = pop \|\| H;
191			my $w = pop \|\| W;
192			$img->sub_rect ($_[0], $_[1], $w, $h)
193	root	1.4	}
194
195	root	1.28	=item scale $img
196
197			=item scale $size_percent, $img
198
199			=item scale $width_percent, $height_percent, $img
200
201			Scales the image by the given percentages in horizontal
202			(C<$width_percent>) and vertical (C<$height_percent>) direction.
203
204			If only one percentage is give, it is used for both directions.
205
206			If no percentages are given, scales the image to the window size without
207			keeping aspect.
208
209			=item resize $width, $height, $img
210
211			Resizes the image to exactly C<$width> times C<$height> pixels.
212
213			=cut
214
215			#TODO: maximise, maximise_fill?
216
217			sub scale($$$) {
218			my $img = pop;
219
220			@_ == 2 ? $img->scale ($_[0] * $img->w * 0.01, $_[1] * $img->h * 0.01)
221			: @_ ? $img->scale ($_[0] * $img->w * 0.01, $_[0] * $img->h * 0.01)
222			: $img->scale (W, H)
223			}
224
225	root	1.2	sub resize($$$) {
226	root	1.7	my $img = pop;
227			$img->scale ($_[0], $_[1])
228	root	1.1	}
229
230	root	1.7	# TODO: ugly
231			sub move($$;$) {
232	root	1.20	my $img = pop->clone;
233			$img->move ($_[0], $_[1]);
234			$img
235			# my $img = pop;
236			# $img->sub_rect (
237			# $_[0], $_[1],
238			# $img->w, $img->h,
239			# $_[2],
240			# )
241	root	1.1	}
242
243	root	1.20	sub rotate($$$$$$) {
244	root	1.7	my $img = pop;
245			$img->rotate (
246			$_[0],
247	root	1.4	$_[1],
248	root	1.7	$_[2] * $img->w * .01,
249			$_[3] * $img->h * .01,
250			$_[4] * (3.14159265 / 180),
251	root	1.4	)
252	root	1.1	}
253
254	root	1.28	sub blur($$;$) {
255			my $img = pop;
256	root	1.1
257	root	1.28	$img->blur ($_[0], @_ >= 2 ? $_[1] : $_[0]);
258	root	1.1	}
259
260	root	1.2	sub contrast($$;$$;$) {
261	root	1.7	my $img = pop;
262			my ($r, $g, $b, $a) = @_;
263	root	1.4
264	root	1.1	($g, $b) = ($r, $r) if @_ < 4;
265			$a = 1 if @_ < 5;
266	root	1.4
267	root	1.1	$img = $img->clone;
268			$img->contrast ($r, $g, $b, $a);
269			$img
270			}
271
272	root	1.2	sub brightness($$;$$;$) {
273	root	1.7	my $img = pop;
274			my ($r, $g, $b, $a) = @_;
275	root	1.4
276	root	1.1	($g, $b) = ($r, $r) if @_ < 4;
277			$a = 1 if @_ < 5;
278	root	1.4
279	root	1.1	$img = $img->clone;
280			$img->brightness ($r, $g, $b, $a);
281			$img
282			}
283
284	root	1.15	=back
285
286	root	1.28	=head2 SETTINGS
287
288			=over 4
289
290			=item border $respect_border=1
291
292			Sets whether the image should respect the terminal border (argument true
293			or missing), or whether it should fill the whole window (the default).
294
295			By default, the image will cover the whole toplevel window. If C<border>
296			is enabled, then it will only fill the character area and leave a normal
297			border in the background colour around it and behind the scrollbar.
298
299			=cut
300
301			sub border {
302			$border = @_ ? $_[0] : 1;
303			}
304
305			=back
306
307	root	1.15	=cut
308
309	root	1.1	}
310
311			sub parse_expr {
312			my $expr = eval "sub {\npackage urxvt::bgdsl;\n#line 0 'background expression'\n$_[0]\n}";
313			die if $@;
314			$expr
315			}
316
317			# compiles a parsed expression
318			sub set_expr {
319			my ($self, $expr) = @_;
320
321			$self->{expr} = $expr;
322			$self->recalculate;
323			}
324
325			# evaluate the current bg expression
326			sub recalculate {
327			my ($self) = @_;
328
329	root	1.10	# rate limit evaluation
330
331	root	1.9	if ($self->{next_refresh} > urxvt::NOW) {
332			$self->{next_refresh_timer} = urxvt::timer->new->after ($self->{next_refresh} - urxvt::NOW)->cb (sub {
333			$self->recalculate;
334			});
335	root	1.12	return;
336	root	1.9	}
337
338			$self->{next_refresh} = urxvt::NOW + $MIN_INTERVAL;
339
340	root	1.10	# set environment to evaluate user expression
341	root	1.6
342	root	1.3	local $bgdsl_self = $self;
343	root	1.28	local $border;
344	root	1.1
345	root	1.3	local $old = $self->{state};
346			local $new = my $state = $self->{state} = {};
347	root	1.1
348	root	1.3	($l, $t, $w, $h) =
349	root	1.1	$self->get_geometry;
350
351	root	1.22	warn "$l,$t,$w,$h\n";#d#
352
353	root	1.10	# evaluate user expression
354
355	root	1.1	my $img = eval { $self->{expr}->() };
356			warn $@ if $@;#d#
357	root	1.15	die if !UNIVERSAL::isa $img, "urxvt::img";
358	root	1.1
359	root	1.10	# if the expression is sensitive to external events, prepare reevaluation then
360
361	root	1.2	my $repeat;
362
363	root	1.1	if (my $again = $state->{again}) {
364	root	1.2	$repeat = 1;
365	root	1.6	$state->{timer} = $again == $old->{again}
366			? $old->{timer}
367	root	1.7	: urxvt::timer->new->after ($again)->interval ($again)->cb (sub {
368			++$self->{counter};
369			$self->recalculate
370			});
371	root	1.1	}
372
373	root	1.2	if (delete $state->{position_sensitive}) {
374			$repeat = 1;
375			$self->enable (position_change => sub { $_[0]->recalculate });
376			} else {
377			$self->disable ("position_change");
378			}
379
380			if (delete $state->{size_sensitive}) {
381			$repeat = 1;
382			$self->enable (size_change => sub { $_[0]->recalculate });
383			} else {
384			$self->disable ("size_change");
385			}
386
387	root	1.9	if (delete $state->{rootpmap_sensitive}) {
388			$repeat = 1;
389			$self->enable (rootpmap_change => sub { $_[0]->recalculate });
390			} else {
391			$self->disable ("rootpmap_change");
392			}
393
394	root	1.10	# clear stuff we no longer need
395
396	root	1.6	%$old = ();
397
398	root	1.5	unless ($repeat) {
399			delete $self->{state};
400			delete $self->{expr};
401			}
402
403	root	1.10	# prepare and set background pixmap
404
405	root	1.4	$img = $img->sub_rect (0, 0, $w, $h)
406			if $img->w != $w \|\| $img->h != $h;
407	root	1.1
408	root	1.28	$self->set_background ($img, $border);
409	root	1.1	$self->scr_recolour (0);
410			$self->want_refresh;
411			}
412
413			sub on_start {
414			my ($self) = @_;
415
416			$self->set_expr (parse_expr $EXPR);
417
418			()
419			}
420