DIRECTORY Atom, Checksum, G3dMappedAndSolidTexture, G3dMatrix, G3dRender, Real, RealFns;
ShadingProcs: CEDAR PROGRAM
IMPORTS Atom, Checksum, G3dMappedAndSolidTexture, G3dMatrix, Real, RealFns

~ BEGIN

RGB: 				TYPE ~ G3dRender.RGB;
Matrix:			TYPE ~ G3dRender.Matrix;
RealSequence:	TYPE ~ G3dRender.RealSequence;
SpotProc:			TYPE ~ G3dRender.SpotProc;
Shape:			TYPE ~ G3dRender.Shape;
ShadingClass:	TYPE ~ G3dRender.ShadingClass;

GetProp: PROC [propList: Atom.PropList, prop: REF ANY] RETURNS [REF ANY] ~
																				 Atom.GetPropFromList;
																				 
Sqr: PROCEDURE [number: REAL] RETURNS [REAL] ~ INLINE { RETURN[number * number]; };

Log2: PROC [n: INT] RETURNS [lg: NAT _ 0] ~ {-- finds log base 2 of input (from M. Plass)
nn: CARD32 ~ n;
k: CARD32 _ 1;
UNTIL k=0 OR k>= nn DO
lg _ lg + 1;
k _ k + k;
ENDLOOP;
};

RegisterEverything: PROC[] ~ {
G3dMappedAndSolidTexture.RegisterTextureFunction[ $GreenSpotsAMoving,
																				 GreenSpotsAMoving ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $GreenSpots, GreenSpots ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $ChecksAMoving, ChecksAMoving ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $Checks, Checks ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $Swirl, Swirl ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $Segue, Segue ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $Crack, Crack ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $BurlWood, BurlWood ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $PartialBurl, PartialBurl ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $ZebraBurlAMoving,
																				 ZebraBurlAMoving ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $ZebraBurl, ZebraBurl ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $Marble, Marble ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $TestNoise, TestNoise ];
G3dMappedAndSolidTexture.RegisterTextureFunction[ $TestOneOverFNoise,
																				 TestOneOverFNoise ];
};

GreenSpotsAMoving: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
xfm: Matrix _ NARROW[ GetProp[NARROW[data], $Shape], Shape].matrix ;
[[spot.val[x], spot.val[y], spot.val[z]]] _ G3dMatrix.Transform[ 
[spot.val[x], spot.val[y], spot.val[z]], xfm
];
GreenSpots[context, shading, spot];
};

GreenSpots: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
transmittance, intensity: REAL _ RealFns.Sin[10.0 * spot.val[x] ] 
				  * RealFns.Sin[14.0 * spot.val[y] ]
				  * RealFns.Sin[20.0 * spot.val[z] ];
intensity _ (intensity + 1.0) / 2.0;
transmittance _ intensity _ (1.0 - intensity);
spot.val[r] _ intensity + transmittance * (spot.val[r] - intensity);
spot.val[g] _ 1.0 + transmittance * (spot.val[g] - 1.0); 							-- leave green
spot.val[b] _ intensity + transmittance * (spot.val[b] - intensity);
spot.val[t] _ spot.val[t] * transmittance;
};

ChecksAMoving: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
xfm: Matrix _ NARROW[ GetProp[NARROW[data], $Shape], Shape].matrix ;
[[spot.val[x], spot.val[y], spot.val[z]]] _ G3dMatrix.Transform[ 
[spot.val[x], spot.val[y], spot.val[z]], xfm
];
Checks[context, shading, spot];
};

Checks: SpotProc ~ {
newClr: RGB _ [0.4, 0.9, 0.2];										-- sort of lightish green
otherClr: RGB _ [0.9, 0.2, 0.2];										-- sort of very red
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;
chooseNewClr: BOOLEAN;
intensityX: BOOLEAN _ ABS[Real.Fix[8.0 * spot.val[x] ] MOD 2] = 1;		-- vary in x
intensityY: BOOLEAN _ ABS[Real.Fix[8.0 * spot.val[y] ] MOD 2] = 1;		-- vary in y
intensityZ: BOOLEAN _ ABS[Real.Fix[8.0 * spot.val[z] ] MOD 2] = 1;		-- vary in z

IF spot.val[x] < 0.0 THEN intensityX _ NOT intensityX;		-- correct for negative MOD
IF spot.val[y] < 0.0 THEN intensityY _ NOT intensityY;
IF spot.val[z] < 0.0 THEN intensityZ _ NOT intensityZ;
chooseNewClr _ (intensityX # intensityY) # intensityZ;		 -- parity (XOR) fn.

IF chooseNewClr 
THEN {		-- new color 
spot.val[r] _  newClr.R * spot.val[r];
spot.val[g] _  newClr.G * spot.val[g];
spot.val[b] _  newClr.B * spot.val[b];
}
ELSE {		-- other color 
spot.val[r] _  otherClr.R * spot.val[r];
spot.val[g] _  otherClr.G * spot.val[g];
spot.val[b] _  otherClr.B * spot.val[b];
};
};

Swirl: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;
intensity: REAL _ RealFns.Sin[Swirler[ spot.val[x],
											spot.val[y],
											spot.val[z] ]*30 + 10*spot.val[z]];
intensity _ (intensity + 1.0) / 2.0;
intensity _ RealFns.Power[intensity, 0.77];
spot.val[r] _ spot.val[r] * intensity;
spot.val[g] _ spot.val[g] * intensity;
spot.val[b] _ spot.val[b] * intensity;
};

Segue: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;
intensity: REAL _ RealFns.Sin[SCVary[
spot.val[x],
spot.val[y],
spot.val[z], 
(spot.val[z] + 1.) / 2]*30 + 10*spot.val[x]
];
intensity _ (intensity + 1.0) / 2.0;
intensity _ RealFns.Power[intensity, 0.77];
spot.val[r] _ spot.val[r] * intensity;
spot.val[g] _ spot.val[g] * intensity;
spot.val[b] _ spot.val[b] * intensity;
};

Crack: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
intensity: REAL;
IF RealFns.Cos[
SimpleOneOverFNoise[spot.val[x], spot.val[y], spot.val[z] ]*10 + 3*spot.val[z]
] > 0. THEN
intensity _ 0. ELSE intensity _ 1.;
spot.val[r] _ spot.val[r] * intensity;
spot.val[g] _ spot.val[g] * intensity;
spot.val[b] _ spot.val[b] * intensity;
};

BurlWood: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
red, grn, blu: REAL;
chaos: REAL _ OneOverFNoise[  spot.val[x], spot.val[y], spot.val[z] ];
midBrown: REAL _ RealFns.Sin[ chaos*8 + 7*spot.val[x]  + 3* spot.val[y] ];
brownLayer: REAL _ ABS[ RealFns.Sin[midBrown] ];
greenLayer: REAL _ - brownLayer;

perturb: REAL _ IF brownLayer > 0.0 
THEN ABS[RealFns.Sin[40 * chaos + 50*spot.val[z] ]]
ELSE ABS[RealFns.Sin[30 * chaos + 30*spot.val[x] ]];
brownPerturb: REAL _ perturb * .6 + .3;		-- perturb up to .6
greenPerturb: REAL _ perturb * .2 + .8;		-- perturb up to .2
grnPerturb: REAL _ perturb * .15 + .85;		-- perturb up to .15

grn _ .5 * RealFns.Power[ABS[brownLayer], 0.3];	-- makes seams

brownLayer _ RealFns.Power[(brownLayer + 1.0) / 2.0, 0.6] * brownPerturb;
greenLayer _ RealFns.Power[(greenLayer + 1.0) / 2.0, 0.6] * greenPerturb;
red _ (.6 * brownLayer + .35 * greenLayer) * 2 * grn; 
blu  _ (.25 * brownLayer + .35 * greenLayer) * 2 * grn;
grn _ grn * MAX[brownLayer, greenLayer] * grnPerturb;

spot.val[r] _ spot.val[r] * red;
spot.val[g] _ spot.val[g] * grn;
spot.val[b] _ spot.val[b] * blu;
};

PartialBurl: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
red, grn, blu: REAL;
transmittance: REAL;
radius: REAL _ ( spot.xIncr[x] + spot.xIncr[y] + spot.xIncr[z] 
				+ spot.yIncr[x] + spot.yIncr[y] + spot.yIncr[z] ) / 2.0; 
chaos: REAL _ OneOverFNoise[  spot.val[x], spot.val[y], spot.val[z], radius ];
midBrown: REAL _ RealFns.Sin[ chaos*8 + 7*spot.val[x]  + 3* spot.val[y] ];
brownLayer: REAL _ RealFns.Sin[midBrown];

IF brownLayer > 0.0 THEN {
brownPerturb, greenPerturb, grnPerturb: REAL;
greenLayer: REAL _ - brownLayer;
perturb: REAL _ ABS[RealFns.Sin[40 * chaos + 50*spot.val[z] ]];
IF radius < 1.0/64.0  THEN { 
a: REAL _ MAX[0.4, 64.0*radius]; -- blend with undertexture when < 1/64
perturb _ perturb * (a + (1.0-a)*ABS[RealFns.Sin[40*chaos + 150*spot.val[x]]])
};
IF radius < 1.0/256.0  THEN { 
a: REAL _ 256.0 * MAX[0.0, 2*(radius-1.0/768.0)]; -- blend with undertexture when < 1/256
perturb _ perturb * (a + (1.0-a)*ABS[RealFns.Sin[900*chaos + 900*spot.val[x]]])
};
IF radius < 1.0/1024.0  THEN { 
a: REAL _ MAX[0.5, 1024.0*radius];	-- blend undertexture when < 1/1024
adjust: REAL _ RealFns.Sin[25000*chaos + 25000*spot.val[z]];
IF adjust > 0.0
THEN perturb _ a * perturb  + (1.0-a) * (perturb + (1.0 - perturb)*adjust)
ELSE perturb _ a * perturb  + (1.0-a) * (perturb + perturb*adjust);
};

brownPerturb _ perturb * .6 + .3;		-- perturb up to .6
greenPerturb _ perturb * .2 + .8;		-- perturb up to .2
grnPerturb _ perturb * .15 + .85;		-- perturb up to .15

grn _ .5 * RealFns.Power[ABS[brownLayer], 0.3];	-- makes seams

brownLayer _ RealFns.Power[(brownLayer + 1.0) / 2.0, 0.6] * brownPerturb;
greenLayer _ RealFns.Power[(greenLayer + 1.0) / 2.0, 0.6] * greenPerturb;
red _ (.6 * brownLayer + .35 * greenLayer) * 2 * grn; 
blu  _ (.25 * brownLayer + .35 * greenLayer) * 2 * grn;
grn _ grn * MAX[brownLayer, greenLayer] * grnPerturb;

transmittance _ MAX[0.0, 4.0 * (.25 - brownLayer)];  -- blend where brownLayer < .25
spot.val[r] _ red + transmittance * (spot.val[r] - red);
spot.val[g] _ grn + transmittance * (spot.val[g] - grn);
spot.val[b] _ blu + transmittance * (spot.val[b] - blu);
spot.val[t] _ spot.val[t] * transmittance;
spot.partShiny _ spot.partShiny * transmittance;				-- no hilite, dull texture
};
};

ZebraBurlAMoving: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
xfm: Matrix _ NARROW[ GetProp[NARROW[data], $Shape], Shape].matrix ;
[[spot.val[x], spot.val[y], spot.val[z]]] _ G3dMatrix.Transform[ 
[spot.val[x], spot.val[y], spot.val[z]], xfm
];
ZebraBurl[context, shading, spot];
};

ZebraBurl: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
red, grn, blu, brownPerturb, greenPerturb, grnPerturb: REAL;
radius: REAL _ ( ABS[spot.xIncr[x]] + ABS[spot.xIncr[y]] + ABS[spot.xIncr[z]] 
				+ ABS[spot.yIncr[x]] + ABS[spot.yIncr[y]] + ABS[spot.yIncr[z]] ) / 2.0; 
chaos: REAL _ OneOverFNoise[  spot.val[x]-.5, spot.val[y], spot.val[z], 40*radius ];
midBrown: REAL _ RealFns.Sin[ chaos*8 + 7*spot.val[x]  + 3* spot.val[y] ];
brownLayer: REAL _ RealFns.Sin[midBrown];
greenLayer: REAL _ - brownLayer;

perturb: REAL _ IF brownLayer > 0.0 		-- should be integrated when radius large
THEN ABS[RealFns.Sin[40 * chaos + 50*spot.val[z] ]]
ELSE ABS[RealFns.Sin[24 * chaos + 30*spot.val[x] ]];

IF radius < 1.0/64.0  THEN { 
a: REAL _ MAX[0.4, 64.0*radius]; -- blend with undertexture when < 1/64
IF brownLayer > 0.0
THEN perturb _ perturb * (a + (1.0-a)*ABS[RealFns.Sin[40*chaos + 150*spot.val[x]]])
ELSE perturb _ perturb * (a + (1.0-a)*ABS[RealFns.Sin[24*chaos + 90*spot.val[z]]]);
};

IF radius < 1.0/256.0  THEN { 
a: REAL _ 256.0 * MAX[0.0, 2*(radius-1.0/768.0)]; -- blend with undertexture when < 1/256
IF brownLayer > 0.0
THEN perturb _ perturb * (a + (1.0-a)*ABS[RealFns.Sin[900*chaos + 900*spot.val[x]]])
ELSE perturb _ perturb * (a + (1.0-a)*ABS[RealFns.Sin[900*chaos + 900*spot.val[z]]]);
};

IF radius < 1.0/1024.0  THEN { 
a: REAL _ MAX[0.5, 1024.0*radius];	-- blend undertexture when < 1/1024
adjust: REAL;
IF brownLayer > 0.0
THEN adjust _ RealFns.Sin[25000*chaos + 25000*spot.val[z]]
ELSE adjust _ RealFns.Sin[25000*chaos + 25000*spot.val[x]];
IF adjust > 0.0
THEN perturb _ a * perturb  + (1.0-a) * (perturb + (1.0 - perturb)*adjust)
ELSE perturb _ a * perturb  + (1.0-a) * (perturb + perturb*adjust);
};

brownPerturb _ perturb * .6 + .3;		-- perturb up to .6
greenPerturb _ perturb * .2 + .8;		-- perturb up to .2
grnPerturb _ perturb * .15 + .85;		-- perturb up to .15

grn _ .5 * RealFns.Power[ABS[brownLayer], 0.3];	-- makes seams

brownLayer _ RealFns.Power[(brownLayer + 1.0) / 2.0, 0.6] * brownPerturb;
greenLayer _ RealFns.Power[(greenLayer + 1.0) / 2.0, 0.6] * greenPerturb;
red _ (.6 * brownLayer + .35 * greenLayer) * 2 * grn; 
blu  _ (.25 * brownLayer + .35 * greenLayer) * 2 * grn;
grn _ grn * MAX[brownLayer, greenLayer] * grnPerturb;

spot.val[r] _ spot.val[r] * red;
spot.val[g] _ spot.val[g] * grn;
spot.val[b] _ spot.val[b] * blu;
};

Marble: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- object space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
intensity: REAL _ RealFns.Sin[OneOverFNoise[  spot.val[x],
											spot.val[y],
											spot.val[z] ]*8 + 7*spot.val[z]];
intensity _ (intensity + 1.0) / 2.0;
intensity _ RealFns.Power[intensity, 0.77];
spot.val[r] _ spot.val[r] * intensity;
spot.val[g] _ spot.val[g] * intensity;
spot.val[b] _ spot.val[b] * intensity;
};

mult: REAL _ 1.0;						-- multiplier for looking at noise at different scales

TestNoise: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- texture space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
intensity: REAL _ Noise[ mult*spot.val[x], mult*spot.val[y], mult*spot.val[z] ];
intensity _ (intensity + 1.0) / 2.0;
spot.val[r] _ spot.val[r] * intensity;
spot.val[g] _ spot.val[g] * intensity;
spot.val[b] _ spot.val[b] * intensity;
};

TestOneOverFNoise: SpotProc ~ {
x: NAT _ spot.val.length-3;    y: NAT _ x+1;    z: NAT _ x+2;	-- texture space coordinate
r: NAT ~ 0;    g: NAT ~ 1;    b: NAT ~ 2;    t: NAT ~ 3;
radius: REAL _ ( spot.xIncr[x] + spot.xIncr[y] + spot.xIncr[z] 
				+ spot.yIncr[x] + spot.yIncr[y] + spot.yIncr[z] ) / 2.0; 
intensity: REAL _ OneOverFNoise[ spot.val[x], spot.val[y], spot.val[z], radius ];
intensity _ (intensity + 1.0) / 2.0;
spot.val[r] _ spot.val[r] * intensity;
spot.val[g] _ spot.val[g] * intensity;
spot.val[b] _ spot.val[b] * intensity;
};

SCVary: PROC[x, y, z, p: REAL] RETURNS [REAL] ~ {
f: REAL _ 1.;
s, t: REAL _ 0.;
FOR n: INT IN [0..7) DO
s _ Noise[x * f, y * f,  z * f];
s _ RealFns.Power[s * s, (p + 1.) / 2];
t _ t + s / f;
f _ 2 * f;
ENDLOOP;
RETURN [t];
};

Swirler: PROC[x, y, z: REAL] RETURNS [REAL] ~ {
f: REAL _ 1.;
s, t: REAL _ 0.;
FOR n: INT IN [0..7) DO
s _ Noise[x * f, y * f,  z * f];
t _ t + s * s / f;
f _ 2 * f;
ENDLOOP;
RETURN [t];
};

noiseType: ATOM _ $Plain;
bulgeUp: BOOLEAN _ TRUE;		-- when true, summations use ABS and start from zero

OneOverFNoise: PROC[x, y, z: REAL, radius: REAL _ 0.006] RETURNS [REAL] ~ {
SELECT noiseType FROM
$Plain => RETURN[PlainOneOverFNoise[x, y, z]];
$Simple => RETURN[SimpleOneOverFNoise[x, y, z]];
$Limited => RETURN[LimitedOneOverFNoise[x, y, z, radius]];
$DblOctave => RETURN[DblOctaveOneOverFNoise[x, y, z]];
ENDCASE => RETURN[(1.0 + RealFns.Sin[x*8])/2.0];		-- give 'em something for screwups
};

SimpleOneOverFNoise: PROC[x, y, z: REAL] RETURNS [REAL] ~ {
f: REAL _ 1.;
s, t: REAL _ 0.;
FOR n: INT IN [0..7) DO
s _ SimpleNoise[x * f, y * f,  z * f];
t _ t + ABS[s] / f;
f _ 2 * f;
ENDLOOP;
RETURN [t];
};

PlainOneOverFNoise: PROC[x, y, z: REAL] RETURNS [REAL] ~ {
f: REAL _ 1.;
s, t: REAL _ 0.;
FOR n: INT IN [0..7) DO
s _ Noise[x * f, y * f,  z * f] / f;
t _ IF bulgeUp THEN t + ABS[s] ELSE t + s;
f _ 2 * f;
ENDLOOP;
RETURN [t];
};

DblOctaveOneOverFNoise: PROC[x, y, z: REAL] RETURNS [REAL] ~ {
f: REAL _ 1.;
s, t: REAL _ 0.;
FOR n: INT IN [0..5) DO
s _ Noise[x * f, y * f,  z * f] / f;
t _ IF bulgeUp THEN t + ABS[s] ELSE t + s;
f _ 4 * f;
ENDLOOP;
RETURN [t];
};

lx, ly, lz: REAL _ 0.0;    pSums: ARRAY [0..6) OF REAL _ ALL[0.0];

LimitedOneOverFNoise: PROC[x, y, z, radius: REAL _ 0.006] RETURNS [REAL] ~ {
f, s, a: REAL _ 1.0; 
t: REAL _ IF bulgeUp THEN 0.0 ELSE 0.5;		-- initial value for result summation
start: INTEGER _ 0;
recip: REAL _ IF radius < 0.006 THEN 64.0 ELSE MAX[1.0, 1.0 / (3*radius)];
limit: INTEGER _ Log2[Real.Round[recip]];
distance: REAL _ ABS[x-lx] + ABS[y-ly] + ABS[z-lz];
SELECT TRUE FROM
distance <= .015625/3.0 => RETURN[pSums[5]];
distance <= 0.03125/3.0 => { start _ 5;  t _ pSums[4] };
distance <= 0.06250/3.0 => { start _ 4;  t _ pSums[3] };
distance <= 0.12500/3.0 => { start _ 3;  t _ pSums[2] };
distance <= 0.25000/3.0 => { start _ 2;  t _ pSums[1] };
distance <= 0.50000/3.0 => { start _ 1;  t _ pSums[0] };
ENDCASE => {  lx _ x;  ly _ y;  lz _ lz;  start _ 0;  };
FOR n: NAT IN [0..start) DO  f _ 2 * f;  ENDLOOP;
FOR n: NAT IN [start..limit) DO						-- sum to finer detail from midpoint
s _ Noise[x*f, y*f, z*f] / f;
t _ IF bulgeUp THEN t + ABS[s] ELSE t + s;
f _ 2 * f;
pSums[n] _ t;
ENDLOOP;

RETURN [MIN[1.0, MAX[0.0, t]]];
};

realScale: REAL _ 2.0 / LAST[CARDINAL];
RTable: TYPE ~ RECORD[SEQUENCE length: NAT OF REAL];
rTable: REF RTable _ NIL;

SimpleNoise: PUBLIC PROC[vx, vy, vz: REAL] RETURNS [REAL] ~ {

R: PROC[i, j, k: REAL] RETURNS [CARDINAL] ~ TRUSTED {
A: TYPE ~ ARRAY [0..3) OF REAL;
a: A _ [i * .12345 , j * .12345 , k * .12345 ];
aPointer: LONG POINTER ~ @a;
h: CARDINAL _ Checksum.ComputeChecksum[nWords: SIZE[A], p: aPointer];
RETURN [h];
};

SCurve: PROC[x: REAL] RETURNS [REAL] ~ {

RETURN [x * x * (3 - 2 * x)];
};

ix, iy, iz: INT;
x, y, z, jx, jy, jz, sx, sy, sz, tx, ty, tz, s, f: REAL;
x _ vx + 1000.;
y _ vy + 1000.;
z _ vz + 1000.;
ix _ Real.Fix[x];
iy _ Real.Fix[y];
iz _ Real.Fix[z];
sx _ SCurve[x - ix];
sy _ SCurve[y - iy];
sz _ SCurve[z - iz];
tx _ 1. - sx;
ty _ 1. - sy;
tz _ 1. - sz;
f _ 0.; -- initialize sum to zero.
FOR n: INT IN [0..8) DO -- sum together 8 local fields from neighboring lattice pts.
SELECT n FROM -- each of 8 corners of the surrounding unit cube.
0 => {jx _ ix		; jy _ iy		; jz _ iz		; s _ tx	* ty	* tz	};
1 => {jx _ ix+1	 								; s _ sx	* ty	* tz	};
2 => {jx _ ix		; jy _ iy+1	 				; s _ tx	* sy	* tz	};
3 => {jx _ ix+1	 								; s _ sx	* sy	* tz	};
4 => {jx _ ix		; jy _ iy		; jz _ iz+1	; s _ tx	* ty	* sz	};
5 => {jx _ ix+1	 								; s _ sx	* ty	* sz	};
6 => {jx _ ix		; jy _ iy+1					; s _ tx	* sy	* sz	};
7 => {jx _ ix+1									; s _ sx	* sy	* sz	};
ENDCASE;
f _ f + s * (R[jx, jy, jz] * realScale - 1.0);
ENDLOOP;
RETURN [f];
};

Noise: PUBLIC PROC[vx, vy, vz: REAL] RETURNS [REAL] ~ {

R: PROC[i, j, k: REAL] RETURNS [CARDINAL] ~ TRUSTED {
A: TYPE ~ ARRAY [0..3) OF REAL;
a: A _ [i * .12345 , j * .12345 , k * .12345 ];
aPointer: LONG POINTER TO A ~ @a;
h: CARDINAL _ Checksum.ComputeChecksum[nWords: SIZE[A], p: aPointer];
RETURN [h];
};

SCurve: PROC[x: REAL] RETURNS [REAL] ~ {

RETURN [x * x * (3 - 2 * x)];
};

m: NAT;
ix, iy, iz: INT;
x, y, z, jx, jy, jz, sx, sy, sz, tx, ty, tz, s, f: REAL;
IF rTable = NIL THEN {
rTable _ NEW[RTable[259]];
FOR n:INT IN [0..259) DO
r:REAL _ n;
rTable[n] _ R[r, r, r] * realScale - 1.;
ENDLOOP;
};
x _ vx + 1000.;
y _ vy + 1000.;
z _ vz + 1000.;
ix _ Real.Fix[x];
iy _ Real.Fix[y];
iz _ Real.Fix[z];
sx _ SCurve[x - ix];
sy _ SCurve[y - iy];
sz _ SCurve[z - iz];
tx _ 1. - sx;
ty _ 1. - sy;
tz _ 1. - sz;
f _ 0.; -- initialize sum to zero.
FOR n: INT IN [0..8) DO -- sum together 8 local fields from neighboring lattice pts.
SELECT n FROM -- each of 8 corners of the surrounding unit cube.
0 => {jx _ ix		; jy _ iy		; jz _ iz		; s _ tx	* ty	* tz	};
1 => {jx _ ix+1	 								; s _ sx	* ty	* tz	};
2 => {jx _ ix		; jy _ iy+1	 				; s _ tx	* sy	* tz	};
3 => {jx _ ix+1	 								; s _ sx	* sy	* tz	};
4 => {jx _ ix		; jy _ iy		; jz _ iz+1	; s _ tx	* ty	* sz	};
5 => {jx _ ix+1	 								; s _ sx	* ty	* sz	};
6 => {jx _ ix		; jy _ iy+1					; s _ tx	* sy	* sz	};
7 => {jx _ ix+1									; s _ sx	* sy	* sz	};
ENDCASE;
m _ R[jx, jy, jz] MOD 256;
f _ f + s * ( rTable[m]/2 + rTable[m+1]*(x-jx) +
				rTable[m+2]*(y-jy) + rTable[m+3]*(z-jz) );
ENDLOOP;
RETURN [f];
};

RegisterEverything[];

END.
 
	0ShadingProcs.mesa 
Copyright Σ 1987 by Xerox Corporation.  All rights reserved.
Example SpotProcs for solid texturing
Last Edited by: Crow, September 6, 1989 5:56:51 pm PDT
Perlin, August 5, 1985 0:23:18 am PDT
PROC[context: Context, spot: REF Spot, data: REF ANY _ NIL]
Regular array of opaque green spots moves over surface with transform
PROC[context: Context, shading: REF ShadingClass, spot: REF Spot, data: REF ANY _ NIL]
Regular array of opaque green spots over whatever lies underneath (for layered textures)
Blend with underlying color using transmittance
PROC[context: Context, shading: REF ShadingClass, spot: REF Spot, data: REF ANY _ NIL]
Regular array of opaque green spots moves over surface with transform
PROC[context: Context, shading: REF ShadingClass, spot: REF Spot, data: REF ANY _ NIL]
Cube tesselation of 3-space
PROC[context: Context, shading: REF ShadingClass, spot: REF Spot, data: REF ANY _ NIL]
PROC[context: Context, shading: REF ShadingClass, spot: REF Spot, data: REF ANY _ NIL]
Regular array of opaque green spots moves over surface with transform
Perlin's marble texture
PROC[context: Context, shading: REF ShadingClass, spot: REF Spot, data: REF ANY _ NIL]
Calculates seven octaves of 1/f noise
Calculates five double octaves of 1/f noise
Calculates up to six octaves of 1/f noise, stopping when radius indicates extra detail unusable
Saves lower octave sums to reuse when last position was nearby
returns band limited noise over R3.
map the unit interval into an "S shaped" cubic f[x] | f[0]=0, f'[0]=0, f[1]=1, f'[1]=0.
declare local variables.
Force everything to be positive
ixyz _ the integer lattice point "just below" v (identifies the surrounding unit cube).
sxyz _ the vector difference v - ixyz biased with an S-Curve in each dimension.
txyz _ the complementary set of S-Curves in each dimension.
Add in each weighted component
returns band limited noise over R3.
map the unit interval into an "S shaped" cubic f[x] | f[0]=0, f'[0]=0, f[1]=1, f'[1]=0.
declare local variables.
initialize random gradient table
Force everything to be positive
ixyz _ the integer lattice point "just below" v (identifies the surrounding unit cube).
sxyz _ the vector difference v - ixyz biased with an S-Curve in each dimension.
txyz _ the complementary set of S-Curves in each dimension.
Add in each weighted component
Κ…˜
head™Icode™<—
defaultš
Οb%™%J™6L™%MšΟk	œO˜X—
head2šœžœ
ž˜JšžœC˜JJ˜Jšœž˜˜Jšžœžœ
žœ
˜Jšœ
žœ˜"Mšœžœ˜,Mšœžœ˜&Mšœ	žœ˜ Mšœžœ˜,J˜—JšΟnœ
žœ!žœ
žœžœžœ
žœ.Ÿ˜‹
šŸœž	œ
žœžœžœžœžœ˜SM˜—šŸœžœžœžœžœ	Οc,˜YLšœžœ˜Lšœžœ˜šžœžœž˜L˜L˜
Lšžœ
˜—L˜L˜—šŸœžœ˜J˜oJ˜LJ˜RJ˜DJ˜BJ˜BJ˜BJ˜HJ˜NJ˜mJ˜JJ˜DJ˜JJš
œo˜oJ˜—šœ˜I
aš
žœžœ
žœ
žœžœ
™;Jš
 E™EJšœžœžœžœ ˜XJšœ
žœ
žœ ˜D˜AJ˜,J˜—J˜#J˜—J˜š
œ˜Ošžœžœžœ
žœ
žœžœ
™VJš
 X™XJšœžœžœžœ ˜XJš	œžœžœžœžœ˜8Jšœžœw˜•
J˜$˜.J™/—J˜DJšœ@ ˜NJ˜DJ˜*J˜J˜—šΠbnœ˜Ošžœžœžœ
žœ
žœžœ
™VJš
 E™EJšœžœžœžœ ˜XJšœ
žœ
žœ ˜D˜AJ˜,J˜—J˜J˜—š‘œ˜Ošžœžœžœ
žœ
žœžœ
™VJ™Jšœžœ ˜AJšœ
žœ ˜=Jšœžœžœžœ ˜XJšœžœžœžœ˜)Jšœž˜Mšœžœžœžœ ˜PJšœžœžœžœ
 ˜PJšœžœžœžœ
 
˜QJšžœžœžœ ˜SJšžœžœžœ˜6Jšžœžœžœ˜6Jšœ9 ˜Mšžœ˜šžœ 
˜J˜&J˜&J˜&J˜
—šžœ ˜J˜(J˜(J˜(J˜——J˜—šœ˜Ošžœžœžœ
žœ
žœžœ
™VJšœžœžœžœ ˜XJšœžœžœžœ˜)Jšœžœk˜zJ˜$J˜+J˜&J˜&J˜&J˜—šœ˜Jšœžœžœžœ ˜XJšœžœžœžœ˜)šœžœ˜%J˜J˜J˜
J˜+J˜—J˜$J˜+J˜&J˜&J˜&J˜—šœ˜Jšœžœžœžœ ˜XJš	œžœžœžœžœ˜8Jšœžœ
˜šžœ
˜Jš
œN˜NJšœž˜Jšœžœ˜#—J˜&J˜&J˜&J˜—šŸœ˜Jšœžœžœžœ ˜XJš	œžœžœžœžœ˜8Jšœžœ
˜Jšœžœ;˜FJšœ
žœ<˜JJšœžœžœ˜0Jšœžœ˜ J˜šœ	žœžœ˜$Jšžœ+˜3Jšžœ
žœ,˜4—Jšœžœ ˜<Jšœžœ ˜<Jšœžœ ˜>Jšœžœ ˜?J˜IJ˜IJ˜6J˜7Jšœžœ'˜6J˜ J˜ J˜ J˜—šŸœ˜Jšœžœžœžœ ˜XJš	œžœžœžœžœ˜8Jšœžœ
˜Jšœžœ
˜Jšœžœq˜}JšœžœC˜NJšœ
žœ<˜JJšœžœ˜*šžœžœ˜Jšœ(žœ
˜-Jšœžœ˜ Jšœ	ž
œ+ž
˜?šžœžœ˜Jšœžœžœ $œ˜GJšœ!žœ*˜NJ˜—šžœžœ˜Jšœžœžœ (˜YJšœ!žœ+˜OJ˜—šžœžœ˜Jšœžœžœ œ˜FJšœžœ0˜<šžœ
˜JšžœF˜JJšžœ?˜C—Jš
œ˜—Jšœ# ˜6Jšœ# ˜6Jšœ# ˜8Jšœžœ ˜?J˜IJ˜IJ˜6J˜7Jšœžœ'˜6Jšœžœ" ˜TJ˜8J˜8J˜8J˜*Jšœ0 ˜NJ˜—J˜—šŸ	œ˜Ošžœžœžœ
žœ
žœžœ
™VJš
 E™EJšœžœžœžœ ˜XJšœ
žœ
žœ ˜D˜AJ˜,J˜—J˜"J˜—šŸ	œ˜Jšœžœžœžœ ˜XJš	œžœžœžœžœ˜8Jšœ7žœ
˜<Jšœžœžœžœžœžœžœžœ˜›
JšœžœI˜TJšœ
žœ<˜JJšœžœ˜)Jšœžœ˜ J˜šœ	žœžœ )˜OJšžœ+˜3Jšžœ
žœ-˜5—šžœžœ˜Jšœžœžœ $œ˜Gšžœ˜Jšžœ"žœ*˜SJšžœ"žœ*˜S—˜J˜——šžœžœ˜Jšœžœžœ (˜Yšžœ˜Jšžœ"žœ+˜TJšžœ"žœ,˜U—˜J˜——šžœžœ˜Jšœžœžœ œ˜FJšœžœ
˜
šžœ˜Jšžœ6˜:Jšžœ7˜;—šžœ
˜JšžœF˜JJšžœ?˜C—š
œ˜J˜——Jšœ# ˜6Jšœ# ˜6Jšœ# ˜8Jšœžœ ˜?J˜IJ˜IJ˜6J˜7Jšœžœ'˜6J˜ J˜ J˜ J˜—šœ˜J™Jšœžœžœžœ ˜XJš	œžœžœžœžœ˜8Jšœžœp˜J˜$J˜+J˜&J˜&J˜&J˜—˜Jšœžœ
 6œ
˜N—š	œ˜Ošžœžœžœ
žœ
žœžœ
™VJšœžœžœžœ ˜YJš	œžœžœžœžœ˜8JšœžœA˜PJ˜$J˜&J˜&J˜&J˜—šŸœ˜Jšœžœžœžœ ˜YJš	œžœžœžœžœ˜8Jšœžœq˜}JšœžœB˜QJ˜$J˜&J˜&J˜&J˜—š
Ÿœžœ
žœžœžœ˜1Jšœžœ˜
Jšœžœ˜šžœžœ
žœž˜J˜ J˜'J˜J˜
Jšžœ
˜—Jšžœ˜J˜—š
Ÿœžœ
žœžœžœ˜/Jšœžœ˜
Jšœžœ˜šžœžœ
žœž˜J˜ J˜J˜
Jšžœ
˜—Jšžœ˜J˜Jšœžœ
˜Jšœ	žœžœ 4œ
˜O—šŸ
œžœ
žœ
žœ
žœžœ˜Kšžœž˜Jšœ
žœ˜.Jšœžœ˜0Jšœžœ(˜:Jšœžœ"˜6Jšžœžœ! "˜T—J˜—š
Ÿœžœ
žœžœžœ˜;Jšœžœ˜
Jšœžœ˜šžœžœ
žœž˜J˜&J˜J˜
Jšžœ
˜—Jšžœ˜J˜—š
Ÿœžœ
žœžœžœ˜:J™%Jšœžœ˜
Jšœžœ˜šžœžœ
žœž˜Jš
œ$˜$Jš	œžœ	žœžœžœ˜*J˜
Jšžœ
˜—Jšžœ˜J˜—š
Ÿœžœ
žœžœžœ˜>J™+Jšœžœ˜
Jšœžœ˜šžœžœ
žœž˜Jš
œ$˜$Jš	œžœ	žœžœžœ˜*J˜
Jšžœ
˜—Jšžœ˜J˜Jšœžœžœžœ
žœžœ˜C—š
Ÿœžœžœ
žœžœ˜LJ™_J™>Jšœ	žœ˜Jš
œžœžœ	žœžœ %˜NJšœžœ˜Jšœžœžœžœžœ
žœ˜JJšœžœ˜)Jš	œ
žœžœ	žœ	žœ˜3šžœ
žœ
ž˜Jšœžœ˜,Jš
œ8˜8Jš
œ8˜8Jš
œ8˜8Jš
œ8˜8Jš
œ8˜8Jšžœ1˜8—Jš
žœžœ
žœžœžœ
˜1š	žœžœ
žœžœ $˜IJš
œ˜Jš	œžœ	žœžœžœ˜*J˜
Jš
œ
˜
Jšžœ
˜—J˜Jšžœžœžœ˜J˜Lšœžœ	žœ
žœ˜'L˜4˜L˜——šŸœžΟs
žœ
žœžœžœ˜=™#J˜šŸ
œžœ
žœžœžœžœ˜5Jš	œžœžœžœ
žœ
˜L˜/Lšœ
žœ
žœ˜Lšœžœ$žœ˜ELšžœ˜J˜—š
Ÿœžœžœžœžœ˜(™WJ˜Jšžœ˜—˜J˜——™Jšœžœ
˜Jšœ3žœ
˜8—™J˜J˜J˜—šœ
ΟdœS™WJ˜J˜J˜—šœ
£œ£œ*™OJ˜J˜J˜—šœ
£œ7™;J˜
J˜
J˜
—Jšœ ˜"š	žœžœ
žœžœ
 <˜Tšžœžœ
 2˜@J˜:J˜.J˜5J˜.J˜;J˜.J˜4J˜-Jšžœ
˜—™J˜.—Jšžœ
˜—Jšžœ˜—J˜—šŸœž’
žœ
žœžœžœ˜7šœ žœ
™#J˜šŸ
œžœ
žœžœžœžœ˜5Jš	œžœžœžœ
žœ
˜L˜/Lšœ
žœ
žœ
žœ˜!Lšœžœ$žœ˜ELšžœ˜J˜—š
Ÿœžœžœžœžœ˜(™WJ˜Jšžœ˜—˜J˜——™Jšœžœ
˜Jšœžœ
˜Jšœ3žœ
˜8—™ šžœ
žœ
žœ˜Jšœ	žœ˜šžœžœ
žœ
ž˜Jšœžœ˜J˜(Jšžœ
˜—J˜——™J˜J˜J˜—šœ
£œS™WJ˜J˜J˜—šœ
£œ£œ*™OJ˜J˜J˜—šœ
£œ7™;J˜
J˜
J˜
—Jšœ ˜"š	žœžœ
žœžœ
 <˜Tšžœžœ
 2˜@J˜:J˜.J˜5J˜.J˜;J˜.J˜4J˜-Jšžœ
˜—™Jšœžœ˜J˜_—Jšžœ
˜—Jšžœ˜—J˜—˜J˜—Jšžœ
˜Mš

˜
——…—LiE