#======================================================================
#                    L I B C P T . P L 
#                    doc: Wed Nov 15 12:28:49 2000
#                    dlm: Mon May 14 21:29:00 2018
#                    (c) 2000 A.M. Thurnherr
#                    uE-Info: 75 58 NIL 0 0 72 2 2 4 NIL ofnI
#======================================================================

# HISTORY:
#	Nov 15, 2000: - created
#	May 29, 2001: - made bg/fg numeric
#	May 31, 2001: - removed dummy bg val from all arrays
#	Dec 12, 2001: - clarified format errors
#	Jun 21, 2004: - relaxed cpt file format restrictions
#			      - made cpt into a hash
#				  - totally re-written
#	Jun 25, 2004: - return good value if $z equal upper cpt table limit
#	Jun 28, 2004: - added default color model
#	Jun 30, 2004: - renamed from libGMT.pl to libCPT.pl
#	Dec  1, 2005: - BUG: roundoff error
#   Jul  1, 2006: - Version 3.3 [HISTORY]
#   Jul 24, 2006: - modified to use $PRACTICALLY_ZERONY
#	Aug 16, 2006: - BUG: last level was returned on value < first level
#	May  9, 2008: - adapted to GMT 4.3 (see also IMPLEMENTATION NOTES
#					in [mkCPT])
#	Mar 26, 2018: - BUG: fg colors could not be set?!?!?!?! (both F and B set bg color)
#				  - implemented color scaling for input files with rgb vals 0-1
#	May 14, 2016: - added input file check

#----------------------------------------------------------------------
# CPT File Parsing
#----------------------------------------------------------------------

# NB: %CPT structure assumes RGB --- if the color model is really HSV,
#	  field names are wrong.

# %CPT
#	levels				number of different color levels
#	color_model			RGB or HSV
#	@from_z				from values (z, RGB) for each level
#	@from_R
#	@from_G
#	@from_B
#	@to_z				to values (z, RGB) for each level
#	@to_R
#	@to_G
#	@to_B
#	bg_R				background vals
#	bg_G
#	bg_B
#	fg_R				foreground vals
#	fg_G
#	fg_B
#	nan_R				nan vals
#	nan_G
#	nan_B

sub readCPT($)
{
	my($f) = @_;
	my($flag,%CPT);

	for ($CPT{levels}=0; <$f>;) {
		$CPT{color_model} = $' if /^# COLOR_MODEL = /; chomp($CPT{color_model});
		s/#.*//;
		next if /^\s*$/;
		my(@f) = split;
		if ($f[0] eq 'B') {
			$CPT{bg_R} = $f[1]; $CPT{bg_G} = $f[2]; $CPT{bg_B} = $f[3];
		} elsif ($f[0] eq 'F') {
			$CPT{fg_R} = $f[1]; $CPT{fg_G} = $f[2]; $CPT{fg_B} = $f[3];
		} elsif ($f[0] eq 'N') {
			$CPT{nan_R} = $f[1]; $CPT{nan_G} = $f[2]; $CPT{nan_B} = $f[3];
		} else {
			croak("$0: format error - 7 fields expected on line: $_") unless ($#f >= 7);
			$CPT{from_z}[$CPT{levels}] = $f[0];
			$CPT{from_R}[$CPT{levels}] = $f[1];
			$CPT{from_G}[$CPT{levels}] = $f[2];
			$CPT{from_B}[$CPT{levels}] = $f[3];
			$CPT{to_z}[$CPT{levels}] = $f[4];
			$CPT{to_R}[$CPT{levels}] = $f[5];
			$CPT{to_G}[$CPT{levels}] = $f[6];
	        $CPT{to_B}[$CPT{levels}] = $f[7];
			$CPT{levels}++;
	    }
    }
    $CPT{color_model} = 'RGB' unless defined($CPT{color_model});
    croak("$0: color model $CPT{color_model} not implemented\n")
    	unless ($CPT{color_model} =~ '\+?[Rr][Gg][Bb]' || $CPT{color_model} =~ '\+?[Hh][Ss][Vv]');

	if ($CPT{from_R}[0]>=0 && $CPT{from_R}[0]<=1 &&								# colors in 0-1 range
		$CPT{from_G}[0]>=0 && $CPT{from_G}[0]<=1 &&
		$CPT{from_B}[0]>=0 && $CPT{from_B}[0]<=1 &&
    	$CPT{from_R}[$CPT{levels}-1]>=0 && $CPT{from_R}[$CPT{levels}-1]<=1 &&
		$CPT{from_G}[$CPT{levels}-1]>=0 && $CPT{from_G}[$CPT{levels}-1]<=1 &&
		$CPT{from_B}[$CPT{levels}-1]>=0 && $CPT{from_B}[$CPT{levels}-1]<=1) {
			$CPT{bg_R} = round(255 * $CPT{bg_R}); $CPT{bg_G} = round(255 * $CPT{bg_G}); $CPT{bg_B} = round(255 * $CPT{bg_B});
			$CPT{fg_R} = round(255 * $CPT{fg_R}); $CPT{fg_G} = round(255 * $CPT{fg_G}); $CPT{fg_B} = round(255 * $CPT{fg_B});
			$CPT{nan_R} = round(255 * $CPT{nan_R}); $CPT{nan_G} = round(255 * $CPT{nan_G}); $CPT{nan_B} = round(255 * $CPT{nan_B});
			for (my($i)=0; $i<$CPT{levels}; $i++) {
				$CPT{from_R}[$i] = round(255 * $CPT{from_R}[$i]);
				$CPT{from_G}[$i] = round(255 * $CPT{from_G}[$i]);
				$CPT{from_B}[$i] = round(255 * $CPT{from_B}[$i]);
				$CPT{to_R}[$i] = round(255 * $CPT{to_R}[$i]);
				$CPT{to_G}[$i] = round(255 * $CPT{to_G}[$i]);
				$CPT{to_B}[$i] = round(255 * $CPT{to_B}[$i]);
			}
	}

	return %CPT;
}
		
sub CPTlvl($%)
{
	my($z,%CPT) = @_;
	my($l);
	
	croak("$0: no valid CPT info\n")
		unless ($CPT{levels} > 0);

	return nan if isnan($z);

	for ($l=0; $l<$CPT{levels}; $l++) {
		return $l if ($CPT{from_z}[$l] <= $z && $z < $CPT{to_z}[$l]);
	}
	return $CPT{levels}-1
		if (abs($z-$CPT{to_z}[$CPT{levels}-1]) < $PRACTICALLY_ZERO);
	return -1 if ($z < $CPT{from_z}[0]);
	return $CPT{levels};
}

1;