mgm/lib/xpm

   1 #!/usr/bin/perl
   2 # -*-Perl-*-
   3
   4 package MGM::Xpm;
   5
   6 # read/write XPM format, simple transformations; grayscale for the moment
   7
   8 my@hex;
   9 for(my$i=0;$i<256;$i++){$hex[$i]=sprintf "%02x", $i}
  10
  11 sub rgb{
  12     my$val=shift;
  13
  14     if($val=~m/#/){
  15        $val=~m/\#(.)(.)(.)/ if(length($val)==4);
  16        $val=~m/\#(..)(..)(..)/ if(length($val)==7);
  17        $val=~m/\#(..)..(..)..(..)/ if(length($val)==13);
  18        my$r=hex$1;
  19        my$g=hex$2;
  20        my$b=hex$3;
  21        if(length($val)==4){$r*=16;$g*=16;$b*=16};
  22        ($r,$g,$b);
  23    }else{
  24        my($r,$g,$b)=$main::toplevel->rgb($val);
  25        ($r/256,$g/256,$b/256);
  26    }
  27 }
  28
  29 sub read{
  30     my($file,$transp)=@_;
  31     die "Couldn't open $file for reading: $!" unless open(XPM,"$file");
  32     undef $/;
  33     my$data=<XPM>;
  34     $/="\n";
  35     close XPM;
  36     &data($data,$transp);
  37 }
  38
  39 sub data{
  40     my($data,$transp)=@_;
  41     $transp="#ffffff"if(!defined($transp));
  42     my@lines=split "\n", $data;
  43     $_=shift @lines;
  44
  45     if(m{/\* XPM \*/}){
  46         $_=shift @lines;
  47         $_=shift @lines;
  48
  49         m/^\"(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/;
  50         if($4==1){
  51             my%xpm;
  52             my$vector;
  53             my$width=$xpm{"width"}=$1;
  54             my$height=$xpm{"height"}=$2;
  55             my$colors=$3;
  56
  57             my$entries;
  58             my$gentries;
  59             my$type='g'; # graymap until upgraded
  60
  61             for(my$i=0;$i<$colors;$i++){
  62                 $_=shift @lines;;m/^\"(.)\s+(\S)\s+([^\"\s]+)/;
  63                 $type='c' if($2 eq 'c');
  64                 $entries.=sprintf "\\%03o", ord $1;
  65                 $val=$3;
  66
  67                 $val=$transp if(ucfirst($val) eq 'None');
  68                 ($red,$green,$blue)=MGM::Xpm::rgb($val);
  69
  70                 $val=$red*.3+$green*.5+$blue*.2;
  71
  72                 $gentries.=sprintf "\\%03o", $val;
  73             }
  74
  75             # read the image bits
  76
  77             for(my$y=0;$y<$height;$y++){
  78                 my$line=shift @lines;
  79                 $line=substr $line, 1, $width;
  80
  81                 # sometimes Perl makes me positively weep for joy:
  82                 eval "\$line=~tr[$entries][$gentries];";
  83                 $vector.=$line;
  84
  85             }
  86
  87             $xpm{"gray"}=$vector;
  88
  89             my$ref=\%xpm;
  90             bless($ref,"MGM::Xpm");
  91             $ref;
  92         }else{
  93             print STDERR "This code can only handle Pixmaps with single ".
  94                 "byte color indicies\n";
  95             undef;
  96         }
  97     }else{
  98         print STDERR "Input file is not in XPM format ".
  99             "(must begin with /* XPM */)\n";
 100         undef;
 101     }
 102 }
 103
 104 sub copy{
 105     my$xpm=shift;
 106     my%copy;
 107
 108
 109     $copy{"width"}=$xpm->{"width"};
 110     my$height=$copy{"height"}=$xpm->{"height"};
 111
 112
 113     $copy{"gray"}=$xpm->{"gray"};
 114
 115     my$ret=\%copy;
 116     bless $ret, "MGM::Xpm";
 117 }
 118
 119 sub write{
 120     my($xpm,$black,$white,$quant,$transp)=@_;
 121     # easier than reading, but harder to do efficiently
 122
 123     $transp=-1 if(!defined($transp));
 124
 125     my$width=$xpm->{"width"};
 126     my$height=$xpm->{"height"};
 127     my$colors=0;
 128     my$type='c';
 129
 130     my%entries;
 131     my$char=' ';
 132     my$buffer;
 133     my$out;
 134
 135     my($br,$bg,$bb)=&rgb($black);
 136     my($wr,$wg,$wb)=&rgb($white);
 137
 138     $wr=$wr-$br;
 139     $wg=$wg-$bg;
 140     $wb=$wb-$bb;
 141
 142     for(my$i=0;$i<$height;$i++){
 143         my@g=unpack 'C*', substr $xpm->{"gray"}, $i*$width, $width;
 144         $buffer.="\",\n\"";
 145
 146         for(my$j=0;$j<$width;$j++){
 147             $buffer.=chr(int($g[$j]*($quant/255))+65);
 148         }
 149     }
 150
 151     $out="/* XPM */\nstatic char * mgm_xpm[] = {\n".
 152         "\"$width $height ".($quant+1)." 1";
 153
 154     foreach $key (0..$quant){
 155         $c=chr($key+65);
 156         $out.="\",\n\"$c  $type ";
 157         if($key eq $transp){
 158             $out.="None";
 159         }else{
 160
 161             my$r=($key/$quant)*$wr+$br;
 162             my$g=($key/$quant)*$wg+$bg;
 163             my$b=($key/$quant)*$wb+$bb;
 164
 165             my$val=$hex[$r].$hex[$g].$hex[$b];
 166
 167             $out.="#$val";
 168         }
 169     }
 170
 171     $out.=$buffer."\"};\n";
 172     $out;
 173 }
 174
 175 sub new{
 176     my($width,$height,$val)=@_;
 177
 178     $width=int($width);
 179     $height=int($height);
 180
 181     my($red,$green,$blue)=MGM::Xpm::rgb($val);
 182     my$gray=chr($red*.3+$green*.5+$blue*.2);
 183     my%xpm;
 184
 185     $xpm{"width"}=$width;
 186     $xpm{"height"}=$height;
 187     $xpm{"gray"}= ($gray) x ($width*$height);
 188
 189     my$ret=\%xpm;
 190     bless $ret, "MGM::Xpm";
 191 }
 192
 193 sub width{
 194     my$xpm=shift;
 195     $xpm->{"width"};
 196 }
 197
 198 sub height{
 199     my$xpm=shift;
 200     $xpm->{"height"};
 201 }
 202
 203 sub merge{
 204     my($to,$tox,$toy,$from,$x,$y,$w,$h)=@_;
 205
 206     my$twidth=$to->{"width"};
 207     my$fwidth=$from->{"width"};
 208
 209     $w=$twidth-$tox if($w+$tox>$twidth);
 210     $w=$fwidth-$x if($w+$x>$fwidth);
 211
 212     for(my$i=0;$i<$h;$i++){
 213         substr($to->{"gray"}, $tox+($i+$toy)*$twidth, $w) =
 214             substr $from->{"gray"}, $x+($i+$y)*$fwidth, $w;
 215     }
 216     $to;
 217 }
 218
 219 sub rot90{
 220     my$xpm=shift;
 221
 222     $w=$xpm->width;
 223     $h=$xpm->height;
 224
 225     # build new grid
 226     my$gray;
 227     for(my$i=$w-1;$i>=0;$i--){
 228         for(my$j=0;$j<$h;$j++){
 229             $gray.=substr $xpm->{"gray"}, $j*$w+$i, 1;
 230         }
 231     }
 232     $xpm->{"gray"}=$gray;
 233     $xpm->{"width"}=$h;
 234     $xpm->{"height"}=$w;
 235     $xpm;
 236 }
 237
 238 sub reduceonex{
 239     my($w,$nw,$v)=@_;
 240     my$del=(1.0*$w)/($nw?$nw:1);
 241     my$prev=0;
 242     my$iprev=0;
 243     my$oldval=$v->[0];
 244
 245     for(my$nx=0;$nx<$nw;$nx++){
 246         my$x=$del*($nx+1);
 247         my$ix=int($x);
 248         $x-=$ix;
 249
 250         my$val=$oldval*(1-$prev);
 251         for(my$i=$iprev+1;$i<$ix;$i++){$val+=$v->[$i]};
 252         $oldval=$v->[$ix];
 253         $val+=$oldval*$x if($x>.0001);
 254
 255         $v->[$nx]=$val/$del+.5;
 256
 257         $prev=$x;
 258         $iprev=$ix;
 259     }
 260 }
 261
 262 sub enlargeonex{
 263     my($w,$nw,$v)=@_;
 264     my$del=$w/$nw;
 265     my$prev=$w;
 266     my$iprev=$w-1;
 267     my$oldval=$v->[$w-1];
 268     for(my$nx=$nw-1;$nx>=0;$nx--){
 269         my$x=$del*($nx);
 270         my$ix=int($x);
 271
 272         if($ix==$iprev){
 273             $v->[$nx]=$v->[$ix];
 274         }else{
 275             my$val=$oldval*($prev-$iprev);
 276             $val+=($oldval=$v->[$ix])*(1-$x+$ix);
 277             $v->[$nx]=$val/$del+.5;
 278         }
 279         $prev=$x;
 280         $iprev=$ix;
 281     }
 282 }
 283
 284 sub reduceoney{
 285     my($w,$h,$nh,$vv)=@_;
 286     my$del=$h/$nh;
 287     my$prev=0;
 288     my$iprev=0;
 289     my@nv;
 290     $#nv=$w;
 291     for(my$ny=0;$ny<$nh;$ny++){
 292         my$y=$del*($ny+1);
 293         my$iy=int($y);
 294
 295         # initial row
 296         my$idel=(1-$prev+$iprev)/$del;
 297         my@v=unpack 'C*', substr $$vv, $iprev*$w, $w;
 298         for(my$x=0;$x<$w;$x++){$nv[$x]=$v[$x]*$idel+.5;}
 299         #intevening rows
 300         $iprev++;
 301         while($iprev<$iy){
 302             @v=unpack 'C*', substr $$vv, $iprev*$w, $w;
 303             for(my$x=0;$x<$w;$x++){$nv[$x]+=$v[$x]/$del;}
 304             $iprev++;
 305         }
 306         # terminal row
 307         $idel=($y-$iy)/$del;
 308         if($idel>.0001){
 309             @v=unpack 'C*', substr $$vv, $iy*$w, $w;
 310             for(my$x=0;$x<$w;$x++){$nv[$x]+=$v[$x]*$idel;}
 311         }
 312         $iprev=$iy;
 313         $prev=$y;
 314
 315         substr($$vv, $ny*$w, $w)=pack 'C*', @nv[0..$w-1];
 316     }
 317 }
 318
 319 sub enlargeoney{
 320     my($w,$h,$nh,$vv)=@_;
 321     my$del=$h/$nh;
 322     my$prev=$h;
 323     my$iprev=$h-1;
 324     my@nv;
 325     $#nv=$w;
 326     for(my$ny=$nh-1;$ny>=0;$ny--){
 327         my$y=$del*$ny;
 328         my$iy=int($y);
 329
 330         if($iprev==$iy){
 331             substr($$vv, $ny*$w, $w)=
 332                 substr($$vv, $iprev*$w, $w);
 333         }else{
 334             # initial row
 335             my$idel=($prev-$iprev)/$del;
 336             @v=unpack 'C*', substr $$vv, $iprev*$w, $w;
 337             for(my$x=0;$x<$w;$x++){$nv[$x]=$v[$x]*$idel;}
 338             # terminal row
 339             $idel=(1-$y+$iy)/$del;
 340             @v=unpack 'C*', substr $$vv, $iy*$w, $w;
 341             for(my$x=0;$x<$w;$x++){$nv[$x]+=$v[$x]*$idel+.5;}
 342             substr($$vv, $ny*$w, $w)=pack 'C*', @nv[0..$w-1];
 343         }
 344         $iprev=$iy;
 345         $prev=$y;
 346     }
 347 }
 348
 349 sub scale{
 350     my($xpm,$nw,$nh)=@_;
 351     $nw=int($nw);
 352     $nh=int($nh);
 353     $w=$xpm->width;
 354     $h=$xpm->height;
 355     if($nw<$w){
 356
 357         for(my$y=0;$y<$h;$y++){
 358             my@temp=unpack 'C*', substr ($xpm->{"gray"}, $y*$w, $w);
 359             &reduceonex($w,$nw,\@temp);
 360             substr ($xpm->{"gray"}, $y*$nw, $nw) = pack 'C*', @temp[0..$nw-1];
 361         }
 362         $w=$nw;
 363         $xpm->{"width"}=$w;
 364     }
 365
 366     if($nh<$h){
 367         &reduceoney($w,$h,$nh,\$xpm->{"gray"});
 368         $h=$nh;
 369         $xpm->{"height"}=$h;
 370     }
 371
 372     if($nw>$w){
 373         substr($xpm->{"gray"}, $h*$w)= 'Xpm Xpm ' x ($h*($nw-$w)/8);
 374         for(my$y=$h-1;$y>=0;$y--){
 375             my@temp=unpack 'C*', substr ($xpm->{"gray"}, $y*$w, $w);
 376             &enlargeonex($w,$nw,\@temp);
 377             substr ($xpm->{"gray"}, $y*$nw, $nw) = pack 'C*', @temp[0..$nw-1];
 378         }
 379         $w=$nw;
 380         $xpm->{"width"}=$w;
 381     }
 382
 383     if($nh>$h){
 384         substr($xpm->{"gray"}, $h*$w)= 'Xpm Xpm ' x ($w*($nh-$h)/8);
 385         &enlargeoney($w,$h,$nh,\$xpm->{"gray"});
 386         $h=$nh;
 387         $xpm->{"height"}=$h;
 388     }
 389
 390     $xpm;
 391 }
 392
 393 sub getpixel{
 394     my($xpm,$x,$y)=@_;
 395     my$w=$xpm->{"width"};
 396     ord (substr ($xpm->{"gray"}, $y*$w+$x, 1));
 397 }
 398
 399 package MGM::Font;
 400
 401 sub new{
 402     my($xpm)=@_;
 403
 404     my%font;
 405     my$count=32;
 406     my$pos=0;
 407
 408     $font{"bitmap"}=$xpm;
 409     $font{"height"}=$xpm->height-1;
 410     while($pos<$xpm->width){
 411         $font{"$count"}=$pos;
 412         # find the width
 413
 414         while(++$pos<$xpm->width){
 415             last if (!$xpm->getpixel($pos,0));
 416         }
 417         $font{($count)."w"}=$pos-$font{"$count"};
 418         $count++;
 419     }
 420     my$ref=\%font;
 421     bless $ref, "MGM::Font";
 422 }
 423
 424 sub textsize{
 425     my($font,$text,$height)=@_;
 426     my$acc=0;
 427     my$pop;
 428     while($pop=ord chop($text)){
 429         $acc+=$font->{($pop)."w"};
 430     }
 431
 432     if(!defined($height)){
 433         ($acc,$font->{"height"});
 434     }else{
 435         (int($height/$font->{"height"}*$acc),$height);
 436     }
 437 }
 438
 439 my%textcache;
 440
 441 sub maketext{
 442     my($font,$text,$height,$widthlimit,$stretch,$rot90,$cache)=@_;
 443
 444     my($bigw,$bigh);
 445     my$bigtext;
 446
 447     if(!defined($textcache{$text})){
 448
 449         # how big?
 450         ($bigw,$bigh)=$font->textsize($text);
 451
 452         # make a pixmap frame
 453         $bigtext=MGM::Xpm::new($bigw+2,$bigh+2,'#ffffff');
 454         $textcache{$text}=$bigtext if(defined($cache));
 455
 456         # paste in characters
 457         my$pos=$bigw+1;
 458         while(my$pop=ord chop($text)){
 459             my$w=$font->{($pop)."w"};
 460             $pos-=$w;
 461             $bigtext->merge($pos,1,$font->{"bitmap"},$font->{$pop},1,
 462                             $w,$bigh);
 463         }
 464
 465     }else{
 466         $bigtext=$textcache{$text};
 467         $bigw=$bigtext->width;
 468         $bigh=$bigtext->height;
 469     }
 470
 471     # scale it.
 472
 473     $width=int($height/$bigh*$bigw*$stretch+.9);
 474     $width=$widthlimit if (defined($widthlimit) && $width>$widthlimit);
 475     my$ret=$bigtext->copy;
 476
 477     $ret->scale($width,$height);
 478
 479     $ret->rot90 if ($rot90);
 480     $ret;
 481 }
 482
 483 #$xpm=MGM::Xpm::read("/home/xiphmont/SnotfishCVS/mgm/lib/helvetica.xpm","#ffffff");
 484 #$xpm->scale(200,31);
 485 #$xpm->rot90;
 486 #$m=MGM::Xpm::new(100,100,'#6542ee');
 487 #$m->merge(2,2,$xpm,4,4,50,50);
 488 #print $m->write('#161262','#ffffff','#ffffff');
 489
 490 1;
 491