Support for ideal dielectric refraction

Support for ideal dielectric refraction

// Global parameters that will be set via a template during compilation time.
#ifndef M_PI
#define M_PI 3.14159265358979323846f
#endif
#define FRAME_W 512
#define FRAME_H 512
#define TEXEL_STEP_X 1.0f / 512.0f
#define TEXEL_STEP_Y 1.0f / 512.0f

#define DEBUG (get_global_id(0) == 420 && get_global_id(1) == 400)

// Limits
#define MAX_TRACE_STEPS 128
#define MAX_BOUNCES 4 // iris pro compilation runs out of memory if set to > 5
#define MIN_BOUNCES_TO_USE_RR 3

// Epsilon values
#define NUDGE_EPSILON 1.0e-3f
#define DIST_SNAP_EPSILON 1.0e-5f

// Vector helpers
#define VEC3_MAX_COMPONENT(v) max(v.x, max(v.y, v.z))
#define VEC1(x) (float4)(x, 0.0f, 0.0f, 0.0f)
#define VEC2(x,y) (float4)(x, y, 0.0f, 0.0f)
#define VEC3(x,y,z) (float4)(x,y,z,0.0f)
#define VEC4(x,y,z,w) (float4)(x,y,z,w)
#define ORIGIN(v) VEC3(v,v,v)

// Normal estimator generators
#define OBJECT_NORMAL_AT(estimatorFn, objIndex, point) \
	normalize( \
		(float4)( \
			estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point + VEC3(NUDGE_EPSILON, 0,0)) - estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point - VEC3(NUDGE_EPSILON, 0,0)), \
			estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point + VEC3(0, NUDGE_EPSILON,0)) - estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point - VEC3(0, NUDGE_EPSILON,0)), \
			estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point + VEC3(0, 0, NUDGE_EPSILON)) - estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point - VEC3(0, 0, NUDGE_EPSILON)), \
			0.0f \
		) \
	)

// Tracer structs
// ---------------------

#define NO_MATERIAL_HIT -1
typedef struct {
	float4 position;
	float4 normal;
	float distFromOrigin;
	int objIndex;
	int matIndex;
} Hit;

// Supported material types
#define MATERIAL_DIFFUSE 0
#define MATERIAL_SPECULAR 1
#define MATERIAL_REFRACTIVE 2
#define MATERIAL_LIGHT 65535

typedef struct {
	unsigned int type;
	float4 diffuse;
	float4 emissive;
	float IOR; // index of refraction
} Material;

// Supported object types
#define OBJECT_PLANE 0
#define OBJECT_SPHERE 1
#define OBJECT_BOX 2
#define OBJECT_TORUS 3

typedef struct {
	unsigned int type;
	unsigned int material;
	float4 origin;
	float4 params;
} Object;

// -----------------------
// Object and material definitions
// The following code will be autogenerated by the scene processor
// ------------------
__constant float4 sceneBgColor = (float4)(0.0f);

__constant Material SceneMaterial[] = {
	{MATERIAL_LIGHT, VEC3(0.0f,0.0f,0.0f), VEC3(50.0f,50.0f,50.0f)},
	{MATERIAL_DIFFUSE, VEC3(0.75f, 0.25f, 0.25f)},
	{MATERIAL_DIFFUSE, VEC3(0.25f, 0.25f, 0.75f)},
	{MATERIAL_DIFFUSE, VEC3(0.75f, 0.75f, 0.75f)},
	{MATERIAL_SPECULAR, VEC3(0.999f, 0.999f, 0.999f)},
	{MATERIAL_REFRACTIVE, VEC3(0.999f, 0.999f, 0.999f), VEC1(0.0f), 1.5f}
};

__constant Object SceneObject[] = {
	// Light
	{OBJECT_SPHERE, 0, VEC3(0.0f, 1.3f, -1.0f), VEC1(0.1f)},
	// Left wall
	{OBJECT_BOX, 1, VEC3(-2.0f,0.0f,0.0f), VEC3(0.1f, 2.0f, 2.0f)},
	// Right wall
	{OBJECT_BOX, 2, VEC3(2.0f,0.0f,0.0f), VEC3(0.1f, 2.0f, 2.0f)},
	// Top wall
	{OBJECT_BOX, 3, VEC3(0.0f,2.0f,0.0f), VEC3(2.0f, 0.1f, 2.0f)},
	// Bottom wall
	{OBJECT_BOX, 3, VEC3(0.0f,-2.0f,0.0f), VEC3(2.0f, 0.1f, 2.0f)},
	// Back wall
	{OBJECT_BOX, 3, VEC3(0,0,-2), VEC3(2.0f, 2.0f, 0.1f)},
	// Mirror ball
	{OBJECT_SPHERE, 4, VEC3(-1.0f, -1.4f, -1.0f), VEC1(0.5f)},
	// Glass ball
	{OBJECT_SPHERE, 5, VEC3(1.4f, -1.4f, -0.5f), VEC1(0.5f)}
};

// -----------------------
// Random number and direction generators
// -----------------------
float2 clRand(uint2 *state)
{
    const float2 invMaxInt = (float2) (1.0f/4294967296.0f, 1.0f/4294967296.0f);
    uint x = (*state).x * 17 + (*state).y * 13123;
    (*state).x = (x<<13) ^ x;
    (*state).y ^= (x<<7);

    uint2 tmp = (uint2)
    (
		(x * (x * x * 15731 + 74323) + 871483),
		(x * (x * x * 13734 + 37828) + 234234)
	);

    return convert_float2(tmp) * invMaxInt;
}

// Return random direction on hemiphere around normal.
// This function has: PDF = cos(theta) / pi
float4 rndCosWeightedHemisphereDir(float4 normal, uint2 *seed) {
	float2 rnd  = clRand(seed);

	// Generate point on disk
	float rd = sqrt(rnd.x);
	float phi = 2.0f*M_PI*rnd.y;

	// Generate tangent, bi-tangent vectors
	float4 u = normalize(cross((fabs(normal.x) > .1f ? (float4)(0.0f, 1.0f, 0.0f, 0.0f) : (float4)(1.0f, 0.0f, 0.0f, 0.0f)), normal));
	float4 v = cross(normal,u);

	// Project disk point to unit hemisphere and rotate so that the normal points up
	return normalize(u * rd * cos(phi) + v * rd * sin(phi) + normal * sqrt(1 - rnd.x));
}

// Return random cosine weighted direction in a cone centered at the normal
// proportional to a solid angle. This function has:
// PDF = cos(theta) /  pi * sin(theta_max)^2
float4 rndCosWeigthedConeDir(float4 normal, float sinThetaMax, uint2 *seed){
	float2 rnd  = clRand(seed);

	float rd = sinThetaMax * sqrt(rnd.x);
	float phi = 2.0f*M_PI*rnd.y;
	float r2t = sqrt(1 - rnd.x*sinThetaMax*sinThetaMax);

	// Generate tangent, bi-tangent vectors
	float4 u = normalize(cross((fabs(normal.x) > .1f ? (float4)(0.0f, 1.0f, 0.0f, 0.0f) : (float4)(1.0f, 0.0f, 0.0f, 0.0f)), normal));
	float4 v = cross(normal,u);

	// Project disk point to unit hemisphere and rotate so that the normal points up
	return normalize(u * rd * cos(phi) + v * rd * sin(phi) + normal * r2t);
}

// Return random direction in a cone centered at the normal
// proportional to a solid angle. This function has:
// PDF = 1 / 2 * pi * (1 - cos(theta_max))
float4 rndConeDir(float4 normal, float cosThetaMax, uint2 *seed){
	float2 rnd  = clRand(seed);

	float rcd = 1.0f - rnd.x*(1.0f - cosThetaMax);
	float rd = sqrt(1.0f - rcd*rcd);
	float phi = 2.0f*M_PI*rnd.y;

	// Generate tangent, bi-tangent vectors
	float4 u = normalize(cross((fabs(normal.x) > .1f ? (float4)(0.0f, 1.0f, 0.0f, 0.0f) : (float4)(1.0f, 0.0f, 0.0f, 0.0f)), normal));
	float4 v = cross(normal,u);

	// Project disk point to unit hemisphere and rotate so that the normal points up
	return normalize(u * rd * cos(phi) + v * rd * sin(phi) + normal * rcd);
}

// -----------------------
// Distance estimators for supported primitives
// -----------------------
float planeSD(float4 origin, float4 dims, float4 point){
	dims = normalize(dims);
	return dot((point - origin).xyz, dims.xyz) + dims.w;
}
float sphereSD(float4 origin, float4 radius, float4 point){
	return length(point - origin) - radius.x;
}
float boxSD(float4 origin, float4 dims, float4 point){
	float3 d = fabs(point.xyz - origin.xyz) - dims.xyz;
	return fmin(VEC3_MAX_COMPONENT(d), 0.0f) + length(fmax(d, 0.0f));
}
float torusSD(float4 origin, float4 dims, float4 point){
	point -= origin;
	return length((float2)(length(point.xz) - dims.x, point.y)) - dims.y;
}

// -----------------------
// Tracer implementation
// -----------------------

// Estimate normal at intersection point
void getNormal(Hit *hit){
	switch(SceneObject[hit->objIndex].type) {
		case OBJECT_PLANE:
			hit->normal = OBJECT_NORMAL_AT(planeSD, hit->objIndex, hit->position);
		break;
		case OBJECT_SPHERE:
			hit->normal = OBJECT_NORMAL_AT(sphereSD, hit->objIndex, hit->position);
		break;
		case OBJECT_BOX:
			hit->normal = OBJECT_NORMAL_AT(boxSD, hit->objIndex, hit->position);
		break;
		case OBJECT_TORUS:
			hit->normal = OBJECT_NORMAL_AT(torusSD, hit->objIndex, hit->position);
		break;
	}
}

// Estimate distance to nearest object
void intersectWorld(const float4 rayOrigin, const float4 rayDir, const float minDist, const float maxDist, Hit *hit){
	hit->objIndex = NO_MATERIAL_HIT;
	hit->matIndex = NO_MATERIAL_HIT;

	float4 point;
	float curDist = minDist;
	float objDist, nearestDist;
	int nearestObj = -1;
	int nearestMat = -1;
	unsigned int objIndex;
	unsigned int numObjects = (uint)(sizeof(SceneObject) / sizeof(Object));
	for(unsigned int step=0;step<MAX_TRACE_STEPS;step++){
		point = rayOrigin + rayDir * curDist;

		// Find nearest object/dist to point
		nearestDist = FLT_MAX;
		for(objIndex=0;objIndex<numObjects; objIndex++){
			switch(SceneObject[objIndex].type) {
				case OBJECT_PLANE:
					objDist = planeSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
				case OBJECT_SPHERE:
					objDist = sphereSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
				case OBJECT_BOX:
					objDist = boxSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
				case OBJECT_TORUS:
					objDist = torusSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
			}

			if(objDist < nearestDist){
				nearestDist = objDist;
				nearestObj = objIndex;
				nearestMat = SceneObject[objIndex].material;
			}
		}

		// If we are inside an object nearestDist will be < 0
		nearestDist = fabs(nearestDist);

		curDist += nearestDist;
		if(curDist > maxDist){
			return;
		}

		// We are close enough to the object to register a hit
		if(nearestDist < DIST_SNAP_EPSILON){
			hit->position = point;
			hit->distFromOrigin = curDist;
			hit->objIndex = nearestObj;
			hit->matIndex = nearestMat;
			return;
		}
	}
}

// Collect direct light at hit point.
float4 getDirectLight(Hit *hit, uint2 *rndSeed){
	float4 light = 0.0f;
	Hit shadowHit;
	__constant Material *material;
	unsigned int objIndex;
	unsigned int numObjects = (uint)(sizeof(SceneObject) / sizeof(Object));

	for(objIndex=0;objIndex<numObjects; objIndex++){
		material = &SceneMaterial[SceneObject[objIndex].material];
		if( material->type != MATERIAL_LIGHT) {
			continue;
		}

		float4 lightDir = SceneObject[objIndex].origin - hit->position;

		// Early rejection for back-facing surfaces
		if(dot(lightDir, hit->normal) < 0){
			continue;
		}

		// Treat the light as a sphere with radius the largest dimension; then
		// generate a lightDir vector to its center and a tangent vector so as to
		// form a right-angled triangle with base (light radius, light dir) and
		// hypotenuse the tangent vector. Then generate a random ray towards
		// the light proportional to the solid angle of the cone defined by
		// the triangle.
		float lightDirLen = length(lightDir);
		float radius = SceneObject[objIndex].params.x;
		float tLen = sqrt(lightDirLen*lightDirLen + radius*radius);
		float cosThetaMax = lightDirLen / tLen;
		lightDir = normalize(lightDir);
		float4 shadowDir = rndConeDir(lightDir, cosThetaMax, rndSeed);

		// Check line of sight; if we hit anything other than the target or nothing reject light
		intersectWorld(hit->position, shadowDir, NUDGE_EPSILON, lightDirLen, &shadowHit);
		if(shadowHit.objIndex != objIndex && shadowHit.objIndex != NO_MATERIAL_HIT){
			continue;
		}

		// Radiance = 1/pi * cos(theta) * emissive * PDF
		light += material->emissive * dot(hit->normal, shadowDir) * 2.0f * (1.0f - cosThetaMax);

	}
	return light;
}

// Trace a ray and return the gathered color.
float4 traceRay(float4 rayOrigin, float4 rayDir, uint2 *rndSeed){
	Hit hit;
	__constant Material *material;
	float4 rCol = (float4)(0.0f);
	float4 mask = (float4)(1.0f);
	unsigned int bounce = 0;
	bool hitDiffuseObject = false;
	float nc, nt, eta, ddn;
	float4 nl;
	for(bounce=0;bounce<MAX_BOUNCES;bounce++){
		intersectWorld(rayOrigin, rayDir, NUDGE_EPSILON, FLT_MAX, &hit);

		// No hit
		if(hit.objIndex == NO_MATERIAL_HIT){
			if(bounce == 0){
				rCol = sceneBgColor;
			}
			break;
		}

		// Get material at hit point
		material = &SceneMaterial[hit.matIndex];

		// If we hit a light just add its emissive property and stop
		if( material->type == MATERIAL_LIGHT ){
			if ( !hitDiffuseObject ){
				rCol += mask * material->emissive;
			}
			break;
		}

		// Get normal at hit point
		getNormal(&hit);

		// After some bounces apply a russian roulette to terminate long paths
		if( bounce > MIN_BOUNCES_TO_USE_RR ) {
			float maxComponent = VEC3_MAX_COMPONENT(material->diffuse);
			if( maxComponent == 0 || clRand(rndSeed).x > maxComponent ){
				break;
			}

			// Boost surviving paths by 1/rr_prob
			mask /= maxComponent;
		}

		// Next bounce starts at hit point
		rayOrigin = hit.position;

		if( material->type == MATERIAL_DIFFUSE ) {
			// Mask outgoing reflectance by material diffuse property
			mask *= material->diffuse;

			hitDiffuseObject = true;
			rCol += mask * getDirectLight(&hit, rndSeed);

			// We do importance sampling for diffuse rays
			rayDir = rndCosWeightedHemisphereDir(hit.normal, rndSeed);
		} else if ( material->type == MATERIAL_SPECULAR){
			// Mask outgoing reflectance by material diffuse property
			mask *= material->diffuse;

			// Reflect ray around normal
			rayDir = normalize(-2.0f * dot(hit.normal, rayDir) * hit.normal + rayDir);
		} else if (material->type == MATERIAL_REFRACTIVE){
			bool insideObject = dot(rayDir, hit.normal) > 0.0f;
			if (insideObject ){
				nl = hit.normal * -1.0f;
				nc = material->IOR;
				nt = 1.0f; // air
			} else {
				nl = hit.normal;
				nc = 1.0f; // air
				nt = material->IOR;
			}
			eta = nt / nc;
			ddn = dot(rayDir, nl);
			float cos2t = 1.0f - eta * eta * (1.0f - ddn*ddn);

			// Total internal reflection
			if( cos2t < 0.0f){
				// Reflect ray around normal
				rayDir = normalize(-2.0f * dot(hit.normal, rayDir) * hit.normal + rayDir);
			} else {

				// Compute transmission ray dir
				float4 transDir = rayDir * eta;
				transDir -= hit.normal * ((insideObject ? 1.0f : -1.0f) * (ddn*eta + sqrt(cos2t)));
				transDir = normalize(transDir);

				// Compute reflectance at normal angle (R0) and reflectance (re) using
				// Schlick's approximation:
				float R0 = (nt-nc)*(nt-nc) / (nt+nc)*(nt+nc);
				// c = cos of transmission ray and normal
				float c= 1.0f - (insideObject ? -ddn : dot(transDir,hit.normal));
				// This is Schlick's approximation for reflectance at angle theta
				float re = R0 + (1.0f - R0) * c * c * c * c * c;
				float tr = 1.0f - re;
				float prob = 0.25f + 0.5f * re;
				// Calc reflection and transmission boost factor based on event probablilities
				float rp = re / prob;
				float tp = tr / (1.0f - prob);

				// Use RR to pick reflection or transmission
				float2 rnd = clRand(rndSeed);
				if( rnd.x < 0.25f) {
					mask *= rp;

					// Reflect ray around normal
					rayDir = normalize(-2.0f * dot(hit.normal, rayDir) * hit.normal + rayDir);
				} else {
					mask *= tp;
					rayDir = transDir;
				}
			}
		}
	}

	return rCol;
}

// Emit the color of a pixel by tracing a ray through the scene.
__kernel void tracePixel(
		__global float4 *frameBuffer,
		__global float4 *frustrumCorners,
		const float4 eyePos,
		const unsigned int blockY,
		const unsigned int samplesPerPixel,
		const float exposure,
		const int seed
		){
	// Get pixel coordinates
	unsigned int x = get_global_id(0);
	unsigned int y = get_global_id(1);
	if ( x > FRAME_W || y > FRAME_H ) {
		return;
	}

	// Setup seed for random numbers
	uint2 rndSeed = (uint2)(x * seed, y * seed);

	// Calculate texel coordinates [0,1] range
	float accumScaler = 1.0f / (float)samplesPerPixel;
	float4 accum = (float4)(0.0f,0.0f,0.0f,0.0f);

	for( uint sample=0;sample<samplesPerPixel;sample++){
		// Apply stratified sampling using a tent filter. This will wrap our
		// random numbers in the [-1, 1] range. X and Y point to the top corner
		// of the current texel so we need to add a bit of offset to get the coords
		// into the [-0.5, 1.5] range.
		float2 random = clRand(&rndSeed);
		float offX = random.x < 0.5f ? sqrt(2.0f * random.x) - 0.5f : 1.5f - sqrt(2.0f - 2.0f * random.x);
		float offY = random.y < 0.5f ? sqrt(2.0f * random.y) - 0.5f : 1.5f - sqrt(2.0f - 2.0f * random.y);
		float tx = ((float)x + offX) * TEXEL_STEP_X;
		float ty = ((float)y + offY) * TEXEL_STEP_Y;

		// Get ray direction using trilinear interpolation; trace ray and
		// add result to accumulation buffer
		float4 lVec = frustrumCorners[0] * (1 - ty) + frustrumCorners[2] * ty;
		float4 rVec = frustrumCorners[1] * (1 - ty) + frustrumCorners[3] * ty;
		accum += traceRay(eyePos, normalize(lVec * (1 - tx) + rVec * tx), &rndSeed);
	}

	// Average samples
	accum *= accumScaler;

	// Apply tone-mapping and gamma correction using:
	// 1 - exp(-hdrColor * exposure)) [tone mapping HDR -> LDR]
	// pow(ldr, 0.45)) [gamma correction]
	frameBuffer[y*FRAME_W + x] = pow(-expm1(-accum*exposure), 0.45f);
}

// Global parameters that will be set via a template during compilation time.
#ifndef M_PI
#define M_PI 3.14159265358979323846f
#endif
#define FRAME_W 512
#define FRAME_H 512
#define TEXEL_STEP_X 1.0f / 512.0f
#define TEXEL_STEP_Y 1.0f / 512.0f
#define NO_MATERIAL_HIT -1

// Limits
#define MAX_TRACE_STEPS 32
#define MAX_BOUNCES 4 // iris pro compilation runs out of memory if set to > 5
#define MIN_BOUNCES_TO_USE_RR 5

// Epsilon values
#define NUDGE_EPSILON 1.0e-1f
#define DIST_SNAP_EPSILON 1.0e-2f

// Vector helpers
#define VEC3_MAX_COMPONENT(v) max(v.x, max(v.y, v.z))
#define VEC1(x) (float4)(x, 0.0f, 0.0f, 0.0f)
#define VEC2(x,y) (float4)(x, y, 0.0f, 0.0f)
#define VEC3(x,y,z) (float4)(x,y,z,0.0f)
#define VEC4(x,y,z,w) (float4)(x,y,z,w)
#define ORIGIN(v) VEC3(v,v,v)

// Normal estimator generators
#define OBJECT_NORMAL_AT(estimatorFn, objIndex, point) \
	normalize( \
		(float4)( \
			estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point + VEC3(NUDGE_EPSILON, 0,0)) - estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point - VEC3(NUDGE_EPSILON, 0,0)), \
			estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point + VEC3(0, NUDGE_EPSILON,0)) - estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point - VEC3(0, NUDGE_EPSILON,0)), \
			estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point + VEC3(0, 0, NUDGE_EPSILON)) - estimatorFn(SceneObject[objIndex].origin,SceneObject[objIndex].params, point - VEC3(0, 0, NUDGE_EPSILON)), \
			0.0f \
		) \
	)

// Tracer structs
// ---------------------

typedef struct {
	float4 position;
	float4 normal;
	float distFromOrigin;
	int objIndex;
	int matIndex;
} Hit;

// Supported material types
#define MATERIAL_DIFFUSE 0
#define MATERIAL_SPECULAR 1
#define MATERIAL_REFRACTIVE 2
#define MATERIAL_LIGHT 65535

typedef struct {
	unsigned int type;
	float4 diffuse;
	float4 emissive;
} Material;

// Supported object types
#define OBJECT_PLANE 0
#define OBJECT_SPHERE 1
#define OBJECT_BOX 2
#define OBJECT_TORUS 3

typedef struct {
	unsigned int type;
	unsigned int material;
	float4 origin;
	float4 params;
} Object;

// -----------------------
// Object and material definitions
// The following code will be autogenerated by the scene processor
// ------------------
__constant float4 sceneBgColor = (float4)(0.0f);

__constant Material SceneMaterial[] = {
	{MATERIAL_LIGHT, VEC3(0.0f,0.0f,0.0f), VEC3(50.0f,50.0f,50.0f)},
	{MATERIAL_DIFFUSE, VEC3(0.75f, 0.25f, 0.25f)},
	{MATERIAL_DIFFUSE, VEC3(0.25f, 0.25f, 0.75f)},
	{MATERIAL_DIFFUSE, VEC3(0.75f, 0.75f, 0.75f)},
	{MATERIAL_SPECULAR, VEC3(0.999f, 0.999f, 0.999f)},
	{MATERIAL_REFRACTIVE, VEC3(0.999f, 0.999f, 0.999f)}
};

__constant Object SceneObject[] = {
	// Light
	{OBJECT_SPHERE, 0, VEC3(0.0f, 1.3f, 0.0f), VEC1(0.1f)},
	// Left wall
	{OBJECT_BOX, 1, VEC3(-2.0f,0.0f,0.0f), VEC3(0.1f, 2.0f, 2.0f)},
	// Right wall
	{OBJECT_BOX, 2, VEC3(2.0f,0.0f,0.0f), VEC3(0.1f, 2.0f, 2.0f)},
	// Top wall
	{OBJECT_BOX, 3, VEC3(0.0f,2.0f,0.0f), VEC3(2.0f, 0.1f, 2.0f)},
	// Bottom wall
	{OBJECT_BOX, 3, VEC3(0.0f,-2.0f,0.0f), VEC3(2.0f, 0.1f, 2.0f)},
	// Back wall
	{OBJECT_BOX, 3, VEC3(0,0,-2), VEC3(2.0f, 2.0f, 0.1f)},
	// Mirror ball
	{OBJECT_SPHERE, 4, VEC3(-1.0f, -1.4f, -1.0f), VEC1(0.5f)},
	// Glass ball
	{OBJECT_SPHERE, 5, VEC3(1.4f, -1.4f, -0.5f), VEC1(0.5f)}
};

// -----------------------
// Random number and direction generators
// -----------------------
float2 clRand(uint2 *state)
{
    const float2 invMaxInt = (float2) (1.0f/4294967296.0f, 1.0f/4294967296.0f);
    uint x = (*state).x * 17 + (*state).y * 13123;
    (*state).x = (x<<13) ^ x;
    (*state).y ^= (x<<7);

    uint2 tmp = (uint2)
    (
		(x * (x * x * 15731 + 74323) + 871483),
		(x * (x * x * 13734 + 37828) + 234234)
	);

    return convert_float2(tmp) * invMaxInt;
}

// Return random direction on hemiphere around normal.
// This function has: PDF = cos(theta) / pi
float4 rndCosWeightedHemisphereDir(float4 normal, uint2 *seed) {
	float2 rnd  = clRand(seed);

	// Generate point on disk
	float rd = sqrt(rnd.x);
	float phi = 2.0f*M_PI*rnd.y;

	// Generate tangent, bi-tangent vectors
	float4 u = normalize(cross((fabs(normal.x) > .1f ? (float4)(0.0f, 1.0f, 0.0f, 0.0f) : (float4)(1.0f, 0.0f, 0.0f, 0.0f)), normal));
	float4 v = cross(normal,u);

	// Project disk point to unit hemisphere and rotate so that the normal points up
	return normalize(u * rd * cos(phi) + v * rd * sin(phi) + normal * sqrt(1 - rnd.x));
}

// Return random cosine weighted direction in a cone centered at the normal
// proportional to a solid angle. This function has:
// PDF = cos(theta) /  pi * sin(theta_max)^2
float4 rndCosWeigthedConeDir(float4 normal, float sinThetaMax, uint2 *seed){
	float2 rnd  = clRand(seed);

	float rd = sinThetaMax * sqrt(rnd.x);
	float phi = 2.0f*M_PI*rnd.y;
	float r2t = sqrt(1 - rnd.x*sinThetaMax*sinThetaMax);

	// Generate tangent, bi-tangent vectors
	float4 u = normalize(cross((fabs(normal.x) > .1f ? (float4)(0.0f, 1.0f, 0.0f, 0.0f) : (float4)(1.0f, 0.0f, 0.0f, 0.0f)), normal));
	float4 v = cross(normal,u);

	// Project disk point to unit hemisphere and rotate so that the normal points up
	return normalize(u * rd * cos(phi) + v * rd * sin(phi) + normal * r2t);
}

// Return random direction in a cone centered at the normal
// proportional to a solid angle. This function has:
// PDF = 1 / 2 * pi * (1 - cos(theta_max))
float4 rndConeDir(float4 normal, float cosThetaMax, uint2 *seed){
	float2 rnd  = clRand(seed);

	float rcd = 1.0f - rnd.x*(1.0f - cosThetaMax);
	float rd = sqrt(1.0f - rcd*rcd);
	float phi = 2.0f*M_PI*rnd.y;

	// Generate tangent, bi-tangent vectors
	float4 u = normalize(cross((fabs(normal.x) > .1f ? (float4)(0.0f, 1.0f, 0.0f, 0.0f) : (float4)(1.0f, 0.0f, 0.0f, 0.0f)), normal));
	float4 v = cross(normal,u);

	// Project disk point to unit hemisphere and rotate so that the normal points up
	return normalize(u * rd * cos(phi) + v * rd * sin(phi) + normal * rcd);
}

// -----------------------
// Distance estimators for supported primitives
// -----------------------
float planeSD(float4 origin, float4 dims, float4 point){
	dims = normalize(dims);
	return dot((point - origin).xyz, dims.xyz) + dims.w;
}
float sphereSD(float4 origin, float4 radius, float4 point){
	return length(point - origin) - radius.x;
}
float boxSD(float4 origin, float4 dims, float4 point){
	float3 d = fabs(point.xyz - origin.xyz) - dims.xyz;
	return fmin(VEC3_MAX_COMPONENT(d), 0.0f) + length(fmax(d, 0.0f));
}
float torusSD(float4 origin, float4 dims, float4 point){
	point -= origin;
	return length((float2)(length(point.xz) - dims.x, point.y)) - dims.y;
}

// -----------------------
// Tracer implementation
// -----------------------

// Estimate normal at intersection point
void getNormal(Hit *hit){
	switch(SceneObject[hit->objIndex].type) {
		case OBJECT_PLANE:
			hit->normal = OBJECT_NORMAL_AT(planeSD, hit->objIndex, hit->position);
		break;
		case OBJECT_SPHERE:
			hit->normal = OBJECT_NORMAL_AT(sphereSD, hit->objIndex, hit->position);
		break;
		case OBJECT_BOX:
			hit->normal = OBJECT_NORMAL_AT(boxSD, hit->objIndex, hit->position);
		break;
		case OBJECT_TORUS:
			hit->normal = OBJECT_NORMAL_AT(torusSD, hit->objIndex, hit->position);
		break;
	}
}

// Estimate distance to nearest object
void intersectWorld(const float4 rayOrigin, const float4 rayDir, const float minDist, const float maxDist, Hit *hit){
	hit->objIndex = NO_MATERIAL_HIT;
	hit->matIndex = NO_MATERIAL_HIT;

	float4 point;
	float curDist = minDist;
	float objDist, nearestDist;
	int nearestObj = -1;
	int nearestMat = -1;
	unsigned int objIndex;
	unsigned int numObjects = (uint)(sizeof(SceneObject) / sizeof(Object));
	for(unsigned int step=0;step<MAX_TRACE_STEPS;step++){
		point = rayOrigin + rayDir * curDist;

		// Find nearest object/dist to point
		nearestDist = FLT_MAX;
		for(objIndex=0;objIndex<numObjects; objIndex++){
			switch(SceneObject[objIndex].type) {
				case OBJECT_PLANE:
					objDist = planeSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
				case OBJECT_SPHERE:
					objDist = sphereSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
				case OBJECT_BOX:
					objDist = boxSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
				case OBJECT_TORUS:
					objDist = torusSD(SceneObject[objIndex].origin, SceneObject[objIndex].params, point);
				break;
			}

			if(objDist < nearestDist){
				nearestDist = objDist;
				nearestObj = objIndex;
				nearestMat = SceneObject[objIndex].material;
			}
		}

		// If we are inside an object nearestDist will be < 0
		nearestDist = fabs(nearestDist);

		curDist += nearestDist;
		if(curDist > maxDist){
			return;
		}

		// We are close enough to the object to register a hit
		if(nearestDist < DIST_SNAP_EPSILON){
			hit->position = point;
			hit->distFromOrigin = curDist;
			hit->objIndex = nearestObj;
			hit->matIndex = nearestMat;
			return;
		}
	}
}

// Collect direct light at hit point.
float4 getDirectLight(Hit *hit, uint2 *rndSeed){
	float4 light = 0.0f;
	Hit shadowHit;
	__constant Material *material;
	unsigned int objIndex;
	unsigned int numObjects = (uint)(sizeof(SceneObject) / sizeof(Object));

	for(objIndex=0;objIndex<numObjects; objIndex++){
		material = &SceneMaterial[SceneObject[objIndex].material];
		if( material->type != MATERIAL_LIGHT) {
			continue;
		}

		float4 lightDir = SceneObject[objIndex].origin - hit->position;

		// Early rejection for back-facing surfaces
		if(dot(lightDir, hit->normal) < 0){
			continue;
		}

		// Treat the light as a sphere with radius the largest dimension; then
		// generate a lightDir vector to its center and a tangent vector so as to
		// form a right-angled triangle with base (light radius, light dir) and
		// hypotenuse the tangent vector. Then generate a random ray towards
		// the light proportional to the solid angle of the cone defined by
		// the triangle.
		float lightDirLen = length(lightDir);
		float radius = SceneObject[objIndex].params.x;
		float tLen = sqrt(lightDirLen*lightDirLen + radius*radius);
		float cosThetaMax = lightDirLen / tLen;
		lightDir = normalize(lightDir);
		float4 shadowDir = rndConeDir(lightDir, cosThetaMax, rndSeed);

		// Check line of sight; if we hit anything other than the target or nothing reject light
		intersectWorld(hit->position, shadowDir, NUDGE_EPSILON, lightDirLen, &shadowHit);
		if(shadowHit.objIndex != objIndex && shadowHit.objIndex != NO_MATERIAL_HIT){
			continue;
		}

		// Radiance = 1/pi * cos(theta) * emissive * PDF
		light += material->emissive * dot(hit->normal, shadowDir) * 2.0f * (1.0f - cosThetaMax);

	}
	return light;
}

// Trace a ray and return the gathered color.
float4 traceRay(float4 rayOrigin, float4 rayDir, uint2 *rndSeed){
	Hit hit;
	__constant Material *material;
	float4 rCol = (float4)(0.0f);
	float4 mask = (float4)(1.0f);
	unsigned int bounce = 0;
	bool hitDiffuseObject = false;
	for(bounce=0;bounce<MAX_BOUNCES;bounce++){
		intersectWorld(rayOrigin, rayDir, NUDGE_EPSILON, FLT_MAX, &hit);

		// No hit
		if(hit.objIndex == NO_MATERIAL_HIT){
			if(bounce == 0){
				rCol = sceneBgColor;
			}
			break;
		}

		// Get material at hit point
		material = &SceneMaterial[hit.matIndex];

		// If we hit a light just add its emissive property and stop
		if( material->type == MATERIAL_LIGHT ){
			if ( !hitDiffuseObject ){
				rCol += mask * material->emissive;
			}
			break;
		}

		// Get normal at hit point
		getNormal(&hit);

		// After some bounces apply a russian roulette to terminate long paths
		if( bounce > MIN_BOUNCES_TO_USE_RR ) {
			float maxComponent = VEC3_MAX_COMPONENT(material->diffuse);
			if( maxComponent == 0 || clRand(rndSeed).x > maxComponent ){
				break;
			}

			// Boost surviving paths by 1/rr_prob
			mask /= maxComponent;
		}

		// Mask outgoing reflectance by material diffuse property
		mask *= material->diffuse;

		// Next bounce starts at hit point
		rayOrigin = hit.position;

		if( material->type == MATERIAL_DIFFUSE ) {
			hitDiffuseObject = true;
			rCol += mask * getDirectLight(&hit, rndSeed);

			// We do importance sampling for diffuse rays
			rayDir = rndCosWeightedHemisphereDir(hit.normal, rndSeed);
		} else if ( material->type == MATERIAL_SPECULAR){
			// Reflect ray around normal
			rayDir = normalize(-2.0f * dot(hit.normal, rayDir) * hit.normal + rayDir);
		} else {
			// todo
			break;
		}

		++bounce;
	}

	return rCol;
}

// Emit the color of a pixel by tracing a ray through the scene.
__kernel void tracePixel(
		__global float4 *frameBuffer,
		__global float4 *frustrumCorners,
		const float4 eyePos,
		const unsigned int blockY,
		const unsigned int samplesPerPixel,
		const float exposure,
		const int seed
		){
	// Get pixel coordinates
	unsigned int x = get_global_id(0);
	unsigned int y = get_global_id(1);
	if ( x > FRAME_W || y > FRAME_H ) {
		return;
	}

	// Setup seed for random numbers
	uint2 rndSeed = (uint2)(x * seed, y * seed);

	// Calculate texel coordinates [0,1] range
	float accumScaler = 1.0f / (float)samplesPerPixel;
	float4 accum = (float4)(0.0f,0.0f,0.0f,0.0f);

	for( uint sample=0;sample<samplesPerPixel;sample++){
		// Apply stratified sampling using a tent filter. This will wrap our
		// random numbers in the [-1, 1] range. X and Y point to the top corner
		// of the current texel so we need to add a bit of offset to get the coords
		// into the [-0.5, 1.5] range.
		float2 random = clRand(&rndSeed);
		float offX = random.x < 0.5f ? sqrt(2.0f * random.x) - 0.5f : 1.5f - sqrt(2.0f - 2.0f * random.x);
		float offY = random.y < 0.5f ? sqrt(2.0f * random.y) - 0.5f : 1.5f - sqrt(2.0f - 2.0f * random.y);
		float tx = ((float)x + offX) * TEXEL_STEP_X;
		float ty = ((float)y + offY) * TEXEL_STEP_Y;

		// Get ray direction using trilinear interpolation; trace ray and
		// add result to accumulation buffer
		float4 lVec = frustrumCorners[0] * (1 - ty) + frustrumCorners[2] * ty;
		float4 rVec = frustrumCorners[1] * (1 - ty) + frustrumCorners[3] * ty;
		accum += traceRay(eyePos, normalize(lVec * (1 - tx) + rVec * tx), &rndSeed);
	}

	// Average samples
	accum *= accumScaler;

	// Apply tone-mapping and gamma correction using:
	// 1 - exp(-hdrColor * exposure)) [tone mapping HDR -> LDR]
	// pow(ldr, 0.45)) [gamma correction]
	frameBuffer[y*FRAME_W + x] = pow(-expm1(-accum*exposure), 0.45f);
}


Tweaking the blinn-phong function

Tweaking the blinn-phong function


Fixes an incorrect use of load in desaturate.

const sampler_t sampler = CLK_NORMALIZED_COORDS_FALSE | CLK_ADDRESS_CLAMP_TO_EDGE | CLK_FILTER_NEAREST;

__kernel void desaturate( __global image2d_t image, __global hh_float* desaturated_out, int width )
{
    int2 coord = (int2)(get_global_id(0), get_global_id(1));
    float4 pixel = read_imagef( image, sampler, coord );
    desaturated_out[coord.x+coord.y*width] = 0.21f * pixel.x + 0.72f * pixel.y + 0.07f * pixel.z;
}

const sampler_t sampler = CLK_NORMALIZED_COORDS_FALSE | CLK_ADDRESS_CLAMP_TO_EDGE | CLK_FILTER_NEAREST;

__kernel void desaturate( __global image2d_t image, __global hh_float* desaturated_out, int width )
{
    int2 coord = (int2)(get_global_id(0), get_global_id(1));
    float4 pixel = read_imagef( image, sampler, coord );
    STORE_HHF( desaturated_out, coord.x+coord.y*width, 0.21f * pixel.x + 0.72f * pixel.y + 0.07f * pixel.z );
    //desaturated_out[coord.x+coord.y*width] = coord.x/(hh_float)width * 255;
    //desaturated_out[coord.x+coord.y*width] = pixel.x;
}


Ignore the error in the previous commit

Ignore the error in the previous commit

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

;; read rss feed
;; from jkf on 5/26/2005

(eval-when (compile load eval)
  (require :aserve)
  (require :pxml-sax))

(defpackage :net.rss.rdf
  (:export #:about
	   #:RDF
	   #:Seq))

(defpackage :net.rss.dc
  (:export #:date))

(defpackage :net.rss.sy
  (:export #:sy))

(defpackage :net.rss.admin
  )

(defpackage :net.rss (:use :common-lisp :excl :net.xml.parser
			   :net.aserve
			   :net.aserve.client
			   )
	    (:export #:feed-rss-p
		     #:feed-slot-value
		     #:read-feed

		     ; important tags
		     #:all-items
		     #:channel
		     #:description
		     #:item
		     #:link
		     #:pubDate
		     #:rss
		     #:title
		     #:version

		     #:feed-error
		     #:feed-error-ignore

		     ;; for EZTV:
		     #:torrent
		     #:fileName

		     #:*uri-to-package*
		     ))

(in-package :net.rss)

(defparameter *uri-to-package*
    (list

     (cons "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
	   :net.rss.rdf)

     (cons "http://purl.org/dc/elements/1.1/"
	   :net.rss.dc)

     (cons "http://purl.org/rss/1.0/modules/syndication/"
	   :net.rss.sy)

     (cons  "http://webns.net/mvcb/"
	   :net.rss.admin)

     (cons  "http://purl.org/rss/1.0/"
	    :net.rss)

     ;; For EZTV
     (cons "http://xmlns.ezrss.it/0.1/"
	   :net.rss)
     ;; Yet another hack for EZTV.  WTF??
     (cons "//xmlns.ezrss.it/0.1/"
	   :net.rss)
     ))

(define-condition feed-error (error)
  ((http-code :initarg :http-code :reader feed-error-httpcode
	      :initform nil)))

(define-condition feed-error-ignore (feed-error) ())

(defun read-feed (url &key timeout verbose
		  &aux (host (net.uri:uri-host (net.uri:parse-uri url))))
  ;;
  ;;* exported
  ;;
  ;; read the feed given by the url and return a feed value
  ;;
  (multiple-value-bind (content code headers)
      (handler-case (do-http-request
			url :timeout timeout
			:headers '(("User-Agent" . "Wget/1.12")))
	(socket-error ()
	  (signal 'feed-error-ignore)
	  (return-from read-feed))
	(error (c)
	  (error 'feed-error
		 :format-control "Error from do-http-request to ~a: ~a"
		 :format-arguments (list host c))))
    (declare (ignore headers))

    (if* (eq 502 code)
       then (signal 'feed-error-ignore)
	    (return-from read-feed)
     elseif (not (eq 200 code))
       then (if* verbose
	       then (error
		     'feed-error
		     :http-code code
		     :format-control "Accessing URL ~s gave response ~s"
		     :format-arguments (list url code))
	       else (error
		     'feed-error
		     :http-code code
		     :format-control "Accessing feed from ~s gave response ~s"
		     :format-arguments (list host code))))

    (parse-feed content)))

(defun parse-feed (content)
  (when (and (< (length content) 100)
	     (match-re "database error" content :case-fold t))
    (error 'feed-error-ignore))
  (setq content
    ;; WTF?  Control chars in feeds?  Cripes, what'll they think of next?
    (remove-if (lambda (c) (<= (char-code c) #.(char-code #\^z)))
	       content))
  ;;
  ;;* exported
  ;;
  ;; read the feed given by the url and return a feed value
  ;;
  (let ((body (car
	       ;; parse-xml was crapping out on EZTV, so I switched to
	       ;; parse-to-lxml on the advice of mm.  When I say
	       ;; "crapping out" I mean crashing the lisp.
	       #+ignore
	       (let ((*package* (find-package :net.rss)))
		 (parse-xml content
			    ;;The eztv.it feed requires this
			    :external nil
			    :uri-to-package *uri-to-package*))
	       (let ((*package* (find-package :net.rss)))
		 (net.xml.sax:parse-to-lxml
		  content
		  ;; needed for parse-to-lxml not parse-xml
		  :package *package*
		  ;;The eztv.it feed requires this
		  :external nil
		  :uri-to-package *uri-to-package*)))))
    ;;(pprint body)
    ;;(setq *body* body)
    (if* (and (consp (car body))
	      (eq 'rss (caar body)))
       then `(rss
	      (version ,(getf (cdar body) 'version))
	      ,@(process-rss-body (cdr body) nil))
     elseif (and (consp (car body))
		 (eq 'net.rss.rdf:RDF (caar body)))
       then ;; rss 1.0
	    `(rss (version "1.0") ,@(process-rss-body (cdr body) 'rdf)))))

(defun process-rss-body (body rdfp)
  (mapcar
   (lambda (ch)
     `(channel
       ,@(mapcar
	  (lambda (it)
	    `(,(car it) ,@(big-stringify (cdr it))))
	  (find-not-items 'item (cdr ch)))
       (all-items
	,@(mapcar
	   (lambda (it
		    &aux (torrent (find-items 'torrent it))
			 ;; EZTV hack:
			 (fileName
			  (when torrent
			    (car (find-items 'fileName (car torrent))))))
	     `(item
	       ,@(mapcar
		  (lambda (vv)
		    `(,(car vv)
		      ,@(big-stringify (cdr vv))))
		  (find-conses (cdr it)))
	       ,@(when fileName (list fileName))))
	   (find-items 'item
		       (if* rdfp
			  then ;; found in main body
			       (cdr body)
			  else ;; found in channel
			       (cdr ch)))))))
   (find-items 'channel body)))

(defun find-items (key objs)
  ;; find all items beginning with key
  (let (res)
    (dolist (obj objs)
      (if* (and (consp obj) (or (eq key (car obj))
				(and (consp (car obj))
				     (eq key (caar obj)))))
	 then (push obj res)))
    (nreverse res)))

(defun find-not-items (key objs)
  ;; find conses not beginning with key
  (let (res)
    (dolist (obj objs)
      (if* (and (consp obj)
		(not (or (eq key (car obj))
			 (and (consp (car obj))
			      (eq key (caar obj))))))
	 then (push obj res)))
    (nreverse res)))

(defun find-conses (objs)
  ;; find all things that are conses
  (let (res)
    (dolist (obj objs)
      (if* (consp obj)
	 then (push obj res)))
    (nreverse res)))

(defun big-stringify (objs)
  ;; concatenate all consecutie strings in objs
  (let (res thisres)
    (do* ((xx objs (cdr xx))
	  (val (car xx) (car xx)))
	((null xx)
	 (if* thisres
	    then (push (apply #'concatenate 'string (nreverse thisres))
		       res))
	 (nreverse res))
      (if* (stringp val)
	 then (push val thisres)
       elseif thisres
	 then (push (apply #'concatenate 'string (nreverse thisres))
		    res)
	      (setq thisres nil)

	      (push val res)))))

;; functions for searching the feed results

(defun feed-rss-p (feed &optional version)
  ;; test if is feed is an rss feed (and if version is given test
  ;; that it is of that particular version).
  ;;
  ;; return the version number if true (or return t if it's an rss
  ;; feed but the version isn't known).
  ;;
  (and (consp feed)
       (eq 'rss (car feed))
       (if* version
	  then (if* (equal (feed-slot-value feed 'version) version)
		  then version)
	  else (or(feed-slot-value feed 'version) t))))

(defun feed-slot-value (feed slot-name)
  (dolist (ent feed)
    (if* (consp ent)
       then (if* (consp (car ent))
	       then (if* (eq slot-name (caar ent))
		       then (return (cdr ent)))
	     elseif (eq slot-name (car ent))
	       then (return (cdr ent))))))

(defun testit ()
  (format t "0.91 feed ~%")
  (pprint (read-feed "http://www.franz.com/rss091_main.xml"))

  (format t "2.0 feed ~%")
  (pprint (read-feed "http://www.franz.com/rss20_main.xml"))

  (format t "1.0 feed ~%")
  (pprint (read-feed "http://www.franz.com/rss10_main.xml")))

(provide :rssreader)

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

;; read rss feed
;; from jkf on 5/26/2005

(eval-when (compile load eval)
  (require :aserve)
  (require :pxml-sax))

(defpackage :net.rss.rdf
  (:export #:about
	   #:RDF
	   #:Seq))

(defpackage :net.rss.dc
  (:export #:date))

(defpackage :net.rss.sy
  (:export #:sy))

(defpackage :net.rss.admin
  )

(defpackage :net.rss (:use :common-lisp :excl :net.xml.parser
			   :net.aserve
			   :net.aserve.client
			   )
	    (:export #:feed-rss-p
		     #:feed-slot-value
		     #:read-feed

		     ; important tags
		     #:all-items
		     #:channel
		     #:description
		     #:item
		     #:link
		     #:pubDate
		     #:rss
		     #:title
		     #:version

		     #:feed-error
		     #:feed-error-ignore

		     ;; for EZTV:
		     #:torrent
		     #:fileName

		     #:*uri-to-package*
		     ))

(in-package :net.rss)

(defparameter *uri-to-package*
    (list

     (cons "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
	   :net.rss.rdf)

     (cons "http://purl.org/dc/elements/1.1/"
	   :net.rss.dc)

     (cons "http://purl.org/rss/1.0/modules/syndication/"
	   :net.rss.sy)

     (cons  "http://webns.net/mvcb/"
	   :net.rss.admin)

     (cons  "http://purl.org/rss/1.0/"
	    :net.rss)

     ;; For EZTV
     (cons "http://xmlns.ezrss.it/0.1/"
	   :net.rss)
     ;; Yet another hack for EZTV.  WTF??
     (cons "//xmlns.ezrss.it/0.1/"
	   :net.rss)
     ))

(define-condition feed-error (error)
  ((http-code :initarg :http-code :reader feed-error-httpcode
	      :initform nil)))

(define-condition feed-error-ignore (feed-error) ())

(defun read-feed (url &key timeout verbose
		  &aux (host (net.uri:uri-host (net.uri:parse-uri url))))
  ;;
  ;;* exported
  ;;
  ;; read the feed given by the url and return a feed value
  ;;
  (multiple-value-bind (content code headers)
      (handler-case (do-http-request
			url :timeout timeout
			:headers '(("User-Agent" . "Wget/1.12")))
	(socket-error ()
	  (signal 'feed-error-ignore)
	  (return-from read-feed))
	(error (c)
	  (error 'feed-error
		 :format-control "Error from do-http-request to ~a: ~a"
		 :format-arguments (list host c))))
    (declare (ignore headers))

    (if* (eq 502 code)
       then (signal 'feed-error-ignore)
	    (return-from read-feed)
     elseif (not (eq 200 code))
       then (if* verbose
	       then (error
		     'feed-error
		     :http-code code
		     :format-control "Accessing URL ~s gave response ~s"
		     :format-arguments (list url code))
	       else (error
		     'feed-error
		     :http-code code
		     :format-control "Accessing feed from ~s gave response ~s"
		     :format-arguments (list host code))))

    (parse-feed content)))

(defun parse-feed (content)
  (when (and (< (length content) 100)
	     (match-re "database error" content :case-fold t))
    (error "bad feed"))
  (setq content
    ;; WTF?  Control chars in feeds?  Cripes, what'll they think of next?
    (remove-if (lambda (c) (<= (char-code c) #.(char-code #\^z)))
	       content))
  ;;
  ;;* exported
  ;;
  ;; read the feed given by the url and return a feed value
  ;;
  (let ((body (car
	       ;; parse-xml was crapping out on EZTV, so I switched to
	       ;; parse-to-lxml on the advice of mm.  When I say
	       ;; "crapping out" I mean crashing the lisp.
	       #+ignore
	       (let ((*package* (find-package :net.rss)))
		 (parse-xml content
			    ;;The eztv.it feed requires this
			    :external nil
			    :uri-to-package *uri-to-package*))
	       (let ((*package* (find-package :net.rss)))
		 (net.xml.sax:parse-to-lxml
		  content
		  ;; needed for parse-to-lxml not parse-xml
		  :package *package*
		  ;;The eztv.it feed requires this
		  :external nil
		  :uri-to-package *uri-to-package*)))))
    ;;(pprint body)
    ;;(setq *body* body)
    (if* (and (consp (car body))
	      (eq 'rss (caar body)))
       then `(rss
	      (version ,(getf (cdar body) 'version))
	      ,@(process-rss-body (cdr body) nil))
     elseif (and (consp (car body))
		 (eq 'net.rss.rdf:RDF (caar body)))
       then ;; rss 1.0
	    `(rss (version "1.0") ,@(process-rss-body (cdr body) 'rdf)))))

(defun process-rss-body (body rdfp)
  (mapcar
   (lambda (ch)
     `(channel
       ,@(mapcar
	  (lambda (it)
	    `(,(car it) ,@(big-stringify (cdr it))))
	  (find-not-items 'item (cdr ch)))
       (all-items
	,@(mapcar
	   (lambda (it
		    &aux (torrent (find-items 'torrent it))
			 ;; EZTV hack:
			 (fileName
			  (when torrent
			    (car (find-items 'fileName (car torrent))))))
	     `(item
	       ,@(mapcar
		  (lambda (vv)
		    `(,(car vv)
		      ,@(big-stringify (cdr vv))))
		  (find-conses (cdr it)))
	       ,@(when fileName (list fileName))))
	   (find-items 'item
		       (if* rdfp
			  then ;; found in main body
			       (cdr body)
			  else ;; found in channel
			       (cdr ch)))))))
   (find-items 'channel body)))

(defun find-items (key objs)
  ;; find all items beginning with key
  (let (res)
    (dolist (obj objs)
      (if* (and (consp obj) (or (eq key (car obj))
				(and (consp (car obj))
				     (eq key (caar obj)))))
	 then (push obj res)))
    (nreverse res)))

(defun find-not-items (key objs)
  ;; find conses not beginning with key
  (let (res)
    (dolist (obj objs)
      (if* (and (consp obj)
		(not (or (eq key (car obj))
			 (and (consp (car obj))
			      (eq key (caar obj))))))
	 then (push obj res)))
    (nreverse res)))

(defun find-conses (objs)
  ;; find all things that are conses
  (let (res)
    (dolist (obj objs)
      (if* (consp obj)
	 then (push obj res)))
    (nreverse res)))

(defun big-stringify (objs)
  ;; concatenate all consecutie strings in objs
  (let (res thisres)
    (do* ((xx objs (cdr xx))
	  (val (car xx) (car xx)))
	((null xx)
	 (if* thisres
	    then (push (apply #'concatenate 'string (nreverse thisres))
		       res))
	 (nreverse res))
      (if* (stringp val)
	 then (push val thisres)
       elseif thisres
	 then (push (apply #'concatenate 'string (nreverse thisres))
		    res)
	      (setq thisres nil)

	      (push val res)))))

;; functions for searching the feed results

(defun feed-rss-p (feed &optional version)
  ;; test if is feed is an rss feed (and if version is given test
  ;; that it is of that particular version).
  ;;
  ;; return the version number if true (or return t if it's an rss
  ;; feed but the version isn't known).
  ;;
  (and (consp feed)
       (eq 'rss (car feed))
       (if* version
	  then (if* (equal (feed-slot-value feed 'version) version)
		  then version)
	  else (or(feed-slot-value feed 'version) t))))

(defun feed-slot-value (feed slot-name)
  (dolist (ent feed)
    (if* (consp ent)
       then (if* (consp (car ent))
	       then (if* (eq slot-name (caar ent))
		       then (return (cdr ent)))
	     elseif (eq slot-name (car ent))
	       then (return (cdr ent))))))

(defun testit ()
  (format t "0.91 feed ~%")
  (pprint (read-feed "http://www.franz.com/rss091_main.xml"))

  (format t "2.0 feed ~%")
  (pprint (read-feed "http://www.franz.com/rss20_main.xml"))

  (format t "1.0 feed ~%")
  (pprint (read-feed "http://www.franz.com/rss10_main.xml")))

(provide :rssreader)