#!/usr/bin/perl
# -*-Perl-*-

package MGM::Xpm;

# read/write XPM format, simple transformations; grayscale for the moment

my@hex;
for(my$i=0;$i<256;$i++){$hex[$i]=sprintf "%02x", $i}

sub rgb{
    my$val=shift;

    if($val=~m/#/){
       $val=~m/\#(.)(.)(.)/ if(length($val)==4);
       $val=~m/\#(..)(..)(..)/ if(length($val)==7);
       $val=~m/\#(..)..(..)..(..)/ if(length($val)==13);
       my$r=hex$1;
       my$g=hex$2;
       my$b=hex$3;
       if(length($val)==4){$r*=16;$g*=16;$b*=16};
       ($r,$g,$b);
   }else{
       my($r,$g,$b)=$main::toplevel->rgb($val);
       ($r/256,$g/256,$b/256);
   }
}

sub read{
    my($file,$transp)=@_;
    die "Couldn't open $file for reading: $!" unless open(XPM,"$file");
    undef $/;
    my$data=<XPM>;
    $/="\n";
    close XPM;
    &data($data,$transp);
}

sub data{
    my($data,$transp)=@_;
    $transp="#ffffff"if(!defined($transp));
    my@lines=split "\n", $data;
    $_=shift @lines;
    
    if(m{/\* XPM \*/}){
	$_=shift @lines;
	$_=shift @lines;

	m/^\"(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/;
	if($4==1){
	    my%xpm;
	    my$vector;
	    my$width=$xpm{"width"}=$1;
	    my$height=$xpm{"height"}=$2;
	    my$colors=$3;
	    
	    my$entries;
	    my$gentries;
	    my$type='g'; # graymap until upgraded
	    
	    for(my$i=0;$i<$colors;$i++){
		$_=shift @lines;;m/^\"(.)\s+(\S)\s+([^\"\s]+)/;
		$type='c' if($2 eq 'c');
		$entries.=sprintf "\\%03o", ord $1;
		$val=$3;
		
		$val=$transp if(ucfirst($val) eq 'None');
		($red,$green,$blue)=MGM::Xpm::rgb($val);
		
		$val=$red*.3+$green*.5+$blue*.2;

		$gentries.=sprintf "\\%03o", $val;
	    }
	    
	    # read the image bits
	    
	    for(my$y=0;$y<$height;$y++){
		my$line=shift @lines;
		$line=substr $line, 1, $width;
		
		# sometimes Perl makes me positively weep for joy:
		eval "\$line=~tr[$entries][$gentries];";
		$vector.=$line;
		
	    }
	    
	    $xpm{"gray"}=$vector;
	    
	    my$ref=\%xpm;
	    bless($ref,"MGM::Xpm");
	    $ref;
	}else{
	    print STDERR "This code can only handle Pixmaps with single ".
		"byte color indicies\n";
	    undef;
	}
    }else{
	print STDERR "Input file is not in XPM format ".
	    "(must begin with /* XPM */)\n";
	undef;
    }
}

sub copy{
    my$xpm=shift;
    my%copy;
    
    
    $copy{"width"}=$xpm->{"width"};
    my$height=$copy{"height"}=$xpm->{"height"};
    
    
    $copy{"gray"}=$xpm->{"gray"};
    
    my$ret=\%copy;
    bless $ret, "MGM::Xpm";
}

sub write{
    my($xpm,$black,$white,$quant,$transp)=@_;
    # easier than reading, but harder to do efficiently
    
    $transp=-1 if(!defined($transp));

    my$width=$xpm->{"width"};
    my$height=$xpm->{"height"};
    my$colors=0;
    my$type='c';
    
    my%entries;
    my$char=' ';
    my$buffer;
    my$out;
    
    my($br,$bg,$bb)=&rgb($black);
    my($wr,$wg,$wb)=&rgb($white);
    
    $wr=$wr-$br;
    $wg=$wg-$bg;
    $wb=$wb-$bb;
    
    for(my$i=0;$i<$height;$i++){
	my@g=unpack 'C*', substr $xpm->{"gray"}, $i*$width, $width;
	$buffer.="\",\n\"";
	
	for(my$j=0;$j<$width;$j++){
	    $buffer.=chr(int($g[$j]*($quant/255))+65);
	}	
    }
    
    $out="/* XPM */\nstatic char * mgm_xpm[] = {\n".
	"\"$width $height ".($quant+1)." 1";
    
    foreach $key (0..$quant){
	$c=chr($key+65);
	$out.="\",\n\"$c  $type ";
	if($key eq $transp){
	    $out.="None";
	}else{
	    
	    my$r=($key/$quant)*$wr+$br;
	    my$g=($key/$quant)*$wg+$bg;
	    my$b=($key/$quant)*$wb+$bb;
	    
	    my$val=$hex[$r].$hex[$g].$hex[$b];
	    
	    $out.="#$val";
	}
    }
    
    $out.=$buffer."\"};\n";
    $out;
}

sub new{
    my($width,$height,$val)=@_;
    
    $width=int($width);
    $height=int($height);

    my($red,$green,$blue)=MGM::Xpm::rgb($val);
    my$gray=chr($red*.3+$green*.5+$blue*.2);
    my%xpm;
    
    $xpm{"width"}=$width;
    $xpm{"height"}=$height;
    $xpm{"gray"}= ($gray) x ($width*$height);
    
    my$ret=\%xpm;
    bless $ret, "MGM::Xpm";
}

sub width{
    my$xpm=shift;
    $xpm->{"width"};
}

sub height{
    my$xpm=shift;
    $xpm->{"height"};
}

sub merge{
    my($to,$tox,$toy,$from,$x,$y,$w,$h)=@_;

    my$twidth=$to->{"width"};
    my$fwidth=$from->{"width"};

    $w=$twidth-$tox if($w+$tox>$twidth);
    $w=$fwidth-$x if($w+$x>$fwidth);
    
    for(my$i=0;$i<$h;$i++){
	substr($to->{"gray"}, $tox+($i+$toy)*$twidth, $w) =
	    substr $from->{"gray"}, $x+($i+$y)*$fwidth, $w;
    }
    $to;
}

sub rot90{
    my$xpm=shift;
    
    $w=$xpm->width;
    $h=$xpm->height;
    
    # build new grid
    my$gray;
    for(my$i=$w-1;$i>=0;$i--){
	for(my$j=0;$j<$h;$j++){
	    $gray.=substr $xpm->{"gray"}, $j*$w+$i, 1;
	}
    }
    $xpm->{"gray"}=$gray;
    $xpm->{"width"}=$h;
    $xpm->{"height"}=$w;
    $xpm;
}

sub reduceonex{
    my($w,$nw,$v)=@_;
    my$del=(1.0*$w)/($nw?$nw:1);
    my$prev=0;
    my$iprev=0;
    my$oldval=$v->[0];
    
    for(my$nx=0;$nx<$nw;$nx++){
	my$x=$del*($nx+1);
	my$ix=int($x);
	$x-=$ix;
	
	my$val=$oldval*(1-$prev);
	for(my$i=$iprev+1;$i<$ix;$i++){$val+=$v->[$i]};
	$oldval=$v->[$ix];
	$val+=$oldval*$x if($x>.0001);
	
	$v->[$nx]=$val/$del+.5;
	
	$prev=$x;
	$iprev=$ix;
    }
}

sub enlargeonex{
    my($w,$nw,$v)=@_;
    my$del=$w/$nw;
    my$prev=$w;
    my$iprev=$w-1;
    my$oldval=$v->[$w-1];
    for(my$nx=$nw-1;$nx>=0;$nx--){
	my$x=$del*($nx);
	my$ix=int($x);
	
	if($ix==$iprev){
	    $v->[$nx]=$v->[$ix];
	}else{
	    my$val=$oldval*($prev-$iprev);
	    $val+=($oldval=$v->[$ix])*(1-$x+$ix);
	    $v->[$nx]=$val/$del+.5;
	}
	$prev=$x;
	$iprev=$ix;
    }
}

sub reduceoney{
    my($w,$h,$nh,$vv)=@_;
    my$del=$h/$nh;
    my$prev=0;
    my$iprev=0;
    my@nv;
    $#nv=$w;
    for(my$ny=0;$ny<$nh;$ny++){
	my$y=$del*($ny+1);
	my$iy=int($y);

	# initial row 
	my$idel=(1-$prev+$iprev)/$del;
	my@v=unpack 'C*', substr $$vv, $iprev*$w, $w;
	for(my$x=0;$x<$w;$x++){$nv[$x]=$v[$x]*$idel+.5;}
	#intevening rows
	$iprev++;
	while($iprev<$iy){
	    @v=unpack 'C*', substr $$vv, $iprev*$w, $w;
	    for(my$x=0;$x<$w;$x++){$nv[$x]+=$v[$x]/$del;}
	    $iprev++;
	}
	# terminal row 
	$idel=($y-$iy)/$del;
	if($idel>.0001){
	    @v=unpack 'C*', substr $$vv, $iy*$w, $w;
	    for(my$x=0;$x<$w;$x++){$nv[$x]+=$v[$x]*$idel;}
	}
	$iprev=$iy;
	$prev=$y;

	substr($$vv, $ny*$w, $w)=pack 'C*', @nv[0..$w-1];
    }
}

sub enlargeoney{
    my($w,$h,$nh,$vv)=@_;
    my$del=$h/$nh;
    my$prev=$h;
    my$iprev=$h-1;
    my@nv;
    $#nv=$w;
    for(my$ny=$nh-1;$ny>=0;$ny--){
	my$y=$del*$ny;
	my$iy=int($y);
	
	if($iprev==$iy){
	    substr($$vv, $ny*$w, $w)=
		substr($$vv, $iprev*$w, $w);
	}else{
	    # initial row 
	    my$idel=($prev-$iprev)/$del;
	    @v=unpack 'C*', substr $$vv, $iprev*$w, $w;
	    for(my$x=0;$x<$w;$x++){$nv[$x]=$v[$x]*$idel;}
	    # terminal row 
	    $idel=(1-$y+$iy)/$del;
	    @v=unpack 'C*', substr $$vv, $iy*$w, $w;
	    for(my$x=0;$x<$w;$x++){$nv[$x]+=$v[$x]*$idel+.5;}
	    substr($$vv, $ny*$w, $w)=pack 'C*', @nv[0..$w-1];
	}
	$iprev=$iy;
	$prev=$y;
    }
}

sub scale{
    my($xpm,$nw,$nh)=@_;
    $nw=int($nw);
    $nh=int($nh);
    $w=$xpm->width;
    $h=$xpm->height;
    if($nw<$w){

	for(my$y=0;$y<$h;$y++){
	    my@temp=unpack 'C*', substr ($xpm->{"gray"}, $y*$w, $w);
	    &reduceonex($w,$nw,\@temp);
	    substr ($xpm->{"gray"}, $y*$nw, $nw) = pack 'C*', @temp[0..$nw-1]; 
	}
	$w=$nw;
	$xpm->{"width"}=$w;
    }
    
    if($nh<$h){
	&reduceoney($w,$h,$nh,\$xpm->{"gray"});
	$h=$nh;
	$xpm->{"height"}=$h;
    }
    
    if($nw>$w){
	substr($xpm->{"gray"}, $h*$w)= 'Xpm Xpm ' x ($h*($nw-$w)/8);
	for(my$y=$h-1;$y>=0;$y--){
	    my@temp=unpack 'C*', substr ($xpm->{"gray"}, $y*$w, $w);
	    &enlargeonex($w,$nw,\@temp);
	    substr ($xpm->{"gray"}, $y*$nw, $nw) = pack 'C*', @temp[0..$nw-1]; 
	}
	$w=$nw;
	$xpm->{"width"}=$w;
    }
    
    if($nh>$h){
	substr($xpm->{"gray"}, $h*$w)= 'Xpm Xpm ' x ($w*($nh-$h)/8);
	&enlargeoney($w,$h,$nh,\$xpm->{"gray"});
	$h=$nh;
	$xpm->{"height"}=$h;
    }

    $xpm;
}

sub getpixel{
    my($xpm,$x,$y)=@_;
    my$w=$xpm->{"width"};
    ord (substr ($xpm->{"gray"}, $y*$w+$x, 1));
}

package MGM::Font;

sub new{
    my($xpm)=@_;

    my%font;
    my$count=32;
    my$pos=0;

    $font{"bitmap"}=$xpm;
    $font{"height"}=$xpm->height-1;
    while($pos<$xpm->width){
	$font{"$count"}=$pos;
	# find the width
   
	while(++$pos<$xpm->width){
	    last if (!$xpm->getpixel($pos,0));
	}
	$font{($count)."w"}=$pos-$font{"$count"};
	$count++;
    }
    my$ref=\%font;
    bless $ref, "MGM::Font";
}

sub textsize{
    my($font,$text,$height)=@_;
    my$acc=0;
    my$pop;
    while($pop=ord chop($text)){
	$acc+=$font->{($pop)."w"};
    }

    if(!defined($height)){
	($acc,$font->{"height"});
    }else{
	(int($height/$font->{"height"}*$acc),$height);
    }
}   

my%textcache;

sub maketext{
    my($font,$text,$height,$widthlimit,$stretch,$rot90,$cache)=@_;

    my($bigw,$bigh);
    my$bigtext;
	
    if(!defined($textcache{$text})){

	# how big?
	($bigw,$bigh)=$font->textsize($text);

	# make a pixmap frame
	$bigtext=MGM::Xpm::new($bigw+2,$bigh+2,'#ffffff');
	$textcache{$text}=$bigtext if(defined($cache));
	
	# paste in characters
	my$pos=$bigw+1;
	while(my$pop=ord chop($text)){
	    my$w=$font->{($pop)."w"};
	    $pos-=$w;
	    $bigtext->merge($pos,1,$font->{"bitmap"},$font->{$pop},1,
			    $w,$bigh);
	}

    }else{
	$bigtext=$textcache{$text};
	$bigw=$bigtext->width;
	$bigh=$bigtext->height;
    }

    # scale it.  

    $width=int($height/$bigh*$bigw*$stretch+.9);
    $width=$widthlimit if (defined($widthlimit) && $width>$widthlimit);
    my$ret=$bigtext->copy;

    $ret->scale($width,$height);

    $ret->rot90 if ($rot90);
    $ret;
}

#$xpm=MGM::Xpm::read("/home/xiphmont/SnotfishCVS/mgm/lib/helvetica.xpm","#ffffff");
#$xpm->scale(200,31);
#$xpm->rot90;
#$m=MGM::Xpm::new(100,100,'#6542ee');
#$m->merge(2,2,$xpm,4,4,50,50);
#print $m->write('#161262','#ffffff','#ffffff');

1;