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