C*********************************************************************** C Module: cmap3.f C C Copyright (C) 1996 Harold Youngren, Mark Drela C C This program is free software; you can redistribute it and/or modify C it under the terms of the GNU General Public License as published by C the Free Software Foundation; either version 2 of the License, or C (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program; if not, write to the Free Software C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. C C Report problems to: guppy@maine.com C or drela@mit.edu C*********************************************************************** program cmap3 c--------------------------------------------------------------- c Color selection program. c c Displays a 2-D slice through the R-G-B color space, c and gives the R,G,B components of a mouse-selected color. c c The cutting plane is perpendicular to the diagonal c axis running from R,G,B = 0,0,0 (black), to c R,G,B = 1,1,1 (white). The position of this cutting c plane is specified by the % saturation 0..300. c The plane passes through one or three pure-color c corners for the specific saturations shown. c c 0% (0 0 0) black c 100% (1 0 0), (0 1 0), (0 0 1) red , green , blue c 200% (1 1 0), (1 0 1), (0 1 1) yellow, magenta, cyan c 300% (1 1 1) white c c For 0-100% and 200-300%, the cutting plane is a triangle. c For 100-200%, the plane is a hexagon. c c--------------------------------------------------------------- c dimension x(4), y(4) logical lok character*1 chkey c ch = 0.03 call PLINITIALIZE c 1 continue c write(*,1100) 1100 format(/' Enter % saturation (0..300) : ', $) read (*,*) isat c if(isat.eq.0) go to 500 c isat = max( 1,isat) isat = min(299,isat) c nc1 = 10 c nc = nc1 if(isat.gt.100) nc = (nc1*isat)/ 100 if(isat.gt.200) nc = (nc1*200 )/(300-isat) + 1 c sat = float(isat) / 100.0 c c c---- R,G,B unit vectors for projection onto x-y cutting plane xr = -sat yr = -sat/sqrt(3.0) c xg = 0.0 yg = sat*2.0/sqrt(3.0) c xb = sat yb = -sat/sqrt(3.0) c call COLORMAPDEFAULT c call PLOPEN(0.8,0,1) c call PLOT(5.5, 4.25, -3) call NEWFACTOR(3.0) c c area = sat * 2.0*sqrt(3.0) c xdel = sat* 2.0 /float(nc) ydel = sat*sqrt(3.0)/float(nc) c do 10 j = 1, nc y0 = yr + ydel*float(j-1) c do 105 i = 1, nc-j+1 x0 = xr + xdel*(float(i-1) + 0.5*float(j-1)) c xx = x0 + 0.5*xdel yy = y0 + ydel/3.0 c r = ((xg-xb)*(yy-yb) - (yg-yb)*(xx-xb))/area g = ((xb-xr)*(yy-yr) - (yb-yr)*(xx-xr))/area b = ((xr-xg)*(yy-yg) - (yr-yg)*(xx-xg))/area c ir = int(256.0*r) ig = int(256.0*g) ib = int(256.0*b) c if( lok(ir,ig,ib) ) then x(1) = x0 y(1) = y0 x(2) = x0 + xdel y(2) = y0 x(3) = x0 + xdel*0.5 y(3) = y0 + ydel x(4) = x0 y(4) = y0 n = 4 c call NEWCOLORRGB(ir,ig,ib) call POLYLINE(x,y,n,1) endif c c if(i.eq.nc-j+1) go to 105 xx = x0 + xdel yy = y0 + 2.0*ydel/3.0 c r = ((xg-xb)*(yy-yb) - (yg-yb)*(xx-xb))/area g = ((xb-xr)*(yy-yr) - (yb-yr)*(xx-xr))/area b = ((xr-xg)*(yy-yg) - (yr-yg)*(xx-xg))/area c ir = int(256.0*r) ig = int(256.0*g) ib = int(256.0*b) c if( lok(ir,ig,ib) ) then x(1) = x0 + xdel y(1) = y0 x(2) = x0 + xdel*1.5 y(2) = y0 + ydel x(3) = x0 + xdel*0.5 y(3) = y0 + ydel x(4) = x0 + xdel y(4) = y0 n = 4 c call NEWCOLORRGB(ir,ig,ib) call POLYLINE(x,y,n,1) endif c 105 continue 10 continue c call PLFLUSH c write(*,*) 'Click on colors...' C 200 call GETCURSORXY(xx,yy,chkey) c r = ((xg-xb)*(yy-yb) - (yg-yb)*(xx-xb))/area g = ((xb-xr)*(yy-yr) - (yb-yr)*(xx-xr))/area b = ((xr-xg)*(yy-yg) - (yr-yg)*(xx-xg))/area c ir = int(256.0*r) ig = int(256.0*g) ib = int(256.0*b) c write(*,1500) ir, ig, ib 1500 format(1x,'R G B = ', i4,',',i4,',',i4) c if( lok(ir,ig,ib) ) then go to 200 endif c go to 1 c 500 call PLOT(0.0,0.0,+999) stop C end logical function lok(ir,ig,ib) lok = ir.LE.255 .AND. ig.LE.255 .AND. ib.LE.255 .AND. & ir.GE.0 .AND. ig.GE.0 .AND. ib.GE.0 return end