 |
|
| Science Forum Index » Fractals Science Forum » New Mathematica ColorFunction algorithm in a... |
|
Page 1 of 1 |
|
| Author |
Message |
| Roger Bagula... |
 Posted: Sat Oct 03, 2009 4:27 am |
|
|
|
Guest
|
http://www.flickr.com/photos/fractalmusic/3977234724/
New Mathematica ColorFunction algorithm in a Manedelbrot:
Clear[f,x,nz]
(*unitary entropy scale to constant*)
f[x_]=Exp[2.034595683218906257862054432 -
3.375606246451309569435876213 \
*Log[x]]
3D and plane*)
(* SQRT(x^2+y^2) limited measure*)
(*by R. L. BAGULA 1 Oct 2009© *)
numberOfz2ToEscape[z_] := Block[
{escapeCount, nz = N[z],nzold=0},
For[
escapeCount = 0,
(Sqrt[Re[nz]^2+Im[nz]^2] < 16) && (escapeCount < 256) && (Abs
[nz-nzold]>.5*10^(-3)),
nzold=nz;
nz=f[nz]+z;
++escapeCount
];
escapeCount
]
FractalPureM[{{ReMin_, ReMax_, ReSteps_},
{ImMin_, ImMax_, ImSteps_}}] : Table[
numberOfz2ToEscape[x + y I],
{y, ImMin, ImMax, (ImMax - ImMin)/ImSteps},
{x, ReMin, ReMax, (ReMax - ReMin)/ReSteps}
]
arraym=FractalPureM[{{-3,3,600},{-3,3,600}}];
gr=ListPlot3D[arraym, Mesh -> False,AspectRatio -> Automatic,Boxed-
[quote:cf57ef1d66]False, Axes->False];
[/quote:cf57ef1d66]
ListDensityPlot[arraym,
Mesh -> False,
AspectRatio -> Automatic,
ColorFunction->(If[Mod[128*#,#]==0,Hue[#-1/(#
+0.01)],Hue[\
1-#]]&),Frame->False,ImageSize\[Rule]800]
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 :http://
www.geocities.com/rlbagulatftn/Index.html
alternative email: rlbagula at (no spam) sbcglobal.net |
|
|
| Back to top |
|
|
|
| Roger Bagula... |
| Posted: Sat Oct 03, 2009 4:42 am |
|
|
|
Guest
|
Here is a color function algorithm I found by searching the net:
(*Fonction pour colorier des isocontours, exemple d'utilisation
typique :
ContourPlot[T[x, y], {x, -10, 10}, {y, -10, 10}, ColorFunction -> cf]
*)
(*http : // perso.ensem.inpl -
nancy.fr/Emmanuel.Plaut/mathematica/mycolorfunction.m*)
colortab = {{0, 0, 0.5625}, {0, 0, 0.625}, {0, 0, 0.6875}, {0, 0,
0.75}, {0, 0,
0.8125}, {0, 0, 0.875}, {0, 0, 0.9375}, {
0, 0, 1}, {0, 0.0625, 1}, {0, 0.125, 1}, {0, 0.1875, 1}, {0,
0.25, 1}, {
0, 0.3125, 1}, {0, 0.375, 1}, {0, 0.4375, 1}, {0, 0.5, 1}, {0,
0.5625, 1}, {0, 0.625, 1}, {0, 0.6875, 1}, {0, 0.75, 1}, {0,
0.8125, 1}, {0, 0.875, 1}, {0, 0.9375, 1}, {0, 1, 1}, {0.0625,
1, 1}, {0.125, 1, 0.9375}, {
0.1875, 1, 0.875}, {0.25, 1, 0.8125}, {0.3125, 1, 0.75},
{0.375,
1, 0.6875}, {0.4375, 1, 0.625}, {0.5, 1, 0.5625}, {
0.5625, 1, 0.5}, {0.625, 1, 0.4375}, {0.6875, 1, 0.375}, {0.75,
1, 0.3125}, {0.8125, 1, 0.25}, {0.875, 1, 0.1875}, {0.9375,
1, 0.125}, {1, 1, 0.0625}, {1,
1, 0}, {1, 0.9375, 0}, {1, 0.875, 0}, {1, 0.8125, 0}, {1, 0.75,
0}, {
1, 0.6875, 0}, {1, 0.625, 0}, {1,
0.5625, 0}, {1, 0.5, 0}, {1, 0.4375, 0}, {1, 0.375, 0}, {1,
0.3125, 0}, {
1, 0.25, 0}, {1, 0.1875, 0}, {1, 0.125, 0}, {1, 0.0625, 0}, {
1, 0, 0}, {0.9375, 0, 0}, {0.875, 0, 0}, {0.8125, 0, 0}, {
0.75, 0, 0}, {0.6875, 0, 0}, {0.625, 0, 0}, {0.5625, 0, 0}};
cf[l_] := Block[{niv, rgb}, niv = If[l < 1/64, 1, Ceiling[64 l]];
rgb = colortab[[niv]];
RGBColor[rgb[[1]], rgb[[2]], rgb[[3]]]];
ListDensityPlot[Log[1/Max[arraym] +
arraym], Mesh -> False, AspectRatio -> Automatic, ColorFunction -
[quote:2cd1cb7f74]
cf, ImageSize -> 600, Frame -> False][/quote:2cd1cb7f74] |
|
|
| Back to top |
|
|
|
|
|
All times are GMT - 5 Hours
The time now is Sun Nov 29, 2009 7:30 am
|
|