#!/usr/bin/perl -w # RCSid $Id: falsecolor.pl,v 2.15 2020/01/04 16:39:10 greg Exp $ use warnings; use strict; use File::Temp qw/ tempdir /; use POSIX qw/ floor /; my @palettes = ('def', 'spec', 'pm3d', 'hot', 'eco', 'tbo'); my $mult = 179.0; # Multiplier. Default W/sr/m2 -> cd/m2 my $label = 'cd/m2'; # Units shown in legend my $scale = 1000; # Top of the scale my $scaledigits = 3; # Number of maximum digits for numbers in legend my $decades = 0; # Default is linear mapping my $pal = 'def'; # Palette my $redv = "${pal}_red(v)"; # Mapping functions for R,G,B my $grnv = "${pal}_grn(v)"; my $bluv = "${pal}_blu(v)"; my $ndivs = 8; # Number of lines in legend my $picture = '-'; my $cpict = ''; my $legwidth = 100; # Legend width and height my $legheight = 200; my $haszero = 1; # print 0 in scale for falsecolor images only my $docont = ''; # Contours: -cl and -cb my $doposter = 0; # Posterization: -cp my $doextrem = 0; # Don't mark extrema my $needfile = 0; my $showpal = 0; # Show availabel colour palettes while ($#ARGV >= 0) { $_ = shift; # Options with qualifiers if (m/-lw/) { # Legend width $legwidth = shift; } elsif (m/-lh/) { # Legend height $legheight = shift; } elsif (m/-m/) { # Multiplier $mult = shift; } elsif (m/-spec/) { die("depricated option '-spec'. Please use '-pal spec' instead."); } elsif (m/-s/) { # Scale $scale = shift; if ($scale =~ m/[aA].*/) { $needfile = 1; } } elsif (m/-d/) { # Number of maximum digits for numbers in legend $scaledigits = shift; } elsif (m/-l$/) { # Label $label = shift; } elsif (m/-log/) { # Logarithmic mapping $decades = shift; } elsif (m/-r/) { # Custom palette functions for R,G,B $redv = shift; } elsif (m/-g/) { $grnv = shift; } elsif (m/-b/) { $bluv = shift; } elsif (m/-pal$/) { # Color palette $pal = shift; if (! grep $_ eq $pal, @palettes) { die("invalid palette '$pal'.\n"); } $redv = "${pal}_red(v)"; $grnv = "${pal}_grn(v)"; $bluv = "${pal}_blu(v)"; } elsif (m/-i$/) { # Image for intensity mapping $picture = shift; } elsif (m/-p$/) { # Image for background $cpict = shift; } elsif (m/-ip/ || m/-pi/) { $picture = shift; $cpict = $picture; } elsif (m/-n/) { # Number of contour lines $ndivs = shift; # Switches } elsif (m/-cl/) { # Contour lines $docont = 'a'; $haszero = 0; } elsif (m/-cb/) { # Contour bands $docont = 'b'; $haszero = 0; } elsif (m/-cp/) { # Posterize $doposter = 1; $haszero = 0; } elsif (m/-palettes/) { # Show all available palettes $scale = 45824; # 256 * 179 $showpal = 1; } elsif (m/-e/) { $doextrem = 1; $needfile = 1; # Oops! Illegal option } else { die("bad option \"$_\"\n"); } } if (($legwidth <= 20) || ($legheight <= 40)) { # Legend is too small to be legible. Don't bother doing one. $legwidth = 0; $legheight = 0; } # Temporary directory. Will be removed upon successful program exit. my $td = tempdir( CLEANUP => 1 ); if ($needfile == 1 && $picture eq '-') { # Pretend that $td/stdin.rad is the actual filename. $picture = "$td/stdin.hdr"; open(FHpic, ">$picture") or die("Unable to write to file $picture\n"); # Input is from STDIN: Capture to file. while (<>) { print FHpic; } close(FHpic); if ($cpict eq '-') { $cpict = "$td/stdin.hdr"; } } # Find a good scale for auto mode. if ($scale =~ m/[aA].*/) { my @histo = split(/\s/, `phisto $picture|`); # e.g. $ phisto tests/richmond.hdr| tail -2 # 3.91267 14 # 3.94282 6 my $LogLmax = $histo[-4]; $scale = $mult / 179 * 10**$LogLmax; } if ($docont ne '') { # -cl -> $docont = a # -cb -> $docont = b my $newv = join( "(v-1/ndivs)*ndivs/(ndivs-1)", split("v", $redv) ); $redv = $newv; $newv = join( "(v-1/ndivs)*ndivs/(ndivs-1)", split("v", $bluv) ); $bluv = $newv; $newv = join( "(v-1/ndivs)*ndivs/(ndivs-1)", split("v", $grnv) ); $grnv = $newv; } elsif ($doposter == 1) { # -cp -> $doposter = 1 my $newv = join( "seg2(v)", split("v", $redv) ); $redv = $newv; $newv = join( "seg2(v)", split("v", $bluv) ); $bluv = $newv; $newv = join( "seg2(v)", split("v", $grnv) ); $grnv = $newv; } my $pc0 = "$td/pc0.cal"; open(FHpc0, ">$pc0"); print FHpc0 <$pc1"); print FHpc1 < $lbimg"; my $cmd = qq[pcomb $pc0args -e "v=x/256"]; $cmd .= qq[ -e "ro=clip(${pal}_red(v));go=clip(${pal}_grn(v));bo=clip(${pal}_blu(v))"]; $cmd .= qq[ -x 256 -y 30 > $fcimg]; system "$cmd"; $pc .= " $fcimg $lbimg"; } system "$pc"; exit 0; } # Contours if ($docont ne '') { # -cl -> $docont = a # -cb -> $docont = b $pc0args .= qq[ -e "in=iscont$docont"]; } if ($cpict eq '') { $pc1args .= qq[ -e "ra=0;ga=0;ba=0"]; } elsif ($cpict eq $picture) { $cpict = ''; } # Logarithmic mapping if ($decades > 0) { $pc1args .= qq[ -e "map(x)=if(x-10^-$decades,log10(x)/$decades+1,0)"]; } # Colours in the legend my $scolpic = "$td/scol.hdr"; # Labels in the legend my $slabpic = "$td/slab.hdr"; my $cmd; if ($legwidth > 0) { # Legend: Create the text labels my $sheight = floor($legheight / $ndivs ); my $theight = floor($legwidth/(8/1.67)); my $stheight = $sheight <= $theight ? $sheight : $theight; my $vlegheight = $sheight * $ndivs * (1+1.5/$ndivs); my $text = "$label\n"; my $tslabpic = "$td/slabT.hdr"; open PSIGN, "| psign -s -.15 -cf 1 1 1 -cb 0 0 0 -h $stheight > $tslabpic"; print PSIGN "$text"; close PSIGN; my $loop = $ndivs+$haszero; my $hlegheight = $sheight * ($loop) + $sheight * .5; my $pcompost = qq[pcompos -b 0 0 0 =-0 $tslabpic 0 $hlegheight ]; for (my $i=0; $i<$loop; $i++) { my $imap = ($ndivs - $i) / $ndivs; my $value = $scale; if ($decades > 0) { $value *= 10**(($imap - 1) * $decades); } else { $value *= $imap; } # Have no more than 3 decimal places $value =~ s/(\.[0-9]{$scaledigits})[0-9]*/$1/; $text = "$value\n"; $tslabpic = "$td/slab$i.hdr"; open PSIGN, "| psign -s -.15 -cf 1 1 1 -cb 0 0 0 -h $stheight > $tslabpic"; print PSIGN "$text"; close PSIGN; $hlegheight = $sheight * ($loop - $i - 1) + $sheight * .5; $pcompost .= qq[=-0 $tslabpic 0 $hlegheight ]; } $pcompost .= qq[ > $slabpic]; system $pcompost; # Legend: Create the background colours $cmd = qq[pcomb $pc0args]; $cmd .= qq[ -x $legwidth -y $vlegheight]; $cmd .= qq[ -e "v=(y+.5-$sheight)/(yres/(1+1.5/$ndivs));vleft=v;vright=v"]; $cmd .= qq[ -e "vbelow=(y-.5-$sheight)/(yres/(1+1.5/$ndivs));vabove=(y+1.5-$sheight)/(yres/(1+1.5/$ndivs))"]; $cmd .= qq[ -e "ra=0;ga=0;ba=0;"]; $cmd .= qq[ > $scolpic]; system $cmd; } else { # Create dummy colour scale and legend labels so we don't # need to change the final command line. open(FHscolpic, ">$scolpic"); print FHscolpic "\n-Y 1 +X 1\naaa\n"; close(FHscolpic); open(FHslabpic, ">$slabpic"); print FHslabpic "\n-Y 1 +X 1\naaa\n"; close(FHslabpic); } # Legend: Invert the text labels (for dropshadow) my $slabinvpic = "$td/slabinv.hdr"; $cmd = qq[pcomb -e "lo=1-gi(1)" $slabpic > $slabinvpic]; system $cmd; my $sh0 = -floor($legheight / $ndivs / 2); if ($haszero < 1) { $sh0 = -floor($legheight / ($ndivs)*1.5); } # Command line without extrema $cmd = qq[pcomb $pc0args $pc1args "$picture"]; $cmd .= qq[ "$cpict"] if ($cpict); $cmd .= qq[ | pcompos -b 0 0 0 $scolpic 0 $sh0 +t .1 $slabinvpic 2 -1 ]; $cmd .= qq[ -t .5 $slabpic 0 0 - $legwidth 0]; if ($doextrem == 1) { # Get min/max image luminance my $cmd1 = 'pextrem -o ' . $picture; my $retval = `$cmd1`; # e.g. # x y r g b # 193 207 3.070068e-02 3.118896e-02 1.995850e-02 # 211 202 1.292969e+00 1.308594e+00 1.300781e+00 my @extrema = split(/\s/, $retval); my ($lxmin, $ymin, $rmin, $gmin, $bmin, $lxmax, $ymax, $rmax, $gmax, $bmax) = @extrema; $lxmin += $legwidth; $lxmax += $legwidth; # Weighted average of R,G,B my $minpos = "$lxmin $ymin"; my $minval = ($rmin * .27 + $gmin * .67 + $bmin * .06) * $mult; $minval =~ s/(\.[0-9]{$scaledigits})[0-9]*/$1/; my $maxval = ($rmax * .27 + $gmax * .67 + $bmax * .06) * $mult; $maxval =~ s/(\.[0-9]{$scaledigits})[0-9]*/$1/; # Create the labels for min/max intensity my $minvpic = "$td/minv.hdr"; system "psign -s -.15 -a 2 -h 16 $minval > $minvpic"; my $maxvpic = "$td/maxv.hdr"; system "psign -s -.15 -a 2 -h 16 $maxval > $maxvpic"; # Add extrema labels to command line $cmd .= qq[ $minvpic $minpos $maxvpic $lxmax $ymax]; } # Process image and combine with legend system "$cmd"; #EOF