1# -*- perl -*-
2
3#
4# $Id: RotFont.pm,v 1.15 2005/11/19 00:11:15 eserte Exp $
5# Author: Slaven Rezic
6#
7# Copyright (C) 2000,2001 Slaven Rezic. All rights reserved.
8# This package is free software; you can redistribute it and/or
9# modify it under the same terms as Perl itself.
10#
11# Mail: eserte@cs.tu-berlin.de
12# WWW:  http://user.cs.tu-berlin.de/~eserte/
13#
14
15package Tk::RotFont;
16
17use strict;
18use vars qw($DEBUG);
19use constant PI => 3.141592653;
20
21BEGIN {
22    if (!$Tk::RotFont::NO_X11) {
23	eval q{
24	    use Tk::X11Font;
25	    use Tk::Font;
26	}; die $@ if $@;
27    }
28}
29
30
31#*canvas = \&canvas_old;
32*canvas = \&rot_text_old;
33#*canvas = \&rot_text_smart_compat;
34#*rot_text = \&rot_text_old;
35
36if (1) {
37    # irgendwas ist hier kaputt gegangen... $Tk::VERSION >= 804
38    # n�, XFree86 4 ist der Schuldige!
39    $Tk::RotFont::NO_X11 = 1;
40}
41
42# XXX durch Variable verf�gbar machen
43if (!$Tk::RotFont::NO_X11) { # XXX rot_text_newer ist wesentlich *langsamer* als rot_text_old
44    # X11::Protocol scheint Speicherfresser zu sein
45    use vars qw($use_rotx11font); # XXX
46    if (!defined $main::x11) {
47	eval '
48	    require X11::Protocol;
49	    $main::x11 = X11::Protocol->new;
50	    #use lib "XXX$ENV{HOME}/devel";
51	    require Tk::RotX11Font;
52	    if ($main::use_font_rot) {
53		$use_rotx11font = 1;
54#		*rot_text = \&rot_text_newer;
55		*canvas = \&rot_text_smart_compat;
56	    }
57	';
58	warn $@ if $@;
59    }
60}
61
62use vars qw(%rot_font_cache);
63
64# Zeichnet den Stra�ennamen mit rotierten Zeichens�tzen.
65# Argumente:
66# $c:        Canvas
67# $abk:      Abk�rzung, wird als Tag verwendet
68# $coordref: Referenz auf Koordinaten der Stra�e
69# $f_sub:    Funktion, die den Fontnamen ermittelt
70# $size:     Fontgr��e
71# $str:      auszugebendes Label
72# %args:     more arguments for createText
73### AutoLoad Sub
74sub rot_text_old {
75    my($c, $abk, $coordref, $f_sub, $size, $str, %args) = @_;
76    return if length($str) == 0;
77    my $ges_strecke_len = 0;
78    my $last_coordref = $#{$coordref};
79    for(my $i = 0; $i<=$last_coordref-3; $i+=2) {
80	$ges_strecke_len +=
81	  Strassen::Util::strecke([$coordref->[$i],   $coordref->[$i+1]],
82				  [$coordref->[$i+2], $coordref->[$i+3]]);
83    }
84    return if $ges_strecke_len == 0;
85    my $len_per_char = (length($str) == 1
86			? 0 : $ges_strecke_len/(length($str)+1));
87    return if $len_per_char < 4; # ansonsten unlesbar
88    my $reversed = 0;
89    if ($coordref->[0] > $coordref->[$last_coordref-1]) {
90	$str = reverse $str;
91	$reversed = 1;
92    }
93    my $last_strecke_len;
94    my $strecke_len = 0;
95    my $curr_pos = $len_per_char;
96    my $curr_i = 0;
97    my @create_text_args = (-anchor => 'w', -tags => "$abk-label", %args);
98    for(my $i = 0; $i<=$last_coordref-3; $i+=2) {
99	$last_strecke_len = $strecke_len;
100	$strecke_len +=
101	  Strassen::Util::strecke([$coordref->[$i],   $coordref->[$i+1]],
102				  [$coordref->[$i+2], $coordref->[$i+3]]);
103	while ($strecke_len > $curr_pos) {
104	    my($ch_x, $ch_y);
105	    my $m = ($curr_pos-$last_strecke_len)/
106	      ($strecke_len-$last_strecke_len);
107	    $ch_x = $m*($coordref->[$i+2]-$coordref->[$i])
108	      + $coordref->[$i];
109	    $ch_y = $m*($coordref->[$i+3]-$coordref->[$i+1])
110	      + $coordref->[$i+1];
111	    my $rotsize;
112	    if ($main::use_font_rot) {
113		my $r = -atan2($coordref->[$i+3]-$coordref->[$i+1],
114			       $coordref->[$i+2]-$coordref->[$i],
115			      );
116		if ($reversed) {
117		    $r += PI;
118		}
119		$rotsize = get_rot_matrix($r, $size);
120	    } else {
121		$rotsize = $size*10;
122	    }
123	    eval {
124		my $substr = substr($str, $curr_i, 1); # workaround Tk804 problem
125		$c->createText
126		    ($ch_x, $ch_y,
127		     -text => $substr,
128		     -font => $f_sub->($rotsize),
129		     @create_text_args,
130		    );
131	    };
132	    if ($@) { warn "Problem at $rotsize: $@\n" }
133	    $curr_i++;
134	    $curr_pos += $len_per_char;
135	}
136    }
137}
138
139# Zeichnet den Stra�ennamen mit rotierten Zeichens�tzen.
140# Verwendet Tk::RotX11Font.
141# XXX Test2
142### AutoLoad Sub
143sub rot_text_newer {
144    my($c, $abk, $coordref, $f_sub, $size, $str) = @_;
145    return if length($str) == 0;
146    my $ges_strecke_len = 0;
147    my $last_coordref = $#{$coordref};
148    for(my $i = 0; $i<=$last_coordref-3; $i+=2) {
149	$ges_strecke_len +=
150	  Strassen::Util::strecke([$coordref->[$i],   $coordref->[$i+1]],
151				  [$coordref->[$i+2], $coordref->[$i+3]]);
152    }
153    return if $ges_strecke_len == 0;
154    my $len_per_char = (length($str) == 1
155			? 0 : $ges_strecke_len/(length($str)+1));
156    return if $len_per_char < 4; # ansonsten unlesbar
157
158    if ($coordref->[0] > $coordref->[$#$coordref-1]) {
159	my(@newcoordref);
160	for(my $i=0; $i<$#$coordref; $i+=2) {
161	    unshift @newcoordref, $coordref->[$i], $coordref->[$i+1];
162	}
163	$coordref = \@newcoordref;
164    }
165
166    my $last_strecke_len;
167    my $strecke_len = 0;
168    my $curr_pos = $len_per_char;
169    my $str_i = 0;
170    eval {
171      STRLOOP:
172	for(my $i = 0; $i<=$last_coordref-3; $i+=2) {
173	    $last_strecke_len = $strecke_len;
174	    $strecke_len +=
175	      Strassen::Util::strecke([$coordref->[$i],   $coordref->[$i+1]],
176				      [$coordref->[$i+2], $coordref->[$i+3]]);
177	    my $r = -atan2($coordref->[$i+3]-$coordref->[$i+1],
178			   $coordref->[$i+2]-$coordref->[$i],
179			  );
180	    my $rotfont1 = new Tk::RotX11Font
181	      substr($str, $str_i), $f_sub, $size, $r;
182	    while ($strecke_len > $curr_pos) {
183		last STRLOOP if ($str_i > length($str));
184		my($ch_x, $ch_y);
185		my $m = ($curr_pos-$last_strecke_len)/
186		  ($strecke_len-$last_strecke_len);
187		$ch_x = $m*($coordref->[$i+2]-$coordref->[$i])
188		  + $coordref->[$i];
189		$ch_y = $m*($coordref->[$i+3]-$coordref->[$i+1])
190		  + $coordref->[$i+1];
191		my $ch = substr($str, $str_i, 1);
192		my($xext1, $yext1) = $rotfont1->x_y_extent($ch);
193		$rotfont1->writeCanvas($c, $ch_x, $ch_y, "$abk-label", $ch);
194		$str_i++;
195		$curr_pos += CORE::sqrt(sqr($xext1) + sqr($yext1));
196	    }
197	}
198    };
199    warn $@ if $@;
200}
201
202# Kompatibilit�tsaufruf
203sub rot_text_smart_compat {
204    my($c, $abk, $coordref, $f_sub, $size, $str) = @_;
205    rot_text_smart($str, $coordref,
206		   -anglesteps => 1,
207		   -fontsub => $f_sub,
208		   -size => $size,
209		   -canvas => $c,
210		   -abbrev => $abk);
211}
212
213# Zeichnet den Stra�ennamen mit rotierten Zeichens�tzen.
214# Der Stra�enname wird dabei in zwei Teile geteilt und am
215# Anfang und Ende der Stra�e gezeichnet.
216# Verwendet entweder Tk::RotX11Font oder benutzerdefinierte Funktionen
217### AutoLoad Sub
218sub rot_text_smart {
219    my($str, $coordref, %args) = @_;
220    return if length($str) == 0;
221    # Aufteilen in "Duden-" und "str." (wenn m�glich)
222    # XXX mehrteilige Stra�ennamen m�ssen nicht geteilt werden
223    # (Hallesches|Ufer, Kaiser-|Wilhelm-|Platz)
224    my($strbase, $strtype);
225    if ($str =~ /^(.*)(\s+|-)(\S+)$/) {
226	($strbase, $strtype) = ($1, $3);
227	if ($2 eq '-') { $strbase .= $2 }
228    } elsif ($str !~ /^(.*)(str\.    |
229			    stra�e   |
230			    damm     |
231			    weg      |
232			    allee    |
233			    chaussee |
234			    ring     |
235			    platz    |
236			    br�cke   |
237			    ufer)$/ix) {
238	return;
239    } else {
240	($strbase, $strtype) = ($1, $2);
241	# Bindestrich bei Bedarf hinzuf�gen
242	if ($strbase =~ /^(.*)(\s+)$/) {
243	    $strbase = $1;
244	} elsif ($strbase !~ /-$/) {
245	    $strbase .= "-";
246	}
247    }
248    $strbase = " $strbase";
249    $strtype .= " ";
250
251    if ($coordref->[0] > $coordref->[$#$coordref-1]) {
252	my(@newcoordref);
253	for(my $i=0; $i<$#$coordref; $i+=2) {
254	    unshift @newcoordref, $coordref->[$i], $coordref->[$i+1];
255	}
256	$coordref = \@newcoordref;
257    }
258
259    my @r;
260    $r[0] = -atan2($coordref->[0+3]-$coordref->[0+1],
261		   $coordref->[0+2]-$coordref->[0],
262		  );
263    my $coordlen3 = $#$coordref-3;
264    $r[1] = -atan2($coordref->[$coordlen3+3]-$coordref->[$coordlen3+1],
265		   $coordref->[$coordlen3+2]-$coordref->[$coordlen3],
266		  );
267    if ($args{-anglesteps}) {
268	# 5�-Schritte erzwingen
269	foreach (@r) {
270	    $_ = int(($_/PI)*36)/36*PI;
271	}
272    }
273    if (ref $args{-drawsub} eq 'CODE') {
274return draw_text_exact($str, $coordref, %args);
275	# use user defined routine
276	# XXX chaos. Die Argumente sind: x, y (nicht transponiert)
277	# Stra�enname (String), Winkel (rad) (muss - genommen werden?!),
278	# optional: delta-w und delta-h (pixel)
279	my($w_all) = $args{-extentsub}->($coordref->[0], $coordref->[1],
280					 $strbase.$strtype, 0);
281	my($w2,$h2) = $args{-extentsub}->($coordref->[-2], $coordref->[-1],
282					  $strtype, $r[1]);
283
284	my $ges_strecke_len = len_of_coordrefs($coordref, \%args);
285	warn "$strbase wall=$w_all ges=$ges_strecke_len\n" if $DEBUG;
286	return if ($ges_strecke_len == 0 || $ges_strecke_len < $w_all);
287
288	warn "r0=" . ($r[0]*180/PI) . " r1=" . ($r[1]*180/PI) . "\n" if $DEBUG;
289	$args{-drawsub}->($coordref->[0], $coordref->[1],
290			  $strbase, $r[0]);
291	$args{-drawsub}->($coordref->[-2], $coordref->[-1],
292			  $strtype, $r[1], $w2, $h2);
293    } else {
294	# use Tk Canvas
295	eval {
296	    my $f_sub = $args{-fontsub};
297	    my $size  = $args{-size};
298	    my $c     = $args{-canvas};
299	    my $abk   = $args{-abbrev};
300
301	    my $rotfont1 = new Tk::RotX11Font $strbase, $f_sub, $size, $r[0];
302	    my $rotfont2 = new Tk::RotX11Font $strtype, $f_sub, $size, $r[1];
303	    my($xext1, $yext1) = $rotfont1->x_y_extent;
304	    my($xext2, $yext2) = $rotfont2->x_y_extent;
305	    if (abs($xext1+$xext2) > abs($coordref->[0]-$coordref->[$#$coordref-1])
306		&&
307		abs($yext1+$yext2) > abs($coordref->[1]-$coordref->[$#$coordref])
308	       ) {
309		warn "$strbase $strtype too large..." if $DEBUG;
310		return;
311	    }
312	    $rotfont1->writeCanvas
313		($c, $coordref->[0], $coordref->[1], "$abk-label");
314	    $rotfont2->writeCanvas
315		($c,
316		 $coordref->[$#$coordref-1]-$xext2, $coordref->[$#$coordref]-$yext2,
317		 "$abk-label");
318	};
319    }
320    warn $@ if $@;
321}
322
323sub draw_text_exact {
324    my($str, $coordref, %args) = @_;
325    my($w_all) = $args{-extentsub}->($coordref->[0], $coordref->[1],
326				     $str, 0);
327    my $ges_strecke_len = len_of_coordrefs($coordref, \%args);
328    my $margin = 5;
329    warn "$str wall=$w_all ges=$ges_strecke_len\n" if $DEBUG;
330    return if ($ges_strecke_len == 0 || $ges_strecke_len < $w_all+2*$margin);
331
332    warn "coords=@$coordref\n" if $DEBUG;
333
334    my($last_x, $last_y, $section) =
335	advance($coordref, \%args, $coordref->[0], $coordref->[1],
336		0, $margin);
337    warn "advance $margin from $coordref->[0]/$coordref->[1] => $last_x/$last_y\n" if $DEBUG;
338    my $last_section = $section;
339
340    my $next_len = 0;
341    my $next_i = 2;
342    my($next_x, $next_y);
343    while($next_i <= $#$coordref) {
344	($next_x, $next_y) = ($coordref->[$next_i], $coordref->[$next_i+1]);
345	$next_len += Strassen::Util::strecke([$next_x,$next_y],[$last_x,$last_y]);
346	last if ($margin < $next_len);
347	$next_i+=2;
348    };
349    my $last_r0 = -atan2($coordref->[$next_i+1]-$last_y,
350			 $coordref->[$next_i]-$last_x);
351{
352my($tx1,$ty1) = $args{-transpose}->($last_x,$last_y);
353my($tx2,$ty2) = $args{-transpose}->($coordref->[$next_i],$coordref->[$next_i+1]);
354my $tr = -atan2($ty2-$ty1, $tx2-$tx1);
355warn "t1=$tx1/$ty1 t2=$tx2/$ty2 tr=$tr\n" if $DEBUG;
356}
357
358    my $len_so_far = 0;
359    my $r; # next
360    my $this_r;
361
362    my $draw = sub {
363	my $j = shift;
364	my($draw_len) = $args{-extentsub}->($last_x, $last_y,
365					    substr($str, 0, $j), 0);
366	warn "draw x/y=$last_x/$last_y, str=($str,0,$j), r0=$last_r0 thisr=$this_r\n" if $DEBUG;
367	$args{-drawsub}->($last_x, $last_y,
368			  substr($str, 0, $j),
369			  (defined $r ? in_between($last_r0, $r) : $last_r0)
370			 );
371	#$last_r0);
372	#$this_r);
373	$str = substr($str, $j);
374	($last_x, $last_y, $section) =
375	    advance($coordref, \%args, $last_x, $last_y,
376		    $section, $draw_len);
377	$last_r0 = $r;
378	$len_so_far = $draw_len;
379	warn "after ($draw_len): (x/y=$last_x/$last_y, $section) r=$last_r0 len=$len_so_far\n"
380	    if $DEBUG;
381    };
382
383 LOOP:
384    while(1) {
385	last if ($section*2+3) > $#$coordref;
386
387	$r = -atan2($coordref->[$section*2+3]-$last_y,
388		    $coordref->[$section*2+2]-$last_x);
389	$this_r = -atan2($coordref->[$section*2+1]-$last_y,
390			 $coordref->[$section*2+0]-$last_x);
391
392	$len_so_far += Strassen::Util::strecke
393	    ([$args{-transpose}->($coordref->[$section*2],
394				  $coordref->[$section*2+1])],
395	     [$args{-transpose}->($coordref->[$section*2+2],
396				  $coordref->[$section*2+3])]);
397
398	# zu gro�e Abweichung von der Geraden:
399	if (abs($r-$last_r0) > 0.175) {
400
401	    for(my $j = 0; $j < length $str; $j++) {
402		if (substr($str, $j, 1) =~ /\s/) {
403		    $draw->($j);
404		    next LOOP;
405		}
406
407		my($w_x) = $args{-extentsub}->($last_x, $last_y,
408					       substr($str, 0, $j), 0);
409		if ($w_x > $len_so_far) {
410		    $draw->($j);
411		    next LOOP;
412		}
413	    }
414	}
415
416	$section++;
417    }
418
419    if ($str ne "") {
420	$draw->(length $str);
421    }
422}
423
424sub len_of_coordrefs {
425    my $coordref = shift;
426    my $args = shift;
427    my $last_coordref = shift || $#{$coordref};
428    my $ges_strecke_len = 0;
429
430    for(my $i = 0; $i<=$last_coordref-3; $i+=2) {
431	$ges_strecke_len +=
432	    Strassen::Util::strecke
433		    ([$args->{-transpose}->($coordref->[$i],
434					    $coordref->[$i+1])],
435		     [$args->{-transpose}->($coordref->[$i+2],
436					    $coordref->[$i+3])]);
437    }
438
439    $ges_strecke_len;
440}
441
442# Advance on the line represented by the $coordref from point $x/$y by
443# $delta and return new $newx,$newy values. The point $x/$y lies on
444# section number $section. A new section is also returned. Sections are
445# numbered from 0. $args should contain the -transpose subroutine.
446sub advance {
447    my($coordref, $args, $x, $y, $section, $delta) = @_;
448    my $i = $section*2 + 2;
449    for(; $i<=$#$coordref; $i+=2) {
450	my $this_hop = Strassen::Util::strecke
451	    ([$args->{-transpose}->($x, $y)],
452	     [$args->{-transpose}->($coordref->[$i],
453				    $coordref->[$i+1])]);
454	if ($this_hop > 0) {
455	    if ($this_hop > $delta) {
456		my $scale = $delta/$this_hop;
457		return (($coordref->[$i]-$x)*$scale+$x,
458			($coordref->[$i+1]-$y)*$scale+$y,
459			$i);
460	    }
461	    $delta -= $this_hop;
462	    ($x, $y) = ($coordref->[$i], $coordref->[$i+1]);
463	}
464    }
465    ($x, $y, $#$coordref+1); # $delta is larger than line
466}
467
468sub in_between {
469    my($a, $b) = @_;
470    #warn "a=$a b=$b middle=" . (($a-$b)/2+$a) . "\n";
471    ($a-$b)/2+$b;
472}
473
474# Erstellt eine Rotationsmatrix f�r X11R6
475# XXX rot-Funktion auslagern (CanvasRotText)
476### AutoLoad Sub
477sub get_rot_matrix {
478    my($r, $size) = @_;
479    $r = int(($r/PI)*36)/36*PI; # 5�-Schritte erzwingen
480    if (abs($r - PI) < 0.1) {
481	$r = 3.2;
482    } elsif (abs($r + PI) < 0.1) {
483	$r = -3.1;
484    }
485    my $mat;
486    my $a1 = $size*cos($r);
487    my $s1 = sin($r);
488    foreach ($a1, $size*$s1, $size*-$s1, $a1) {
489	s/-/~/g;
490	if ($mat) { $mat .= " " }
491	$mat .= $_;
492    }
493    '[' . $mat . ']';
494}
495
496# Rotiert den angegebenen Font um $r (Bogenma�)
497### AutoLoad Sub
498sub rot_font {
499    my($font, $r) = @_;
500    my $top = $main::top;
501    my $font_obj;
502    eval {
503	$font_obj = $top->X11Font($font);
504    };
505    if (!$font_obj) {
506	# $font ist ein Tk-font und kann nicht als Argument f�r
507	# Font verwendet werden.
508	my(%f) = $top->fontActual($font);
509	$font_obj = $top->Font(family => $f{-family},
510			       point  => $f{-size}*10,
511# �bersetzung zu medium/old etc. n�tig
512#			       weight => $f{-weight},
513			       slant  => 'r',
514#XXX �bersetzung zu o/i etc. n�tig
515#			       slant  => $f{-slant},
516			      );
517    }
518    my $matrix = get_rot_matrix($r, $font_obj->Point/10);
519    $font_obj->Point("");
520    $font_obj->Pixel($matrix);
521    $font_obj->as_string;
522}
523
524# Zeichnet den Stra�ennamen mit rotierten Zeichens�tzen.
525# XXX kann mit perl nicht zufriedenstellend gel�st werden
526### AutoLoad Sub
527sub createRotText {
528    my($c, $x, $y, %args) = @_;
529    my $str  = delete $args{-text};
530    my $font = delete $args{-font};
531# XXX effizienter gestalten
532    my $dummy_l = $c->parent->Label(defined $font ? (-font => $font) : ());
533    my $font_n_obj = $dummy_l->cget(-font);
534
535    my $rot  = delete $args{-rot};
536    if ($rot) {
537	my $cache_name = "$font/$rot";
538	if (exists $rot_font_cache{$cache_name}) {
539	    $font = $rot_font_cache{$cache_name};
540	} else {
541	    $font = rot_font($font, $rot);
542	    $rot_font_cache{$cache_name} = $font;
543	}
544    }
545    my $anchor = delete $args{-anchor} || 'w';
546    foreach (split(//, $str)) {
547	$c->createText($x, $y, -text => $_, -font => $font, %args,
548		       -anchor => $anchor,
549		      );
550	my $xadd = $main::top->font('measure', $font_n_obj, $_);
551	$y -= $xadd*sin($rot);
552	$x += $xadd*cos($rot);
553    }
554}
555# XXX ^^^
556
5571;
558
559__END__
560