(******************************************************************************) (* :Title: Color *) (* :Author: Jeff Olson *) (* :Summary: Provides definitions of basic colors, functions for dealing with color primatives, and functions for producing basic color charts. *) (* :Package Version: 1.0 *) (* :Copyright: *) (* :Context: JOlson`Color` *) (* :Category: Graphics *) (* :History: *) (* :Keywords: *) (* :Sources: *) (* :Warnings: *) (* :Mathematica Version: 4.0 *) (* :Limitations: *) (* :Discussion: *) (* :Requirements: Graphics`ArgColors`, Utilities`FilterOptions` *) (* :Examples: *) (******************************************************************************) (******************************************************************************) BeginPackage["JOlson`Color`", {"Graphics`ArgColors`"} ] Through[{Unprotect, ClearAll}[ CMYColor, ColorChart, ColorGradient, ColorParametricPlot3D, ColorPlot, ColorPlot3D, ColorPolarPlot, ColorQ, ColorWheel, Red, Green, Blue, Cyan, Magenta, Yellow, White, Black, LightRed, LightGreen, LightBlue, LightCyan, LightMagenta, LightYellow, DarkRed, DarkGreen, DarkBlue, DarkCyan, DarkMagenta, DarkYellow ]] CMYColor::usage = "CMYColor[cyan, magenta, yellow] gives a color in the CMY system." ColorChart::usage = "ColorChart[func] gives a color chart of the color-valued pure function given on the range 0 to 1. ColorChart[func, {min, max}] gives a color chart on the given range." ColorGradient::usage = "ColorGradient[{color1, color2,...}] returns an RGBColor pure function which can be used as an option value to ColorFunction->func. ColorGradient evenly spaces the colors on the range 0 to 1. ColorGradient[{{val1, color1},{val2, color2},...}] creates a ColorFunction explicitly specifying where each of the colors should lie." ColorPlot::usage = "ColorPlot[f[x, y], {x, xmin, xmax}, {y, ymin, ymax}]." ColorQ::usage = "ColorQ[col] gives True if col is a color directive, otherwise it gives False." If[Head[Black] === Symbol, Scan[(MessageName[#,"usage"] = ToString[#] <> " is a color directive.")&, {Red, Green, Blue, Cyan, Magenta, Yellow, White, Black} ]; Scan[(MessageName[#,"usage"] = ToString[#] <> " is a color directive.")&, Flatten[Composition[ToExpression, {"Light"<>#, "Dark"<>#}&, ToString]/@ {Red, Green, Blue, Cyan, Magenta, Yellow} ] ] ] ColorParametricPlot3D ColorPlot3D ColorPolorPlot ColorWheel (* messages *) ColorPlot::pptt = "Value of option `1` is not an integer >= 2 or a list of two such integers." (******************************************************************************) (******************************************************************************) Begin["`Private`"] Needs["Utilities`FilterOptions`"] (****************************************************************************** * auxiliary functions ******************************************************************************) xyfunc[val:{_, _}] := val xyfunc[val:_] := {val, val} goodPlotPoints[{gx_Integer, gy_Integer}] := (gx >= 2) && (gy >= 2) goodPlotPoints[_] := False safePlotPoints[given_, default_] := Module[{ppts}, ppts = xyfunc[PlotPoints /. given]; If[Not[goodPlotPoints[ppts]], Message[ColorPlot::pptt, given]; ppts = xyfunc[PlotPoints /. default] ]; ppts ] (****************************************************************************** * color directives ******************************************************************************) If[Head[Black] === Symbol, Scan[Set[Evaluate[#[[1]]], #[[2]]]&, { {Black, RGBColor[0, 0, 0]}, {Red, RGBColor[1, 0, 0]}, {Green, RGBColor[0, 1, 0]}, {Blue, RGBColor[0, 0, 1]}, {Cyan, RGBColor[0, 1, 1]}, {Magenta, RGBColor[1, 0, 1]}, {Yellow, RGBColor[1, 1, 0]}, {White, RGBColor[1, 1, 1]}, {LightRed, RGBColor[1, 1/2, 1/2]}, {LightGreen, RGBColor[1/2, 1, 1/2]}, {LightBlue, RGBColor[1/2, 1/2, 1]}, {LightCyan, RGBColor[1/2, 1, 1]}, {LightMagenta, RGBColor[1, 1/2, 1]}, {LightYellow, RGBColor[1, 1, 1/2]}, {DarkRed, RGBColor[1/2, 0, 0]}, {DarkGreen, RGBColor[0, 1/2, 0]}, {DarkBlue, RGBColor[0, 0, 1/2]}, {DarkCyan, RGBColor[0, 1/2, 1/2]}, {DarkMagenta, RGBColor[1/2, 0, 1/2]}, {DarkYellow, RGBColor[1/2, 1/2, 0]} }]] (****************************************************************************** * ColorQ ******************************************************************************) unitIntervalQ[x_] := FreeQ[IntervalMemberQ[Interval[{0, 1}], x], False] realQ[x_] := MatchQ[N[x], _Real | _Rational | _Integer] ColorQ[GrayLevel[x_]] := unitIntervalQ[x] ColorQ[RGBColor[r_, g_, b_]] := unitIntervalQ[{r, g, b}] ColorQ[CMYKColor[c_, m_, y_, k_]] := unitIntervalQ[{c, m, y, k}] ColorQ[Hue[h_]] := realQ[h] ColorQ[Hue[h_, s_, b_]] := realQ[h] && unitIntervalQ[{s, b}] ColorQ[_] := False (****************************************************************************** * ToColor ******************************************************************************) Unprotect[ToColor] ToColor[GrayLevel[x_], Hue] := Hue[0, 0, x] ToColor[RGBColor[r_, g_, b_] /; r == g == b, Hue] := Hue[0, 0, r] ToColor[RGBColor[r_, g_, b_] /; r >= g >= b, Hue] := Hue[(g - b)/(r - b)/6, (r - b)/r, r] ToColor[RGBColor[r_, g_, b_] /; g >= r >= b, Hue] := Hue[1/3 - (r - b)/(g - b)/6, (g - b)/g, g] ToColor[RGBColor[r_, g_, b_] /; g >= b >= r, Hue] := Hue[1/3 + (b - r)/(g - r)/6, (g - r)/g, g] ToColor[RGBColor[r_, g_, b_] /; b >= g >= r, Hue] := Hue[2/3 - (g - r)/(b - r)/6, (b - r)/b, b] ToColor[RGBColor[r_, g_, b_] /; b >= r >= g, Hue] := Hue[2/3 + (r - g)/(b - g)/6, (b - g)/b, b] ToColor[RGBColor[r_, g_, b_] /; r >= b >= g, Hue] := Hue[1 - (b - g)/(r - g)/6, (r - g)/r, r] ToColor[col_CMYKColor, Hue] := ToColor[ToColor[col, RGBColor], Hue] Protect[ToColor] (****************************************************************************** * ColorCircle ******************************************************************************) Unprotect[ColorCircle]; Clear[ColorCircle]; ColorCircle[h_] := Hue[h/(2 Pi)] ColorCircle[_, b_ /; b == 0] := Hue[0, 1, 0] ColorCircle[h_, b_] := Hue[h/(2 Pi), Min[1, 1/Abs[b]], Min[1, Abs[b]]] Protect[ColorCircle]; (****************************************************************************** * CMYColor ******************************************************************************) CMYColor[c_, m_, y_] := RGBColor[1 - c, 1 - m, 1 - y] (****************************************************************************** * ColorChart ******************************************************************************) ColorChart[f_] := ColorChart[f, {0, 1}] ColorChart[f_, {min_?NumericQ, max_?NumericQ}] := Module[{x, y}, ColorPlot[f[x], {x, min, max}, {y, 0, 1}, AspectRatio -> 1/10, Axes -> {True, False}, Frame -> False, Mesh -> False, PlotPoints -> 50 ] ] (****************************************************************************** * ColorGradient ******************************************************************************) ColorGradient[{col_?ColorQ}] := (col&) ColorGradient[x:{cols__?ColorQ}] := ColorGradient[Transpose[{Range[0, Length[x]-1]/(Length[x]-1), x}]] ColorGradient[x:{{_, _?ColorQ}..}] := Module[{newx, xvals, cols, res, redf, greenf, bluef}, newx = Sort[x, OrderedQ[{#1[[1]], #2[[1]]}]&]; If[newx[[1,1]] =!= 0, PrependTo[newx, {0, newx[[1,2]]}] ]; If[N[Last[newx][[1]]] =!= 1., AppendTo[newx, {1, Last[newx][[2]]}] ]; {xvals, cols} = Transpose[newx]; res = Transpose[{xvals, #}]& /@ Transpose[Apply[List, ToColor[#, RGBColor]& /@ cols, {1}]]; {redf, greenf, bluef} = Interpolation[#, InterpolationOrder->1]& /@ res; Evaluate[RGBColor[redf[#], greenf[#], bluef[#]]]& ] (****************************************************************************** * ColorPlot ******************************************************************************) Options[ColorPlot] = {AspectRatio -> 1, Axes -> False, AxesLabel -> None, AxesOrigin -> Automatic, AxesStyle -> Automatic, Background -> Automatic, ColorOutput -> Automatic, Compiled -> True, DefaultColor -> Automatic, Epilog -> {}, Frame -> True, FrameLabel -> None, FrameStyle -> Automatic, FrameTicks -> Automatic, ImageSize -> Automatic, Mesh -> True, MeshRange -> Automatic, MeshStyle -> Automatic, PlotLabel -> None, PlotPoints -> 15, PlotRange -> Automatic, PlotRegion -> Automatic, Prolog -> {}, RotateLabel -> True, Ticks -> Automatic, DefaultFont :> $DefaultFont, DisplayFunction :> $DisplayFunction, FormatType :> $FormatType, TextStyle :> $TextStyle}; SetAttributes[ColorPlot, HoldFirst]; ColorPlot[f_, {x_, xMin_, xMax_}, {y_, yMin_, yMax_}, opts___?OptionQ] := Module[ {fullopts, plotpoints, xpp, ypp, dx, dy, intOpts}, fullopts = Flatten[{opts, Options[ColorPlot]}]; (* determine increments *) plotpoints = safePlotPoints[ First[Options[fullopts, PlotPoints]], First[Options[ColorPlot, PlotPoints]] ]; dx = N[xMax - xMin] / (plotpoints[[1]] - 1); dy = N[yMax - yMin] / (plotpoints[[2]] - 1); Show[Graphics[ RasterArray[ Table[f, {y, yMin, yMax, dy}, {x, xMin, xMax, dx}], {{xMin, yMin}, {xMax, yMax}} ], FilterOptions[Graphics, fullopts] ]] ] /; FreeQ[NumericQ /@ {xMin, xMax, yMin, yMax}, False] End[ ] (******************************************************************************) (******************************************************************************) Protect[ CMYColor, ColorChart, ColorGradient, ColorParametricPlot3D, ColorPlot, ColorPlot3D, ColorPolarPlot, ColorQ, ColorWheel, Red, Green, Blue, Cyan, Magenta, Yellow, White, Black, LightRed, LightGreen, LightBlue, LightCyan, LightMagenta, LightYellow, DarkRed, DarkGreen, DarkBlue, DarkCyan, DarkMagenta, DarkYellow ] EndPackage[ ] (******************************************************************************) (******************************************************************************)